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