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