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