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