[r2003-11-20 11:32:33 by szach] - output format bugfixes for #dump_value directive

- added raise' and failwith' to raise CDuce exceptions

- added a map_xml function

Original author: szach
Date: 2003-11-20 11:32:33+00:00

runtime/value.ml

@@ -323,7 +323,7 @@ let dump_xml ppf v =
           (fun ppf x -> print_record ppf (LabelMap.get x)) x
     | Atom a ->
         Format.fprintf ppf "@[<hv1>";
-        Format.fprintf ppf "<record>@,%a@,</record>@]"
+        Format.fprintf ppf "<atom>@,%a@,</atom>@]"
           (fun ppf x -> Atoms.V.print ppf x) a
     | Integer i ->
         Format.fprintf ppf "@[<hv1>";
@@ -341,12 +341,13 @@ let dump_xml ppf v =
         Format.fprintf ppf "<abstraction2 />@]"
     | String_latin1 (_, _, s, v) ->
         Format.fprintf ppf "@[<hv1>";
-        Format.fprintf ppf "<string_latin1>@,%s@,</string_latin1>" s;
+        Format.fprintf ppf "<string_latin1>@,%s@,</string_latin1>@," s;
         Format.fprintf ppf "@[<hv1>";
         Format.fprintf ppf "<follow>@,%a@,</follow>@]</string_latin1>@]" aux v
     | String_utf8 (_, _, s, v) ->
         Format.fprintf ppf "@[<hv1>";
-        Format.fprintf ppf "<string_utf8>@,%s@,</string_utf8>" (Utf8.get_str s);
+        Format.fprintf ppf "<string_utf8>@,%s@,</string_utf8>@,"
+          (Utf8.get_str s);
         Format.fprintf ppf "@[<hv1>";
         Format.fprintf ppf "<follow>@,%a@,</follow>@]</string_utf8>@]" aux v
     | Concat (x, y) ->
@@ -432,7 +433,6 @@ let rec compare x y =
       | Atom _,_ -> -1 | _, Atom _ -> 1
       | Integer _,_ -> -1 | _, Integer _ -> 1
 
-
 let iter_xml pcdata_callback other_callback =
   let rec aux = function
     | v when compare v nil = 0 -> ()
@@ -455,6 +455,30 @@ let iter_xml pcdata_callback other_callback =
     | Xml (_,_,cont) -> aux cont
     | _ -> raise (Invalid_argument "Value.iter_xml")
 
+let map_xml map_pcdata map_other =
+  let patch_string_utf8 cont = function
+    | String_utf8 (i, j, u, v) when compare v nil = 0 ->
+        String_utf8 (i, j, u, cont)
+    | _ -> assert false
+  in
+  let rec aux = function
+    | Pair (Char c, tl) ->
+        let ustring = map_pcdata (U.mk_char (Chars.V.to_int c)) in
+        patch_string_utf8 (aux tl) (string_utf8 ustring)
+    | String_latin1 (i,j,s,tl) ->
+        let ustring = map_pcdata (U.mk_latin1 (String.sub s i j)) in
+        patch_string_utf8 (aux tl) (string_utf8 ustring)
+    | String_utf8 (i,j,s,tl) ->
+        let ustring = map_pcdata (U.mk (U.get_substr s i j)) in
+        patch_string_utf8 (aux tl) (string_utf8 ustring)
+    | Pair (hd, tl) -> Pair (map_other hd, aux tl)
+    | Concat (_,_) as v -> eval_lazy_concat v; aux v
+    | v when compare v nil = 0 -> v
+    | v -> raise (Invalid_argument "Value.map_xml")
+  in
+  function
+    | Xml (tag,attrs,cont) -> Xml (tag, attrs, aux cont)
+    | _ -> raise (Invalid_argument "Value.map_xml")
 
   (** set of values *)
 
@@ -485,3 +509,7 @@ let rec flatten = function
   | q -> q
 
 *)
+
+let failwith' s = raise (CDuceExn (string_latin1 s))
+let raise' v = raise (CDuceExn v)
+

runtime/value.mli

@@ -26,6 +26,8 @@ type t =
 module ValueSet: Set.S with type elt = t
 
 exception CDuceExn of t
+val raise': t -> 'a
+val failwith': string -> 'a
 
 val print: Format.formatter -> t -> unit
 val dump_xml: Format.formatter -> t -> unit
@@ -46,10 +48,14 @@ val vbool : bool -> t
 val vrecord : (string * t) list -> t
 
 val sequence : t list -> t
+
   (* iterator on the content of an Xml value. First callback is invoked on Utf8
   character children; second callback is invoked on other children values *)
 val iter_xml : (U.t -> unit) -> (t -> unit) -> t -> unit
 
+  (* as above for map *)
+val map_xml : (U.t -> U.t) -> (t -> t) -> t -> t
+
 val concat : t -> t -> t
 val flatten : t -> t