Skip to content

GitLab

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

Further improve the pretty printing and add some test cases in part2.cd

parent 3b42bafb
Hide whitespace changes
Inline Side-by-side
tests/poly/part2.cd
View file @ e2548aaa
......@@ -42,6 +42,8 @@ let balance ( Unbal ->Rtree ; ('b \ Unbal) ->('b \ Unbal) )
| x -> x
;;
let f (_ : ('a | 'b | 'c)) (_ : (Int&'d&'e \1--3 )) : Any = raise "123";;
let balance (Unbal ->Rtree ; 'a -> 'a )
| <blk (z)>[ <red (y)>[ <red (x)>[ a b ] c ] d ]
| <blk (z)>[ <red (x)>[ a <red (y)>[ b c ] ] d ]
......
types/types.ml
View file @ e2548aaa
......@@ -1691,6 +1691,28 @@ struct
| Neg of nd
| Abs of nd
module Key = struct
type t = Var.Set.t * Var.Set.t
let hash (x, y) = Var.Set.hash x + 17 * Var.Set.hash y
let equal ((a,b) as x) ((c,d) as y) =
x == y || Var.Set.(equal a c && equal b d)
let compare (a, b) (c, d) =
let r = Var.Set.compare a c in
if r == 0 then Var.Set.compare b d else r
end
module VarTable = Hashtbl.Make(Key)
module KeySet = Set.Make(Key)
type matrix = {
mchars : BoolChars.t VarTable.t;
mints : BoolIntervals.t VarTable.t;
matoms : BoolAtoms.t VarTable.t;
mtimes : BoolPair.t VarTable.t;
mxml : BoolPair.t VarTable.t;
marrow : BoolPair.t VarTable.t;
mrecord : BoolRec.t VarTable.t;
mabstract : BoolAbstracts.t VarTable.t;
}
let compare x y = x.id - y.id
module S = struct
......@@ -1808,250 +1830,230 @@ struct
tlv : intersection of toplevel variables that are common to all non empty kinds
tv : the rest of the type
*)
let split_vars (type s) (module BV : BoolVar.S with type t = s) bdd =
List.fold_left (fun (acc_v, acc_nv) (p, n) ->
match p, n with
(([ `Atm _ ]|[]), ([ `Atm _]| [])) ->
acc_v, BV.cup acc_nv (BV.build [ (p,n)])
| _ -> BV.cup acc_v (BV.build [(p,n)]), acc_nv) (BV.empty,BV.empty) (BV.get bdd)
in
let vchars, nvchars = split_vars (module BoolChars) not_seq.chars in
let vints, nvints = split_vars (module BoolIntervals) not_seq.ints in
let vatoms, nvatoms = split_vars (module BoolAtoms) not_seq.atoms in
let vtimes, nvtimes = split_vars (module BoolPair) not_seq.times in
let vxml, nvxml = split_vars (module BoolPair) not_seq.xml in
let varrow, nvarrow = split_vars (module BoolPair) not_seq.arrow in
let vrecord, nvrecord = split_vars (module BoolRec) not_seq.record in
let vabstract, nvabstract = split_vars (module BoolAbstracts) not_seq.abstract in
let not_var = { empty with
chars = nvchars;
ints = nvints;
atoms = nvatoms;
times = nvtimes;
xml = nvxml;
arrow = nvarrow;
record = nvrecord;
abstract = nvabstract;
}
in
let not_seq = { not_seq with
chars = vchars;
ints = vints;
atoms = vatoms;
times = vtimes;
xml = vxml;
arrow = varrow;
record = vrecord;
abstract = vabstract;
}
in
let all_vars_in_line l =
List.fold_left (fun acc e ->
(* Given a bdd
\/_i (p_i & pvar_i, n_i& nvar_i)
we fill a table appropriately where the entries are the (pvar_i,nvar_i)
and the data the variable-less bdd (p_i \ n_i)
*)
let split_var_atom op init l =
List.fold_left (fun (acc_v, acc_a) e ->
match e with
| `Var _ as x -> Var.Set.add x acc
| _ -> acc) Var.Set.empty l
`Atm _ -> (acc_v, op e acc_a)
| `Var _ as x -> (Var.Set.add x acc_v, acc_a)
) (Var.Set.empty, init) l
in
let inter s1 s2 =
match s1, s2 with
None, None -> None
| None, Some s | Some s, None -> Some s
| Some s1, Some s2 -> Some (Var.Set.inter s1 s2)
let fill_line (type s)
(module BV : BoolVar.S with type t = s) (table : s VarTable.t) (bdd : s) =
List.iter (fun (p, n) ->
let v1, a1 = split_var_atom (fun a b -> BV.(cap (atom a) b)) BV.full p in
let v2, a2 = split_var_atom (fun a b -> BV.(cup (atom a) b)) BV.empty n in
let a = BV.diff a1 a2 in
let key = v1, v2 in
let new_a = try BV.cup a (VarTable.find table key) with Not_found -> a in
VarTable.replace table key new_a) (BV.get bdd);
table
in
let get_set = function None -> Var.Set.empty | Some s -> s in
let factorize_tlv get bdd acc =
List.fold_left (fun (p_acc,n_acc) (p,n) ->
(inter p_acc (Some (all_vars_in_line p)),
inter n_acc (Some (all_vars_in_line n)))
) acc (get bdd)
let not_seq_matrix =
{ mints = (let h = VarTable.create 17 in fill_line (module BoolIntervals) h not_seq.ints);
mchars = (let h = VarTable.create 17 in fill_line (module BoolChars) h not_seq.chars);
matoms = (let h = VarTable.create 17 in fill_line (module BoolAtoms) h not_seq.atoms);
mtimes = (let h = VarTable.create 17 in fill_line (module BoolPair) h not_seq.times);
mxml = (let h = VarTable.create 17 in fill_line (module BoolPair) h not_seq.xml);
marrow = (let h = VarTable.create 17 in fill_line (module BoolPair) h not_seq.arrow);
mrecord = (let h = VarTable.create 17 in fill_line (module BoolRec) h not_seq.record);
mabstract = (let h = VarTable.create 17 in fill_line (module BoolAbstracts) h not_seq.abstract); }
in
let tv_acc = factorize_tlv BoolChars.get not_seq.chars (None, None) in
let tv_acc = factorize_tlv BoolIntervals.get not_seq.ints tv_acc in
let tv_acc = factorize_tlv BoolAtoms.get not_seq.atoms tv_acc in
let tv_acc = factorize_tlv BoolPair.get not_seq.times tv_acc in
let tv_acc = factorize_tlv BoolPair.get not_seq.xml tv_acc in
let tv_acc = factorize_tlv BoolPair.get not_seq.arrow tv_acc in
let tv_acc = factorize_tlv BoolRec.get not_seq.record tv_acc in
let tv_pos, tv_neg = factorize_tlv BoolAbstracts.get not_seq.abstract tv_acc in
let tv_pos, tv_neg = get_set tv_pos, get_set tv_neg in
let tv_pos, tv_neg = Var.Set.diff tv_pos tv_neg, Var.Set.diff tv_neg tv_pos in
let remove_tlv (type s) (module BV : BoolVar.S with type t = s) bdd =
let open BV in
let inter_tlv pol vset l =
List.fold_left (fun acc t ->
match t with
`Var _ as x when Var.Set.mem x vset -> acc
| (`Var _ | `Atm _ ) as x -> cap acc (pol (atom x))
) full l
let get_keys table acc = VarTable.fold (fun k _ acc ->
KeySet.add k acc) table acc
in
List.fold_left (fun acc (p,n) ->
(cup (cap (inter_tlv (fun x -> x) tv_pos p)
(inter_tlv (fun x -> diff full x) tv_neg n)) acc)
) empty (get bdd)
let all_keys =
let m = not_seq_matrix in
let acc = get_keys m.mints KeySet.empty in
let acc = get_keys m.mchars acc in
let acc = get_keys m.matoms acc in
let acc = get_keys m.mxml acc in
let acc = get_keys m.marrow acc in
let acc = get_keys m.mrecord acc in
get_keys m.mabstract acc
in
let type_tlv =
diff (Var.Set.fold (fun acc v -> cap acc (var v)) any tv_pos)
(Var.Set.fold (fun acc v -> cup acc (var v)) empty tv_neg)
let found_any, all_descrs =
let m = not_seq_matrix in
let get k m e = try VarTable.find m k with Not_found -> e
in
let found_any = ref false in
let res =
KeySet.fold (fun ((v1, v2) as k) acc ->
(*Format.eprintf "Processing set: %a, %a@\n%!"
Var.Set.pp v1 Var.Set.pp v2; *)
if !found_any then acc
else if Var.Set.(not (is_empty (inter v1 v2)))
then ((*Format.eprintf "Found some variables in common: %a\n@!"
Var.Set.pp (Var.Set.inter v1 v2);*) acc)
else
let tt =
{ empty with
ints = get k m.mints BoolIntervals.empty;
chars = get k m.mchars BoolChars.empty;
atoms = get k m.matoms BoolAtoms.empty;
times = get k m.mtimes BoolPair.empty;
xml = get k m.mxml BoolPair.empty;
arrow = get k m.marrow BoolPair.empty;
record = get k m.mrecord BoolRec.empty;
abstract = get k m.mabstract BoolAbstracts.empty;
absent = not_seq.absent;
}
in
if is_empty tt then acc
else
if Var.Set.(is_empty v1 && is_empty v2) &&
subtype any tt then (found_any := true; acc) else
(k, tt) :: acc
) all_keys []
in
!found_any, res
in
let printed_topvar, not_seq =
if Var.Set.is_empty tv_pos && Var.Set.is_empty tv_neg then [], not_seq
else
let not_seq = cup not_seq (cap not_var type_tlv) in
(Var.Set.fold (fun acc v -> (Atomic (fun ppf -> Var.pp ppf v)) :: acc)
(Var.Set.fold (fun acc v -> (Neg (alloc [Atomic (fun ppf -> Var.pp ppf v)])) :: acc) [] tv_neg)
tv_pos),
{ not_seq with
chars = remove_tlv (module BoolChars) not_seq.chars;
ints = remove_tlv (module BoolIntervals) not_seq.ints;
atoms = remove_tlv (module BoolAtoms) not_seq.atoms;
times = remove_tlv (module BoolPair) not_seq.times;
xml = remove_tlv (module BoolPair) not_seq.xml;
arrow = remove_tlv (module BoolPair) not_seq.arrow;
record = remove_tlv (module BoolRec) not_seq.record;
abstract = remove_tlv (module BoolAbstracts) not_seq.abstract
}
in
let cons constr empty = function
(*Format.eprintf "All descr has size: %i, all_keys has size: %i, found_any=%b@\n%!" (List.length all_descrs) KeySet.(cardinal all_keys) found_any; *)
if found_any then (slot.def <- [Neg (alloc [])];slot)
else
let cons constr empty = function
[] -> empty
| [ t ] -> t
| l -> constr (alloc l)
in
let intersection l = cons (fun x -> Intersection x) (Neg (alloc [])) l in
let union l = cons (fun x -> Union x) (Union (alloc [])) l in
let prepare_boolvar get print bdd acc =
let fold_line acc l = List.fold_left (fun acc t ->
match t with
| `Var _ as x -> (Atomic (fun ppf -> Var.pp ppf x)) :: acc
| `Atm bdd -> (print bdd) @ acc) acc l
in
List.fold_left (fun acc (p,n) ->
let pos_line = fold_line [] p in
let neg_line = fold_line [] n in
match pos_line, neg_line with
[],[] -> acc
| [], n -> (Neg (alloc [ (union n) ])) :: acc
| p, [] -> (intersection p) :: acc
| p, n -> (intersection (p @ (List.map (fun n -> Neg (alloc [ n] )) n))) :: acc
) acc (get bdd)
in
let printed_seq = if non_empty seq then (Regexp (decompile seq)) :: [] else [] in
let print_descr tt =
if is_empty tt then [] else
let tt, fix =
if worth_complement tt then diff any tt, (fun x -> [Neg (alloc x)])
else tt , fun x -> x
| [ t ] -> t
| l -> constr (alloc l)
in
(* base types *)
let u_acc = prepare_boolvar BoolChars.get (fun bdd ->
match Chars.is_char bdd with
| Some c -> [Char c]
| None -> [Union(alloc (List.map (fun x -> (Atomic x)) (Chars.print bdd)))]
) tt.chars []
let intersection l = cons (fun x -> Intersection x) (Neg (alloc [])) l in
let union l = cons (fun x -> Union x) (Union (alloc [])) l in
let prepare_boolvar get print bdd acc =
let fold_line acc l = List.fold_left (fun acc t ->
match t with
| `Var _ as x -> (Atomic (fun ppf -> Var.pp ppf x)) :: acc
| `Atm bdd -> (print bdd) @ acc) acc l
in
List.fold_left (fun acc (p,n) ->
let pos_line = fold_line [] p in
let neg_line = fold_line [] n in
match pos_line, neg_line with
[],[] -> acc
| [], n -> (Neg (alloc [ (union n) ])) :: acc
| p, [] -> (intersection p) :: acc
| p, n -> (intersection (p @ (List.map (fun n -> Neg (alloc [ n] )) n))) :: acc
) acc (get bdd)
in
let printed_seq = if non_empty seq then (Regexp (decompile seq)) :: [] else [] in
let print_descr tv_pos tv_neg tt =
if is_empty tt then [] else
let printed_topvars =
let pneg =
Var.Set.fold
(fun acc v -> (Neg (alloc [Atomic (fun ppf -> Var.pp ppf v)])) :: acc) [] tv_neg
in
Var.Set.fold
(fun acc v -> (Atomic (fun ppf -> Var.pp ppf v)) :: acc) pneg tv_pos
in
if subtype any tt then printed_topvars else
let tt, fix =
if worth_complement tt then diff any tt, (fun x -> [Neg (alloc x)])
else tt , fun x -> x
in
(* base types *)
let u_acc = prepare_boolvar BoolChars.get (fun bdd ->
match Chars.is_char bdd with
| Some c -> [Char c]
| None -> [Union(alloc (List.map (fun x -> (Atomic x)) (Chars.print bdd)))]
) tt.chars []
in
let u_acc = prepare_boolvar BoolIntervals.get (fun bdd ->
match Intervals.print bdd with
|[x] -> [Atomic x]
|l -> [Union(alloc (List.map (fun x -> (Atomic x)) l))]
) tt.ints u_acc
in
let u_acc = prepare_boolvar BoolIntervals.get (fun bdd ->
match Intervals.print bdd with
|[x] -> [Atomic x]
|l -> [Union(alloc (List.map (fun x -> (Atomic x)) l))]
) tt.ints u_acc
in
let bool =
Atoms.cup
(Atoms.atom (Atoms.V.mk_ascii "false"))
(Atoms.atom (Atoms.V.mk_ascii "true"))
in
let u_acc = prepare_boolvar BoolAtoms.get (fun bdd ->
match Atoms.print bdd with
|[x] when (Atoms.equal bool bdd) ->
[Atomic (fun ppf -> Format.fprintf ppf "Bool")]
|[x] -> [Atomic x]
|l -> [Union(alloc (List.map (fun x -> (Atomic x)) l))]
) tt.atoms u_acc
in
let bool =
Atoms.cup
(Atoms.atom (Atoms.V.mk_ascii "false"))
(Atoms.atom (Atoms.V.mk_ascii "true"))
in
let u_acc = prepare_boolvar BoolAtoms.get (fun bdd ->
match Atoms.print bdd with
|[x] when (Atoms.equal bool bdd) ->
[Atomic (fun ppf -> Format.fprintf ppf "Bool")]
|[x] -> [Atomic x]
|l -> [Union(alloc (List.map (fun x -> (Atomic x)) l))]
) tt.atoms u_acc
in
(* pairs *)
let u_acc = prepare_boolvar BoolPair.get (fun x ->
List.map (fun (t1,t2) ->
Pair (prepare t1, prepare t2)
) (Product.partition any x)
) tt.times u_acc
in
(* pairs *)
let u_acc = prepare_boolvar BoolPair.get (fun x ->
List.map (fun (t1,t2) ->
Pair (prepare t1, prepare t2)
) (Product.partition any x)
) tt.times u_acc
in
(* xml pairs *)
let u_acc = prepare_boolvar BoolPair.get (fun x ->
List.flatten (
List.map (fun (t1,t2) ->
try let n = DescrPairMap.find (t1,t2) !named_xml in [(Name n)]
with Not_found ->
let tag =
match Atoms.print_tag (BoolAtoms.leafconj t1.atoms) with
| Some a when is_empty { t1 with atoms = BoolAtoms.empty } -> `Tag a
| _ -> `Type (prepare t1)
in
assert (equal { t2 with times = empty.times } empty);
List.map (fun (ta,tb) ->
(Xml (tag, prepare ta, prepare tb))
) (Product.get t2);
) (Product.partition any_pair x)
)
) tt.xml u_acc
in
(* xml pairs *)
let u_acc = prepare_boolvar BoolPair.get (fun x ->
List.flatten (
List.map (fun (t1,t2) ->
try let n = DescrPairMap.find (t1,t2) !named_xml in [(Name n)]
with Not_found ->
let tag =
match Atoms.print_tag (BoolAtoms.leafconj t1.atoms) with
| Some a when is_empty { t1 with atoms = BoolAtoms.empty } -> `Tag a
| _ -> `Type (prepare t1)
in
assert (equal { t2 with times = empty.times } empty);
List.map (fun (ta,tb) ->
(Xml (tag, prepare ta, prepare tb))
) (Product.get t2);
) (Product.partition any_pair x)
)
) tt.xml u_acc
in
(* arrows *)
let u_acc = prepare_boolvar BoolPair.get (fun x ->
List.map (fun (p,n) ->
let aux (t,s) = prepare (descr t), prepare (descr s) in
let p = List.map aux p and n = List.map aux n in
(Arrows (p,n))
) (Pair.get x)) tt.arrow u_acc
in
(* arrows *)
let u_acc = prepare_boolvar BoolPair.get (fun x ->
List.map (fun (p,n) ->
let aux (t,s) = prepare (descr t), prepare (descr s) in
let p = List.map aux p and n = List.map aux n in
(Arrows (p,n))
) (Pair.get x)) tt.arrow u_acc
in
(* records *)
let u_acc = prepare_boolvar BoolRec.get (fun x ->
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 = BoolRec.atom (`Atm x) })) tt.record u_acc
in
(* records *)
let u_acc = prepare_boolvar BoolRec.get (fun x ->
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 = BoolRec.atom (`Atm x) })) tt.record u_acc
in
let u_acc = prepare_boolvar BoolAbstracts.get (fun bdd ->
match Abstracts.print bdd with
|[x] -> [Atomic x]
|l -> [Union(alloc (List.map (fun x -> (Atomic x)) l))]
) tt.abstract u_acc
in
let u_acc = prepare_boolvar BoolAbstracts.get (fun bdd ->
match Abstracts.print bdd with
|[x] -> [Atomic x]
|l -> [Union(alloc (List.map (fun x -> (Atomic x)) l))]
) tt.abstract u_acc
in
let u_acc =
if tt.absent then (Atomic (fun ppf -> Format.fprintf ppf "#ABSENT")) :: u_acc
else u_acc
in
fix u_acc
in
let printed = if is_empty not_var then [] else print_descr not_var in
let printed = printed @ printed_seq in
if is_empty not_seq then (slot.def <- printed @ slot.def ; slot)
else
let printed_not_seq = print_descr not_seq in
begin
match printed_topvar with
[] -> if subtype any not_seq then slot.def <- (Neg (alloc [])) :: slot.def
else slot.def <- printed @ printed_not_seq @ slot.def
| _ -> if subtype any not_seq then slot.def <- ((intersection printed_topvar) :: printed) @ slot.def
else
slot.def <- (intersection ((union printed_not_seq) :: printed_topvar)) :: (printed @ slot.def)
end;
let u_acc =
if tt.absent then (Atomic (fun ppf -> Format.fprintf ppf "#ABSENT")) :: u_acc
else u_acc
in
let p_t = fix u_acc in
printed_topvars @ p_t
in
let all_printed =
List.fold_left (fun acc ((vp,vn),t) ->
match print_descr vp vn t with
[] -> acc
| [p] -> p :: acc
| l -> (intersection l) :: acc
) printed_seq all_descrs
in
slot.def <- all_printed @ slot.def;
slot
and decompile d =
let aux t =
let tr = Product.get t in
......@@ -2145,7 +2147,7 @@ struct
| Regexp r -> Format.fprintf ppf "@[[ %a ]@]" (do_print_regexp 0) r
| Atomic a -> a ppf
| Intersection { def = ([ Neg b ; a ] | [ a; Neg b]) } ->
Format.fprintf ppf "@[%a@] \\ (@[%a@])" (do_print pri) a (do_print_slot pri) b
Format.fprintf ppf "(@[%a@] \\ (@[%a@]))" (do_print pri) a (do_print_slot pri) b
| Intersection { def = [ a ] }
| Union { def = [ a ] } -> Format.fprintf ppf "@[%a@]" (do_print pri) a
| Intersection a -> Format.fprintf ppf "@[%a@]" (do_print_slot ~sep:"&" 2) a
......
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