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 root : t -> t
  28   val is_root : t -> bool
  29   val id : t -> int
  30   val tag : t -> Tag.t
  31   val print_xml_fast : out_channel -> t -> unit
  32   val compare : t -> t -> int
  33   val equal : t -> t -> bool
  34   module DocIdSet :
  35   sig
  36     include Set.S
  37   end
  38     with type elt = string_content
  39   val string_below : t -> string_content -> bool
  40   val contains : t -> string -> DocIdSet.t
  41   val contains_old : t -> string -> DocIdSet.t
  42   val contains_iter : t -> string -> DocIdSet.t
  43   val count_contains : t -> string -> int
  44   val count : t -> string -> int
  45   val dump : t -> unit
  46   val get_string : t -> string_content -> string
  47   val has_tagged_desc : t -> Tag.t -> bool
  48   val has_tagged_foll : t -> Tag.t -> bool
  49   val tagged_desc : t -> Tag.t -> t
  50   val tagged_foll : t -> Tag.t -> t
  51   val init_tagged_next : t -> Tag.t -> unit
  52   val tagged_next : t -> Tag.t -> t
  53   val subtree_tags : t -> Tag.t -> int
  54   val is_left : t -> bool
  55   val print_id : Format.formatter -> t -> unit
  56   val test_xml_tree : Format.formatter -> Ptset.t -> t -> unit
  57 end
  58
  59 module XML =
  60 struct
  61
  62   type t
  63   type 'a node = int
  64   type node_kind = [`Text | `Tree ]
  65
  66   let compare : 'a node -> 'a node -> int = (-)
  67   let equal : 'a node -> 'a node -> bool = (==)
  68
  69         (* abstract type, values are pointers to a XMLTree C++ object *)
  70
  71   external int_of_node : 'a node -> int = "%identity"
  72
  73   external parse_xml_uri : string -> int -> bool -> bool -> t = "caml_call_shredder_uri"
  74   external parse_xml_string :  string -> int -> bool -> bool -> t = "caml_call_shredder_string"
  75
  76   external save_tree : t -> string -> unit = "caml_xml_tree_save"
  77   external load_tree : string -> int -> t = "caml_xml_tree_load"
  78
  79
  80   module Text =
  81   struct
  82     let equal : [`Text] node -> [`Text] node -> bool = equal
  83
  84     (* Todo *)
  85     external nullt : unit -> [`Text ] node = "caml_xml_tree_nullt"
  86     let nil = nullt ()
  87     external get_text : t -> [`Text] node -> string = "caml_text_collection_get_text"
  88
  89 (*    let get_text t n =
  90       if equal nil n then ""
  91       else  get_text t n
  92 *)
  93
  94     external is_empty : t -> [`Text ] node -> bool = "caml_text_collection_empty_text"
  95
  96     let is_empty t n =
  97       (equal nil n) || is_empty t n
  98
  99     external get_cached_text : t -> [`Text ] node -> string = "caml_text_collection_get_cached_text"
 100
 101
 102     let get_text t n =
 103       if equal nil n then ""
 104       else get_cached_text t n
 105
 106     external size : t -> int = "caml_text_collection_size"
 107     external is_contains : t -> string -> bool = "caml_text_collection_is_contains"
 108     external count_contains : t -> string -> int = "caml_text_collection_count_contains"
 109     external count : t -> string -> int = "caml_text_collection_count"
 110     external contains : t -> string -> [`Text ] node array = "caml_text_collection_contains"
 111   end
 112
 113
 114   module Tree =
 115   struct
 116
 117     let equal : [`Tree ] node -> [`Tree] node -> bool = equal
 118     external serialize : t -> string -> unit = "caml_xml_tree_serialize"
 119     external unserialize : string -> t = "caml_xml_tree_unserialize"
 120
 121     external root : t -> [`Tree] node = "caml_xml_tree_root"
 122     external nullt : unit -> [`Tree ] node = "caml_xml_tree_nullt"
 123
 124     let nil = nullt ()
 125     let is_nil x = equal x nil
 126
 127     external parent : t -> [`Tree] node -> [`Tree] node = "caml_xml_tree_parent"
 128     external parent_doc : t -> [`Text ] node -> [`Tree ] node = "caml_xml_tree_parent_doc"
 129     external first_child : t -> [`Tree] node -> [`Tree] node = "caml_xml_tree_first_child"
 130
 131
 132
 133     external next_sibling : t -> [`Tree] node -> [`Tree] node = "caml_xml_tree_next_sibling"
 134     external prev_sibling : t -> [`Tree] node -> [`Tree] node = "caml_xml_tree_prev_sibling"
 135     external is_leaf : t  -> [`Tree] node -> bool = "caml_xml_tree_is_leaf"
 136
 137 (*    external tag : t -> [`Tree ] node -> T = "caml_xml_tree_tag"*)
 138     external tag_id : t -> [`Tree ] node -> Tag.t = "caml_xml_tree_tag_id"
 139
 140 (*
 141     let tag_hash = Array.make 6_000_000 (Tag.nullt)
 142
 143     let tag_id t id =
 144         let tag =  tag_hash.(int_of_node id)
 145         in
 146           if tag != Tag.nullt then tag
 147           else
 148             let tag = tag_id t id in
 149             (tag_hash.(int_of_node id) <- tag; tag)
 150 *)
 151     let is_last t n = equal nil (next_sibling t n)
 152
 153     external prev_text : t -> [`Tree] node -> [`Text ] node = "caml_xml_tree_prev_text"
 154
 155
 156     external my_text : t -> [`Tree] node -> [`Text ] node = "caml_xml_tree_my_text"
 157     external next_text : t -> [`Tree] node -> [`Text ] node = "caml_xml_tree_next_text"
 158
 159     external text_xml_id : t -> [`Text ] node -> int = "caml_xml_tree_text_xml_id"
 160     external node_xml_id : t -> [`Tree ] node -> int = "caml_xml_tree_node_xml_id"
 161     external is_ancestor : t -> [`Tree ] node -> [`Tree ] node -> bool = "caml_xml_tree_is_ancestor"
 162     external tagged_desc : t -> [`Tree ] node -> Tag.t -> [`Tree ] node = "caml_xml_tree_tagged_desc"
 163     external tagged_foll : t -> [`Tree ] node -> Tag.t -> [`Tree ] node = "caml_xml_tree_tagged_foll"
 164     external tagged_next : t -> [`Tree ] node -> Tag.t -> [`Tree ] node = "caml_xml_tree_tagged_next"
 165     external subtree_tags : t -> [`Tree ] node -> Tag.t -> int = "caml_xml_tree_subtree_tags"
 166
 167
 168
 169     let test_xml_tree ppf tags v =
 170       let pr x = Format.fprintf ppf x in
 171       let rec aux id =
 172         if (is_nil id)
 173         then ()
 174         else
 175           begin
 176             pr "Node %i, (Tag) %i='%s' (GetTagName), NodeXMLId (Preorder)=%i\n%!"
 177               (int_of_node id)
 178               (tag_id v id)
 179               (Tag.to_string (tag_id v id))
 180               (node_xml_id v id);
 181             pr "DocID of PrevText,MyText,NextText : (%i = %s,%i = %s,%i = %s) ParentDoc(my_text)=%i\n%!"
 182               (int_of_node (prev_text v id))
 183               (Text.get_text v (prev_text v id))
 184               (int_of_node (my_text v id))
 185               (Text.get_text v (my_text v id))
 186               (int_of_node (next_text v id))
 187               (Text.get_text v (next_text v id))
 188               (int_of_node(parent_doc v (my_text v id)));
 189             pr "Testing Tagged*\n%!";
 190             Ptset.iter (fun t ->
 191                           let str = Tag.to_string t in
 192                             if Tag.pcdata <> t
 193                             then begin
 194                               pr "Tag: %s : \n%!" str;
 195                               pr "TaggedDesc = %i%!, " (tagged_desc v id t);
 196                               pr "TaggedFoll = %i\n%!" (tagged_foll v id t);
 197                               pr "SubtreeTags = %i\n%!" (subtree_tags v id t);
 198                             end) tags;
 199               pr "----------------------------\n";
 200             aux(first_child v id);
 201             aux(next_sibling v id);
 202           end
 203       in
 204         aux (root v)
 205
 206
 207
 208
 209
 210
 211     let print_skel t =
 212       let rec aux id =
 213         if (is_nil id)
 214         then Printf.eprintf "#\n"
 215         else
 216           begin
 217             Printf.eprintf "Node %i has tag '%i=%s' DocOrder=%i, DocID of PrevText,MyText,NextText : (%i = %s,%i = %s,%i = %s) parent_doc(my_text)=%i\n%!"
 218               (int_of_node id)
 219               (tag_id t id)
 220               (Tag.to_string (tag_id t id))
 221               (node_xml_id t id)
 222               (int_of_node (prev_text t id))
 223               (Text.get_text t (prev_text t id))
 224               (int_of_node (my_text t id))
 225               (Text.get_text t (my_text t id))
 226               (int_of_node (next_text t id))
 227               (Text.get_text t (next_text t id))
 228               (int_of_node(parent_doc t (my_text t id)));
 229
 230             aux(first_child t id);
 231             aux(next_sibling t id);
 232           end
 233       in
 234         aux (root t)
 235
 236     let traversal t =
 237         let rec aux id =
 238           if not (is_nil id)
 239           then
 240             begin
 241               (* ignore (tag t id);
 242               ignore (Text.get_text t (prev_text t id));
 243               if (is_leaf t id)
 244                 then ignore (Text.get_text t (my_text t id));
 245               if (is_last t id)
 246                 then ignore (Text.get_text t (next_text t id)); *)
 247               aux (first_child t id);
 248               aux (next_sibling t id);
 249             end
 250         in
 251           aux (root t)
 252
 253
 254
 255   end
 256
 257
 258   module Binary  = struct
 259
 260     type node_content =
 261         NC of [`Tree ] node
 262       | SC of [`Text ] node * [`Tree ] node
 263     type string_content = [ `Text ] node
 264     type descr =
 265       | Nil
 266       | Node of node_content
 267       | String of string_content
 268
 269     type doc = t
 270
 271     type t = { doc : doc;
 272                node : descr }
 273
 274     let dump { doc=t } = Tree.print_skel t
 275     let test_xml_tree ppf tags { doc=t } = Tree.test_xml_tree ppf tags t
 276
 277     module DocIdSet = struct
 278       include Set.Make (struct type t = string_content
 279                                let compare = (-) end)
 280
 281     end
 282     let is_node = function { node=Node(_) } -> true | _ -> false
 283
 284     let get_string t (i:string_content) = Text.get_text t.doc i
 285     open Tree
 286     let node_of_t t = { doc= t;
 287                         node = Node(NC (root t)) }
 288
 289
 290     let parse_xml_uri str = node_of_t
 291       (MM((parse_xml_uri str
 292              !Options.sample_factor
 293              !Options.index_empty_texts
 294              !Options.disable_text_collection),__LOCATION__))
 295
 296     let parse_xml_string str = node_of_t
 297       (MM((parse_xml_string str
 298          !Options.sample_factor
 299          !Options.index_empty_texts
 300          !Options.disable_text_collection),__LOCATION__))
 301
 302
 303     let save t str = save_tree t.doc str
 304
 305     let load ?(sample=64) str = node_of_t (load_tree str sample)
 306
 307
 308     external pool : doc -> Tag.pool = "%identity"
 309     let tag_pool t = pool t.doc
 310
 311     let compare a b = match a.node,b.node  with
 312       | Node(NC i),Node(NC j) -> compare i j
 313       | _, Node(NC( _ )) -> 1
 314       | Node(SC (i,_)),Node(SC (j,_)) -> compare i j
 315       | Node(NC( _ )),Node(SC (_,_)) -> -1
 316       | _, Node(SC (_,_)) -> 1
 317       | String i, String j -> compare i j
 318       | Node _ , String _ -> -1
 319       | _ , String _ -> 1
 320       | Nil, Nil -> 0
 321       | _,Nil -> -1
 322
 323     let equal a b = (compare a b) == 0
 324
 325     let string t = match t.node with
 326       | String i ->  Text.get_text t.doc i
 327       | _ -> assert false
 328
 329     let norm (n : [`Tree ] node ) =  if is_nil n then Nil else Node (NC n)
 330
 331     let descr t = t.node
 332
 333     let nts = function
 334         Nil -> "Nil"
 335       | String i -> Printf.sprintf "String %i" i
 336       | Node (NC t) -> Printf.sprintf "Node (NC %i)"  (int_of_node t)
 337       | Node (SC (t,i)) -> Printf.sprintf "Node (SC (%i,%i))"  (int_of_node t) (int_of_node i)
 338
 339
 340     let root n = { n with node = norm (Tree.root n.doc) }
 341     let is_root n = match n.node with
 342       | Node(NC t) -> (int_of_node t) == 0
 343       | _ -> false
 344
 345     let parent n =
 346       if is_root n then { n with node=Nil}
 347       else
 348       let node' =
 349         match n.node with
 350           |  Node(NC t) ->
 351                let txt = prev_text n.doc t in
 352                  if Text.is_empty n.doc txt then
 353                    let ps = Tree.prev_sibling n.doc t in
 354                      if is_nil ps
 355                      then
 356                        Node(NC (Tree.parent n.doc t))
 357                      else Node(NC ps)
 358                  else
 359                    Node(SC (txt,t))
 360           | Node(SC(i,t)) ->
 361               let ps = Tree.prev_sibling n.doc t in
 362                 if is_nil ps
 363                 then Node (NC(parent_doc n.doc i))
 364                 else Node(NC ps)
 365           | _ -> failwith "parent"
 366       in
 367         { n with node = node' }
 368
 369     let first_child n =
 370       let node' =
 371         match n.node with
 372           | Node (NC t) when is_leaf n.doc t ->
 373               let txt = my_text n.doc t in
 374                 if Text.is_empty n.doc txt
 375                 then Nil
 376                 else Node(SC (txt,Tree.nil))
 377           | Node (NC t) ->
 378               let fs = first_child n.doc t in
 379               let txt = prev_text n.doc fs in
 380                 if Text.is_empty n.doc txt
 381                 then norm fs
 382                 else Node (SC (txt, fs))
 383           | Node(SC (i,_)) -> String i
 384           | Nil | String _ -> failwith "first_child"
 385       in
 386         { n with node = node'}
 387
 388     let next_sibling n =
 389       let node' =
 390         match n.node with
 391           | Node (SC (_,ns)) -> norm ns
 392           | Node(NC t) ->
 393               let ns = next_sibling n.doc t in
 394               let txt = next_text n.doc t in
 395                 if Text.is_empty n.doc txt
 396                 then norm ns
 397                 else Node (SC (txt, ns))
 398           | Nil | String _  -> failwith "next_sibling"
 399       in
 400         { n with node = node'}
 401
 402
 403     let left = first_child
 404     let right = next_sibling
 405
 406     let id =
 407       function  { doc=d; node=Node(NC n)}  -> node_xml_id d n
 408         | { doc=d;  node=Node(SC (i,_) )} -> text_xml_id d i
 409         | _ ->  -1 (*
 410             Format.fprintf Format.err_formatter "Failure id on %s\n%!" (nts x.node);
 411             failwith "id" *)
 412
 413     let tag =
 414       function { node=Node(SC _) } -> Tag.pcdata
 415         | { doc=d; node=Node(NC n)} -> tag_id d n
 416         | _ -> failwith "tag"
 417
 418     let string_below t id =
 419       let strid = parent_doc t.doc id in
 420         match t.node with
 421           | Node(NC(i)) ->
 422               (Tree.equal i strid) || (is_ancestor t.doc i strid)
 423           | Node(SC(i,_)) -> Text.equal i id
 424           | _ -> false
 425
 426
 427     let tagged_foll t tag =
 428       if tag = Tag.attribute || tag = Tag.pcdata then failwith "tagged_foll"
 429       else match t with
 430         | { doc=d; node=Node(NC n) } -> { t with node = norm (tagged_foll d n tag) }
 431         | { doc=d; node=Node(SC (_,n)) } when is_nil n -> { t with node= Nil }
 432         | { doc=d; node=Node(SC (_,n)) } ->
 433             let nnode =
 434               if tag_id d n == tag then n
 435               else
 436                 let n' = tagged_desc d n tag in
 437                   if is_nil n' then tagged_foll d n tag
 438                   else n'
 439             in {t with node= norm nnode}
 440         | _ -> { t with node=Nil }
 441
 442
 443     let tagged_desc t tag =
 444       if tag = Tag.attribute || tag = Tag.pcdata then failwith "tagged_desc"
 445       else match t with
 446         | { doc=d; node=Node(NC n) } -> { t with node = norm (tagged_desc d n tag) }
 447         | _ -> { t with node=Nil }
 448
 449 (*
 450     let tagged_next t tag =
 451       if tag == Tag.attribute || tag == Tag.pcdata then failwith "tagged_next"
 452       else
 453         match tagged_desc t tag with
 454           | { doc = d; node=Nil } -> tagged_foll t tag
 455           | x -> x
 456 *)
 457     let subtree_tags t tag =
 458       match t with
 459           { doc = d; node = Node(NC n) } ->
 460             subtree_tags d n tag
 461         | _ -> 0
 462
 463     let tagged_desc_array = ref [| |]
 464     let idx = ref 0
 465
 466     let init_tagged_next t tagid =
 467       let l = subtree_tags (root t) tagid
 468       in
 469         tagged_desc_array := Array.create l { t with node= Nil };
 470         let i = ref 0 in
 471           let rec collect t =
 472             if is_node t then begin
 473               if tag t == tagid then
 474                 begin
 475                   !tagged_desc_array.(!i) <- t;
 476                   incr i;
 477                 end;
 478               collect (first_child t);
 479               collect (next_sibling t)
 480             end;
 481           in
 482             collect t;
 483             idx := 0
 484
 485     let print_id ppf v =
 486       let pr x= Format.fprintf ppf x in
 487         match v with
 488             { node=Nil } -> pr "NULLT: -1"
 489           | { node=String(i) } | { node=Node(SC(i,_)) } -> pr "DocID: %i" (int_of_node i)
 490           | { node=Node(NC(i)) } -> pr "Node: %i" (int_of_node i)
 491
 492
 493
 494     let tagged_next t tag =
 495       if !idx >= Array.length !tagged_desc_array
 496       then {t with node=Nil}
 497       else
 498         let r = !tagged_desc_array.(!idx)
 499         in
 500           incr idx; r
 501
 502
 503
 504     let has_tagged_foll t tag = is_node (tagged_foll t tag)
 505     let has_tagged_desc t tag = is_node (tagged_desc t tag)
 506
 507     let contains t s =
 508       Array.fold_left (fun a i -> DocIdSet.add i a) DocIdSet.empty (Text.contains t.doc s)
 509
 510
 511     let contains_old t s =
 512       let regexp = Str.regexp_string s in
 513       let matching arg =
 514         try
 515           let _ = Str.search_forward regexp arg 0;
 516           in true
 517         with _ -> false
 518       in
 519       let rec find t acc = match t.node with
 520         | Nil -> acc
 521         | String i ->
 522             if  matching (string t) then DocIdSet.add i acc else acc
 523         | Node(_) ->  (find (left t )) ((find (right t))  acc)
 524       in
 525         find t DocIdSet.empty
 526
 527
 528     let contains_iter t s =
 529       let regexp = Str.regexp_string s in
 530       let matching arg =
 531         try
 532           let _ = Str.search_forward regexp arg 0;
 533           in true
 534         with _ -> false
 535       in
 536       let size = Text.size t.doc in
 537       let rec find acc n =
 538         if n == size then acc
 539         else
 540           find
 541             (if matching (Text.get_cached_text t.doc (Obj.magic n)) then
 542              DocIdSet.add (Obj.magic n) acc
 543            else acc) (n+1)
 544       in
 545         find DocIdSet.empty 0
 546
 547
 548
 549
 550     let count_contains t s =   Text.count_contains t.doc s
 551     let count t s =   Text.count t.doc s
 552
 553     let is_left t =
 554       if is_root t then false
 555       else
 556       if tag (parent t) == Tag.pcdata then false
 557       else
 558         let u = left (parent t) in
 559           (id t) == (id u)
 560
 561     let print_xml_fast outc t =
 562       let rec loop ?(print_right=true) t = match t.node with
 563         | Nil -> ()
 564         | String (s) -> output_string outc (Text.get_text t.doc s)
 565         | Node _ when Tag.equal (tag t) Tag.pcdata ->
 566             loop (left t);
 567             if print_right then loop (right t)
 568
 569         | Node (_) ->
 570             let tg = Tag.to_string (tag t) in
 571             let l = left t
 572             and r = right t
 573             in
 574               output_char outc  '<';
 575               output_string outc  tg;
 576               ( match l.node with
 577                     Nil -> output_string outc  "/>"
 578                   | String _ -> assert false
 579                   | Node(_) when Tag.equal (tag l) Tag.attribute ->
 580                       (loop_attributes (left l);
 581                        match (right l).node with
 582                          | Nil -> output_string outc  "/>"
 583                          | _ ->
 584                              output_char outc  '>';
 585                              loop (right l);
 586                              output_string outc  "</";
 587                              output_string outc  tg;
 588                              output_char outc '>' )
 589                   | _ ->
 590                       output_char outc  '>';
 591                       loop l;
 592                       output_string outc "</";
 593                       output_string outc tg;
 594                       output_char outc '>'
 595               );if print_right then loop r
 596       and loop_attributes a =
 597
 598         match a.node with
 599           | Node(_) ->
 600               let value =
 601                 match (left a).node with
 602                   | Nil -> ""
 603                   | _ -> string (left(left a))
 604               in
 605                 output_char outc ' ';
 606                 output_string outc (Tag.to_string (tag a));
 607                 output_string outc "=\"";
 608                 output_string outc value;
 609                 output_char outc '"';
 610                 loop_attributes (right a)
 611         | _ -> ()
 612       in
 613         loop ~print_right:false t
 614
 615
 616     let print_xml_fast outc t =
 617       if Tag.to_string (tag t) = "" then
 618         print_xml_fast outc (first_child t)
 619       else print_xml_fast outc t
 620
 621
 622
 623
 624
 625     let traversal t = Tree.traversal t.doc
 626     let full_traversal t =
 627       let rec aux n =
 628         match n.node with
 629         | Nil -> ()
 630         | String i -> () (*ignore(Text.get_text t.doc i)  *)
 631         | Node(_) ->
 632             (* tag_id n; *)
 633             aux (first_child n);
 634             aux (next_sibling n)
 635       in aux t
 636
 637     let print_stats _ = ()
 638   end
 639
 640 end
 641
 642
 643
 644 IFDEF DEBUG
 645 THEN
 646 module DEBUGTREE
 647   = struct
 648
 649     let _timings = Hashtbl.create 107
 650
 651
 652     let time _ref f arg =
 653       let t1 = Unix.gettimeofday () in
 654       let r = f arg in
 655       let t2 = Unix.gettimeofday () in
 656       let t = (1000. *.(t2 -. t1)) in
 657
 658       let (time,count) = try
 659         Hashtbl.find _timings _ref
 660       with
 661         | Not_found -> 0.,0
 662       in
 663       let time = time+. t
 664       and count = count + 1
 665       in
 666         Hashtbl.replace _timings _ref (time,count);r
 667
 668     include XML.Binary
 669
 670
 671     let first_child_ doc node =
 672      time ("XMLTree.FirstChild()") (XML.Tree.first_child doc)  node
 673     let next_sibling_ doc node =
 674       time ("XMLTree.NextSibling()") (XML.Tree.next_sibling doc) node
 675
 676     let is_empty_ text node =
 677       time ("TextCollection.IsEmpty()") (XML.Text.is_empty text) node
 678
 679     let prev_text_ doc node =
 680       time ("XMLTree.PrevText()") (XML.Tree.prev_text doc) node
 681
 682     let my_text_ doc node =
 683       time ("XMLTree.MyText()") (XML.Tree.my_text doc) node
 684
 685     let next_text_ doc node =
 686       time ("XMLTree.NextText()") (XML.Tree.next_text doc) node
 687
 688     let is_leaf_ doc node =
 689       time ("XMLTree.IsLeaf()") (XML.Tree.is_leaf doc ) node
 690
 691     let node_xml_id_ doc node =
 692       time ("XMLTree.NodeXMLId()") (XML.Tree.node_xml_id doc ) node
 693
 694     let text_xml_id_ doc node =
 695       time ("XMLTree.TextXMLId()") (XML.Tree.text_xml_id doc ) node
 696
 697
 698     let first_child n =
 699       let node' =
 700         match n.node with
 701           | Node (NC t) when is_leaf_ n.doc t ->
 702               let txt = my_text_ n.doc t in
 703                 if is_empty_ n.doc txt
 704                 then Nil
 705                 else Node(SC (txt,XML.Tree.nil))
 706           | Node (NC t) ->
 707               let fs = first_child_ n.doc t in
 708               let txt = prev_text_ n.doc fs in
 709                 if is_empty_ n.doc txt
 710                 then norm fs
 711                 else Node (SC (txt, fs))
 712           | Node(SC (i,_)) -> String i
 713           | Nil | String _ -> failwith "first_child"
 714       in
 715         { n with node = node'}
 716
 717
 718     let next_sibling n =
 719       let node' =
 720         match n.node with
 721           | Node (SC (_,ns)) -> norm ns
 722           | Node(NC t) ->
 723               let ns = next_sibling_ n.doc t in
 724               let txt =
 725                 if XML.Tree.is_nil ns then
 726                   next_text_ n.doc t
 727                 else prev_text_ n.doc ns
 728               in
 729                 if is_empty_ n.doc txt
 730                 then norm ns
 731                 else Node (SC (txt, ns))
 732           | Nil | String _  -> failwith "next_sibling"
 733       in
 734         { n with node = node'}
 735
 736     let id =
 737       function  { doc=d; node=Node(NC n)}  -> node_xml_id_ d n
 738         | { doc=d;  node=Node(SC (i,_) )} -> text_xml_id_ d i
 739         | _ -> failwith "id"
 740
 741     (* Wrapper around critical function *)
 742     let string t = time ("TextCollection.GetText()") (string) t
 743     let left = first_child
 744     let right = next_sibling
 745     let tag t =  time ("XMLTree.GetTag()") (tag) t
 746
 747     let print_stats ppf =
 748       let total_time,total_calls =
 749         Hashtbl.fold  (fun _ (t,c) (tacc,cacc) ->
 750                          tacc+. t, cacc + c)  _timings (0.,0)
 751
 752       in
 753         Format.fprintf ppf
 754           "Timing : Function Name, number of calls,%% of total calls, mean time, total time, %% of total time\n%!";
 755         Hashtbl.iter (fun name (time,count) ->
 756                         Format.fprintf ppf  "%-27s% 8d\t% 4.2f%%\t% 4.6f ms\t% 4.6f ms\t%04.2f%%\n%!"
 757                           name
 758                           count
 759                           (100. *. (float_of_int count)/.(float_of_int total_calls))
 760                           (time /. (float_of_int count))
 761                           time
 762                           (100. *. time /.  total_time)) _timings;
 763         Format.fprintf ppf  "-------------------------------------------------------------------\n";
 764         Format.fprintf ppf "%-27s% 8d\t% 4.0f%%\t########## ms\t% 4.6f ms\t% 4.0f%%\n%!"
 765           "Total" total_calls 100. total_time 100.
 766
 767
 768     let print_xml_fast outc t =
 769       let rec loop ?(print_right=true) t = match t.node with
 770         | Nil -> ()
 771         | String (s) -> output_string outc (string t)
 772         | Node _ when Tag.equal (tag t) Tag.pcdata -> loop (left t); loop (right t)
 773
 774         | Node (_) ->
 775             let tg = Tag.to_string (tag t) in
 776             let l = left t
 777             and r = right t
 778             in
 779               output_char outc  '<';
 780               output_string outc  tg;
 781               ( match l.node with
 782                     Nil -> output_string outc  "/>"
 783                   | String _ -> assert false
 784                   | Node(_) when Tag.equal (tag l) Tag.attribute ->
 785                       (loop_attributes (left l);
 786                        match (right l).node with
 787                          | Nil -> output_string outc  "/>"
 788                          | _ ->
 789                              output_char outc  '>';
 790                              loop (right l);
 791                              output_string outc  "</";
 792                              output_string outc  tg;
 793                              output_char outc '>' )
 794                   | _ ->
 795                       output_char outc  '>';
 796                       loop l;
 797                       output_string outc "</";
 798                       output_string outc tg;
 799                       output_char outc '>'
 800               );if print_right then loop r
 801       and loop_attributes a =
 802
 803         match a.node with
 804           | Node(_) ->
 805               let value =
 806                 match (left a).node with
 807                   | Nil -> ""
 808                   | _ -> string (left(left a))
 809               in
 810                 output_char outc ' ';
 811                 output_string outc (Tag.to_string (tag a));
 812                 output_string outc "=\"";
 813                 output_string outc value;
 814                 output_char outc '"';
 815                 loop_attributes (right a)
 816         | _ -> ()
 817       in
 818         loop ~print_right:false t
 819
 820
 821     let print_xml_fast outc t =
 822       if Tag.to_string (tag t) = "" then
 823         print_xml_fast outc (first_child t)
 824       else print_xml_fast outc t
 825
 826
 827
 828
 829 end
 830
 831 module Binary = DEBUGTREE
 832 ELSE
 833 module Binary = XML.Binary
 834 END (* IFDEF DEBUG *)