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