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
34 i -> kind | QNameId lsl 8
44 let nil = next (dummy)
45 let root _t = next (next dummy)
47 let size t = (idx (Array.length t.table)) - 2
50 Array.unsafe_get t.table (n + 0)
52 let next_sibling t n =
53 Array.unsafe_get t.table (n + 1)
56 Array.unsafe_get t.table (n + 2)
59 Array.unsafe_get t.tags (idx n)
61 let kind t n : Tree.NodeKind.t =
62 Obj.magic (String.unsafe_get t.kind (idx n))
67 let data t n = Array.unsafe_get t.data (idx n)
68 let by_preorder _ i = (i+2) / 3
71 let output_escape_string out s =
72 for i = 0 to String.length s - 1 do
74 | '<' -> output_string out "<"
75 | '>' -> output_string out ">"
76 | '&' -> output_string out "&"
77 | '"' -> output_string out """
78 | '\'' -> output_string out "'"
79 | c -> output_char out c
83 let rec print_attributes ?(sep=true) stop out tree node =
84 if (kind tree node == Tree.NodeKind.Attribute) && node != stop then
85 let tag = QName.to_string (tag tree node) in
86 if sep then output_char out ' ';
87 output_string out tag;
88 output_string out "=\"";
89 output_escape_string out (data tree node);
91 print_attributes stop out tree (next_sibling tree node)
95 let rec print_xml stop out tree node =
96 if node != nil && node != stop then
98 let open Tree.NodeKind in
99 match kind tree node with
101 | Text -> output_escape_string out (data tree node)
102 | Element | Document ->
103 let tag = QName.to_string (tag tree node)in
105 output_string out tag;
106 let fchild = print_attributes stop out tree (first_child tree node) in
107 if fchild == nil then output_string out "/>"
110 print_xml stop out tree fchild;
111 output_string out "</";
112 output_string out tag;
115 | Attribute -> ignore (print_attributes stop ~sep:false out tree node)
117 output_string out "<!--";
118 output_string out (data tree node);
119 output_string out "-->"
120 | ProcessingInstruction ->
121 output_string out "<?";
122 output_string out (QName.to_string (tag tree node));
124 output_string out (data tree node);
125 output_string out "?>"
127 print_xml stop out tree (next_sibling tree node)
129 let print_xml out tree node =
130 print_xml (next_sibling tree node) out tree node
133 let mk_node table_a data_a kind_a tags_a i kind tag data pre_fc pre_ns pre_p =
135 data_a.(i+2) <- data;
137 Bytes.unsafe_set kind_a (i+2) (Obj.magic kind);
139 let fc = (pre_fc + 2) * 3 in
140 let ns = (pre_ns + 2) * 3 in
141 let p = (pre_p + 2) * 3 in
143 table_a.(n + 1) <- ns;
145 with _ -> assert false
149 let s = Naive_tree.size t in
150 let len = (s + 2) * 3 in
151 let table = Array.make len ~-1 (* int16_unsigned c_layout len *) in
152 let data = Array.make (s + 2) "" in
153 let tags = Array.make (s+2) dummy_tag in
154 let kind = Bytes.make (s+2) '\000' in
155 mk_node table data kind tags ~-2 Tree.NodeKind.Element dummy_tag "" dummy dummy dummy;
156 mk_node table data kind tags ~-1 Tree.NodeKind.Element QName.nil "" nil nil nil;
157 for i = 0 to s - 1 do
158 let node = Naive_tree.by_preorder t i in
159 mk_node table data kind tags i (Naive_tree.kind t node)
160 (Naive_tree.tag t node)
161 (Naive_tree.data t node)
162 (Naive_tree.preorder t (Naive_tree.first_child t node))
163 (Naive_tree.preorder t (Naive_tree.next_sibling t node))
164 (Naive_tree.preorder t (Naive_tree.parent t node))
166 { data; table; tags ; kind }
168 let load_xml_string s = of_naive (Naive_tree.load_xml_string s)
169 let load_xml_file f = of_naive (Naive_tree.load_xml_file f)
171 let print_node fmt n = Format.fprintf fmt "%d" n