Commit ae31d5c7 by Kim Nguyễn

Further simplification of the pretty-printing code.

parent 8097d14b
 ... ... @@ -2019,6 +2019,66 @@ module Print = struct (Atoms.atom (Atoms.V.mk_ascii "true")))) ) (** pretty-printers for each kind, without top-level variables *) let print_seq finite_atoms decompile acc tt = 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 = VarTimes.(update Descr.empty (proj seq)) in if is_empty seq || (is_empty seq_times && not finite_atoms) then acc, tt else let tt = let d = diff tt seqs_descr in if finite_atoms then d else cup d (cap tt nil_type) in (Regexp (decompile seq)) :: acc, tt else [], tt let print_chars acc tt = (* use fold_right to preserve order... see if that + the List.rev at the end cancel nicely *) List.fold_right (fun x acc -> (Atomic x) :: acc) (Chars.print (VarChars.(leafconj (proj tt)))) acc let print_ints acc tt = List.fold_right (fun x acc -> (Atomic x) :: acc) (Intervals.print (VarIntervals.(leafconj (proj tt)))) acc let print_atoms acc tt = (* We need this complex bit because Atoms.print does not know about the precedence of outer operators *) let pr_atoms acc l = List.fold_left (fun acc (ns, atm) -> (match atm with `Finite l -> List.map (fun a -> Atomic (fun ppf -> Atoms.V.print_quote ppf a)) l | `Cofinite l -> [ Diff (alloc [ Atomic (fun ppf -> Format.fprintf ppf "`%a" Ns.InternalPrinter.print_any_ns ns) ], alloc (List.map (fun a -> Atomic (fun ppf -> Atoms.V.print_quote ppf a)) l)) ]) @ acc ) acc l in match Atoms.extract (VarAtoms.(leafconj (proj tt))) with `Finite l -> pr_atoms acc l | `Cofinite [] -> (Display "Atom") :: acc | `Cofinite l -> (Diff (alloc[Display "Atom"], alloc (pr_atoms [] l))) :: acc (** [prepare d] massages a type and convert it to the syntactic form. Rough algorithm: - check whether [d] has been memoized (recursive types) ... ... @@ -2038,6 +2098,8 @@ module Print = struct - if an atomic type is finite and contains the atoms `false and `true then write it has Bool. *) let rec prepare d = let d = lookup d in try DescrHash.find memo d ... ... @@ -2229,63 +2291,23 @@ module Print = struct (* sequence type. We do not want to split types such as Any into Any \ [ Any *] | Any, and likewise, write Atom \ [] | []. *) let finite_atoms = Atoms.is_finite (VarAtoms.leafconj tt.atoms) in let u_acc, tt = 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 = VarTimes.(update Descr.empty (proj seq)) in if is_empty seq || (is_empty seq_times && not finite_atoms) then [], tt else let tt = let d = diff tt seqs_descr in if finite_atoms then d else cup d (cap tt nil_type) in [ (Regexp (decompile seq)) ], tt else [], tt in let finite_atoms = Atoms.is_finite VarAtoms.(leafconj (proj tt)) in (* base types *) let u_acc = (List.map (fun x -> Atomic x) (Chars.print (VarChars.leafconj tt.chars))) @ u_acc in let u_acc = (List.map (fun x -> (Atomic x)) (Intervals.print (VarIntervals.leafconj tt.ints))) @ u_acc in let u_acc, tt = print_seq finite_atoms decompile [] tt in (* basic types *) let u_acc = print_chars u_acc tt in let u_acc = print_ints u_acc tt in (* display the Bool type explicitely if present *) let u_acc, tt = if finite_atoms && subtype bool_type tt then (Display "Bool") :: u_acc, diff tt bool_type else u_acc, tt in let pr_atoms l = List.fold_left (fun acc (ns, atm) -> (match atm with `Finite l -> List.map (fun a -> Atomic (fun ppf -> Atoms.V.print_quote ppf a)) l | `Cofinite l -> [ Diff (alloc [ Atomic (fun ppf -> Format.fprintf ppf "`%a" Ns.InternalPrinter.print_any_ns ns) ] , alloc (List.map (fun a -> Atomic (fun ppf -> Atoms.V.print_quote ppf a)) l)) ]) @ acc ) [] l in let u_acc = match Atoms.extract (VarAtoms.leafconj tt.atoms) with `Finite l -> (pr_atoms l) @ u_acc | `Cofinite [] -> (Display "Atom") :: u_acc | `Cofinite l -> (Diff (alloc[Display "Atom"], alloc (pr_atoms l))) :: u_acc in let u_acc = print_atoms u_acc tt in (* pairs *) let u_acc = List.fold_left (fun acc (t1,t2) -> ... ... @@ -2301,7 +2323,7 @@ module Print = struct try let n = DescrPairMap.find (t1,t2) !named_xml in [(Name n)] with Not_found -> let tag = match Atoms.print_tag (VarAtoms.leafconj t1.atoms) with match Atoms.print_tag (VarAtoms.(leafconj (proj t1))) with Some a when is_empty (VarAtoms.(update t1 empty)) -> `Tag a | _ -> `Type (prepare t1) in ... ... @@ -2343,7 +2365,6 @@ module Print = struct (Abstracts.print (VarAbstracts.leafconj tt.abstract)) ) @ u_acc in assert (not tt.absent); (* is taken care of at the top *) print_topvars positive u_acc in let all_printed = ... ... @@ -2359,7 +2380,7 @@ module Print = struct let tr = Product.merge_same_first tr in let tr = Product.clean_normal tr in let eps = Atoms.contains nil_atom (VarAtoms.leafconj t.atoms) in let eps = Atoms.contains nil_atom (VarAtoms.(leafconj (proj t))) in let tr_cons = List.map (fun (li,ti) -> (cons li, cons ti)) tr in try ... ... @@ -2391,7 +2412,7 @@ module Print = struct let g = !gen in s.state <- `Marked; List.iter assign_name_rec s.def; (* + 8 allows to disable sharing for small subtrees *) (* + 8 disables 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 | _ -> () ... ...
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!