Commit 169c58ca authored by Pietro Abate's avatar Pietro Abate

Fix printer for parametric types

parent abbc0f5d
......@@ -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; *)
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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 =
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment