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 Obj.magic (String.unsafe_get t.summary (idx n))
62 let kind t n : Tree.NodeKind.t =
63 Tree.NodeSummary.kind (summary t n)
68 let data t n = Array.unsafe_get t.data (idx n)
69 let by_preorder _ i = (i+2) / 3
72 let output_escape_string out s =
73 for i = 0 to String.length s - 1 do
75 | '<' -> output_string out "<"
76 | '>' -> output_string out ">"
77 | '&' -> output_string out "&"
78 | '"' -> output_string out """
79 | '\'' -> output_string out "'"
80 | c -> output_char out c
84 let rec print_attributes ?(sep=true) stop out tree node =
85 if (kind tree node == Tree.NodeKind.Attribute) && node != stop then
86 let tag = QName.to_string (tag tree node) in
87 if sep then output_char out ' ';
88 output_string out tag;
89 output_string out "=\"";
90 output_escape_string out (data tree node);
92 print_attributes stop out tree (next_sibling tree node)
96 let rec print_xml stop out tree node =
97 if node != nil && node != stop then
99 let open Tree.NodeKind in
100 match kind tree node with
102 | Text -> output_escape_string out (data tree node)
103 | Element | Document ->
104 let tag = QName.to_string (tag tree node)in
106 output_string out tag;
107 let fchild = print_attributes stop out tree (first_child tree node) in
108 if fchild == nil then output_string out "/>"
111 print_xml stop out tree fchild;
112 output_string out "</";
113 output_string out tag;
116 | Attribute -> ignore (print_attributes stop ~sep:false out tree node)
118 output_string out "<!--";
119 output_string out (data tree node);
120 output_string out "-->"
121 | ProcessingInstruction ->
122 output_string out "<?";
123 output_string out (QName.to_string (tag tree node));
125 output_string out (data tree node);
126 output_string out "?>"
128 print_xml stop out tree (next_sibling tree node)
130 let print_xml out tree node =
131 print_xml (next_sibling tree node) out tree node
134 let mk_node table_a data_a kind_a tags_a i summary tag data pre_fc pre_ns pre_p =
136 data_a.(i+2) <- data;
138 Bytes.unsafe_set kind_a (i+2) (Char.chr (summary land 0xff));
140 let fc = (pre_fc + 2) * 3 in
141 let ns = (pre_ns + 2) * 3 in
142 let p = (pre_p + 2) * 3 in
144 table_a.(n + 1) <- ns;
146 with _ -> assert false
150 let s = Naive_tree.size t in
151 let len = (s + 2) * 3 in
152 let table = Array.make len ~-1 (* int16_unsigned c_layout len *) in
153 let data = Array.make (s + 2) "" in
154 let tags = Array.make (s+2) dummy_tag in
155 let summaries = Bytes.make (s+2) '\000' in
156 mk_node table data summaries tags ~-2 Tree.NodeSummary.dummy dummy_tag "" dummy dummy dummy;
157 mk_node table data summaries tags ~-1 Tree.NodeSummary.dummy QName.nil "" nil nil nil;
158 for i = 0 to s - 1 do
159 let node = Naive_tree.by_preorder t i in
160 mk_node table data summaries tags i
161 (Naive_tree.summary t node)
162 (Naive_tree.tag t node)
163 (Naive_tree.data t node)
164 (Naive_tree.preorder t (Naive_tree.first_child t node))
165 (Naive_tree.preorder t (Naive_tree.next_sibling t node))
166 (Naive_tree.preorder t (Naive_tree.parent t node))
168 { data; table; tags ; summary = summaries }
170 let load_xml_string s = of_naive (Naive_tree.load_xml_string s)
171 let load_xml_file f = of_naive (Naive_tree.load_xml_file f)
173 let print_node fmt n = Format.fprintf fmt "%d" n