[r2003-05-19 20:30:05 by cvscast] Improve pretty-printer

Original author: cvscast
Date: 2003-05-19 20:30:05+00:00

misc/pretty.ml

@@ -4,32 +4,148 @@ type 'a regexp =
   | Seq of 'a regexp * 'a regexp
   | Alt of 'a regexp * 'a regexp
   | Star of 'a regexp
+  | Plus of 'a regexp
   | Trans of 'a
 
-module Decompile(H : Hashtbl.S) = struct
-  let alt s1 s2 = match (s1,s2) with
-    | Empty,s | s,Empty -> s2 
-    | (s1,s2) -> Alt (s1,s2)
+type 'a re =
+  | RSeq of 'a re list
+  | RAlt of 'a re list
+  | RTrans of 'a
+  | RStar of 'a re
 
-  let star = function
-    | Empty | Epsilon -> Epsilon
-    | Star _ as s -> s 
-    | s -> Star s
+  | RPlus of 'a re
+
+
+module Decompile(H : Hashtbl.S)(S : Set.OrderedType) = struct
+  let rec compare s1 s2 = 
+    if s1 == s2 then 0 
+    else match (s1,s2) with
+      | RSeq x, RSeq y | RAlt x, RAlt y -> compare_list x y
+      | RSeq _, _ -> -1 | _, RSeq _ -> 1
+      | RAlt _, _ -> -1 | _, RAlt _ -> 1
+      | RTrans x, RTrans y -> S.compare x y
+      | RTrans _, _ -> -1 | _, RTrans _ -> 1
+      | RStar x, RStar y | RPlus x, RPlus y -> compare x y
+      | RStar _, _ -> -1 | _, RStar _ -> 1
+  and compare_list l1 l2 = match (l1,l2) with
+    | x1::y1, x2::y2 -> 
+	let c = compare x1 x2 in if c = 0 then compare_list y1 y2 else c
+    | [], [] -> 0
+    | [], _ -> -1 | _, [] -> 1
+
+  let rec dump ppf = function
+    | RSeq l -> Format.fprintf ppf "Seq(%a)" dump_list l
+    | RAlt l -> Format.fprintf ppf "Alt(%a)" dump_list l
+    | RStar r -> Format.fprintf ppf "Star(%a)" dump r
+    | RPlus r -> Format.fprintf ppf "Plus(%a)" dump r
+    | RTrans x -> Format.fprintf ppf "Trans"
+  and dump_list ppf = function
+    | [] -> ()
+    | [h] ->  Format.fprintf ppf "%a" dump h
+    | h::t ->  Format.fprintf ppf "%a,%a" dump h dump_list t
+
+  let rec factor accu l1 l2 = match (l1,l2) with
+    | (x1::y1,x2::y2) when compare x1 x2 = 0 -> factor (x1::accu) y1 y2 
+    | (l1,l2) -> (accu,l1,l2)
+   
+
+  let rec regexp = function
+    | RSeq l ->
+	let rec aux = function 
+	    | [h] -> regexp h 
+	    | h::t -> Seq (regexp h,aux t) 
+	    | [] -> Epsilon in
+	aux l
+    | RAlt l ->
+	let rec aux = function 
+	    | [h] -> regexp h 
+	    | h::t -> Alt (regexp h,aux t) 
+	    | [] -> Empty in
+	aux l
+    | RTrans x -> Trans x
+    | RStar r -> Star (regexp r)
+    | RPlus r -> Plus (regexp r)
+
+  let epsilon = RSeq []
+  let empty = RAlt []
+
+  let rec nullable = function
+    | RAlt l -> List.exists nullable l
+    | RSeq l -> List.for_all nullable l
+    | RPlus r -> nullable r
+    | RStar _ -> true
+    | RTrans _ -> false
+
+  let has_epsilon =
+    List.exists (function RSeq [] -> true | _ -> false)
 
