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 summary : Tree.NodeSummary.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   summary = Tree.NodeSummary.dummy;
  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   summary = Tree.NodeSummary.dummy;
  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               summary = Tree.NodeSummary.make false false false false 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.summary <- Tree.NodeSummary.make false false false false 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.summary <- Tree.NodeSummary.make false false false false 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.summary <- Tree.NodeSummary.make false false false false 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.summary <- Tree.NodeSummary.make false false false false 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            summary = Tree.NodeSummary.make false false false false 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              n.summary <-
 215                Tree.NodeSummary.make
 216                  (n == n.parent.first_child)
 217                  (n == n.parent.next_sibling)
 218                  (n.first_child != nil)
 219                  (n.next_sibling != nil)
 220                  (Tree.NodeSummary.kind n.summary);
 221              a.(n.preorder) <- n;
 222              loop n.first_child;
 223              loop n.next_sibling;
 224            end
 225        in
 226        loop root;
 227        { root = root;
 228          size = ctx.current_preorder;
 229          by_preorder = a
 230        }
 231     )
 232
 233   let error e parser_ =
 234     let msg = Printf.sprintf "%i.%i %s"
 235       (Expat.get_current_line_number parser_)
 236       (Expat.get_current_column_number parser_)
 237       (Expat.xml_error_to_string e)
 238     in
 239     raise (Tree.Parse_error msg)
 240
 241   let parse_string s =
 242     let parser_, finalize = create_parser () in
 243     try
 244       Expat.parse parser_ s;
 245       finalize ()
 246     with
 247       Expat.Expat_error e -> error e parser_
 248
 249   let parse_file fd =
 250     let buffer = String.make 4096 '\000' in
 251     let parser_, finalize = create_parser () in
 252     let rec loop () =
 253       let read = input fd buffer 0 4096 in
 254       if read != 0 then
 255         let () = Expat.parse_sub parser_ buffer 0 read in
 256         loop ()
 257     in try
 258          loop (); finalize ()
 259       with
 260         Expat.Expat_error e -> error e parser_
 261
 262 end
 263
 264
 265 let load_xml_file = Parser.parse_file
 266 let load_xml_string = Parser.parse_string
 267
 268 let output_escape_string out s =
 269   for i = 0 to String.length s - 1 do
 270     match s.[i] with
 271     | '<' -> output_string out "&lt;"
 272     | '>' -> output_string out "&gt;"
 273     | '&' -> output_string out "&amp;"
 274     | '"' -> output_string out "&quot;"
 275     | '\'' -> output_string out "&apos;"
 276     | c -> output_char out c
 277   done
 278
 279 let kind _ n = Tree.NodeSummary.kind n.summary
 280 let summary _ n = n.summary
 281
 282 let rec print_attributes ?(sep=true) out tree_ node =
 283   if (kind tree_ node == Tree.NodeKind.Attribute) then
 284     let tag = QName.to_string node.tag in
 285     if sep then output_char out ' ';
 286     output_string out tag;
 287     output_string out "=\"";
 288     output_escape_string out node.data;
 289     output_char out '\"';
 290     print_attributes out tree_ node.next_sibling
 291   else
 292     node
 293
 294 let rec print_xml out tree_ node =
 295   if node != nil then
 296   let () =
 297     let open Tree.NodeKind in
 298     match kind tree_ node with
 299     | Node -> ()
 300     | Text -> output_escape_string out node.data
 301     | Element | Document ->
 302         let tag = QName.to_string node.tag in
 303         output_char out '<';
 304         output_string out tag;
 305         let fchild = print_attributes out tree_ node.first_child in
 306         if fchild == nil then output_string out "/>"
 307         else begin
 308           output_char out '>';
 309           print_xml out tree_ fchild;
 310           output_string out "</";
 311           output_string out tag;
 312           output_char out '>'
 313         end
 314     | Attribute -> ignore (print_attributes ~sep:false out tree_ node)
 315     | Comment ->
 316         output_string out "<!--";
 317         output_string out node.data;
 318         output_string out "-->"
 319     | ProcessingInstruction ->
 320         output_string out "<?";
 321         output_string out (QName.to_string  node.tag);
 322         output_char out ' ';
 323         output_string out node.data;
 324         output_string out "?>"
 325   in
 326   print_xml out tree_ node.next_sibling
 327
 328 let print_xml out tree_ node =
 329   let nnode =  { node with next_sibling = nil } in print_xml out tree_ nnode
 330
 331 let root t = t.root
 332 let size t = t.size
 333 let first_child _ n = n.first_child
 334 let next_sibling _ n = n.next_sibling
 335 let parent _ n = n.parent
 336 let tag _ n = n.tag
 337 let data _ n = n.data
 338 let preorder _ n = n.preorder
 339 let by_preorder t i =
 340  if i >= 0 && i < t.size then Array.unsafe_get t.by_preorder i
 341  else let e = Invalid_argument "by_preorder" in raise e
 342 let print_node fmt n = Parser.debug_node fmt n