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