Perform a more aggressive memoization of substituted types and register the...

Perform a more aggressive memoization of substituted types and register the name if the original type was named.
Make the pretty-printer re-entrant.

misc/utils.ml

 let string_of_formatter pp t =
+  ignore (Format.flush_str_formatter ());
   Format.fprintf Format.str_formatter "%a" pp t;
   Format.flush_str_formatter ()
 
@@ -11,4 +12,3 @@ let pp_list ?(delim=("[","]")) ?(sep=",") f ppf l =
   match l with
     |[] -> Format.fprintf ppf "%s%s" (fst delim) (snd delim)
     |_ -> Format.fprintf ppf "%s%a%s" (fst delim) aux l (snd delim)
-

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 * t array
+  type gname = string * Ns.QName.t * (Var.var * t) list
 
   type nd = {
     id : int;
@@ -2315,10 +2315,25 @@ module Print = struct
     | r -> (List.rev accu,Some r)
 
   and print_gname ppf = function
-    |(cu,n,[||]) -> Format.fprintf ppf "%s%a" cu Ns.QName.print n
+    |(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 local_pp ppf t =
+        let old_to_print = !to_print in
+        let old_count_name = !count_name in
+        let old_memo = DescrHash.copy memo in
+        to_print := [];
+        count_name := 0;
+        DescrHash.clear memo;
+        pp_type ppf t;
+        to_print := old_to_print;
+        count_name := old_count_name;
+        DescrHash.iter (fun k v -> DescrHash.add memo k v) old_memo
+      in
+        Format.fprintf ppf "@[%s%a " cu Ns.QName.print n;
+        Utils.pp_list ~delim:("(",")") local_pp ppf
+          (List.map snd al);
+
+        Format.fprintf ppf "@]"
 
   and pp_type ppf t =
     let t = uniq t in
@@ -2814,7 +2829,9 @@ module Positive = struct
     apply_subst ~subst:subst ~after:(fun y -> define x y;x) t
 
   (* Pre-condition : alpha \not\in \delta *)
-  module MemoSubst = Hashtbl.Make (struct
+  module MemoSubst =
+    struct
+      include Hashtbl.Make (struct
       type t = descr * (Var.t * descr) list
       let hash (t, l) =
         List.fold_left
@@ -2826,23 +2843,13 @@ module Positive = struct
             Var.equal v1 v2 && Descr.equal t1 t2) l1 l2 with _ -> false)
     end)
 
-  let memo_subst = MemoSubst.create 17
-  let () = at_exit (fun () ->
-      Format.eprintf "%i@\n%!" (MemoSubst.length memo_subst))
+    end
 
-  let substitute t (alpha,s) =
-    let k = (t, [(alpha, s)]) in
-    try
-      MemoSubst.find memo_subst k
-    with Not_found ->
-      let r =
-        let vs = ty s in
-        let subst d = if Var.equal d alpha then vs else var d in
-        apply_subst ~subst:subst t
-      in
-      MemoSubst.add memo_subst k r; r
 
-  let substitute_list t l =
+  let memo_subst = MemoSubst.create 17
+
+  let rec substitute_list t l =
+    if no_var t || l == [] then t else
     let k = (t,l) in
     try
       MemoSubst.find memo_subst k
@@ -2857,7 +2864,20 @@ module Positive = struct
         in
         apply_subst ~subst:subst t
       in
-      MemoSubst.add memo_subst k r; r
+      let () =
+          try
+            let (cu, name, subst) = DescrMap.find t !Print.named in
+            let _nsubst =
+              List.map (fun (v, vt) -> v, substitute_list vt l) subst
+            in
+            Print.register_global (cu, name, _nsubst) r;
+          with Not_found -> ()
+      in
+      MemoSubst.add memo_subst k r;
+      r
+
+
+  let substitute t s = substitute_list t [s]
 
 
   let substitute_free delta t =

types/types.mli

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

types/var.ml

-
 module V = struct
   type t = { id : Ident.U.t ; fr : int ; kind : int }
   type kind = int

typing/typer.ml

@@ -30,7 +30,7 @@ type schema = {
 
 type item =
   (* These are really exported by CDuce units: *)
-| Type of (Types.t * Var.t array)
+| Type of (Types.t * Var.t list)
 | Val of Types.t
 | ECDuce of Compunit.t
 | ESchema of schema
@@ -51,10 +51,10 @@ type t = {
 let pp_env ppf env =
   let pp_item ppf (s,t) = match t with
     |Val t -> Format.fprintf ppf "val %s : %a" s Types.Print.pp_type t
-    |Type (t,[||]) -> Format.fprintf ppf "type %s = %a" s Types.Print.pp_noname t
+    |Type (t,[]) -> Format.fprintf ppf "type %s = %a" s Types.Print.pp_noname t
     |Type (t,al) ->
       Format.fprintf ppf "type %s(%a) = %a" s
-        (Utils.pp_list ~delim:("","") Var.pp) (Array.to_list al)
+        (Utils.pp_list ~delim:("","") Var.pp) al
         Types.Print.pp_noname t
     |_ -> ()
   in
@@ -138,11 +138,11 @@ let type_using env loc x cu =
   with Not_found ->
     error loc ("Cannot find external unit " ^ (U.to_string cu))
 
-let enter_type id t env = enter_id id (Type (t,[||])) env
+let enter_type id t env = enter_id id (Type (t,[])) env
 let enter_types l env =
   { env with ids =
       List.fold_left (fun accu (id,t,al) ->
-        Env.add id (Type (t,al)) accu
+        Env.add id (Type (t,List.map fst al)) accu
       ) env.ids l
   }
 
@@ -186,7 +186,9 @@ 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,vars) ->
+    let subst = List.map (fun x -> x, Types.var x) vars in
+    Types.Print.register_global (cu,(Ident.value x), subst) t
   | _ -> ()
   ) env.ids
 
@@ -265,7 +267,7 @@ let type_ns env loc p ns =
 let find_global_type env loc ids =
   match find_global env loc ids with
   | Type (t,pargs) -> (t,pargs)
-  | ESchemaComponent (t,_) -> (t,[||]) (* XXX *)
+  | ESchemaComponent (t,_) -> (t,[]) (* XXX *)
   | _ -> error loc "This path does not refer to a type"
 
 let find_global_schema_component env loc ids =
@@ -498,9 +500,9 @@ module IType = struct
                 let id = ident env.penv_tenv loc id in
                 try List.length (snd (Env.find id env.penv_derec))
                 with Not_found ->
-                  Array.length (snd (find_local_type env.penv_tenv loc id))
+                  List.length (snd (find_local_type env.penv_tenv loc id))
               else
-                Array.length (snd (find_global_type env.penv_tenv loc ids))
+                List.length (snd (find_global_type env.penv_tenv loc ids))
             with _ -> 0
           in
           if nargs != 0 then (* instantiation *)
@@ -534,24 +536,19 @@ module IType = struct
                  try fst (Hashtbl.find cmap id) with Not_found -> ~-1)
               else (find_global_type env.penv_tenv loc ids, ~-1)
             in
