[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

runtime/print_xml.ml

@@ -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;