From e8ecd9491158063195c8a3fb911343615649d0b0 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Kim=20Nguy=E1=BB=85n?= <kn@lri.fr>
Date: Mon, 23 Mar 2015 15:06:28 +0100
Subject: [PATCH] Add a wrapper around the type printing function to prevent
 them from outputing illegal code (such as [(Char | (*--2)*)* ]. (which
 contains CDuce comments).

---
 types/types.ml | 44 ++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 44 insertions(+)

diff --git a/types/types.ml b/types/types.ml
index f0f3b43b..3564b732 100644
--- a/types/types.ml
+++ b/types/types.ml
@@ -2704,6 +2704,50 @@ module Print = struct
     named := old_named;
     named_xml := old_named_xml
 
+  let wrap_formatter ppf =
+    let out_fun,flush_fun = Format.pp_get_formatter_output_functions ppf () in
+    let buffer = Buffer.create 16 in
+    let prev_char = "\000" in
+    let new_out_fun str start len =
+      for i = start to start + len - 1 do
+        let c = str.[i] in
+        if c == '*' && prev_char.[0] == '(' then
+          Buffer.add_char buffer ' '
+        else if c == ')' && prev_char.[0] == '*' then
+          Buffer.add_char buffer ' ';
+        prev_char.[0] <- c;
+        Buffer.add_char buffer c;
+      done;
+      let new_str = Buffer.contents buffer in
+      Buffer.clear buffer;
+      out_fun new_str 0 (String.length new_str)
+    in
+    let new_flush_fun () =
+      let new_str = Buffer.contents buffer in
+      let len = String.length new_str in
+      if len > 0 then begin
+        Buffer.clear buffer;
+        out_fun new_str 0 len;
+      end;
+      flush_fun ();
+    in
+    Format.pp_set_formatter_output_functions ppf new_out_fun new_flush_fun;
+    fun () ->
+      Format.pp_print_flush ppf ();
+      Format.pp_set_formatter_output_functions ppf out_fun flush_fun
+
+
+  let pp_type ppf t =
+    let reset = wrap_formatter ppf in
+    pp_type ppf t;
+    reset ()
+
+  let pp_noname ppf t =
+    let reset = wrap_formatter ppf in
+    pp_noname ppf t;
+    reset ()
+
+
   let pp_node ppf n = pp_type ppf (descr n)
 
   let () = forward_print := pp_type
-- 
2.18.1