1 (***********************************************************************)
5 (* Kim Nguyen, LRI UMR8623 *)
6 (* Université Paris-Sud & CNRS *)
8 (* Copyright 2010-2016 Université Paris-Sud and Centre National de la *)
9 (* Recherche Scientifique. All rights reserved. This file is *)
10 (* distributed under the terms of the GNU Lesser General Public *)
11 (* License, with the special exception on linking described in file *)
14 (***********************************************************************)
18 let dummy_tag = QName.of_string "#dummy"
23 (* type table = (int, int16_unsigned_elt, c_layout) Array1.t *)
24 type table = int array
43 let nil = next (dummy)
44 let root _t = next (next dummy)
46 let size t = (idx (Array.length t.table)) - 2
49 Array.unsafe_get t.table (n + 0)
51 let next_sibling t n =
52 Array.unsafe_get t.table (n + 1)
55 Array.unsafe_get t.table (n + 2)
58 Array.unsafe_get t.tags (idx n)
60 let kind t n : Tree.NodeKind.t =
61 Obj.magic (String.unsafe_get t.kind (idx n))
66 let data t n = Array.unsafe_get t.data (idx n)
67 let by_preorder _ i = (i+2) / 3
70 let output_escape_string out s =
71 for i = 0 to String.length s - 1 do
73 | '<' -> output_string out "<"
74 | '>' -> output_string out ">"
75 | '&' -> output_string out "&"
76 | '"' -> output_string out """
77 | '\'' -> output_string out "'"
78 | c -> output_char out c
82 let rec print_attributes ?(sep=true) stop out tree node =
83 if (kind tree node == Tree.NodeKind.Attribute) && node != stop then
84 let tag = QName.to_string (tag tree node) in
85 if sep then output_char out ' ';
86 output_string out tag;
87 output_string out "=\"";
88 output_escape_string out (data tree node);
90 print_attributes stop out tree (next_sibling tree node)
94 let rec print_xml stop out tree node =
95 if node != nil && node != stop then
97 let open Tree.NodeKind in
98 match kind tree node with
100 | Text -> output_escape_string out (data tree node)
101 | Element | Document ->
102 let tag = QName.to_string (tag tree node)in
104 output_string out tag;
105 let fchild = print_attributes stop out tree (first_child tree node) in
106 if fchild == nil then output_string out "/>"
109 print_xml stop out tree fchild;
110 output_string out "</";
111 output_string out tag;
114 | Attribute -> ignore (print_attributes stop ~sep:false out tree node)
116 output_string out "<!--";
117 output_string out (data tree node);
118 output_string out "-->"
119 | ProcessingInstruction ->
120 output_string out "<?";
121 output_string out (QName.to_string (tag tree node));
123 output_string out (data tree node);
124 output_string out "?>"
126 print_xml stop out tree (next_sibling tree node)
128 let print_xml out tree node =
129 print_xml (next_sibling tree node) out tree node
132 let mk_node table_a data_a kind_a tags_a i kind tag data pre_fc pre_ns pre_p =
134 data_a.(i+2) <- data;
136 Bytes.unsafe_set kind_a (i+2) (Obj.magic kind);
138 let fc = (pre_fc + 2) * 3 in
139 let ns = (pre_ns + 2) * 3 in
140 let p = (pre_p + 2) * 3 in
142 table_a.(n + 1) <- ns;
144 with _ -> assert false
148 let s = Naive_tree.size t in
149 let len = (s + 2) * 3 in
150 let table = Array.make len ~-1 (* int16_unsigned c_layout len *) in
151 let data = Array.make (s + 2) "" in
152 let tags = Array.make (s+2) dummy_tag in
153 let kind = Bytes.make (s+2) '\000' in
154 mk_node table data kind tags ~-2 Tree.NodeKind.Element dummy_tag "" dummy dummy dummy;
155 mk_node table data kind tags ~-1 Tree.NodeKind.Element QName.nil "" nil nil nil;
156 for i = 0 to s - 1 do
157 let node = Naive_tree.by_preorder t i in
158 mk_node table data kind tags i (Naive_tree.kind t node)
159 (Naive_tree.tag t node)
160 (Naive_tree.data t node)
161 (Naive_tree.preorder t (Naive_tree.first_child t node))
162 (Naive_tree.preorder t (Naive_tree.next_sibling t node))
163 (Naive_tree.preorder t (Naive_tree.parent t node))
165 { data; table; tags ; kind }
167 let load_xml_string s = of_naive (Naive_tree.load_xml_string s)
168 let load_xml_file f = of_naive (Naive_tree.load_xml_file f)
170 let print_node fmt n = Format.fprintf fmt "%d" n