-            let palen = Array.length pargs in
-            if palen <> List.length args then
-              raise_loc_generic loc
-                (Printf.sprintf "Wrong number of parameters for parametric type %s" (U.to_string id));
             if cidx >= 0 && tidx == cidx && not (comp_var_pat cparams args) then
               raise_loc_generic loc (Printf.sprintf "Invalid instantiation of type %s during its recursive definition" (U.to_string id));
-            let a = Array.of_list args in
-            let l = ref [] in
-            for i = 0 to (Array.length pargs) - 1 do
+            let err s = Error s in
+            let l =
               try
-                let err s = Error s in
-                let tai = typ ~err (derecurs env a.(i)) in
-                l := (pargs.(i), tai )::!l
-              with
-              |Error s -> raise_loc_generic loc s
-              |_ -> assert false
-            done;
-            mk_type (Types.Positive.substitute_list t !l)
+                List.map2
+                  (fun v p -> (v, typ ~err (derecurs env p))) pargs args
+              with Invalid_argument _ ->
+              raise_loc_generic loc
+                (Printf.sprintf "Wrong number of parameters for parametric type %s" (U.to_string id));
+                 | Error s -> raise_loc_generic loc s
+            in
+            mk_type (Types.Positive.substitute_list t l)
 	  with Not_found ->
             assert (rest == []);
             if args != [] then
