Commit 99357a17 authored by Kim Nguyễn's avatar Kim Nguyễn
Browse files

Register instances of polymorphic type to print them by name later-on.

parent 94266c5f
Pipeline #157 failed with stages
in 36 seconds
......@@ -141,7 +141,8 @@ let find_id env0 env loc head x =
try Env.find id env.ids
with Not_found when head -> (
try ECDuce (!load_comp_unit x)
with Not_found -> error loc "Cannot resolve this identifier")
with Not_found ->
error loc ("Cannot resolve this identifier: " ^ U.get_str x))
let find_id_comp env0 env loc x =
if
......@@ -177,8 +178,11 @@ let iter_values env f =
let register_types cu env =
Env.iter
(fun x t ->
(* TODO *)
match t with Type (t, _) -> Types.Print.register_global cu x t | _ -> ())
match t with
| Type (t, vparams) ->
let params = List.map Types.var vparams in
Types.Print.register_global cu x ~params t
| _ -> ())
env.ids
let rec const env loc = function
......@@ -404,7 +408,12 @@ module IType = struct
let current_params = ref dummy_params
let clean_params () = current_params := dummy_params
let to_register = ref []
let clean_params () =
current_params := dummy_params;
to_register := []
let clean_on_err () =
all_delayed := [];
......@@ -532,11 +541,22 @@ module IType = struct
else invalid_instance_error loc id
with Not_found -> (
try
let (t, pargs), tidx =
let (cu, name), (t, pargs), tidx =
if rest == [] then
( find_local_type env.penv_tenv loc v,
( ("", v),
find_local_type env.penv_tenv loc v,
try fst (Hashtbl.find cmap id) with Not_found -> ~-1 )
else (find_global_type env.penv_tenv loc ids, ~-1)
else
let t, pargs = find_global_type env.penv_tenv loc ids in
match find_id env.penv_tenv env.penv_tenv loc true id with
| ECDuce _ | EOCaml _ ->
( ( U.get_str id,
ident env.penv_tenv loc
(U.mk @@ String.concat "." @@ List.map U.get_str rest)
),
(t, pargs),
~-1 )
| _ -> assert false
in
if cidx >= 0 && tidx == cidx && not (comp_var_pat cparams args) then
invalid_instance_error loc id;
......@@ -551,8 +571,10 @@ module IType = struct
"Wrong number of parameters for parametric type %s"
(U.to_string id))
in
let l = Types.Subst.from_list l in
mk_type (Types.Subst.apply_full l t)
let sub = Types.Subst.from_list l in
let ti = mk_type (Types.Subst.apply_full sub t) in
to_register := (cu, name, List.map snd l, ti, loc) :: !to_register;
ti
with Not_found ->
assert (rest == []);
if args != [] then
......@@ -656,9 +678,18 @@ module IType = struct
(v, t_rhs, List.map snd vars_mapping))
(List.rev b)
in
List.iter (fun (v, t, _al) -> Types.Print.register_global "" v t) b;
(* TODO *)
enter_types b env
List.iter
(fun (v, t, al) ->
let params = List.map Types.var al in
Types.Print.register_global "" v ~params t)
b;
let env = enter_types b env in
List.iter
(fun (cu, name, params, ti, loc) ->
let tti = aux loc ti in
Types.Print.register_global cu name ~params tti)
!to_register;
env
let equal_params l1 l2 = try List.for_all2 U.equal l1 l2 with _ -> false
......
......@@ -38,15 +38,20 @@ module Print = struct
type gname = string * Ns.QName.t
type nd = {
and nd = {
id : int;
mutable def : d list;
mutable state :
[ `Expand | `None | `Marked | `GlobalName of gname | `Named of U.t ];
[ `Expand
| `None
| `Marked
| `GlobalName of gname * Types.t list
| `Named of U.t ];
}
and d =
| Name of gname
| Name of gname * nd list
| Var of Var.t
| Display of string
| Regexp of nd Pretty.regexp
| Atomic of (Format.formatter -> unit)
......@@ -91,17 +96,20 @@ module Print = struct
let named_xml = ref DescrPairMap.empty
let register_global cu (name : Ns.QName.t) d =
let register_global cu (name : Ns.QName.t) ?(params = []) d =
let d = uniq d in
let params = List.map uniq params in
(if equal Xml.(update d Dnf.empty) empty then
let l = (*Product.merge_same_2*) Product.get ~kind:`XML d in
match l with
| [ (t1, t2) ] ->
if DescrPairMap.mem (t1, t2) !named_xml then ()
else named_xml := DescrPairMap.add (t1, t2) (cu, name) !named_xml
else
named_xml :=
DescrPairMap.add (t1, t2) ((cu, name), params) !named_xml
| _ -> ());
if DescrMap.mem d !named then ()
else named := DescrMap.add d (cu, name) !named
else named := DescrMap.add d ((cu, name), params) !named
let unregister_global d =
let d = uniq d in
......@@ -294,10 +302,11 @@ module Print = struct
try DescrHash.find memo d
with Not_found -> (
try
let n = DescrMap.find d !named in
let gname, params = DescrMap.find d !named in
let s = alloc [] in
s.state <- `GlobalName n;
s.state <- `GlobalName (gname, params);
DescrHash.add memo d s;
s.def <- [ Name (gname, List.map prepare params) ];
s
with Not_found ->
if Absent.get d then alloc [ Abs (prepare Absent.(update d false)) ]
......@@ -331,11 +340,7 @@ module Print = struct
slot
end
else
let print_vars s =
Var.Set.fold
(fun acc v -> Atomic (fun ppf -> Var.print ppf v) :: acc)
[] s
in
let print_vars s = Var.Set.fold (fun acc v -> Var v :: acc) [] s in
let acc =
VarTable.fold
(fun (pv, nv) tt acc ->
......@@ -385,8 +390,10 @@ module Print = struct
(List.map
(fun (t1, t2) ->
try
let n = DescrPairMap.find (t1, t2) !named_xml in
[ Name n ]
let n, params =
DescrPairMap.find (t1, t2) !named_xml
in
[ Name (n, List.map prepare params) ]
with Not_found ->
let tag =
match AtomSet.print_tag (Atom.get t1) with
......@@ -502,7 +509,7 @@ module Print = struct
and assign_name_rec = function
| Neg t -> assign_name t
| Abs t -> assign_name t
| Name _ | Char _ | Atomic _ | Interval _ | Display _ -> ()
| Name _ | Char _ | Atomic _ | Interval _ | Display _ | Var _ -> ()
| Intersection l -> List.iter assign_name l
| Regexp r -> assign_name_regexp r
| Diff (t1, t2) ->
......@@ -580,11 +587,15 @@ module Print = struct
let lv_ldiff = Level.make 7
let lv_seq = Level.make 8
let lv_app = Level.make 8
let lv_seq = Level.make 9
let lv_post = Level.make 9
let lv_post = Level.make 10
let lv_xml = Level.make 10
let lv_xml = Level.make 11
let lv_comma = Level.make 12
let _lv_max = Level.make 20
......@@ -615,26 +626,42 @@ module Print = struct
let rec do_print_slot (pri : Level.t) ppf s =
match s.state with
| `Named n -> U.print ppf n
| `GlobalName n -> print_gname ppf n
| _ -> do_print_slot_real pri ppf s.def
| `Named n -> U.print ppf n
| `GlobalName (gname, []) -> print_gname ppf gname
| _ -> do_print_slot_real pri ppf s.def
and do_print_slot_real pri ppf def =
do_print_list "Empty" pri "|" lv_alt do_print ppf def
and do_print pri ppf = function
| Neg { def = []; _ } -> Format.fprintf ppf "Any"
| Neg t -> Format.fprintf ppf "Any \\ @[%a@]"
(do_print_slot lv_diff) t
| Abs t -> Format.fprintf ppf "?(@[%a@])"
(do_print_slot lv_min) t
| Name n -> print_gname ppf n
| Display s -> Format.fprintf ppf "%s" s
| Char c -> CharSet.V.print ppf c
| Regexp r -> Format.fprintf ppf "@[[ %a ]@]"
(do_print_regexp lv_min) r
| Atomic a -> a ppf
| Interval i -> (
| Neg { def = []; _ } -> Format.fprintf ppf "Any"
| Neg t -> Format.fprintf ppf "Any \\ @[%a@]" (do_print_slot lv_diff) t
| Abs t -> Format.fprintf ppf "?(@[%a@])" (do_print_slot lv_min) t
| Var v -> Format.fprintf ppf "%a" Var.print v
| Name (n, []) -> print_gname ppf n
| Name
( n,
[
({
def = [ (Name (_, []) | Record _ | Pair _ | Char _ | Var _) ];
_;
} as param);
] ) ->
opar ppf ~level:lv_app pri;
Format.fprintf ppf "@[%a@ %a@]" print_gname n (do_print_slot lv_app)
param;
cpar ppf ~level:lv_app pri
| Name (n, params) ->
opar ppf ~level:lv_app pri;
Format.fprintf ppf "@[%a@ (@[%a@])@]" print_gname n
(do_print_list "#ERROR" pri "," lv_comma do_print_slot)
params;
cpar ppf ~level:lv_app pri
| Display s -> Format.fprintf ppf "%s" s
| Char c -> CharSet.V.print ppf c
| Regexp r -> Format.fprintf ppf "@[[ %a ]@]" (do_print_regexp lv_min) r
| Atomic a -> a ppf
| Interval i -> (
match List.rev_map (fun x -> Atomic x) (Intervals.print i) with
| [] -> assert false
| [ a ] ->
......@@ -649,19 +676,18 @@ module Print = struct
then Format.fprintf ppf " ";
do_print_slot_real lv_alt ppf lst;
cpar ppf ~level:lv_alt pri)
| Diff (a, b) ->
| Diff (a, b) ->
opar ppf ~level:lv_diff pri;
Format.fprintf ppf "@[%a@] \\ @[%a@]" (do_print_slot lv_ldiff) a
(do_print_slot lv_diff) b;
cpar ppf ~level:lv_diff pri
| Intersection [] -> ()
| Intersection [ p ] -> do_print_slot pri ppf p
| Intersection a -> do_print_list "Any" pri "&" lv_and do_print_slot
ppf a
| Pair (t1, t2) ->
| Intersection [] -> ()
| Intersection [ p ] -> do_print_slot pri ppf p
| Intersection a -> do_print_list "Any" pri "&" lv_and do_print_slot ppf a
| Pair (t1, t2) ->
Format.fprintf ppf "@[(%a,%a)@]" (do_print_slot lv_pair) t1
(do_print_slot lv_min) t2
| Xml (tag, attr, t) ->
| Xml (tag, attr, t) ->
opar ppf ~level:lv_xml pri;
Format.fprintf ppf "<%a%a>%a" do_print_tag tag do_print_attr attr
(do_print_slot lv_xml) t;
......@@ -670,9 +696,9 @@ module Print = struct
Format.fprintf ppf "@[{";
do_print_record ppf (r, some, none);
Format.fprintf ppf " }@]"
| Arrows (p, []) ->
| Arrows (p, []) ->
do_print_list "Arrow" pri "&" lv_and do_print_arrow ppf p
| Arrows (p, n) ->
| Arrows (p, n) ->
opar ppf ~level:lv_diff pri;
do_print_list "Arrow" lv_diff "&" lv_and do_print_arrow ppf p;
Format.fprintf ppf " \\@ ";
......@@ -871,7 +897,7 @@ module Service = struct
| `Named n ->
trace ("debug:convert " ^ U.to_string n);
convert_real name s.Print.def
| `GlobalName n -> (
| `GlobalName (n,_) -> (
let t = get_gtype n in
trace ("debug:convert:globalname: " ^ t);
match t with
......
(** Pretty-printing of types. *)
val register_global : string -> Ns.QName.t -> Types.t -> unit
val register_global :
string -> Ns.QName.t -> ?params:Types.t list -> Types.t -> unit
(** [register_global cu name t] registers type [t] under [name] for compilation
unit [cu]. The name is then used by [print] and [print_node] in place of
the type expansion.
the type expansion. The optional [params] parameters allows one to pass
type parameters in case [t] is a parametric type.
*)
val print_const : Format.formatter -> Types.const -> unit
......@@ -25,13 +27,11 @@ val to_string : Types.t -> string
val print_node : Format.formatter -> Types.Node.t -> unit
(** [print_node fmt n] is an alias for [print fmt (Types.descr n)]. *)
val print_noname : Format.formatter -> Types.t -> unit
(** [print_noname fmt t] behaves like [print fmt t] except that name are not used,
except for : [Any], [Int], [Char], [Atoms] and the special case [Bool].
*)
(**/**)
type service_params =
......
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