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

More work on pretty-printing:

- Simplify the pretty-printing descriptor type
- Fix a bug where some unions were shown as intersections
- Correctly display parentheses where needed (issue: #17)
- Prevent sharing for "small" subtrees (AST less than 6 nodes), so:
  (Int -> Int) -> Int -> Int
  is not shown as:
  X1 -> X1 where X1 = Int -> Int
  (but bigger types are).
parent bc7a6f34
......@@ -1686,19 +1686,16 @@ struct
| Xml of [ `Tag of (Format.formatter -> unit) | `Type of nd ] * nd * nd
| Record of (bool * nd) label_map * bool * bool
| Arrows of (nd * nd) list * (nd * nd) list
| Intersection of nd
| Union of nd
| Intersection of nd list
| Diff of nd * nd
| 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
include Custom.Pair(Var.Set)(Var.Set)
let empty = Var.Set.(empty,empty)
let is_empty (v1, v2) = Var.Set.(is_empty v1 && is_empty v2)
end
module VarTable = Hashtbl.Make(Key)
module KeySet = Set.Make(Key)
......@@ -1751,7 +1748,10 @@ struct
let memo = DescrHash.create 63
let counter = ref 0
let alloc def = { id = (incr counter; !counter); def = def; state = `None }
let alloc def = { id = (incr counter; !counter);
def = def;
state = `None;
}
let count_name = ref 0
let name () =
......@@ -1869,14 +1869,13 @@ struct
let res =
VarTable.fold (fun ((v1, v2) as k) tt acc ->
if Var.Set.(not (is_empty (inter v1 v2))) || is_empty tt then acc
else if Var.Set.(is_empty v1 && is_empty v2) &&
subtype any tt then raise Not_found
else if Key.is_empty k && subtype any tt then raise Not_found
else
(k, tt) :: acc
) h []
in
false, res
with Not_found -> true, [ Var.Set.(empty,empty), any ]
with Not_found -> true, [ Key.empty , any ]
in
if found_any then (slot.def <- [Neg (alloc [])];slot)
else
......@@ -1913,29 +1912,19 @@ struct
merge_columns ((factv, remv,t)::acc) nll
in
let all_descrs = merge_columns [] all_descrs in
let cons constr empty = function
| [] -> empty
| [ t ] -> t
| l -> constr (alloc l)
let intersection l =
match l with
[] -> Neg (alloc [])
| [ p ] -> p
| [ p ; Neg { def = [] } ] -> p
| _ -> Intersection (List.map (fun x -> alloc [x]) 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 _ -> assert false
(* there should not be any toplevel variable left *)
| `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)
(* there should not be any toplevel variable left *)
match get bdd with
[ ] -> acc
| [ ([`Atm bdd], []) ] -> (print bdd) @ acc
| _ -> assert false
in
let print_vars l =
Var.Set.fold
......@@ -1945,34 +1934,32 @@ struct
List.fold_left (fun acc (p,n) ->
let pneg = print_vars n in
let ppos = print_vars p in
match List.rev ppos, List.rev pneg with
match List.rev ppos, List.rev pneg with
[],[] -> acc
| [p],[] -> p::acc
| [],l -> Neg(alloc[ (union l)]) :: acc
| [],l -> Neg(alloc l) :: acc
| l, [] -> (intersection l) :: acc
| l1,l2 -> (intersection [intersection l1;
Neg(alloc[ (union l2)])]) :: acc
Neg(alloc l2)]) :: acc
) [] l
in
let print_descr (pvars,nvars) lvars tt =
if is_empty tt then None else
if is_empty tt then [] else
let print_topvars pos rem =
let printed_nvars = print_vars nvars in
let negative_part = match printed_nvars @ (if not pos then rem else []) with
([] | [ _ ]) as l -> l
| l -> [ union l ]
in
let rem = List.rev rem in
let printed_nvars = List.rev (print_vars nvars) in
let negative_part = printed_nvars @ (if pos then [] else rem) in
let printed_lvars = print_pnvars lvars in
let positive_part2 = match printed_lvars @ (if pos then rem else []) with
([] | [ _ ]) as l -> l
| l -> [ union l ]
let positive_part2 = printed_lvars @ (if pos then rem else []) in
let positive_part =
(List.rev_map (fun e -> alloc [e]) (print_vars pvars))
@ (if positive_part2 == []
then [] else [ alloc positive_part2 ])
in
let positive_part = (print_vars pvars) @ positive_part2 in
match positive_part, negative_part with
[], [] -> None
| [], l -> Some ( Neg (alloc l) )
| l, [] -> Some ( intersection l )
| l1, l2 -> Some ( intersection [ intersection l1; Neg (alloc l2) ])
[], [] -> []
| [], l -> [ Neg (alloc l) ]
| l, [] -> [ Intersection l ]
| l1, l2 -> [ Diff (alloc [Intersection l1], alloc l2) ]
in
if subtype any tt then print_topvars true [] else
let tt, positive =
......@@ -1995,14 +1982,13 @@ struct
match Chars.is_char bdd with
| Some c -> [Char c]
| None ->
[union (List.map (fun x -> (Atomic x)) (Chars.print bdd))]
List.map (fun x -> (Atomic x)) (Chars.print bdd)
) tt.chars u_acc
in
let u_acc = prepare_boolvar BoolIntervals.get (fun bdd ->
match Intervals.print bdd with
|[x] -> [Atomic x]
|l -> [union (List.map (fun x -> (Atomic x)) l)]
let l = Intervals.print bdd in
List.map (fun x -> (Atomic x)) l
) tt.ints u_acc
in
......@@ -2013,10 +1999,9 @@ struct
in
let u_acc = prepare_boolvar BoolAtoms.get (fun bdd ->
match Atoms.print bdd with
|[x] when (Atoms.equal bool bdd) ->
| [ x ] when (Atoms.equal bool bdd) ->
[Atomic (fun ppf -> Format.fprintf ppf "Bool")]
|[x] -> [Atomic x]
|l -> [ union (List.map (fun x -> (Atomic x)) l) ]
| l -> List.map (fun x -> (Atomic x)) l
) tt.atoms u_acc
in
......@@ -2066,9 +2051,8 @@ struct
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))]
let l = Abstracts.print bdd in
List.map (fun x -> (Atomic x)) l
) tt.abstract u_acc
in
......@@ -2080,13 +2064,10 @@ struct
in
let all_printed =
List.fold_left (fun acc (factvars,lvars,t) ->
match print_descr factvars lvars t, acc with
None, _ -> acc
| Some p, (Union { def = l }) :: racc -> (union (p :: l)) :: racc
| Some p, _ -> p::acc
) [] all_descrs
(print_descr factvars lvars t) @ acc
) slot.def all_descrs
in
slot.def <- all_printed @ slot.def;
slot.def <- all_printed;
slot
and decompile d =
let aux t =
......@@ -2117,61 +2098,6 @@ struct
in
Decompile.decompile aux d
(* clean a pretty-printed representation:
- merge intersection of intersections/unions of unions
*)
let cleanup_pretty nd =
let rec clean_nd parent nd =
{ nd with def = clean_slot parent nd.def }
and clean_slot parent l =
List.fold_right (fun d acc ->
(clean_d parent d) @ acc ) l []
and clean_d parent d =
match d with
| Name _ | Atomic _ | Char _ -> [ d ]
| Regexp reg -> [ Regexp (clean_regexp d reg) ]
| Pair (nd1, nd2) -> [ Pair(clean_nd d nd1, clean_nd d nd2) ]
| Xml (t, nd1, nd2) ->
let nt = match t with
`Tag _ as x -> x
| `Type nd0 -> `Type (clean_nd d nd0)
in
[ Xml (nt, clean_nd d nd1, clean_nd d nd2) ]
| Record (lm, b1, b2) ->
[ Record(Ident.LabelMap.map (fun (b, nd) -> b, clean_nd d nd) lm, b1, b2) ]
| Arrows (l1, l2) ->
[ Arrows (List.map (fun (nd1, nd2) -> (clean_nd d nd1, clean_nd d nd2)) l1,
List.map (fun (nd1, nd2) -> (clean_nd d nd1, clean_nd d nd2)) l2)]
| Intersection nd ->
let new_nd = clean_nd d nd in begin
match parent, new_nd.def with
Intersection _,_ | _, [ _ ] -> new_nd.def
| _ -> [ Intersection new_nd ]
end
| Union nd ->
let new_nd = clean_nd d nd in begin
match parent, new_nd.def with
Union _,_ | _, [ _ ] -> new_nd.def
| _ -> [ Union new_nd ] end
| Neg nd ->
let new_nd = clean_nd d nd in begin
match new_nd.def with
[ Neg nd' ] -> nd'.def
| _ -> [ Neg new_nd ] end
| Abs nd -> [ Abs (clean_nd d nd) ]
and clean_regexp parent reg =
match reg with
Pretty.Empty | Pretty.Epsilon -> reg
| Pretty.Seq (r1, r2) -> Pretty.Seq(clean_regexp parent r1,
clean_regexp parent r2)
| Pretty.Alt (r1, r2) -> Pretty.Alt(clean_regexp parent r1,
clean_regexp parent r2)
| Pretty.Star r -> Pretty.Star(clean_regexp parent r)
| Pretty.Plus r -> Pretty.Plus(clean_regexp parent r)
| Pretty.Trans nd -> Pretty.Trans(clean_nd parent nd)
in
clean_nd (Union (alloc [])) nd
let gen = ref 0
......@@ -2182,7 +2108,8 @@ struct
let g = !gen in
s.state <- `Marked;
List.iter assign_name_rec s.def;
if (s.state == `Marked) && (!gen == g) then s.state <- `None
(* + 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
......@@ -2191,8 +2118,8 @@ struct
| Name _ | Char _ | Atomic _ -> ()
| Regexp r -> assign_name_regexp r
| Pair (t1,t2) -> assign_name t1; assign_name t2
| Intersection t -> () (* assign_name_rec t.def ??? *)
| Union t -> () (* assign_name t *)
| Intersection l -> List.iter assign_name l
| Diff (t1, t2) -> assign_name t1; assign_name t2
| Xml (tag,t2,t3) ->
(match tag with `Type t -> assign_name t | _ -> ());
assign_name t2;
......@@ -2212,74 +2139,115 @@ struct
let print_gname ppf (cu,n) =
Format.fprintf ppf "%s%a" cu Ns.QName.print n
let rec do_print_slot ?(sep="|") pri ppf s =
(* operator precedences:
10 names, constants, ...
9 star plus ?
8 seq
7 \ left of \
6 \
5 &
4 | alt
3 <t1 >
2 arrow left of arrow
1 t1 -> t2
0
*)
let opar ppf ~level pri =
if level < pri then Format.fprintf ppf "@[("
let cpar ppf ~level pri =
if level < pri then Format.fprintf ppf ")@]"
let rec do_print_slot pri ppf s =
match s.state with
| `Named n -> U.print ppf n
| `GlobalName n -> print_gname ppf n
| _ -> do_print_slot_real ~sep pri ppf s.def
and do_print_slot_real ?(sep="|") pri ppf def =
| _ -> do_print_slot_real pri ppf s.def
and do_print_slot_real pri ppf def =
let rec aux ppf = function
| [] -> Format.fprintf ppf "Empty"
| [ h ] -> (do_print pri) ppf h
| h :: t -> Format.fprintf ppf "%a %s@ %a" (do_print pri) h sep aux t
| [] -> assert false
| [ h ] -> (do_print 4) ppf h
| h :: t -> Format.fprintf ppf "%a |@ %a" (do_print 4) h aux t
in
if (pri >= 2) && (List.length def >= 2) then
Format.fprintf ppf "@[(%a)@]" aux def
else
aux ppf def
match def with
[] -> Format.fprintf ppf "Empty"
| [ h ] -> do_print pri ppf h
| _ when pri >= 5 -> Format.fprintf ppf "@[(%a)@]" aux def
| _ -> aux ppf def
and do_print pri ppf =
function
| Neg { def = [] } -> Format.fprintf ppf "Any"
| Neg t -> Format.fprintf ppf "Any \\ (@[%a@])" (do_print_slot 0) t
| Neg t -> Format.fprintf ppf "Any \\ @[%a@]" (do_print_slot 6) t
| Abs t -> Format.fprintf ppf "?(@[%a@])" (do_print_slot 0) t
| Name n -> print_gname ppf n
| Char c -> Chars.V.print ppf c
| 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
| 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
| Union a -> Format.fprintf ppf "@[%a@]" (do_print_slot ~sep:"|" 2) a
| Diff (a, b) ->
opar ppf ~level:6 pri;
Format.fprintf ppf "@[%a@] \\ @[%a@]" (do_print_slot 7) a
(do_print_slot 6) b;
cpar ppf ~level:6 pri
| Intersection [] -> ()
| Intersection [ p ] -> do_print_slot pri ppf p
| Intersection a ->
opar ppf ~level:5 pri;
begin
match a with
[] -> assert false
| [ i ] -> do_print_slot pri ppf i
| h :: t ->
Format.fprintf ppf "%a" (do_print_slot 5) h;
List.iter (fun i -> Format.fprintf ppf " &@ %a" (do_print_slot 5) i) t
end;
cpar ppf ~level:5 pri
| Pair (t1,t2) ->
Format.fprintf ppf "@[(%a,%a)@]"
(do_print_slot 0) t1
(do_print_slot 0) t2
| Xml (tag,attr,t) ->
opar ppf ~level:3 pri;
Format.fprintf ppf "<%a%a>%a"
do_print_tag tag
do_print_attr attr
(do_print_slot 2) t
(do_print_slot 3) t;
cpar ppf ~level:3 pri;
| Record (r,some,none) ->
Format.fprintf ppf "@[{";
do_print_record ppf (r,some,none);
Format.fprintf ppf " }@]"
| Arrows (p,n) ->
(match p with
| [] -> Format.fprintf ppf "Arrow"
| (t,s)::l ->
Format.fprintf ppf "%a" (do_print_arrow pri) (t,s);
List.iter (fun (t,s) ->
Format.fprintf ppf " &@ %a" (do_print_arrow pri) (t,s)
) l
);
if n != [] then opar ppf ~level:6 pri;
(match p with
| [] -> Format.fprintf ppf "Arrow"
| (t,s)::[] ->
let pri = if n == [] then pri else 7 in
Format.fprintf ppf "%a" (do_print_arrow pri) (t,s);
| (t,s)::l ->
Format.fprintf ppf "%a" (do_print_arrow 5) (t,s);
List.iter (fun (t,s) ->
Format.fprintf ppf " \\@ %a" (do_print_arrow pri) (t,s)
) n
Format.fprintf ppf " &@ %a" (do_print_arrow 5) (t,s)
) l
);
List.iter (fun (t,s) ->
let pri = if n == [] then pri else 6 in
Format.fprintf ppf " \\@ %a" (do_print_arrow pri) (t,s)
) n;
if n != [] then cpar ppf ~level:6 pri
and do_print_arrow pri ppf (t,s) =
if (pri = 3) then Format.fprintf ppf "(";
opar ppf ~level:1 pri;
Format.fprintf ppf "%a -> %a"
(do_print_slot 3) t
(do_print_slot 2) s;
if (pri = 3) then Format.fprintf ppf ")"
(do_print_slot 2) t
(do_print_slot 1) s;
cpar ppf ~level:1 pri
and do_print_tag ppf = function
| `Tag s -> s ppf
| `Type t -> Format.fprintf ppf "(%a)" (do_print_slot 0) t
and do_print_attr ppf = function
| { state = `Marked|`Expand|`None;
def = [ Record (r,some,none) ] } -> do_print_record ppf (r,some,none)
| t -> Format.fprintf ppf " (%a)" (do_print_slot 2) t
| t -> Format.fprintf ppf " (%a)" (do_print_slot 0) t
and do_print_record ppf (r,some,none) =
List.iter
(fun (l,(o,t)) ->
......@@ -2299,29 +2267,29 @@ struct
List.iter (Chars.V.print_in_string ppf) s;
Format.fprintf ppf "'"
| s, Some r ->
if pri >= 3 then Format.fprintf ppf "@[(";
Format.fprintf ppf "'";
List.iter (Chars.V.print_in_string ppf) s;
Format.fprintf ppf "' %a" (do_print_regexp 2) r;
if pri >= 3 then Format.fprintf ppf ")@]")
opar ppf ~level:8 pri;
Format.fprintf ppf "'";
List.iter (Chars.V.print_in_string ppf) s;
Format.fprintf ppf "' %a" (do_print_regexp 8) r;
cpar ppf ~level:8 pri)
| Pretty.Seq (r1,r2) ->
if pri >= 3 then Format.fprintf ppf "@[(";
Format.fprintf ppf "%a@ %a"
(do_print_regexp 2) r1
(do_print_regexp 2) r2;
if pri >= 3 then Format.fprintf ppf ")@]"
opar ppf ~level:8 pri;
Format.fprintf ppf "%a@ %a"
(do_print_regexp 8) r1
(do_print_regexp 8) r2;
cpar ppf ~level:8 pri
| Pretty.Alt (r,Pretty.Epsilon) | Pretty.Alt (Pretty.Epsilon,r) ->
Format.fprintf ppf "@[%a@]?" (do_print_regexp 3) r
Format.fprintf ppf "@[%a@]?" (do_print_regexp 9) r
| Pretty.Alt (r1,r2) ->
if pri >= 2 then Format.fprintf ppf "@[(";
Format.fprintf ppf "%a |@ %a"
(do_print_regexp 1) r1
(do_print_regexp 1) r2;
if pri >= 2 then Format.fprintf ppf ")@]"
opar ppf ~level:4 pri;
Format.fprintf ppf "%a |@ %a"
(do_print_regexp 4) r1
(do_print_regexp 4) r2;
cpar ppf ~level:4 pri
| Pretty.Star r ->
Format.fprintf ppf "@[%a@]*" (do_print_regexp 3) r
Format.fprintf ppf "@[%a@]*" (do_print_regexp 9) r
| Pretty.Plus r ->
Format.fprintf ppf "@[%a@]+" (do_print_regexp 3) r
Format.fprintf ppf "@[%a@]+" (do_print_regexp 9) r
| Pretty.Trans t ->
do_print_slot pri ppf t
and extract_string accu = function
......@@ -2339,7 +2307,6 @@ struct
let pp_type ppf t =
let t = uniq t in
let t = prepare t in
let t = cleanup_pretty t in
assign_name t;
Format.fprintf ppf "@[@[%a@]" (do_print_slot 0) t;
(match List.rev !to_print with
......
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