Simplify the automaton encoding a bit (remove redundant predicates in formulae).
[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 type node = {
17   tag : QName.t;
18   preorder : int;
19   mutable kind : Tree.NodeKind.t;
20   mutable data : string;
21   mutable first_child : node;
22   mutable next_sibling : node;
23   mutable parent: node;
24 }
25
26
27
28 let rec nil = {
29   tag = QName.nil;
30   kind = Tree.NodeKind.Element;
31   preorder = -1;
32   data = "";
33   first_child = nil;
34   next_sibling = nil;
35   parent = nil;
36 }
37
38 let dummy_tag = QName.of_string "#dummy"
39 let rec dummy = {
40   tag = dummy_tag;
41   kind = Tree.NodeKind.Element;
42   preorder = -1;
43   data = "";
44   first_child = dummy;
45   next_sibling = dummy;
46   parent = dummy;
47 }
48
49
50 type t = {
51   root : node;
52   size : int;
53   by_preorder : node array;
54   (* TODO add other intersting stuff *)
55 }
56
57
58
59 module Parser =
60 struct
61
62   type context = {
63     mutable stack : node list;
64     text_buffer : Buffer.t;
65     mutable current_preorder : int;
66   }
67
68   let print_node_ptr fmt n =
69     Format.fprintf fmt "<%s>"
70       (if n == nil then "NIL" else
71         if n == dummy then "DUMMY" else
72           "NODE " ^  string_of_int n.preorder)
73
74   let debug_node fmt node =
75     Format.fprintf fmt
76       "{ tag=%s; preorder=%i; data=%S;\
77 first_child=%a; next_sibling=%a; parent=%a }"
78       (QName.to_string node.tag)
79       node.preorder
80       node.data
81       print_node_ptr node.first_child
82       print_node_ptr node.next_sibling
83       print_node_ptr node.parent
84
85
86   let debug_ctx fmt ctx =
87     Format.fprintf fmt "Current context: { preorder = %i\n; stack = \n%a\n }\
88 \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     start_element_handler parser_ ctx att [];
134     let n = top ctx in
135     n.data <- value;
136     n.kind <- Tree.NodeKind.Attribute;
137     end_element_handler parser_ ctx att
138
139   and consume_closing ctx n =
140     if n.next_sibling != dummy then
141       let _ = pop ctx in consume_closing ctx (top ctx)
142
143   and end_element_handler parser_ ctx _ =
144     do_text parser_ ctx;
145     let node = top ctx in
146     if node.first_child == dummy then node.first_child <- nil
147     else begin
148       node.next_sibling <- nil;
149       consume_closing ctx node
150     end
151
152   and do_text parser_ ctx =
153     if Buffer.length ctx.text_buffer != 0 then
154       let s = Buffer.contents ctx.text_buffer in
155       Buffer.clear  ctx.text_buffer;
156       start_element_handler parser_ ctx text_string [];
157       let node = top ctx in
158       node.data <- s;
159       node.kind <- Tree.NodeKind.Text;
160       end_element_handler parser_ ctx text_string
161
162   and comment_handler parser_ ctx s =
163     do_text parser_ ctx;
164     start_element_handler parser_ ctx comment_string [];
165     let node = top ctx in
166     node.data <- s;
167     node.kind <- Tree.NodeKind.Comment;
168     end_element_handler parser_ ctx comment_string
169
170   and processing_instruction_handler parser_ ctx tag data =
171     do_text parser_ ctx;
172     start_element_handler parser_ ctx tag [];
173     let node = top ctx in
174     node.data <- data;
175     node.kind <- Tree.NodeKind.ProcessingInstruction;
176     end_element_handler parser_ ctx tag
177
178
179   let character_data_handler _parser ctx text =
180     Buffer.add_string ctx.text_buffer text
181
182   let create_parser () =
183     let ctx = { text_buffer = Buffer.create 512;
184                 current_preorder = 0;
185                 stack = [] } in
186     let psr = Expat.parser_create ~encoding:None in
187     Expat.set_start_element_handler psr (start_element_handler psr ctx);
188     Expat.set_end_element_handler psr (end_element_handler psr ctx);
189     Expat.set_character_data_handler
190       psr (character_data_handler psr ctx);
191     Expat.set_comment_handler psr (comment_handler psr ctx);
192     Expat.set_processing_instruction_handler psr
193       (processing_instruction_handler psr ctx);
194     push { tag = QName.document;
195            preorder = next ctx;
196            kind = Tree.NodeKind.Document;
197            data = "";
198            first_child = dummy;
199            next_sibling = dummy;
200            parent = nil;
201          } ctx;
202     (psr,
203      fun () ->
204        let node = top ctx in
205        node.next_sibling <- nil;
206        consume_closing ctx node;
207        Expat.final psr;
208        let root = List.hd ctx.stack in
209        root.next_sibling <- nil;
210        let a = Array.make ctx.current_preorder nil in
211        let rec loop n =
212          if n != nil then
213            begin
214              a.(n.preorder) <- n;
215              loop n.first_child;
216              loop n.next_sibling;
217            end
218        in
219        loop root;
220        { root = root;
221          size = ctx.current_preorder;
222          by_preorder = a
223        }
224     )
225
226   let error e parser_ =
227     let msg = Printf.sprintf "%i.%i %s"
228       (Expat.get_current_line_number parser_)
229       (Expat.get_current_column_number parser_)
230       (Expat.xml_error_to_string e)
231     in
232     raise (Tree.Parse_error msg)
233
234   let parse_string s =
235     let parser_, finalize = create_parser () in
236     try
237       Expat.parse parser_ s;
238       finalize ()
239     with
240       Expat.Expat_error e -> error e parser_
241
242   let parse_file fd =
243     let buffer = String.make 4096 '\000' in
244     let parser_, finalize = create_parser () in
245     let rec loop () =
246       let read = input fd buffer 0 4096 in
247       if read != 0 then
248         let () = Expat.parse_sub parser_ buffer 0 read in
249         loop ()
250     in try
251          loop (); finalize ()
252       with
253         Expat.Expat_error e -> error e parser_
254
255 end
256
257
258 let load_xml_file = Parser.parse_file
259 let load_xml_string = Parser.parse_string
260
261 let output_escape_string out s =
262   for i = 0 to String.length s - 1 do
263     match s.[i] with
264     | '<' -> output_string out "&lt;"
265     | '>' -> output_string out "&gt;"
266     | '&' -> output_string out "&amp;"
267     | '"' -> output_string out "&quot;"
268     | '\'' -> output_string out "&apos;"
269     | c -> output_char out c
270   done
271
272
273 let rec print_attributes ?(sep=true) out tree_ node =
274   if (node.kind == Tree.NodeKind.Attribute) then
275     let tag = QName.to_string node.tag in
276     if sep then output_char out ' ';
277     output_string out tag;
278     output_string out "=\"";
279     output_escape_string out node.data;
280     output_char out '\"';
281     print_attributes out tree_ node.next_sibling
282   else
283     node
284
285 let rec print_xml out tree_ node =
286   if node != nil then
287   let () =
288     let open Tree.NodeKind in
289     match node.kind with
290     | Node -> ()
291     | Text -> output_escape_string out node.data
292     | Element | Document ->
293         let tag = QName.to_string node.tag in
294         output_char out '<';
295         output_string out tag;
296         let fchild = print_attributes out tree_ node.first_child in
297         if fchild == nil then output_string out "/>"
298         else begin
299           output_char out '>';
300           print_xml out tree_ fchild;
301           output_string out "</";
302           output_string out tag;
303           output_char out '>'
304         end
305     | Attribute -> ignore (print_attributes ~sep:false out tree_ node)
306     | Comment ->
307         output_string out "<!--";
308         output_string out node.data;
309         output_string out "-->"
310     | ProcessingInstruction ->
311         output_string out "<?";
312         output_string out (QName.to_string  node.tag);
313         output_char out ' ';
314         output_string out node.data;
315         output_string out "?>"
316   in
317   print_xml out tree_ node.next_sibling
318
319 let print_xml out tree_ node =
320   let nnode =  { node with next_sibling = nil } in print_xml out tree_ nnode
321
322 let root t = t.root
323 let size t = t.size
324 let first_child _ n = n.first_child
325 let next_sibling _ n = n.next_sibling
326 let parent _ n = n.parent
327 let tag _ n = n.tag
328 let data _ n = n.data
329 let kind _ n = n.kind
330 let preorder _ n = n.preorder
331 let by_preorder t i =
332  if i >= 0 && i < t.size then Array.unsafe_get t.by_preorder i
333  else let e = Invalid_argument "by_preorder" in raise e
334 let print_node fmt n = Parser.debug_node fmt n