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