print_xml.ml 4.68 KB
Newer Older
1 2 3 4 5
(* Print XML documents, using PXP *)

open Pxp_aux
open Pxp_types
open Value
6
open Ident
7
module U = Encodings.Utf8
8

9
let exn_print_xml = CDuceExn (Pair (
10
				Atom (Atoms.V.mk_ascii "Invalid_argument"),
11
				string_latin1 "print_xml"))
12

13 14 15 16 17 18
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 *)
19 20 21
let rec schema_value ?(recurs=true) ~wds v = match v with
  | Abstract ("float",f) ->
      wds (U.mk (string_of_float (Obj.magic f : float)))
22 23 24
  | Record _ as v ->
      (try
        wds (Schema_builtin.string_of_time_type (Value.get_fields v))
25
      with Schema_builtin.Error _ -> raise exn_print_xml)
26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42
  | 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

43
let string_of_xml ~utf8 ns_table v = 
44
  let to_enc = if utf8 then `Enc_utf8 else `Enc_iso88591 in
45 46

  let buffer = Buffer.create 127 in
47
  let printer = Ns.Printer.printer ns_table in
48 49 50

  let wms = 
    write_markup_string
51
      ~from_enc:`Enc_utf8 
52 53 54
      ~to_enc
      (`Out_buffer buffer)

55
  and wds s =
56
    write_data_string
57
      ~from_enc:`Enc_utf8
58 59
      ~to_enc
      (`Out_buffer buffer)
60
      (U.get_str s)
61
  in
62 63 64 65 66 67 68 69 70
  let write_att (n,v) =
    wms (" " ^ (Ns.Printer.attr printer n) ^ "=\""); wds v; wms "\"" in
  let write_xmlns (pr,ns) =
    let pr = U.get_str pr in
    if pr = "" then wms " xmlns"
    else (wms " xmlns:"; wms pr);
    wms "=\"";
    wds (Ns.value ns);
    wms "\"" in
71

72 73 74 75 76 77 78 79 80 81 82 83
  let element_start n xmlns attrs = 
    wms ("<" ^ (Ns.Printer.tag printer n)); 
    List.iter write_xmlns xmlns;
    List.iter write_att attrs; 
    wms ">"
  and empty_element n xmlns attrs = 
    wms ("<" ^ (Ns.Printer.tag printer n)); 
    List.iter write_xmlns xmlns;
    List.iter write_att attrs; 
    wms "/>"
  and element_end n = 
    wms ("</" ^ (Ns.Printer.attr printer n) ^ ">")
84
  and document_start () = 
85
(*    wms ("<?xml version='1.0' encoding='" ^
86
	 Netconversion.string_of_encoding to_enc ^
87
	 "'?>\n") *)
88
    ()
89
  in
90

91 92 93 94 95
  let rec register_elt = function
    | Xml (Atom tag, Record attrs, content) ->
	List.iter
	  (fun (n,_) -> Ns.Printer.register_attr printer (LabelPool.value n))
	  (LabelMap.get attrs);
96
	Ns.Printer.register_tag printer (Atoms.V.value tag);
97 98 99 100 101 102
	register_content content
    | _ -> ()
  and register_content = function
    | String_utf8 (_,_,_,q)
    | String_latin1 (_,_,_,q) -> register_content q
    | Pair (x, q) -> register_elt x; register_content q
103
    | Concat (x,y) -> register_content x; register_content y
104 105 106 107 108
    | _ -> () 
  in
  register_elt v;

  let rec print_elt xmlns = function
109
    | Xml (Atom tag, Record attrs, content) ->
110
	let tag = Atoms.V.value tag in
111 112
	let attrs = LabelMap.mapi_to_list 
		      (fun n v -> 
113 114 115 116 117 118 119 120 121 122 123 124
                         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
125
		      ) attrs in
126
	(match content with
127
	  | Atom a when a = Sequence.nil_atom -> empty_element tag xmlns attrs
128
	  | _ ->
129
	      element_start tag xmlns attrs;
130 131
	      print_content content;
	      element_end tag)
132
    | _ -> raise exn_print_xml
133 134 135 136
  and print_content v =
    let (s,q) = get_string_utf8 v in
    wds s;
    match q with
137
      | Pair (Xml _ as x, q) -> print_elt [] x; print_content q
138
      | Atom a when a = Sequence.nil_atom -> ()
139
      | v -> schema_value ~wds v
140 141
  in
  document_start ();
142
  print_elt (Ns.Printer.prefixes printer) v;
143
  Buffer.contents buffer
144

145
let print_xml ~utf8 ns_table s =
146
  try   
147
    let s = string_of_xml ~utf8 ns_table s in
148
    if utf8 then string_utf8 (U.mk s) else string_latin1 s
149 150 151
  with 
      CDuceExn _ as exn -> raise exn
    | exn -> raise (Location.Generic (Pxp_types.string_of_exn exn))
152