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

[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
parent 2be608b8
......@@ -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)
......@@ -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
......
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