-  let rec seq s1 s2 = match (s1,s2) with
-    | Empty,_ | _,Empty -> Empty
-    | Epsilon,s | s,Epsilon -> s
-    | Seq (a,b),s2 -> Seq (a, seq b s2)
-    | (s1,s2) -> Seq (s1,s2)
+  let remove_epsilon =
+    List.filter (function RSeq [] -> false | _ -> true)
+
+  let rec merge l1 l2 = match (l1,l2) with
+    | x1::y1, x2::y2 ->
+	let c = compare x1 x2 in
+	if c = 0 then x1::(merge y1 y2)
+	else if c < 0 then x1::(merge y1 l2)
+	else x2::(merge l1 y2)
+    | [], l | l,[] -> l
+
+
+  let rec absorb_epsilon = function
+    | RPlus r :: l -> RStar r :: l
+    | (r :: _) as l when nullable r -> l
+    | r :: l -> r :: (absorb_epsilon l)
+    | [] -> [ epsilon ]
+
+  let alt s1 s2 =
+    let s1 = match s1 with RAlt x -> x | x -> [x] in
+    let s2 = match s2 with RAlt x -> x | x -> [x] in
+    let l = merge s1 s2 in
+    let l = 
+      if has_epsilon l 
+      then absorb_epsilon (remove_epsilon l)
+      else l in
+    match l with
+      | [x] -> x
+      | l -> RAlt l
+
+
+  let rec seq s1 s2 =
+    match (s1,s2) with
+      | RAlt [], _ | _, RAlt [] -> epsilon
+      | RSeq [], x | x, RSeq [] -> x
+      | _ ->
+	  let s1 = match s1 with RSeq x -> x | x -> [x] in
+	  let s2 = match s2 with RSeq x -> x | x -> [x] in
+	  find_plus [] (s1 @ s2)
+  and find_plus before = function
+    | [] -> (match before with [h] -> h | l -> RSeq (List.rev l))
+    | (RStar s)::after ->
+	let star = match s with RSeq x -> x | x -> [x] in
+	let (right,star',after') = factor [] star after in
+	let (left,star'',before') = factor [] (List.rev star') before in
+	(match star'' with
+	   | [] ->
+	       let s = find_plus [] (left @ (List.rev right)) in
+	       find_plus ((RPlus s)::before') after'
+	   | _  -> 
+	       find_plus ((RStar s)::before) after)
+    | x::after -> find_plus (x::before) after
+
+  let star = function
+    | RAlt [] | RSeq [] -> epsilon
+    | RStar _ as s -> s
+    | s -> RStar s
 
   type 'a slot = { 
     mutable weight : int;
-    mutable outg : ('a slot * 'a regexp) list;
-    mutable inc  : ('a slot * 'a regexp) list;
-    mutable self : 'a regexp;
+    mutable outg : ('a slot * 'a re) list;
+    mutable inc  : ('a slot * 'a re) list;
+    mutable self : 'a re;
     mutable ok   : bool
   }
-  let empty () = { weight = 0; outg = []; inc = []; self = Empty; ok = false }
+  let alloc_slot () = 
+    { weight = 0; outg = []; inc = []; self = empty; ok = false }
 
   let decompile trans n0 =
     let slot_table = H.create 121 in
@@ -37,7 +153,7 @@ module Decompile(H : Hashtbl.S) = struct
     let slot n =
       try H.find slot_table n
       with Not_found -> 
-	let s = empty () in
+	let s = alloc_slot () in
 	H.add slot_table n s;
 	slots := s :: !slots;
 	s in
@@ -47,16 +163,16 @@ module Decompile(H : Hashtbl.S) = struct
       then s1.self <- alt s1.self t
       else (s1.outg <- (s2,t) :: s1.outg; s2.inc <- (s1,t) :: s2.inc) in
 
-    let final = empty () in
-    let initial = empty () in
+    let final = alloc_slot () in
+    let initial = alloc_slot () in
 
     let rec conv n =
       let s = slot n in
       if not s.ok then (
 	s.ok <- true;
 	let (tr,f) = trans n in
-	if f then add_trans s final Epsilon;
-	List.iter (fun (l,dst) -> add_trans s (conv dst) (Trans l)) tr;
+	if f then add_trans s final epsilon;
+	List.iter (fun (l,dst) -> add_trans s (conv dst) (RTrans l)) tr;
       );
       s in
 
@@ -71,14 +187,17 @@ module Decompile(H : Hashtbl.S) = struct
 	     s.outg
 	) s.inc in
 
-    add_trans initial (conv n0) Epsilon;
+    add_trans initial (conv n0) epsilon;
     List.iter 
       (fun s -> s.weight <- List.length s.inc * List.length s.outg)
       !slots;
-    let slots = List.sort (fun s1 s2 -> compare s1.weight s2.weight) !slots in
+    let slots = 
+      List.sort (fun s1 s2 -> Pervasives.compare s1.weight s2.weight) !slots in
     List.iter elim slots;
-    List.fold_left 
-      (fun accu (s,t) -> if s == final then alt accu t else accu)
-      Empty
-      initial.outg
+    let r = 
+      List.fold_left 
+	(fun accu (s,t) -> if s == final then alt accu t else accu)
+	empty
+	initial.outg in
+    regexp r
 end

misc/pretty.mli

@@ -6,8 +6,10 @@ type 'a regexp =
   | Seq of 'a regexp * 'a regexp
   | Alt of 'a regexp * 'a regexp
   | Star of 'a regexp
