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 INCLUDE "debug.ml"
   8 module type BINARY =
   9 sig
  10   type node_content
  11   type string_content
  12   type descr = Nil | Node of node_content  |String of string_content
  13   type t
  14   val parse_xml_uri : string -> t
  15   val parse_xml_string : string -> t
  16   val save : t -> string -> unit
  17   val load : ?sample:int -> string -> t
  18   val tag_pool : t -> Tag.pool
  19   val string : t -> string
  20   val descr : t -> descr
  21   val is_node : t -> bool
  22   val left : t -> t
  23   val right : t -> t
  24   val first_child : t -> t
  25   val next_sibling : t -> t
  26   val parent : t -> t
  27   val id : t -> int
  28   val tag : t -> Tag.t
  29   val print_xml_fast : out_channel -> t -> unit
  30   val compare : t -> t -> int
  31   val equal : t -> t -> bool
  32   module DocIdSet :
  33   sig
  34     include Set.S
  35   end
  36     with type elt = string_content
  37   val string_below : t -> string_content -> bool
  38   val contains : t -> string -> DocIdSet.t
  39   val contains_old : t -> string -> bool
  40   val dump : t -> unit
  41   val get_string : t -> string_content -> string
  42 end
  43
  44 module XML =
  45 struct
  46
  47   type t
  48   type 'a node = int
  49   type node_kind = [`Text | `Tree ]
  50
  51   let compare : 'a node -> 'a node -> int = (-)
  52   let equal : 'a node -> 'a node -> bool = (==)
  53
  54         (* abstract type, values are pointers to a XMLTree C++ object *)
  55
  56   external int_of_node : 'a node -> int = "%identity"
  57
  58   external parse_xml_uri : string -> int -> bool -> bool -> t = "caml_call_shredder_uri"
  59   external parse_xml_string :  string -> int -> bool -> bool -> t = "caml_call_shredder_string"
  60
  61   external save_tree : t -> string -> unit = "caml_xml_tree_save"
  62   external load_tree : string -> int -> t = "caml_xml_tree_load"
  63
  64
  65   module Text =
  66   struct
  67     let equal : [`Text] node -> [`Text] node -> bool = equal
  68
  69     (* Todo *)
  70     external nullt : unit -> [`Text ] node = "caml_xml_tree_nullt"
  71     let nil = nullt ()
  72     external get_text : t -> [`Text] node -> string = "caml_text_collection_get_text"
  73
  74     let get_text t n =
  75       if equal nil n then ""
  76       else  get_text t n
  77
  78     external is_empty : t -> [`Text ] node -> bool = "caml_text_collection_empty_text"
  79     let is_empty t n =
  80       (equal nil n) || is_empty t n
  81
  82     external is_contains : t -> string -> bool = "caml_text_collection_is_contains"
  83     external count_contains : t -> string -> int = "caml_text_collection_count_contains"
  84     external contains : t -> string -> [`Text ] node array = "caml_text_collection_contains"
  85   end
  86
  87
  88   module Tree =
  89   struct
  90
  91     let equal : [`Tree ] node -> [`Tree] node -> bool = equal
  92     external serialize : t -> string -> unit = "caml_xml_tree_serialize"
  93     external unserialize : string -> t = "caml_xml_tree_unserialize"
  94
  95     external root : t -> [`Tree] node = "caml_xml_tree_root"
  96     external nullt : unit -> [`Tree ] node = "caml_xml_tree_nullt"
  97
  98     let nil = nullt ()
  99     let is_nil x = equal x nil
 100
 101     external parent : t -> [`Tree] node -> [`Tree] node = "caml_xml_tree_parent"
 102     external parent_doc : t -> [`Text ] node -> [`Tree ] node = "caml_xml_tree_parent_doc"
 103     external first_child : t -> [`Tree] node -> [`Tree] node = "caml_xml_tree_first_child"
 104
 105
 106
 107     external next_sibling : t -> [`Tree] node -> [`Tree] node = "caml_xml_tree_next_sibling"
 108
 109     external is_leaf : t  -> [`Tree] node -> bool = "caml_xml_tree_is_leaf"
 110
 111 (*    external tag : t -> [`Tree ] node -> T = "caml_xml_tree_tag"*)
 112     external tag_id : t -> [`Tree ] node -> Tag.t = "caml_xml_tree_tag_id"
 113
 114     let is_last t n = equal nil (next_sibling t n)
 115
 116     external prev_text : t -> [`Tree] node -> [`Text ] node = "caml_xml_tree_prev_text"
 117
 118
 119     external my_text : t -> [`Tree] node -> [`Text ] node = "caml_xml_tree_my_text"
 120     external next_text : t -> [`Tree] node -> [`Text ] node = "caml_xml_tree_next_text"
 121
 122     external text_xml_id : t -> [`Text ] node -> int = "caml_xml_tree_text_xml_id"
 123     external node_xml_id : t -> [`Tree ] node -> int = "caml_xml_tree_node_xml_id"
 124     external is_ancestor : t -> [`Tree ] node -> [`Tree ] node -> bool = "caml_xml_tree_is_ancestor"
 125
 126     let print_skel t =
 127       let rec aux id =
 128         if (is_nil id)
 129         then Printf.eprintf "#\n"
 130         else
 131           begin
 132             Printf.eprintf "Node %i has tag '%s' DocOrder=%i, DocID of PrevText,MyText,NextText : (%i = %s,%i = %s,%i = %s) parent_doc(my_text)=%i\n%!"
 133               (int_of_node id)
 134               (Tag.to_string (tag_id t id))
 135               (node_xml_id t id)
 136               (int_of_node (prev_text t id))
 137               (Text.get_text t (prev_text t id))
 138               (int_of_node (my_text t id))
 139               (Text.get_text t (my_text t id))
 140               (int_of_node (next_text t id))
 141               (Text.get_text t (next_text t id))
 142               (int_of_node(parent_doc t (my_text t id)));
 143
 144             aux(first_child t id);
 145             aux(next_sibling t id);
 146           end
 147       in
 148         aux (root t)
 149
 150     let traversal t =
 151         let rec aux id =
 152           if not (is_nil id)
 153           then
 154             begin
 155               (* ignore (tag t id);
 156               ignore (Text.get_text t (prev_text t id));
 157               if (is_leaf t id)
 158                 then ignore (Text.get_text t (my_text t id));
 159               if (is_last t id)
 160                 then ignore (Text.get_text t (next_text t id)); *)
 161               aux (first_child t id);
 162               aux (next_sibling t id);
 163             end
 164         in
 165           aux (root t)
 166   end
 167
 168
 169   module Binary  = struct
 170
 171     type node_content =
 172         NC of [`Tree ] node
 173       | SC of [`Text ] node * [`Tree ] node
 174     type string_content = [ `Text ] node
 175     type descr =
 176       | Nil
 177       | Node of node_content
 178       | String of string_content
 179
 180     type doc = t
 181
 182     type t = { doc : doc;
 183                node : descr }
 184
 185     let dump { doc=t } = Tree.print_skel t
 186     module DocIdSet = struct
 187       include Set.Make (struct type t = string_content
 188                                let compare = (-) end)
 189
 190     end
 191     let is_node = function { node=Node(_) } -> true | _ -> false
 192     let get_string t (i:string_content) = Text.get_text t.doc i
 193     open Tree
 194     let node_of_t t = { doc= t;
 195                         node = Node(NC (root t)) }
 196
 197
 198     let parse_xml_uri str = node_of_t
 199       (MM((parse_xml_uri str
 200              !Options.sample_factor
 201              !Options.index_empty_texts
 202              !Options.disable_text_collection),__LOCATION__))
 203
 204     let parse_xml_string str = node_of_t
 205       (MM((parse_xml_string str
 206          !Options.sample_factor
 207          !Options.index_empty_texts
 208          !Options.disable_text_collection),__LOCATION__))
 209
 210
 211     let save t str = save_tree t.doc str
 212
 213     let load ?(sample=64) str = node_of_t (load_tree str sample)
 214
 215
 216     external pool : doc -> Tag.pool = "%identity"
 217     let tag_pool t = pool t.doc
 218
 219     let compare a b = match a.node,b.node  with
 220       | Node(NC i),Node(NC j) -> compare i j
 221       | _, Node(NC( _ )) -> 1
 222       | Node(SC (i,_)),Node(SC (j,_)) -> compare i j
 223       | Node(NC( _ )),Node(SC (_,_)) -> -1
 224       | _, Node(SC (_,_)) -> 1
 225       | String i, String j -> compare i j
 226       | Node _ , String _ -> -1
 227       | _ , String _ -> 1
 228       | Nil, Nil -> 0
 229       | _,Nil -> -1
 230
 231     let equal a b = (compare a b) == 0
 232
 233     let string t = match t.node with
 234       | String i ->  Text.get_text t.doc i
 235       | _ -> assert false
 236
 237     let norm (n : [`Tree ] node ) =  if is_nil n then Nil else Node (NC n)
 238
 239     let descr t = t.node
 240
 241     let nts = function
 242         Nil -> "Nil"
 243       | String i -> Printf.sprintf "String %i" i
 244       | Node (NC t) -> Printf.sprintf "Node (NC %i)"  (int_of_node t)
 245       | Node (SC (t,i)) -> Printf.sprintf "Node (SC (%i,%i))"  (int_of_node t) (int_of_node i)
 246
 247
 248     let parent n =
 249       let node' =
 250         match n.node with
 251           | Node(NC t) | Node(SC (_,t)) ->
 252               if (Tree.root n.doc) == t
 253               then Nil
 254               else Node(NC(Tree.parent n.doc t)) (* A parent node can never be a SC *)
 255           | _ -> assert false
 256       in
 257         { n with node = node' }
 258
 259     let first_child n =
 260       let node' =
 261         match n.node with
 262           | Node (NC t) when is_leaf n.doc t ->
 263               let txt = my_text n.doc t in
 264                 if Text.is_empty n.doc txt
 265                 then Nil
 266                 else Node(SC (txt,Tree.nil))
 267           | Node (NC t) ->
 268               let fs = first_child n.doc t in
 269               let txt = prev_text n.doc fs in
 270                 if Text.is_empty n.doc txt
 271                 then norm fs
 272                 else Node (SC (txt, fs))
 273           | Node(SC (i,_)) -> String i
 274           | Nil | String _ -> failwith "first_child"
 275       in
 276         { n with node = node'}
 277
 278
 279     let next_sibling n =
 280       let node' =
 281         match n.node with
 282           | Node (SC (_,ns)) -> norm ns
 283           | Node(NC t) ->
 284               let ns = next_sibling n.doc t in
 285               let txt = next_text n.doc t in
 286                 if Text.is_empty n.doc txt
 287                 then norm ns
 288                 else Node (SC (txt, ns))
 289           | Nil | String _  -> failwith "next_sibling"
 290       in
 291         { n with node = node'}
 292
 293
 294     let left = first_child
 295     let right = next_sibling
 296
 297     let id =
 298       function  { doc=d; node=Node(NC n)}  -> node_xml_id d n
 299         | { doc=d;  node=Node(SC (i,_) )} -> text_xml_id d i
 300         | _ -> failwith "id"
 301
 302     let tag =
 303       function { node=Node(SC _) } -> Tag.pcdata
 304         | { doc=d; node=Node(NC n)} -> tag_id d n
 305         | _ -> failwith "tag"
 306
 307 (*    let tag_id =
 308       function  { node=Node(SC _) } -> ()
 309         | { doc=d; node=Node(NC n)} -> tag_id d n
 310         | _ -> ()
 311 *)
 312     let string_below t id =
 313       let strid = parent_doc t.doc id in
 314         match t.node with
 315           | Node(NC(i)) ->
 316               (Tree.equal i strid) || (is_ancestor t.doc i strid)
 317           | Node(SC(i,_)) -> Text.equal i id
 318           | _ -> false
 319
 320
 321     let contains t s =
 322       Array.fold_left (fun a i -> DocIdSet.add i a) DocIdSet.empty (Text.contains t.doc s)
 323
 324     let contains_old t s =
 325       let regexp = Str.regexp_string s in
 326       let matching arg =
 327         try
 328           let _ = Str.search_forward regexp arg 0;
 329           in true
 330         with _ -> false
 331       in
 332       let rec find t = match t.node with
 333         | Nil -> false
 334         | String _ -> matching (string t)
 335         | Node(_) -> (find (left t )) || (find (right t))
 336       in
 337         find t
 338
 339     let print_xml_fast outc t =
 340       let rec loop ?(print_right=true) t = match t.node with
 341         | Nil -> ()
 342         | String (s) -> output_string outc (string t)
 343         | Node _ when Tag.equal (tag t) Tag.pcdata ->
 344             loop (left t);
 345             if print_right then loop (right t)
 346
 347         | Node (_) ->
 348             let tg = Tag.to_string (tag t) in
 349             let l = left t
 350             and r = right t
 351             in
 352               output_char outc  '<';
 353               output_string outc  tg;
 354               ( match l.node with
 355                     Nil -> output_string outc  "/>"
 356                   | String _ -> assert false
 357                   | Node(_) when Tag.equal (tag l) Tag.attribute ->
 358                       (loop_attributes (left l);
 359                        match (right l).node with
 360                          | Nil -> output_string outc  "/>"
 361                          | _ ->
 362                              output_char outc  '>';
 363                              loop (right l);
 364                              output_string outc  "</";
 365                              output_string outc  tg;
 366                              output_char outc '>' )
 367                   | _ ->
 368                       output_char outc  '>';
 369                       loop l;
 370                       output_string outc "</";
 371                       output_string outc tg;
 372                       output_char outc '>'
 373               );if print_right then loop r
 374       and loop_attributes a =
 375
 376         match a.node with
 377           | Node(_) ->
 378               let value =
 379                 match (left a).node with
 380                   | Nil -> ""
 381                   | _ -> string (left(left a))
 382               in
 383                 output_char outc ' ';
 384                 output_string outc (Tag.to_string (tag a));
 385                 output_string outc "=\"";
 386                 output_string outc value;
 387                 output_char outc '"';
 388                 loop_attributes (right a)
 389         | _ -> ()
 390       in
 391         loop ~print_right:false t
 392
 393
 394     let print_xml_fast outc t =
 395       if Tag.to_string (tag t) = "" then
 396         print_xml_fast outc (first_child t)
 397       else print_xml_fast outc t
 398
 399     let traversal t = Tree.traversal t.doc
 400     let full_traversal t =
 401       let rec aux n =
 402         match n.node with
 403         | Nil -> ()
 404         | String i -> () (*ignore(Text.get_text t.doc i)  *)
 405         | Node(_) ->
 406             (* tag_id n; *)
 407             aux (first_child n);
 408             aux (next_sibling n)
 409       in aux t
 410
 411     let print_stats _ = ()
 412   end
 413
 414 end
 415
 416
 417
 418 IFDEF DEBUG
 419 THEN
 420 module DEBUGTREE
 421   = struct
 422
 423     let _timings = Hashtbl.create 107
 424
 425
 426     let time _ref f arg =
 427       let t1 = Unix.gettimeofday () in
 428       let r = f arg in
 429       let t2 = Unix.gettimeofday () in
 430       let t = (1000. *.(t2 -. t1)) in
 431
 432       let (time,count) = try
 433         Hashtbl.find _timings _ref
 434       with
 435         | Not_found -> 0.,0
 436       in
 437       let time = time+. t
 438       and count = count + 1
 439       in
 440         Hashtbl.replace _timings _ref (time,count);r
 441
 442     include XML.Binary
 443
 444
 445     let first_child_ doc node =
 446      time ("XMLTree.FirstChild()") (XML.Tree.first_child doc)  node
 447     let next_sibling_ doc node =
 448       time ("XMLTree.NextSibling()") (XML.Tree.next_sibling doc) node
 449
 450     let is_empty_ text node =
 451       time ("TextCollection.IsEmpty()") (XML.Text.is_empty text) node
 452
 453     let prev_text_ doc node =
 454       time ("XMLTree.PrevText()") (XML.Tree.prev_text doc) node
 455
 456     let my_text_ doc node =
 457       time ("XMLTree.MyText()") (XML.Tree.my_text doc) node
 458
 459     let next_text_ doc node =
 460       time ("XMLTree.NextText()") (XML.Tree.next_text doc) node
 461
 462     let is_leaf_ doc node =
 463       time ("XMLTree.IsLeaf()") (XML.Tree.is_leaf doc ) node
 464
 465     let node_xml_id_ doc node =
 466       time ("XMLTree.NodeXMLId()") (XML.Tree.node_xml_id doc ) node
 467
 468     let text_xml_id_ doc node =
 469       time ("XMLTree.TextXMLId()") (XML.Tree.text_xml_id doc ) node
 470
 471
 472     let first_child n =
 473       let node' =
 474         match n.node with
 475           | Node (NC t) when is_leaf_ n.doc t ->
 476               let txt = my_text_ n.doc t in
 477                 if is_empty_ n.doc txt
 478                 then Nil
 479                 else Node(SC (txt,XML.Tree.nil))
 480           | Node (NC t) ->
 481               let fs = first_child_ n.doc t in
 482               let txt = prev_text_ n.doc fs in
 483                 if is_empty_ n.doc txt
 484                 then norm fs
 485                 else Node (SC (txt, fs))
 486           | Node(SC (i,_)) -> String i
 487           | Nil | String _ -> failwith "first_child"
 488       in
 489         { n with node = node'}
 490
 491
 492     let next_sibling n =
 493       let node' =
 494         match n.node with
 495           | Node (SC (_,ns)) -> norm ns
 496           | Node(NC t) ->
 497               let ns = next_sibling_ n.doc t in
 498               let txt =
 499                 if XML.Tree.is_nil ns then
 500                   next_text_ n.doc t
 501                 else prev_text_ n.doc ns
 502               in
 503                 if is_empty_ n.doc txt
 504                 then norm ns
 505                 else Node (SC (txt, ns))
 506           | Nil | String _  -> failwith "next_sibling"
 507       in
 508         { n with node = node'}
 509
 510     let id =
 511       function  { doc=d; node=Node(NC n)}  -> node_xml_id_ d n
 512         | { doc=d;  node=Node(SC (i,_) )} -> text_xml_id_ d i
 513         | _ -> failwith "id"
 514
 515     (* Wrapper around critical function *)
 516     let string t = time ("TextCollection.GetText()") (string) t
 517     let left = first_child
 518     let right = next_sibling
 519     let tag t =  time ("XMLTree.GetTag()") (tag) t
 520
 521     let print_stats ppf =
 522       let total_time,total_calls =
 523         Hashtbl.fold  (fun _ (t,c) (tacc,cacc) ->
 524                          tacc+. t, cacc + c)  _timings (0.,0)
 525
 526       in
 527         Format.fprintf ppf
 528           "Timing : Function Name, number of calls,%% of total calls, mean time, total time, %% of total time\n%!";
 529         Hashtbl.iter (fun name (time,count) ->
 530                         Format.fprintf ppf  "%-27s% 8d\t% 4.2f%%\t% 4.6f ms\t% 4.6f ms\t%04.2f%%\n%!"
 531                           name
 532                           count
 533                           (100. *. (float_of_int count)/.(float_of_int total_calls))
 534                           (time /. (float_of_int count))
 535                           time
 536                           (100. *. time /.  total_time)) _timings;
 537         Format.fprintf ppf  "-------------------------------------------------------------------\n";
 538         Format.fprintf ppf "%-27s% 8d\t% 4.0f%%\t########## ms\t% 4.6f ms\t% 4.0f%%\n%!"
 539           "Total" total_calls 100. total_time 100.
 540
 541
 542     let print_xml_fast outc t =
 543       let rec loop ?(print_right=true) t = match t.node with
 544         | Nil -> ()
 545         | String (s) -> output_string outc (string t)
 546         | Node _ when Tag.equal (tag t) Tag.pcdata -> loop (left t); loop (right t)
 547
 548         | Node (_) ->
 549             let tg = Tag.to_string (tag t) in
 550             let l = left t
 551             and r = right t
 552             in
 553               output_char outc  '<';
 554               output_string outc  tg;
 555               ( match l.node with
 556                     Nil -> output_string outc  "/>"
 557                   | String _ -> assert false
 558                   | Node(_) when Tag.equal (tag l) Tag.attribute ->
 559                       (loop_attributes (left l);
 560                        match (right l).node with
 561                          | Nil -> output_string outc  "/>"
 562                          | _ ->
 563                              output_char outc  '>';
 564                              loop (right l);
 565                              output_string outc  "</";
 566                              output_string outc  tg;
 567                              output_char outc '>' )
 568                   | _ ->
 569                       output_char outc  '>';
 570                       loop l;
 571                       output_string outc "</";
 572                       output_string outc tg;
 573                       output_char outc '>'
 574               );if print_right then loop r
 575       and loop_attributes a =
 576
 577         match a.node with
 578           | Node(_) ->
 579               let value =
 580                 match (left a).node with
 581                   | Nil -> ""
 582                   | _ -> string (left(left a))
 583               in
 584                 output_char outc ' ';
 585                 output_string outc (Tag.to_string (tag a));
 586                 output_string outc "=\"";
 587                 output_string outc value;
 588                 output_char outc '"';
 589                 loop_attributes (right a)
 590         | _ -> ()
 591       in
 592         loop ~print_right:false t
 593
 594
 595     let print_xml_fast outc t =
 596       if Tag.to_string (tag t) = "" then
 597         print_xml_fast outc (first_child t)
 598       else print_xml_fast outc t
 599
 600
 601
 602
 603 end
 604
 605 module Binary = DEBUGTREE
 606 ELSE
 607 module Binary = XML.Binary
 608 END (* IFDEF DEBUG *)