Commit 8097d14b authored by Kim Nguyễn's avatar Kim Nguyễn

Remove explicit access to the type fields in the Print module, add some more pretty-printer tests.

parent 5641fa93
......@@ -51,3 +51,8 @@ let x025 : [ ('a -> 'b) & 'c ] = raise []
let x026 : [ 'a | 'b \ 'c ] = raise []
let x027 : [ 'a -> 'b \ 'c ] = raise []
let x028 : [ 'a -> (T ('a)) & 'c ] = raise []
(* xml and records *)
let x029 : { x=? Int .. } = raise []
let x030 : { x=? Int y=? Bool } = raise []
......@@ -172,6 +172,8 @@ sig
val empty: t
val any : t
val is_empty : t -> bool
val get_absent : t -> bool
val set_absent : t -> bool -> t
end =
struct
......@@ -273,6 +275,8 @@ struct
let accu = if a.absent then accu+5 else accu in
accu
let get_absent t = t.absent
let set_absent t b = { t with absent = b }
end
and Node :
sig
......@@ -1928,7 +1932,7 @@ module Print = struct
let memo = ref Cache.emp
let uniq t =
let c',r = Cache.find (fun t -> t) t !memo in
let c',r = Cache.find Iter.simplify t !memo in
memo := c';
r
......@@ -1938,7 +1942,7 @@ module Print = struct
let named_xml = ref DescrPairMap.empty
let register_global (cu,name,al) d =
let d = uniq d in
if equal { d with xml = VarXml.empty } empty then begin
if is_empty (VarXml.update d VarXml.empty) then begin
match Product.get ~kind:`XML d with
| [(t1,t2)] ->
if DescrPairMap.mem (t1,t2) !named_xml then ()
......@@ -1951,9 +1955,9 @@ module Print = struct
let unregister_global d =
let d = uniq d in
if equal { d with xml = VarXml.empty } empty then begin
if is_empty (VarXml.update d VarXml.empty) then begin
match Product.get ~kind:`XML d with
| [(t1,t2)] ->
| [(t1, t2)] ->
named_xml := DescrPairMap.remove (t1,t2) !named_xml
| _ -> ()
end;
......@@ -1974,11 +1978,7 @@ module Print = struct
let to_print = ref []
let trivial_rec b =
b == VarRec.empty ||
(is_empty { empty with record = VarRec.diff VarRec.full b})
let trivial (type atom) (module T : VarType with type Atom.t = atom) t =
let trivial (module T : VarType) t =
let t1 = T.inj (T.proj t) in
is_empty t1 ||
is_empty (diff (T.inj T.full) t1)
......@@ -2013,12 +2013,11 @@ module Print = struct
in
loop t
let bool_type =
{ empty with atoms = VarAtoms.atom
(`Atm(Atoms.cup
(Atoms.atom (Atoms.V.mk_ascii "false"))
(Atoms.atom (Atoms.V.mk_ascii "true"))))
}
VarAtoms.inj (VarAtoms.atom
(`Atm(Atoms.cup
(Atoms.atom (Atoms.V.mk_ascii "false"))
(Atoms.atom (Atoms.V.mk_ascii "true"))))
)
(** [prepare d] massages a type and convert it to the syntactic form.
Rough algorithm:
......@@ -2051,7 +2050,7 @@ module Print = struct
s
end with Not_found ->
if d.absent then
alloc [Abs (prepare ({d with absent=false}))]
alloc [Abs (prepare (cap any d))] (* clears the absent field *)
else
let slot = alloc [] in
if not (worth_abbrev d) then
......@@ -2082,7 +2081,7 @@ module Print = struct
let key = v1, v2 in
let old_t =
try VarTable.find table key with
Not_found -> { empty with absent = t.absent }
Not_found -> Descr.(set_absent empty (get_absent t))
in
let new_a = V.cup a (V.proj old_t) in
VarTable.replace table key (V.update old_t new_a))
......@@ -2232,10 +2231,10 @@ module Print = struct
Atom \ [] | []. *)
let finite_atoms = Atoms.is_finite (VarAtoms.leafconj tt.atoms) in
let u_acc, tt =
let tt_times = { empty with times = tt.times } in
let tt_times = VarTimes.(inj (proj tt)) in
if subtype tt_times seqs_descr && proper_seq tt_times then
let seq = cap tt seqs_descr in
let seq_times = { empty with times = seq.times } in
let seq_times = VarTimes.(update Descr.empty (proj seq)) in
if is_empty seq || (is_empty seq_times && not finite_atoms) then
[], tt
else
......@@ -2303,14 +2302,14 @@ module Print = struct
with Not_found ->
let tag =
match Atoms.print_tag (VarAtoms.leafconj t1.atoms) with
| Some a when is_empty { t1 with atoms = VarAtoms.empty } -> `Tag a
Some a when is_empty (VarAtoms.(update t1 empty)) -> `Tag a
| _ -> `Type (prepare t1)
in
assert (equal { t2 with times = empty.times } empty);
assert (is_empty VarTimes.(update t2 empty));
List.rev_map (fun (ta,tb) ->
(Xml (tag, prepare ta, prepare tb))
) (Product.get t2);
) (Product.partition any_pair (VarXml.leafconj tt.xml))
) (Product.partition any_pair (VarXml.(leafconj (proj tt))))
)
) @ u_acc
in
......@@ -2326,17 +2325,17 @@ module Print = struct
(prepare (descr t), prepare (descr s))) n
in
(Arrows (p,n))
) (Pair.get (VarArrow.leafconj tt.arrow))) @ u_acc
) (Pair.get (VarArrow.(leafconj (proj tt))))) @ u_acc
in
(* records *)
let u_acc =
(List.map (fun (r,some,none) ->
let r = LabelMap.map (fun (o,t) -> (o, prepare t)) r in
(Record (r,some,none))
)
(Record.get { empty with record =
VarRec.atom (`Atm (VarRec.leafconj tt.record)) })
(List.map
(fun (r,some,none) ->
let r = LabelMap.map (fun (o,t) -> (o, prepare t)) r in
(Record (r,some,none))
)
(Record.get (VarRec.(inj (atom (`Atm (leafconj (proj tt)))))))
) @ u_acc
in
let u_acc =
......
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