+  | Plus of 'a regexp
   | Trans of 'a
 
-module Decompile(H : Hashtbl.S) : sig
-  val decompile: (H.key -> ('a * H.key) list * bool) -> H.key -> 'a regexp
+module Decompile(H : Hashtbl.S)(S : Set.OrderedType) 
+: sig
+  val decompile: (H.key -> (S.t * H.key) list * bool) -> H.key -> S.t regexp
 end

types/types.ml

@@ -951,9 +951,11 @@ struct
     (n, d)
 
   let is_regexp t = subtype t seqs_descr
-  module Decompile = Pretty.Decompile(DescrHash)
 
-  type t = { mutable def : d list; mutable name : string option }
+  module S = struct
+  type t = { id : int; 
+	     mutable def : d list; 
+	     mutable state : [ `Expand | `None | `Marked | `Named of string ] }
   and  d =
     | Name of string
     | Regexp of t Pretty.regexp
@@ -964,6 +966,10 @@ struct
     | Record of (bool * t) label_map * bool * bool
     | Arrows of (t * t) list * (t * t) list
     | Neg of t
+  let compare x y = x.id - y.id
+  end
+  module Decompile = Pretty.Decompile(DescrHash)(S)
+  open S
 
   module DescrPairMap = 
     Map.Make(
@@ -985,7 +991,8 @@ struct
     named := DescrMap.add d name !named
 
   let memo = DescrHash.create 63
-  let empty_t = { def = []; name = None }
+  let counter = ref 0
+  let alloc def = { id = (incr counter; !counter); def = def; state = `None }
 
   let count_name = ref 0
   let name () =
@@ -994,7 +1001,9 @@ struct
 
   let to_print = ref []
 
-  let trivial_rec b = b == BoolRec.empty || (is_empty { empty with record = BoolRec.diff BoolRec.full b})
+  let trivial_rec b = 
+    b == BoolRec.empty || 
+    (is_empty { empty with record = BoolRec.diff BoolRec.full b})
 
   let trivial_pair b = b == BoolPair.empty || b == BoolPair.full
 
@@ -1014,27 +1023,22 @@ struct
       aux BoolRec.compare d.record any.record in
     n >= 4
 
-
   let rec prepare d =
-    try 
-      let slot = DescrHash.find memo d  in
-      if (slot.name == None) then
-	(let n = name () in
-	 slot.name <- Some n;
-	 to_print := (n,slot) :: !to_print);
-      slot 
+    try DescrHash.find memo d
     with Not_found ->
       try 
 	let n = DescrMap.find d !named in
-	let s = { name = Some n; def = [] } in
+	let s = alloc [] in
+	s.state <- `Named n;
 	DescrHash.add memo d s;
 	s
       with Not_found ->
 	if worth_complement d then 
-	  { empty_t with def = [Neg (prepare (neg d))] }
+	  alloc [Neg (prepare (neg d))]
 	else
-	let slot = { empty_t with def = []  } in
-	if worth_abbrev d then DescrHash.add memo d slot;
+	let slot = alloc [] in
+	if not (worth_abbrev d) then slot.state <- `Expand;
+	DescrHash.add memo d slot;
 	let (seq,not_seq) =
 	  if (subtype { empty with times = d.times } seqs_descr) then
 	    (cap d seqs_descr, diff d seqs_descr)
@@ -1095,10 +1099,38 @@ struct
 	 tr, Atoms.contains nil_atom t.atoms)
       d
 
+  let rec assign_name s =
+    match s.state with
+      | `None ->  s.state <- `Marked; List.iter assign_name_rec s.def
+      | `Marked -> s.state <- `Named (name ()); to_print := s :: !to_print
+      | _ -> ()
+  and assign_name_rec = function
+    | Neg t -> assign_name t
+    | Name _ | Char _ | Atomic _ -> ()
+    | Regexp r -> assign_name_regexp r
+    | Pair (t1,t2) -> assign_name t1; assign_name t2
+    | Xml (tag,t2,t3) -> 
+	(match tag with `Type t -> assign_name t | _ -> ());
+	assign_name t2;
+	assign_name t3
+    | Record (r,_,_) ->
+	List.iter (fun (_,(_,t)) -> assign_name t) (LabelMap.get r)
+    | Arrows (p,n) ->
+	List.iter (fun (t1,t2) -> assign_name t1; assign_name t2) p;
+	List.iter (fun (t1,t2) -> assign_name t1; assign_name t2) n
+  and assign_name_regexp = function
+    | Pretty.Epsilon | Pretty.Empty -> ()
+    | Pretty.Alt (r1,r2) 
+    | Pretty.Seq (r1,r2) -> assign_name_regexp r1; assign_name_regexp r2
+    | Pretty.Star r | Pretty.Plus r -> assign_name_regexp r
+    | Pretty.Trans t -> assign_name t
+
   let rec do_print_slot pri ppf s =
-    match s.name with
-      | None -> do_print_slot_real pri ppf s.def
-      | Some n -> Format.fprintf ppf "%s" n
+    match s.state with
+      | `Named n -> Format.fprintf ppf "%s" n
+      | `None -> assert false
+      | `Expand | `Marked ->
+	  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"
@@ -1118,11 +1150,11 @@ struct
 	Format.fprintf ppf "@[(%a,%a)@]" 
 	  (do_print_slot 0) t1 
 	  (do_print_slot 0) t2
-    | Xml (tag,t2,t3) -> 
+    | Xml (tag,attr,t) -> 
 	Format.fprintf ppf "<%a%a>%a" 
 	  do_print_tag tag
-	  do_print_attr t2 
-	  (do_print_slot 0) t3
+	  do_print_attr attr
+	  (do_print_slot 0) t
     | Record (r,some,none) ->
 	if some then Format.fprintf ppf "@[{"
 	else Format.fprintf ppf "@[{|";
@@ -1151,7 +1183,8 @@ struct
     | `Tag s -> Format.fprintf ppf "%s" s
     | `Type t -> Format.fprintf ppf "(%a)" (do_print_slot 0) t
   and do_print_attr ppf = function
-    | { name = None; def = [ Record (r,true,true) ] } -> do_print_record ppf r
+    | { state = `Marked|`Expand; 
+	def = [ Record (r,true,true) ] } -> do_print_record ppf r
     | t -> Format.fprintf ppf " %a" (do_print_slot 2) t
   and do_print_record ppf r =
     let first = ref true in
@@ -1163,13 +1196,9 @@ struct
 	   (LabelPool.value l) opt (do_print_slot 0) t
       ) (LabelMap.get r)
   and do_print_regexp pri ppf = function
-    | Pretty.Empty -> assert false
+    | Pretty.Empty ->  Format.fprintf ppf "Empty" (*assert false *)
     | Pretty.Epsilon -> ()
-    | Pretty.Seq (Pretty.Trans t1,Pretty.Star (Pretty.Trans t2))
-    | Pretty.Seq (Pretty.Star (Pretty.Trans t1),Pretty.Trans t2)
-	when t1 == t2 -> 
-	Format.fprintf ppf "@[%a@]+" (do_print_slot 3) t1
-    | Pretty.Seq (Pretty.Trans { name = None; def = [ Char _ ] }, _) as r-> 
+    | Pretty.Seq (Pretty.Trans { def = [ Char _ ] }, _) as r-> 
 	(match extract_string [] r with
 	  | s, None ->
 	      Format.fprintf ppf "'";
@@ -1197,28 +1226,36 @@ struct
 	if pri >= 2 then Format.fprintf ppf ")@]"
     | Pretty.Star r -> 
 	Format.fprintf ppf "@[%a@]*" (do_print_regexp 3) r
+    | Pretty.Plus r -> 
+	Format.fprintf ppf "@[%a@]+" (do_print_regexp 3) r
     | Pretty.Trans t ->
 	do_print_slot pri ppf t
   and extract_string accu = function
-    | Pretty.Seq (Pretty.Trans { name = None; def = [ Char c ] }, r) ->
+    | Pretty.Seq (Pretty.Trans { def = [ Char c ] }, r) ->
 	extract_string (c :: accu) r
-    | Pretty.Trans { name = None; def = [ Char c ] } ->
+    | Pretty.Trans { def = [ Char c ] } ->
 	(List.rev (c :: accu), None)
     | r -> (List.rev accu,Some r)
 
 
+  let get_name = function
+    | { state = `Named n } -> n
+    | _ -> assert false
+
   let print ppf d =
     let t = prepare d in
+    assign_name t;
     Format.fprintf ppf "@[@[%a@]" (do_print_slot 0) t;
     (match List.rev !to_print with
        | [] -> ()
-       | (n,s)::t ->
+       | s::t ->
 	   Format.fprintf ppf 
-	     " where@ @[<v>%s = @[%a@]" n (do_print_slot_real 0) s.def;
+	     " where@ @[<v>%s = @[%a@]" (get_name s) 
+	   (do_print_slot_real 0) s.def;
 	   List.iter 
-	     (fun (n,s) -> 
+	     (fun s -> 
 		Format.fprintf ppf " and@ %s = @[%a@]" 
-		  n (do_print_slot_real 0) s.def)
+		  (get_name s) (do_print_slot_real 0) s.def)
 	     t;
 	   Format.fprintf ppf "@]"
     );