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