tree.ml

   1 (******************************************************************************)
   2 (*  SXSI : XPath evaluator                                                    *)
   3 (*  Kim Nguyen (Kim.Nguyen@nicta.com.au)                                      *)
   4 (*  Copyright NICTA 2008                                                      *)
   5 (*  Distributed under the terms of the LGPL (see LICENCE)                     *)
   6 (******************************************************************************)
   7 module type BINARY =
   8 sig
   9   type node_content
  10   type string_content
  11   type descr = Nil | Node of node_content  |String of string_content
  12   type t
  13   val parse_xml_uri : string -> t
  14   val parse_xml_string : string -> t
  15   val string : t -> string
  16   val descr : t -> descr
  17   val left : t -> t
  18   val right : t -> t
  19   val id : t -> int
  20   val tag : t -> Tag.t
  21   val print_xml_fast : out_channel -> t -> unit
  22   val compare : t -> t -> int
  23   val equal : t -> t -> bool
  24 end
  25
  26 module OldBinary =
  27 struct
  28
  29   type string_content = string
  30   type descr = Nil | Node of node_content  | String of string_content
  31   and node_content = int*Tag.t * descr * descr * (descr ref)
  32   type t = descr
  33
  34   let descr t = t
  35
  36   let string = function String s -> s | _ -> failwith "string"
  37
  38
  39   external parse_xml_uri : string -> t = "caml_call_shredder_uri"
  40   external parse_xml_string : string -> t = "caml_call_shredder_string"
  41
  42   let parse_xml_uri s = Node(0,Tag.tag "",parse_xml_uri s,Nil,ref Nil)
  43   let parse_xml_string s = Node(0,Tag.tag "",parse_xml_string s,Nil,ref Nil)
  44   let tstring = function Nil -> "Nil"
  45     | Node (_,_,_,_,_) -> "Node"
  46     | String _ -> "String"
  47
  48
  49 let print_xml fmt t =
  50   let pp_str = Format.pp_print_string fmt in
  51   let rec loop = function Nil -> ()
  52     | String (s) -> pp_str s
  53     | Node (_,t,l,r,_) when Tag.equal t Tag.pcdata -> loop l;loop r
  54     | Node (_,t,l,r,_) ->
  55         pp_str ("<" ^ (Tag.to_string t));
  56         ( match l with
  57               Nil -> pp_str "/>"
  58             | Node(_,t',atts,children,_) when Tag.equal t' Tag.attribute ->
  59                 (loop_attributes atts;
  60                  match children with
  61                    | Nil -> pp_str "/>"
  62                    | _ ->
  63                        pp_str ">";
  64                        loop children;
  65                        pp_str ("</"^ (Tag.to_string t)^">" )
  66                 )
  67             | _ -> pp_str ">"; loop l;
  68                 pp_str ("</"^ (Tag.to_string t)^">" );
  69         );loop r
  70   and loop_attributes = function
  71     | Node(_,t,Node(_,_,String(s),_,_),r,_) ->
  72         pp_str (" "^(Tag.to_string t)^"=\""^ s ^"\"") ;
  73         loop_attributes r
  74     | _ -> ()
  75
  76   in
  77     loop t
  78
  79 let print_xml fmt =
  80   function Node(i,t,l,_,_) -> print_xml fmt (Node(i,t,l,Nil,ref Nil))
  81   | t -> print_xml fmt t
  82
  83
  84 (* a bit ugly but inlining like this makes serialization faster *)
  85
  86 let print_xml_fast outc t =
  87   let rec loop = function Nil -> ()
  88     | String (s) -> output_string outc  s
  89     | Node (_,t,l,r,_) when Tag.equal t Tag.pcdata -> loop l;loop r
  90     | Node (_,t,l,r,_) -> let t = Tag.to_string t in
  91         output_char outc  '<';
  92         output_string outc  t;
  93         ( match l with
  94               Nil -> output_string outc  "/>"
  95             | Node(_,t',atts,children,_) when Tag.equal t' Tag.attribute ->
  96                 (loop_attributes atts;
  97                  match children with
  98                    | Nil -> output_string outc  "/>"
  99                    | _ ->
 100                        output_char outc  '>';
 101                        loop children;
 102                        output_string outc  "</";
 103                        output_string outc  t;
 104                        output_char outc '>' )
 105             | _ ->
 106                 output_char outc  '>';
 107                 loop l;
 108                 output_string outc  "</";
 109                 output_string outc t;
 110                 output_char outc '>'
 111         );loop r
 112   and loop_attributes = function
 113     | Node(_,t,Node(_,_,String(s),_,_),r,_) ->
 114         output_char outc ' ';
 115         output_string outc (Tag.to_string t);
 116         output_string outc "=\"";
 117         output_string outc s;
 118         output_char outc '"';
 119         loop_attributes r
 120     | _ -> ()
 121
 122   in
 123     loop t
 124
 125 let print_xml_fast outc =
 126   function Node(i,t,l,_,_) -> print_xml_fast outc (Node(i,t,l,Nil,ref Nil))
 127   | t -> print_xml_fast outc t
 128
 129
 130
 131 let tabs = ref 0
 132
 133 let prtabs fmt =
 134   for i = 0 to !tabs
 135   do
 136     Format.fprintf fmt " "
 137   done
 138
 139
 140 let rec dump fmt t =
 141   incr tabs;
 142   let _ = match t with
 143     | Nil ->  prtabs fmt; Format.fprintf fmt "#"
 144     | String s -> prtabs fmt; Format.fprintf fmt "(String %s)" s
 145     | Node(id,t,l,r,_) ->
 146         prtabs fmt;
 147         Format.fprintf fmt " (tag='";
 148         Tag.print fmt t;
 149         Format.fprintf fmt "', id='%i')\n" id;
 150         prtabs fmt;
 151         dump fmt l;
 152         Format.fprintf fmt "\n";
 153         prtabs fmt;
 154         dump fmt r;
 155         Format.fprintf fmt "\n";
 156         prtabs fmt;prtabs fmt;
 157         Format.fprintf fmt "(id='%i'end )\n" id
 158   in decr tabs
 159
 160
 161 let dump fmt t =
 162   tabs:=0;
 163   dump fmt t;
 164   tabs:=0
 165
 166 let id = function Node(i,_,_,_,_) -> i
 167   | _ -> failwith "id"
 168
 169 let tag = function Node(_,t,_,_,_) -> t
 170   | _ -> failwith "tag"
 171
 172 let left = function Node(_,_,l,_,_) -> l
 173   | _ -> failwith "left"
 174
 175 let right = function Node(_,_,_,r,_) -> r
 176   | _ -> failwith "right"
 177
 178 let first_child = left
 179 let next_sibling = right
 180
 181 let is_root = function Node (_,_,_,_,{contents=Nil}) -> true | _ -> false
 182 let is_left n = match n with
 183   | Node (_,_,_,_,{contents=p}) when not(is_root n) && (left p) == n -> true
 184   | _ -> false
 185
 186 let is_right n = match n with
 187   | Node (_,_,_,_,{contents=p}) when not(is_root n) && (right p) == n -> true
 188   | _ -> false
 189
 190
 191 let compare t1 t2 = match t1,t2 with
 192   | Nil,Nil -> 0
 193   | String s1, String s2 -> String.compare s1 s2
 194   | Nil, String _ -> -1
 195   | String _, Nil -> 1
 196   | Node(i1,_,_,_,_), Node(i2,_,_,_,_) -> i1 - i2
 197   | _, Node _ -> -1
 198   | Node _ , _ -> 1
 199 let equal t1 t2 = (compare t1 t2) == 0
 200
 201 let int_size = Sys.word_size/8
 202 let ssize s = ((String.length s)/4 +1)*4
 203 let rec size =
 204   function Nil -> (int_size,1,0,0)
 205     | String s -> (int_size + (ssize s),0,1,0)
 206     | Node(_,_,l,r,_) ->
 207         let sizel,nl,sl,il = size l
 208         and sizer,nr,sr,ir = size r
 209         in
 210           (sizel+sizer+(7*int_size),nl+nr,sl+sr,il+ir+1)
 211 let size t =
 212   let s,n,st,i = size t in
 213     s/1024,n,st,i
 214 end
 215
 216
 217 module XML =
 218 struct
 219
 220   type t
 221   type 'a node = int
 222   type node_kind = [`Text | `Tree ]
 223
 224   let compare : 'a node -> 'a node -> int = (-)
 225   let equal : 'a node -> 'a node -> bool = (==)
 226
 227         (* abstract type, values are pointers to a XMLTree C++ object *)
 228
 229   external int_of_node : 'a node -> int = "%identity"
 230
 231   external parse_xml_uri : string  -> t = "caml_call_shredder_uri"
 232   let parse_xml_uri uri = parse_xml_uri uri
 233
 234   external parse_xml_string :  string  -> t = "caml_call_shredder_string"
 235   let parse_xml_string uri = parse_xml_string uri
 236
 237
 238   module Text =
 239   struct
 240     type t (* pointer to the text collection *)
 241     (* Todo *)
 242     external nullt : unit -> [`Text ] node = "caml_xml_tree_nullt"
 243     let nil = nullt ()
 244     external get_text : t -> [`Text] node -> string = "caml_text_collection_get_text"
 245
 246     let get_text t n =
 247       if equal nil n then ""
 248       else  get_text t n
 249
 250     external is_empty : t -> [`Text ] node -> bool = "caml_text_collection_empty_text"
 251   end
 252
 253
 254   module Tree =
 255   struct
 256
 257
 258     external serialize : string -> unit = "caml_xml_tree_serialize"
 259     external unserialize : string -> t = "caml_xml_tree_unserialize"
 260
 261     external root : t -> [`Tree] node = "caml_xml_tree_root"
 262     external nullt : unit -> [`Tree ] node = "caml_xml_tree_nullt"
 263
 264     let nil = nullt ()
 265     let is_nil x = equal x nil
 266
 267     external parent : t -> [`Tree] node -> [`Tree] node = "caml_xml_tree_first_child"
 268     external parent_doc : t -> [`Text ] node -> [`Tree ] node = "caml_xml_tree_parent_doc"
 269     external first_child : t -> [`Tree] node -> [`Tree] node = "caml_xml_tree_first_child"
 270
 271
 272
 273     external next_sibling : t -> [`Tree] node -> [`Tree] node = "caml_xml_tree_next_sibling"
 274
 275     external is_leaf : t  -> [`Tree] node -> bool = "caml_xml_tree_is_leaf"
 276
 277     external tag : t -> [`Tree ] node -> Tag.t = "caml_xml_tree_tag"
 278
 279     external text_collection : t -> Text.t = "caml_xml_tree_text_collection"
 280
 281     let is_last t n = equal nil (next_sibling t n)
 282
 283     external prev_text : t -> [`Tree] node -> [`Text ] node = "caml_xml_tree_prev_text"
 284
 285
 286     external my_text : t -> [`Tree] node -> [`Text ] node = "caml_xml_tree_my_text"
 287     external next_text : t -> [`Tree] node -> [`Text ] node = "caml_xml_tree_next_text"
 288
 289     external text_xml_id : t -> [`Text ] node -> int = "caml_xml_tree_text_xml_id"
 290     external node_xml_id : t -> [`Tree ] node -> int = "caml_xml_tree_node_xml_id"
 291
 292
 293     let print_skel t =
 294       let textcol = text_collection t in
 295       let rec aux id =
 296         if (is_nil id)
 297         then Printf.eprintf "#"
 298         else
 299           begin
 300             Printf.eprintf "Node %i has tag '%s', DocID of PrevText,MyText,NextText : (%i = %s,%i = %s,%i = %s)\n%!"
 301               (int_of_node id)
 302               (Tag.to_string (tag t id))
 303               (int_of_node (prev_text t id))
 304               (Text.get_text textcol (prev_text t id))
 305               (int_of_node (my_text t id))
 306               (Text.get_text textcol (my_text t id))
 307               (int_of_node (next_text t id))
 308               (Text.get_text textcol (next_text t id));
 309             aux(first_child t id);
 310             aux(next_sibling t id);
 311           end
 312       in
 313         aux (root t)
 314
 315     let traversal t =
 316       let textcol = text_collection t in
 317         let rec aux id =
 318           if not (is_nil id)
 319           then
 320             begin
 321               ignore (tag t id);
 322               ignore (Text.get_text textcol (prev_text t id));
 323               if (is_leaf t id)
 324                 then ignore (Text.get_text textcol (my_text t id));
 325               if (is_last t id)
 326                 then ignore (Text.get_text textcol (next_text t id));
 327               aux (first_child t id);
 328               aux (next_sibling t id);
 329             end
 330         in
 331           aux (root t)
 332   end
 333
 334
 335   module Binary  = struct
 336
 337     type node_content =
 338         NC of [`Tree ] node
 339       | SC of [`Text ] node * [`Tree ] node
 340     type string_content = [ `Text ] node
 341     type descr =
 342       | Nil
 343       | Node of node_content
 344       | String of string_content
 345
 346     type doc = t
 347
 348     type t = { doc : doc;
 349                text : Text.t;
 350                node : descr }
 351
 352     let dump { doc=t } = Tree.print_skel t
 353     open Tree
 354     let node_of_t t = { doc= t;
 355                         text = text_collection t;
 356                         node = Node(NC (root t)) }
 357
 358
 359     let parse_xml_uri str = node_of_t (parse_xml_uri str)
 360     let parse_xml_string str = node_of_t (parse_xml_string str)
 361
 362     let compare a b = match a.node,b.node  with
 363       | Node(NC i),Node(NC j) -> compare i j
 364       | _, Node(NC( _ )) -> 1
 365       | Node(SC (i,_)),Node(SC (j,_)) -> compare i j
 366       | Node(NC( _ )),Node(SC (_,_)) -> -1
 367       | _, Node(SC (_,_)) -> 1
 368       | String i, String j -> compare i j
 369       | Node _ , String _ -> -1
 370       | _ , String _ -> 1
 371       | Nil, Nil -> 0
 372       | _,Nil -> -1
 373
 374     let equal a b = (compare a b) == 0
 375
 376     let string t = match t.node with
 377       | String i ->  Text.get_text t.text i
 378       | _ -> assert false
 379
 380     let norm (n : [`Tree ] node ) =  if is_nil n then Nil else Node (NC n)
 381
 382     let descr t = t.node
 383
 384     let nts = function
 385         Nil -> "Nil"
 386       | String i -> Printf.sprintf "String %i" i
 387       | Node (NC t) -> Printf.sprintf "Node (NC %i)"  (int_of_node t)
 388       | Node (SC (t,i)) -> Printf.sprintf "Node (SC (%i,%i))"  (int_of_node t) (int_of_node i)
 389
 390     let first_child n =
 391       let node' =
 392         match n.node with
 393           | Node (NC t) when is_leaf n.doc t ->
 394               let txt = my_text n.doc t in
 395                 if Text.is_empty n.text txt
 396                 then Nil
 397                 else Node(SC (txt,Tree.nil))
 398           | Node (NC t) ->
 399               let fs = first_child n.doc t in
 400               let txt = prev_text n.doc fs in
 401                 if Text.is_empty n.text txt
 402                 then norm fs
 403                 else Node (SC (txt, fs))
 404           | Node(SC (i,_)) -> String i
 405           | Nil | String _ -> failwith "first_child"
 406       in
 407         { n with node = node'}
 408
 409
 410     let next_sibling n =
 411       let node' =
 412         match n.node with
 413           | Node (SC (_,ns)) -> norm ns
 414           | Node(NC t) ->
 415               let ns = next_sibling n.doc t in
 416               let txt = next_text n.doc t in
 417                 if Text.is_empty n.text txt
 418                 then norm ns
 419                 else Node (SC (txt, ns))
 420           | Nil | String _  -> failwith "next_sibling"
 421       in
 422         { n with node = node'}
 423
 424
 425     let left = first_child
 426     let right = next_sibling
 427
 428     let id =
 429       function  { doc=d; node=Node(NC n)}  -> text_xml_id d n
 430         | { doc=d;  node=Node(SC (i,_) )} -> node_xml_id d i
 431         | _ -> failwith "id"
 432
 433     let tag =
 434       function { node=Node(SC _) } -> Tag.pcdata
 435         | { doc=d; node=Node(NC n)} -> tag d n
 436         | _ -> failwith "Tag"
 437
 438
 439
 440     let print_xml_fast outc t =
 441       let rec loop ?(print_right=true) t = match t.node with
 442         | Nil -> ()
 443         | String (s) -> output_string outc (string t)
 444         | Node _ when Tag.equal (tag t) Tag.pcdata -> loop (left t); loop (right t)
 445
 446         | Node (_) ->
 447             let tg = Tag.to_string (tag t) in
 448             let l = left t
 449             and r = right t
 450             in
 451               output_char outc  '<';
 452               output_string outc  tg;
 453               ( match l.node with
 454                     Nil -> output_string outc  "/>"
 455                   | String _ -> assert false
 456                   | Node(_) when Tag.equal (tag l) Tag.attribute ->
 457                       (loop_attributes (left l);
 458                        match (right l).node with
 459                          | Nil -> output_string outc  "/>"
 460                          | _ ->
 461                              output_char outc  '>';
 462                              loop (right l);
 463                              output_string outc  "</";
 464                              output_string outc  tg;
 465                              output_char outc '>' )
 466                   | _ ->
 467                       output_char outc  '>';
 468                       loop l;
 469                       output_string outc "</";
 470                       output_string outc tg;
 471                       output_char outc '>'
 472               );if print_right then loop r
 473       and loop_attributes a =
 474
 475         match a.node with
 476           | Node(_) ->
 477               let value =
 478                 match (left a).node with
 479                   | Nil -> ""
 480                   | _ -> string (left(left a))
 481               in
 482                 output_char outc ' ';
 483                 output_string outc (Tag.to_string (tag a));
 484                 output_string outc "=\"";
 485                 output_string outc value;
 486                 output_char outc '"';
 487                 loop_attributes (right a)
 488         | _ -> ()
 489       in
 490         loop ~print_right:false t
 491
 492
 493     let print_xml_fast outc t =
 494       if Tag.to_string (tag t) = "" then
 495         print_xml_fast outc (first_child t)
 496       else print_xml_fast outc t
 497
 498     let traversal t = Tree.traversal t.doc
 499     let full_traversal t =
 500       let rec aux n =
 501         match n.node with
 502         | Nil -> ()
 503         | String i -> ignore(Text.get_text t.text i)
 504         | Node(_) ->
 505             ignore (tag n);
 506             aux (first_child n);
 507             aux (next_sibling n)
 508       in aux t
 509   end
 510
 511 end
 512
 513
 514 let dump = XML.Binary.dump
 515 let traversal = XML.Binary.traversal
 516 let full_traversal = XML.Binary.full_traversal
 517 external cpp_traversal : XML.t -> unit = "caml_cpp_traversal"
 518 let cpp_traversal t = cpp_traversal t.XML.Binary.doc
 519
 520 include XML