[r2003-05-18 13:56:14 by cvscast] Pretty-printer for sample values

Original author: cvscast
Date: 2003-05-18 13:56:14+00:00

types/types.ml

@@ -1410,33 +1410,36 @@ and sample_rec_record_aux memo (labels,(oleft,left),rights) =
 	    
 
 
-
-let get x = try sample_rec Assumptions.empty x with Not_found -> Other
+    
+  let get x = try sample_rec Assumptions.empty x with Not_found -> Other
 
   let rec print_sep f sep ppf = function
     | [] -> ()
     | [x] -> f ppf x
     | x::rem -> f ppf x; Format.fprintf ppf "%s" sep; print_sep f sep ppf rem
 
+  let rec is_seq = function
+    | Atom a -> a == Print.nil_atom
+    | Pair (_,y) -> is_seq y
+    | _ -> false
 
-  let rec print ppf = function
+  let rec print ppf s = 
+    if is_seq s then
+      Format.fprintf ppf "@[[@ %a]@]" print_seq s
+    else match s with
     | Int i -> Intervals.print_v ppf i
     | Atom a -> Atoms.print_v ppf a
     | Char c -> Chars.print_v ppf c
     | Pair (x1,x2) -> Format.fprintf ppf "(%a,%a)" print x1 print x2
+    | Xml (Atom tag, Pair (Record (o,r), child)) -> 
+	Format.fprintf ppf "<%s%a>%a" (Atoms.value tag) print_rec r 
+	print child
     | Xml (Atom tag, Pair (attr, child)) -> 
 	Format.fprintf ppf "<%s %a>%a" (Atoms.value tag) print attr print child
     | Xml (x1,x2) -> Format.fprintf ppf "XML(%a,%a)" print x1 print x2
     | Record (o,r) ->
-	Format.fprintf ppf "{ %a%s }"
-	  (print_sep 
-	     (fun ppf (l,x) -> 
-		Format.fprintf ppf "%s = %a"
-		(LabelPool.value l)
-		print x
-	     )
-	     " ; "
-	  ) r
+	Format.fprintf ppf "{%a%s }"
+	  print_rec r
 	  (if o then "; ..." else "")
     | Fun iface ->
 	Format.fprintf ppf "(fun ( %a ) x -> ...)"
@@ -1449,6 +1452,17 @@ let get x = try sample_rec Assumptions.empty x with Not_found -> Other
 	  ) iface
     | Other ->
 	Format.fprintf ppf "[cannot determine value]"
+  and print_rec ppf r = 
+    print_sep 
+      (fun ppf (l,x) -> 
+	 Format.fprintf ppf " %s = %a"
+	 (LabelPool.value l)
+	 print x
+      )
+      " ;" ppf r
+  and print_seq ppf = function
+    | Pair(x,y) -> print ppf x; Format.fprintf ppf "@ "; print_seq ppf y
+    | _ -> ()
 end