[r2004-12-20 22:08:36 by afrisch] Pretty print patterns

Original author: afrisch
Date: 2004-12-20 22:08:36+00:00

driver/cduce.ml

@@ -176,9 +176,11 @@ let debug ppf tenv cenv = function
        with Not_found ->
 	 Format.fprintf ppf "Empty type : no sample !@.")
   | `Filter (t,p) -> 
-      Format.fprintf ppf "[DEBUG:filter]@.";
       let t = Typer.typ tenv t
       and p = Typer.pat tenv p in
+      Format.fprintf ppf "[DEBUG:filter t=%a p=%a]@."
+	Types.Print.print (Types.descr t)
+	Patterns.Print.print (Patterns.descr p);
       let f = Patterns.filter (Types.descr t) p in
       List.iter (fun (x,t) ->
 		   Format.fprintf ppf " %a:%a@." U.print (Id.value x)

types/patterns.ml

@@ -232,6 +232,113 @@ module Node = struct
 
 end
 
+(* Pretty-print *)
+
+module P = struct
+  type t = descr
+  let rec compare (t1,fv1,d1) (t2,fv2,d2) = if d1 == d2 then 0 else
+    match (d1,d2) with
+      | Constr t1, Constr t2 -> Types.compare t1 t2
+      | Constr _, _ -> -1 | _, Constr _ -> 1
+
+      | Cup (x1,y1), Cup (x2,y2) | Cap (x1,y1), Cap (x2,y2) ->
+	  let c = compare x1 x2 in if c <> 0 then c 
+	  else compare y1 y2
+      | Cup _, _ -> -1 | _, Cup _ -> 1
+      | Cap _, _ -> -1 | _, Cap _ -> 1
+
+      | Times (x1,y1), Times (x2,y2) | Xml (x1,y1), Xml (x2,y2) ->
+	  let c = Node.compare x1 x2 in if c <> 0 then c
+	  else Node.compare y1 y2
+      | Times _, _ -> -1 | _, Times _ -> 1
+      | Xml _, _ -> -1 | _, Xml _ -> 1
+
+      | Record (x1,y1), Record (x2,y2) ->
+	  let c = LabelPool.compare x1 x2 in if c <> 0 then c
+	  else Node.compare y1 y2
+      | Record _, _ -> -1 | _, Record _ -> 1
+
+      | Capture x1, Capture x2 ->
+	  Id.compare x1 x2
+      | Capture _, _ -> -1 | _, Capture _ -> 1
+
+      | Constant (x1,y1), Constant (x2,y2) ->
+	  let c = Id.compare x1 x2 in if c <> 0 then c
+	  else Types.Const.compare y1 y2
+      | Constant _, _ -> -1 | _, Constant _ -> 1
+
+      | Dummy, Dummy -> assert false
+end
+
+module Print = struct
+  module M = Map.Make(P)
+  module S = Set.Make(P)
+
+  let names = ref M.empty
+  let printed = ref S.empty
+  let toprint = Queue.create ()
+  let id = ref 0
+
+  let rec mark seen ((_,_,d) as p) =
+    if (M.mem p !names) then ()
+    else if (S.mem p seen) then
+      (incr id;
+       names := M.add p !id !names;
+       Queue.add p toprint)
+    else 
+      let seen = S.add p seen in
+      match d with
+	| Cup (p1,p2) | Cap (p1,p2) -> mark seen p1; mark seen p2
+	| Times (q1,q2) | Xml (q1,q2) -> mark seen q1.descr; mark seen q2.descr
+	| Record (_,q) -> mark seen q.descr
+	| _ -> ()
+
+  let rec print ppf p =
+    try 
+      let i = M.find p !names in
+      Format.fprintf ppf "P%i" i
+    with Not_found ->
+      real_print ppf p
+  and real_print ppf (_,_,d) =  match d with
+    | Constr t ->
+	Types.Print.print ppf t
+    | Cup (p1,p2) ->
+	Format.fprintf ppf "(%a | %a)" print p1 print p2
+    | Cap (p1,p2) ->
+	Format.fprintf ppf "(%a & %a)" print p1 print p2
+    | Times (q1,q2) ->
+	Format.fprintf ppf "(%a,%a)" print q1.descr print q2.descr
+    | Xml (q1,{ descr = (_,_,Times(q2,q3)) }) ->
+	Format.fprintf ppf "<(%a) (%a)>(%a)" print q1.descr print q2.descr print q2.descr
+    | Xml _ -> assert false
+    | Record (l,q) ->
+	Format.fprintf ppf "{%a=%a}" Label.print (LabelPool.value l) print q.descr
+    | Capture x ->
+	Format.fprintf ppf "%a" Ident.print x
+    | Constant (x,c) ->
+	Format.fprintf ppf "(%a:=%a)" Ident.print x Types.Print.print_const c
+    | Dummy -> assert false
+      
+  let print ppf p =
+    mark S.empty p;
+    print ppf p;
+    let first = ref true in
+    (try while true do
+       let p = Queue.pop toprint in
+       if not (S.mem p !printed) then 
+	 ( printed := S.add p !printed;
+	   Format.fprintf ppf " %s@ @[%a=%a@]"
+	     (if !first then (first := false; "where") else "and")
+	     print p
+	     real_print p
+	);
+     done with Queue.Empty -> ());
+    id := 0;
+    names := M.empty;
+    printed := S.empty
+end
+
+
 
 (* Static semantics *)
 

types/patterns.mli

@@ -25,6 +25,12 @@ val id: node -> int
 val descr: node -> descr
 val fv : node -> fv
 
+(* Pretty-printing *)
+
+module Print : sig
+  val print: Format.formatter -> descr -> unit
+end
+
 (* Pattern matching: static semantics *)
 
 val accept : node -> Types.Node.t