Flatten the sources, only leave the XPath module packed.
[tatoo.git] / src / naive_tree.ml
1 (***********************************************************************)
2 (*                                                                     *)
3 (*                               TAToo                                 *)
4 (*                                                                     *)
5 (*                     Kim Nguyen, LRI UMR8623                         *)
6 (*                   Universit√© Paris-Sud & CNRS                       *)
7 (*                                                                     *)
8 (*  Copyright 2010-2012 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   *)
12 (*  ../LICENSE.                                                        *)
13 (*                                                                     *)
14 (***********************************************************************)
15
16 (*
17   Time-stamp: <Last modified on 2013-04-04 18:47:30 CEST by Kim Nguyen>
18 *)
19
20 type node = {
21   tag : QName.t;
22   preorder : int;
23   mutable kind : Tree.NodeKind.t;
24   mutable data : string;
25   mutable first_child : node;
26   mutable next_sibling : node;
27   mutable parent: node;
28 }
29
30
31
32 let rec nil = {
33   tag = QName.nil;
34   kind = Tree.NodeKind.Element;
35   preorder = -1;
36   data = "";
37   first_child = nil;
38   next_sibling = nil;
39   parent = nil;
40 }
41
42 let dummy_tag = QName.of_string "#dummy"
43 let rec dummy = {
44   tag = dummy_tag;
45   kind = Tree.NodeKind.Element;
46   preorder = -1;
47   data = "";
48   first_child = dummy;
49   next_sibling = dummy;
50   parent = dummy;
51 }
52
53
54 type t = {
55   root : node;
56   size : int;
57   (* TODO add other intersting stuff *)
58 }
59
60
61
62 module Parser =
63 struct
64
65   type context = {
66     mutable stack : node list;
67     text_buffer : Buffer.t;
68     mutable current_preorder : int;
69   }
70
71   let print_node_ptr fmt n =
72     Format.fprintf fmt "<%s>"
73       (if n == nil then "NIL" else
74         if n == dummy then "DUMMY" else
75           "NODE " ^  string_of_int n.preorder)
76
77   let debug_node fmt node =
78     Format.fprintf fmt "{ tag=%s; preorder=%i; data=%S; first_child=%a; next_sibling=%a; parent=%a }"
79       (QName.to_string node.tag)
80       node.preorder
81       node.data
82       print_node_ptr node.first_child
83       print_node_ptr node.next_sibling
84       print_node_ptr node.parent
85
86
87   let debug_ctx fmt ctx =
88     Format.fprintf fmt "Current context: { preorder = %i\n; stack = \n%a\n }\n-------------\n"
89       ctx.current_preorder
90       (Pretty.print_list ~sep:";\n" debug_node) ctx.stack
91
92
93   let push n ctx = ctx.stack <- n :: ctx.stack
94   let pop ctx =
95     match ctx.stack with
96       [] -> failwith "XML parse error"
97     | e :: l -> ctx.stack <- l; e
98
99   let top ctx = match ctx.stack with
100     | [] -> failwith "XML parse error"
101     | e :: _ -> e
102
103   let next ctx =
104     let i = ctx.current_preorder in
105     ctx.current_preorder <- 1 + i;
106     i
107
108   let is_left n = n.next_sibling == dummy
109
110
111   let text_string = QName.to_string QName.text
112   let comment_string = QName.to_string QName.comment
113
114
115   let rec start_element_handler parser_ ctx tag attr_list =
116     do_text parser_ ctx;
117     let parent = top ctx in
118     let n = { tag = QName.of_string tag;
119               kind = Tree.NodeKind.Element;
120               preorder = next ctx;
121               data = "";
122               first_child = dummy;
123               next_sibling = dummy;
124               parent = parent;
125             }
126     in
127     if parent.first_child == dummy then parent.first_child <- n
128     else parent.next_sibling <- n;
129     push n ctx;
130     List.iter (do_attribute parser_ ctx) attr_list
131
132   and do_attribute parser_ ctx (att, value) =
133     let att_tag = QName.to_string (QName.attribute (QName.of_string att)) in
134     start_element_handler parser_ ctx att_tag [];
135     let n = top ctx in
136     n.data <- value;
137     n.kind <- Tree.NodeKind.Attribute;
138     end_element_handler parser_ ctx att_tag
139
140   and consume_closing ctx n =
141     if n.next_sibling != dummy then
142       let _ = pop ctx in consume_closing ctx (top ctx)
143
144   and end_element_handler parser_ ctx _ =
145     do_text parser_ ctx;
146     let node = top ctx in
147     if node.first_child == dummy then node.first_child <- nil
148     else begin
149       node.next_sibling <- nil;
150       consume_closing ctx node
151     end
152
153   and do_text parser_ ctx =
154     if Buffer.length ctx.text_buffer != 0 then
155       let s = Buffer.contents ctx.text_buffer in
156       Buffer.clear  ctx.text_buffer;
157       start_element_handler parser_ ctx text_string [];
158       let node = top ctx in
159       node.data <- s;
160       node.kind <- Tree.NodeKind.Text;
161       end_element_handler parser_ ctx text_string
162
163   and comment_handler parser_ ctx s =
164     do_text parser_ ctx;
165     start_element_handler parser_ ctx comment_string [];
166     let node = top ctx in
167     node.data <- s;
168     node.kind <- Tree.NodeKind.Comment;
169     end_element_handler parser_ ctx comment_string
170
171   and processing_instruction_handler parser_ ctx tag data =
172     do_text parser_ ctx;
173     let pi = QName.to_string
174       (QName.processing_instruction (QName.of_string tag))
175     in
176     start_element_handler parser_ ctx pi [];
177     let node = top ctx in
178     node.data <- data;
179     node.kind <- Tree.NodeKind.ProcessingInstruction;
180     end_element_handler parser_ ctx pi
181
182
183   let character_data_handler _parser ctx text =
184     Buffer.add_string ctx.text_buffer text
185
186   let create_parser () =
187     let ctx = { text_buffer = Buffer.create 512;
188                 current_preorder = 0;
189                 stack = [] } in
190     let psr = Expat.parser_create ~encoding:None in
191     Expat.set_start_element_handler psr (start_element_handler psr ctx);
192     Expat.set_end_element_handler psr (end_element_handler psr ctx);
193     Expat.set_character_data_handler
194       psr (character_data_handler psr ctx);
195     Expat.set_comment_handler psr (comment_handler psr ctx);
196     Expat.set_processing_instruction_handler psr
197       (processing_instruction_handler psr ctx);
198     push { tag = QName.document;
199            preorder = next ctx;
200            kind = Tree.NodeKind.Document;
201            data = "";
202            first_child = dummy;
203            next_sibling = dummy;
204            parent = nil;
205          } ctx;
206     (psr,
207      fun () ->
208        let node = top ctx in
209        node.next_sibling <- nil;
210        consume_closing ctx node;
211        match ctx.stack with
212          [ root ] ->
213            root.next_sibling <- nil;
214            { root = root;
215              size = ctx.current_preorder
216            }
217        | _ -> raise (Expat.Expat_error Expat.UNCLOSED_TOKEN)
218     )
219
220
221   let parse_string s =
222     let parser_, finalize = create_parser () in
223     Expat.parse parser_ s;
224     finalize ()
225
226   let parse_file fd =
227     let buffer = String.create 4096 in
228     let parser_, finalize = create_parser () in
229     let rec loop () =
230       let read = input fd buffer 0 4096 in
231       if read != 0 then
232         let () = Expat.parse_sub parser_ buffer 0 read in
233         loop ()
234     in loop (); finalize ()
235
236 end
237
238
239 let load_xml_file = Parser.parse_file
240 let load_xml_string = Parser.parse_string
241
242 let output_escape_string out s =
243   for i = 0 to String.length s - 1 do
244     match s.[i] with
245     | '<' -> output_string out "&lt;"
246     | '>' -> output_string out "&gt;"
247     | '&' -> output_string out "&amp;"
248     | '"' -> output_string out "&quot;"
249     | '\'' -> output_string out "&apos;"
250     | c -> output_char out c
251   done
252
253
254 let rec print_attributes ?(sep=true) out tree_ node =
255   if (node.kind == Tree.NodeKind.Attribute) then
256     let tag = QName.to_string (QName.remove_prefix node.tag) in
257     if sep then output_char out ' ';
258     output_string out tag;
259     output_string out "=\"";
260     output_escape_string out node.data;
261     output_char out '\"';
262     print_attributes out tree_ node.next_sibling
263   else
264     node
265
266 let rec print_xml out tree_ node =
267   if node != nil then
268   let () =
269     let open Tree.NodeKind in
270     match node.kind with
271     | Node -> ()
272     | Text -> output_escape_string out node.data
273     | Element | Document ->
274         let tag = QName.to_string node.tag in
275         output_char out '<';
276         output_string out tag;
277         let fchild = print_attributes out tree_ node.first_child in
278         if fchild == nil then output_string out "/>"
279         else begin
280           output_char out '>';
281           print_xml out tree_ fchild;
282           output_string out "</";
283           output_string out tag;
284           output_char out '>'
285         end
286     | Attribute -> ignore (print_attributes ~sep:false out tree_ node)
287     | Comment ->
288         output_string out "<!--";
289         output_string out node.data;
290         output_string out "-->"
291     | ProcessingInstruction ->
292         output_string out "<?";
293         output_string out (QName.to_string (QName.remove_prefix node.tag));
294         output_char out ' ';
295         output_string out node.data;
296         output_string out "?>"
297   in
298   print_xml out tree_ node.next_sibling
299
300 let print_xml out tree_ node =
301   let nnode =  { node with next_sibling = nil } in print_xml out tree_ nnode
302
303 let root t = t.root
304 let size t = t.size
305 let first_child _ n = n.first_child
306 let next_sibling _ n = n.next_sibling
307 let parent _ n = n.parent
308 let tag _ n = n.tag
309 let data _ n = n.data
310 let kind _ n = n.kind
311 let preorder _ n = n.preorder
312
313 let print_node fmt n = Parser.debug_node fmt n