@@ -572,15 +569,15 @@ module IType = struct
 	    ("Multiple definitions for the type identifer " ^
 		(Ident.to_string v));
 	seen := IdSet.add v !seen;
-	(v,args,p,delayed loc)
+	(v,loc,args,p,delayed loc)
       ) b
     in
     let n = List.fold_left
-        (fun env (v,a,p,s) -> Env.add v (s,a) env)
+        (fun env (v,_,a,p,s) -> Env.add v (s,a) env)
         env.penv_derec b
     in
     let env = { env with penv_derec = n } in
-    List.iter (fun (v,_, p,s) -> link s (derecurs env p)) b;
+    List.iter (fun (v,_,_, p,s) -> link s (derecurs env p)) b;
     (env, b)
 
   let derec penv p =
@@ -600,7 +597,7 @@ module IType = struct
 	("Capture variable not allowed: " ^ (Ident.to_string x))
 
   let type_defs env b =
-    let _,b' = derecurs_def (penv env) b in
+    let _, b = derecurs_def (penv env) b in
     elim_concats ();
     check_delayed ();
     let aux loc d =
@@ -610,39 +607,31 @@ module IType = struct
       with Patterns.Error s -> raise_loc_generic loc s
     in
     let b =
-      List.map2 (fun ((loc,v),pl,p) (v',_,_, d) ->
-
+      List.map (fun (v, loc, args, _, d) ->
         let t_rhs = aux loc d in
         if (loc <> noloc) && (Types.is_empty t_rhs) then
           warning loc
-            ("This definition yields an empty type for " ^ (U.to_string v));
+            ("This definition yields an empty type for " ^ (Ident.to_string v));
 
         let vars_rhs = Types.all_vars t_rhs in
+        if List.exists (fun x -> not (Var.Set.mem (Var.mk (U.to_string x)) vars_rhs)) args then
+          raise_loc_generic loc
+            (Printf.sprintf "Definition of type %s contains unbound type variables"
+               (Ident.to_string v));
         let vars_mapping = (* create a sequence 'a -> 'a_0 for all variables *)
-          List.map (fun v -> let vv =  Var.mk (Ident.U.to_string v) in vv, Var.fresh vv) pl
-        in
-        let vars_lhs =
-          List.fold_left (fun acc (v, _) -> Var.Set.add v acc) Var.Set.empty vars_mapping
+          List.map (fun v -> let vv =  Var.mk (U.to_string v) in vv, Var.fresh vv) args
         in
-        if not (Var.Set.subset vars_rhs vars_lhs) then
-          error loc
-            (Printf.sprintf "Definition of type %s contains unbound type variables"
-               (U.to_string v));
-
+        let sub_list = List.map (fun (v,vt) -> v, Types.var vt) vars_mapping in
         let t_rhs =
-          Types.Positive.substitute_list t_rhs
-            (List.map (fun (v,vt) -> v, Types.var vt) vars_mapping)
+          Types.Positive.substitute_list t_rhs sub_list
         in
-        let al =
-          let a = Array.make (List.length pl) (Var.mk "dummy") in
-          List.iteri (fun i (_,v) -> a.(i) <- v) vars_mapping;
-          a
+        let nargs = List.map2 (fun (_, v) (_, vt) -> v, vt) vars_mapping sub_list
         in
-        (v',t_rhs,al)
-      ) (List.rev b) (List.rev b')
+        (v,t_rhs,nargs)
+      ) (List.rev b)
     in
     List.iter (fun (v,t,al) ->
-      Types.Print.register_global ("",v,Array.map Types.var al) t
+      Types.Print.register_global ("",v, al) t
     ) b;
     enter_types b env