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