src/tree/naive.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-03-09 18:49:04 CET by Kim Nguyen>
  18 *)
  19 open Utils
  20
  21 type node = {
  22   tag : QName.t;
  23   preorder : int;
  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   preorder = -1;
  35   data = "";
  36   first_child = nil;
  37   next_sibling = nil;
  38   parent = nil;
  39 }
  40
  41 let dummy_tag = QName.of_string "#dummy"
  42 let rec dummy = {
  43   tag = dummy_tag;
  44   preorder = -1;
  45   data = "";
  46   first_child = dummy;
  47   next_sibling = dummy;
  48   parent = dummy;
  49 }
  50
  51
  52 type t = {
  53   root : node;
  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 "{ tag=%s; preorder=%i; data=%S; first_child=%a; next_sibling=%a; parent=%a }"
  76       (QName.to_string node.tag)
  77       node.preorder
  78       node.data
  79       print_node_ptr node.first_child
  80       print_node_ptr node.next_sibling
  81       print_node_ptr node.parent
  82
  83
  84   let debug_ctx fmt ctx =
  85     Format.fprintf fmt "Current context: { preorder = %i\n; stack = \n%a\n }\n-------------\n"
  86       ctx.current_preorder
  87       (Pretty.print_list ~sep:";\n" debug_node) ctx.stack
  88
  89
  90   let push n ctx = ctx.stack <- n :: ctx.stack
  91   let pop ctx =
  92     match ctx.stack with
  93       [] -> failwith "XML parse error"
  94     | e :: l -> ctx.stack <- l; e
  95
  96   let top ctx = match ctx.stack with
  97     | [] -> failwith "XML parse error"
  98     | e :: _ -> e
  99
 100   let next ctx =
 101     let i = ctx.current_preorder in
 102     ctx.current_preorder <- 1 + i;
 103     i
 104
 105   let is_left n = n.next_sibling == dummy
 106
 107
 108   let text_string = QName.to_string QName.text
 109   let attr_map_string = QName.to_string QName.attribute_map
 110
 111   let att_pref = QName.node QName.attribute_prefix
 112   let rec start_element_handler parser_ ctx tag attr_list =
 113     do_text parser_ ctx;
 114     let parent = top ctx in
 115     let n = { tag = QName.of_string tag;
 116               preorder = next ctx;
 117               data = "";
 118               first_child = dummy;
 119               next_sibling = dummy;
 120               parent = parent;
 121             }
 122     in
 123     if parent.first_child == dummy then parent.first_child <- n
 124     else parent.next_sibling <- n;
 125     push n ctx;
 126     List.iter (do_attribute parser_ ctx) attr_list
 127
 128   and do_attribute parser_ ctx (att, value) =
 129     let att_tag = att_pref ^ att in
 130     start_element_handler parser_ ctx att_tag [];
 131     let n = top ctx in n.data <- value;
 132     end_element_handler parser_ ctx att_tag
 133
 134   and consume_closing ctx n =
 135     if n.next_sibling != dummy then
 136       let _ = pop ctx in consume_closing ctx (top ctx)
 137
 138   and end_element_handler parser_ ctx _ =
 139     do_text parser_ ctx;
 140     let node = top ctx in
 141     if node.first_child == dummy then node.first_child <- nil
 142     else begin
 143       node.next_sibling <- nil;
 144       consume_closing ctx node
 145     end
 146
 147   and do_text parser_ ctx =
 148     if Buffer.length ctx.text_buffer != 0 then
 149       let s = Buffer.contents ctx.text_buffer in
 150       Buffer.clear  ctx.text_buffer;
 151       start_element_handler parser_ ctx text_string [];
 152       let node = top ctx in
 153       node.data <- s;
 154       end_element_handler parser_ ctx text_string
 155
 156
 157
 158   let character_data_handler _parser ctx text =
 159     Buffer.add_string ctx.text_buffer text
 160
 161   let create_parser () =
 162     let ctx = { text_buffer = Buffer.create 512;
 163                 current_preorder = 0;
 164                 stack = [] } in
 165     let parser_ = Expat.parser_create ~encoding:None in
 166     Expat.set_start_element_handler parser_ (start_element_handler parser_ ctx);
 167     Expat.set_end_element_handler parser_ (end_element_handler parser_ ctx);
 168     Expat.set_character_data_handler parser_ (character_data_handler parser_ ctx);
 169     push { tag = QName.document;
 170            preorder = next ctx;
 171            data = "";
 172            first_child = dummy;
 173            next_sibling = dummy;
 174            parent = nil;
 175          } ctx;
 176     (parser_,
 177      fun () ->
 178        let node = top ctx in
 179        node.next_sibling <- nil;
 180        consume_closing ctx node;
 181        match ctx.stack with
 182          [ root ] ->
 183            root.next_sibling <- nil;
 184            { root = root }
 185        | _ -> raise (Expat.Expat_error Expat.UNCLOSED_TOKEN)
 186     )
 187
 188
 189   let parse_string s =
 190     let parser_, finalize = create_parser () in
 191     Expat.parse parser_ s;
 192     finalize ()
 193
 194   let parse_file fd =
 195     let buffer = String.create 4096 in
 196     let parser_, finalize = create_parser () in
 197     let rec loop () =
 198       let read = input fd buffer 0 4096 in
 199       if read != 0 then
 200         let () = Expat.parse_sub parser_ buffer 0 read in
 201         loop ()
 202     in loop (); finalize ()
 203
 204 end
 205
 206
 207 let load_xml_file = Parser.parse_file
 208 let load_xml_string = Parser.parse_string
 209
 210
 211 let output_escape_string out s =
 212   for i = 0 to String.length s - 1 do
 213     match s.[i] with
 214     | '<' -> output_string out "&lt;"
 215     | '>' -> output_string out "&gt;"
 216     | '&' -> output_string out "&amp;"
 217     | '"' -> output_string out "&quot;"
 218     | '\'' -> output_string out "&apos;"
 219     | c -> output_char out c
 220   done
 221
 222 let rec print_attributes ?(sep=true) out tree_ node =
 223   let tag = node.tag in
 224   if QName.has_attribute_prefix tag then begin
 225     let ntag = QName.node tag in
 226     if sep then output_char out ' ';
 227     output out ntag 1 (String.length ntag - 1);
 228     output_string out "=\"";
 229     output_escape_string out node.data;
 230     output_char out '"';
 231     print_attributes out tree_ node.next_sibling
 232  end
 233  else
 234   node
 235
 236 let rec print_xml out tree_ node =
 237   if node != nil then
 238   let () =
 239     if node.tag == QName.text then
 240     output_escape_string out node.data
 241     else
 242     let tag = QName.to_string node.tag in
 243     output_char out '<';
 244     output_string out tag;
 245     let fchild = print_attributes out tree_ node.first_child in
 246     if fchild == nil then output_string out "/>"
 247     else begin
 248       output_char out '>';
 249       print_xml out tree_ fchild;
 250       output_string out "</";
 251       output_string out tag;
 252       output_char out '>'
 253     end
 254   in
 255   print_xml out tree_ node.next_sibling
 256
 257 let print_xml out tree_ node =
 258   let nnode =  { node with next_sibling = nil } in
 259   if QName.has_attribute_prefix nnode.tag then
 260     ignore (print_attributes ~sep:false out tree_ nnode)
 261   else
 262     print_xml out tree_ nnode
 263
 264 let root t = t.root
 265 let first_child _ n = n.first_child
 266 let next_sibling _ n = n.next_sibling
 267 let parent _ n = n.parent
 268 let tag _ n = n.tag
 269 let data _ n = n.data
 270 let preorder _ n = n.preorder
 271
 272 let print_node fmt n = Parser.debug_node fmt n