Fix printer for parametric types

schema/schema_converter.ml

@@ -171,7 +171,7 @@ let load_schema schema_name uri =
   let schema_name = schema_name ^ "." in
   let log_schema_component kind name cd_type =
     if not (Schema_builtin.is name) then begin
-      Types.Print.register_global (schema_name,name) cd_type;
+      Types.Print.register_global (schema_name,name,[||]) cd_type;
       
 (*      Format.fprintf Format.std_formatter "Registering schema %s: %a@." kind 
 	Ns.QName.print name; *)

types/builtin.ml

@@ -32,7 +32,7 @@ let env =
   List.fold_left
     (fun accu (n,t) -> 
        let n = (Ns.empty, Ident.U.mk n) in
-       Types.Print.register_global ("",n) t;
+       Types.Print.register_global ("",n,[||]) t;
        Typer.enter_type (Ident.ident n) t accu
     )
     Typer.empty_env

types/types.ml

@@ -1642,7 +1642,7 @@ module Print = struct
 
   let is_regexp t = subtype t seqs_descr
 
-  type gname = string * Ns.QName.t
+  type gname = string * Ns.QName.t * t array
 
   type nd = {
     id : int;
@@ -1699,18 +1699,18 @@ module Print = struct
 
   let named = ref DescrMap.empty
   let named_xml = ref DescrPairMap.empty
-  let register_global (cu,name) d =
+  let register_global (cu,name,al) d =
     let d = uniq d in
     if equal { d with xml = BoolPair.empty } empty then begin
        match Product.get ~kind:`XML d with
 	 | [(t1,t2)] ->
 	     if DescrPairMap.mem (t1,t2) !named_xml then ()
 	     else
-	       named_xml := DescrPairMap.add (t1,t2) (cu,name) !named_xml
+	       named_xml := DescrPairMap.add (t1,t2) (cu,name,al) !named_xml
 	 | _ -> ()
     end;
     if DescrMap.mem d !named then ()
-    else named := DescrMap.add d (cu,name) !named
+    else named := DescrMap.add d (cu,name,al) !named
 
   let unregister_global d =
     let d = uniq d in
@@ -1950,9 +1950,7 @@ module Print = struct
             in
             (* sequence type. We do not want to split types such as
                Any into Any \ [ Any *] | Any, and likewise, write
-               Atom \ [] | [].
-
-            *)
+               Atom \ [] | []. *)
             let finite_atoms =
               try match BoolAtoms.get tt.atoms with
               | [ ( [ `Atm bdd ], [] ) ] ->
@@ -2109,14 +2107,14 @@ module Print = struct
   let rec assign_name s =
     incr gen;
     match s.state with
