Commit 22ec8391 authored by Pietro Abate's avatar Pietro Abate
Browse files

More work on type pretty printing

parent 90028212
...@@ -1584,7 +1584,8 @@ struct ...@@ -1584,7 +1584,8 @@ struct
else else
let slot = alloc [] in let slot = alloc [] in
if not (worth_abbrev d) then slot.state <- `Expand; if not (worth_abbrev d) then slot.state <- `Expand;
DescrHash.add memo d slot;
DescrHash.add memo d slot;
let (seq,not_seq) = let (seq,not_seq) =
if (subtype { empty with times = d.times } seqs_descr) then if (subtype { empty with times = d.times } seqs_descr) then
...@@ -1595,25 +1596,26 @@ struct ...@@ -1595,25 +1596,26 @@ struct
let add u = slot.def <- u :: slot.def in let add u = slot.def <- u :: slot.def in
let prepare_boolvar ?(t=false) get print tlv bdd = let prepare_boolvar ?(displayvars=false) ?(displayatoms=true) get is_full print tlv bdd =
List.iter (fun (p,n) -> List.iter (fun (p,n) ->
let l1 = let l1 =
List.fold_left (fun acc -> function List.fold_left (fun acc -> function
|(`Var v) as x -> |(`Var v) as x ->
begin match (t, (TLV.mem (x,true) tlv)) with begin match (displayvars, (TLV.mem (x,true) tlv)) with
|(true,true) |(true,true) |(_,false) -> (Atomic (fun ppf -> Var.print ppf x))::acc
|(_,false) -> (Atomic (fun ppf -> Var.print ppf x))::acc |(_,_) -> acc
|(false,true) -> acc end end
|`Atm bdd -> (print bdd) @ acc |`Atm bdd -> if displayatoms then (print bdd) @ acc else acc
) [] p ) [] p
in in
let l2 = let l2 =
List.fold_left (fun acc -> function List.fold_left (fun acc -> function
|(`Var v) as x -> |(`Var v) as x ->
begin match (t, (TLV.mem (x,false) tlv)) with begin match (displayvars, (TLV.mem (x,false) tlv)) with
|(true,true) |(true,true) |(_,false) ->
|(_,false) -> (Atomic (fun ppf -> Format.fprintf ppf "~ %a" Var.print x))::acc (Atomic (fun ppf -> Format.fprintf ppf "~ %a" Var.print x))::acc
|(false,true) -> acc end |(_,_) -> acc
end
|`Atm bdd -> assert false |`Atm bdd -> assert false
) [] n ) [] n
in in
...@@ -1625,30 +1627,33 @@ struct ...@@ -1625,30 +1627,33 @@ struct
if (non_empty seq) then add (Regexp (decompile seq)); if (non_empty seq) then add (Regexp (decompile seq));
let displayatoms = TLV.no_toplevel not_seq.toplvars in
let displayvars = true in
(* base types *) (* base types *)
prepare_boolvar ~t:true BoolIntervals.get (fun x -> prepare_boolvar ~displayvars ~displayatoms BoolIntervals.get (Intervals.equal Intervals.full) (fun x ->
List.map (fun x -> (Atomic x)) (Intervals.print x) List.map (fun x -> (Atomic x)) (Intervals.print x)
) not_seq.toplvars not_seq.ints; ) not_seq.toplvars not_seq.ints;
prepare_boolvar BoolChars.get (fun x -> prepare_boolvar ~displayatoms BoolChars.get (Chars.equal Chars.full) (fun x ->
match Chars.is_char x with match Chars.is_char x with
| Some c -> [(Char c)] | Some c -> [(Char c)]
| None -> List.map (fun x -> (Atomic x)) (Chars.print x) | None -> List.map (fun x -> (Atomic x)) (Chars.print x)
) not_seq.toplvars not_seq.chars; ) not_seq.toplvars not_seq.chars;
prepare_boolvar BoolAtoms.get (fun x -> prepare_boolvar ~displayatoms BoolAtoms.get (Atoms.equal Atoms.full) (fun x ->
List.map (fun x -> (Atomic x)) (Atoms.print x) List.map (fun x -> (Atomic x)) (Atoms.print x)
) not_seq.toplvars not_seq.atoms; ) not_seq.toplvars not_seq.atoms;
(* pairs *) (* pairs *)
prepare_boolvar BoolPair.get (fun x -> prepare_boolvar ~displayatoms BoolPair.get (Pair.equal Pair.full) (fun x ->
List.map (fun (t1,t2) -> List.map (fun (t1,t2) ->
(Pair (prepare t1, prepare t2)) (Pair (prepare t1, prepare t2))
) (Product.partition any x)) not_seq.toplvars not_seq.times; ) (Product.partition any x)) not_seq.toplvars not_seq.times;
(* xml pairs *) (* xml pairs *)
prepare_boolvar BoolPair.get (fun x -> prepare_boolvar ~displayatoms BoolPair.get (Pair.equal Pair.full) (fun x ->
List.flatten ( List.flatten (
List.map (fun (t1,t2) -> List.map (fun (t1,t2) ->
try let n = DescrPairMap.find (t1,t2) !named_xml in [(Name n)] try let n = DescrPairMap.find (t1,t2) !named_xml in [(Name n)]
...@@ -1666,7 +1671,7 @@ struct ...@@ -1666,7 +1671,7 @@ struct
)) not_seq.toplvars not_seq.xml; )) not_seq.toplvars not_seq.xml;
(* arrows *) (* arrows *)
prepare_boolvar BoolPair.get (fun x -> prepare_boolvar ~displayatoms BoolPair.get (Pair.equal Pair.full) (fun x ->
List.map (fun (p,n) -> List.map (fun (p,n) ->
let aux (t,s) = prepare (descr t), prepare (descr s) in let aux (t,s) = prepare (descr t), prepare (descr s) in
let p = List.map aux p and n = List.map aux n in let p = List.map aux p and n = List.map aux n in
......
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