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