-      | `None ->
-	  let g = !gen in
-	  s.state <- `Marked;
-	  List.iter assign_name_rec s.def;
-        (* + 8 allows to disable sharing for small subtrees *)
-	  if (s.state == `Marked) && (!gen < g + 8) then s.state <- `None
-      | `Marked -> s.state <- `Named (name ()); to_print := s :: !to_print
-      | _ -> ()
+    | `None ->
+      let g = !gen in
+      s.state <- `Marked;
+      List.iter assign_name_rec s.def;
+      (* + 8 allows to disable sharing for small subtrees *)
+      if (s.state == `Marked) && (!gen < g + 8) then s.state <- `None
+    | `Marked -> s.state <- `Named (name ()); to_print := s :: !to_print
+    | _ -> ()
   and assign_name_rec = function
     | Neg t -> assign_name t
     | Abs t -> assign_name t
@@ -2141,9 +2139,6 @@ module Print = struct
     | Pretty.Star r | Pretty.Plus r -> assign_name_regexp r
     | Pretty.Trans t -> assign_name t
 
-  let print_gname ppf (cu,n) =
-    Format.fprintf ppf "%s%a" cu Ns.QName.print n
-
 (* operator precedences:
    20 names, constants, ...
    10 : <t1 >
@@ -2202,7 +2197,11 @@ module Print = struct
       loop (List.rev l);
       cpar ppf ~level:pri_op pri
 
+  let get_name = function
+    | { state = `Named n } -> n
+    | _ -> assert false
 
+  
   let rec do_print_slot (pri : Level.t) ppf s =
     match s.state with
       | `Named n -> U.print ppf n
@@ -2315,11 +2314,13 @@ module Print = struct
 	(List.rev (c :: accu), None)
     | r -> (List.rev accu,Some r)
 
-  let get_name = function
-    | { state = `Named n } -> n
-    | _ -> assert false
+  and print_gname ppf = function 
+    |(cu,n,[||]) -> Format.fprintf ppf "%s%a" cu Ns.QName.print n
+    |(cu,n,al) ->
+        Format.fprintf ppf "%s%a(%s)" cu Ns.QName.print n 
+        (String.concat "," (List.map (Utils.string_of_formatter pp_type) (Array.to_list al)))
 
-  let pp_type ppf t =
+  and pp_type ppf t =
     let t = uniq t in
     let t = prepare t in
     assign_name t;
@@ -2342,7 +2343,7 @@ module Print = struct
     to_print := [];
     DescrHash.clear memo
 
-  let pp_noname ppf t =
+  and pp_noname ppf t =
     let old_named = !named in
     let old_named_xml = !named_xml in
     unregister_global t;
@@ -2385,13 +2386,9 @@ struct
     Format.pp_print_flush ppf ();
     Buffer.contents b
 
-  let get_gname (cu,n) =
-    Ns.QName.to_string n;;
-
-  let get_gtype t =
-    get_gname t;;
+  let get_gname (cu,n,_) = Ns.QName.to_string n
 
-(* from ns:atom, returns :atom. *)
+  (* from ns:atom, returns :atom. *)
   let strip_namespace tagname =
     let len = String.length tagname in
     let cur = ref len in
@@ -2420,7 +2417,7 @@ struct
       | `Named n -> trace ("debug:convert " ^ (U.to_string n)) ;
 	  convert_real name s.Print.def
       | `GlobalName n ->
-	  let t = get_gtype n in
+	  let t = get_gname n in
 	  trace("debug:convert:globalname: " ^ t);
 	  (match t with
 	    | "Int" | "String" | "Float" | "Bool"
@@ -2487,8 +2484,6 @@ struct
 	  trace ("debug:convert_attrs:Named "
 	  ^ (U.to_string n));
 	  convert_record flags (r,some,none)
-	    (*	  convert_real name s.Print.def *)
-	    (*      | `GlobalName n -> get_gtype n name *)
       | _ -> trace "convert_attrs:_"; ()
   and convert_record flags (r,some,none) =
     List.iter

types/types.mli

@@ -331,7 +331,7 @@ val cond_partition: t -> (t * t) list -> t list
      to answer all the questions. *)
 
 module Print : sig
-  type gname = string * Ns.QName.t
+  type gname = string * Ns.QName.t * t array
   val register_global : gname -> t -> unit
   val pp_const : Format.formatter -> const -> unit
   val pp_type: Format.formatter -> t -> unit

typing/typer.ml

@@ -193,7 +193,7 @@ let iter_values env f =
 
 let register_types cu env =
   Env.iter (fun x -> function
-    | Type (t,_) -> Types.Print.register_global (cu,(Ident.value x)) t
+    | Type (t,_) -> Types.Print.register_global (cu,(Ident.value x),[||]) t
     | _ -> ()
   ) env.ids
 
@@ -460,7 +460,9 @@ module IType = struct
         (v',t,al)
       ) b b' 
     in
-    List.iter (fun (v,t,_) -> Types.Print.register_global ("",v) t) b;
+    List.iter (fun (v,t,al) ->
+      Types.Print.register_global ("",v,Array.map Types.var al) t
+    ) b;
     enter_types b env
 
   let type_defs env b =