Commit cd5b7676 authored by Pietro Abate's avatar Pietro Abate
Browse files

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

Original author: afrisch
Date: 2004-12-20 22:08:36+00:00
parent 6dda32d0
......@@ -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)
......
......@@ -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 *)
......
......@@ -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
......
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