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