Commit 936bfadb authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2003-11-29 11:26:53 by szach] added support for schema validated values

Original author: szach
Date: 2003-11-29 11:26:53+00:00
parent d551a2e8
......@@ -10,6 +10,35 @@ let exn_print_xml = CDuceExn (Pair (
Atom (Atoms.V.mk_ascii "Invalid_argument"),
string_latin1 "print_xml"))
let blank = U.mk " "
let true_literal = U.mk "true"
let false_literal = U.mk "false"
(* @raise exn_print_xml in case of failure. Rationale: schema printing is
* the last attempt to print a value, others have already failed *)
let rec schema_value ?(recurs=true) ~wds v =
match v with
| Record _ as v ->
(try
wds (Schema_builtin.string_of_time_type (Value.get_fields v))
with Schema_builtin.Schema_builtin_error _ -> raise exn_print_xml)
| Integer i -> wds (U.mk (Intervals.V.to_string i))
| v when Value.equal v Value.vtrue -> wds true_literal
| v when Value.equal v Value.vfalse -> wds false_literal
| Pair _ as v when recurs -> schema_values ~wds v
| String_utf8 _ as v -> wds (fst (get_string_utf8 v))
| _ -> raise exn_print_xml
and schema_values ~wds v =
match v with
| Pair (hd, Atom a) when a = Sequence.nil_atom ->
schema_value ~recurs:false ~wds hd
| Pair (hd, tl) ->
schema_value ~recurs:false ~wds hd;
wds blank;
schema_values ~wds tl
| _ -> raise exn_print_xml
let string_of_xml ~utf8 ns_table v =
let to_enc = if utf8 then `Enc_utf8 else `Enc_iso88591 in
......@@ -38,6 +67,7 @@ let string_of_xml ~utf8 ns_table v =
wms "=\"";
wds (Ns.value ns);
wms "\"" in
let element_start n xmlns attrs =
wms ("<" ^ (Ns.Printer.tag printer n));
List.iter write_xmlns xmlns;
......@@ -79,12 +109,18 @@ let string_of_xml ~utf8 ns_table v =
let tag = Atoms.V.value tag in
let attrs = LabelMap.mapi_to_list
(fun n v ->
if not (is_str v) then raise exn_print_xml;
let (s,q) = get_string_utf8 v in
match q with
| Atom a when a = Sequence.nil_atom ->
(LabelPool.value n), s
| _ -> raise exn_print_xml
if is_str v then begin
let (s,q) = get_string_utf8 v in
match q with
| Atom a when a = Sequence.nil_atom ->
(LabelPool.value n), s
| _ -> raise exn_print_xml
end else begin
let buf = Buffer.create 20 in
let wds s = Buffer.add_string buf (U.get_str s) in
schema_value ~wds v;
(LabelPool.value n, U.mk (Buffer.contents buf))
end
) attrs in
(match content with
| Atom a when a = Sequence.nil_atom -> empty_element tag xmlns attrs
......@@ -97,9 +133,9 @@ let string_of_xml ~utf8 ns_table v =
let (s,q) = get_string_utf8 v in
wds s;
match q with
| Pair (x, q) -> print_elt [] x; print_content q
| Pair (Xml _ as x, q) -> print_elt [] x; print_content q
| Atom a when a = Sequence.nil_atom -> ()
| _ -> raise exn_print_xml
| v -> schema_value ~wds v
in
document_start ();
print_elt (Ns.Printer.prefixes printer) v;
......
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