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 "utils.ml"
   8
   9 type tree
  10 type 'a node = int
  11 type node_kind = [`Text | `Tree ]
  12
  13 let compare_node : 'a node -> 'a node -> int = (-)
  14 let equal_node : 'a node -> 'a node -> bool = (==)
  15
  16 (* abstract type, values are pointers to a XMLTree C++ object *)
  17
  18 external int_of_node : 'a node -> int = "%identity"
  19
  20 external parse_xml_uri : string -> int -> bool -> bool -> tree = "caml_call_shredder_uri"
  21 external parse_xml_string :  string -> int -> bool -> bool -> tree = "caml_call_shredder_string"
  22
  23 external save_tree : tree -> string -> unit = "caml_xml_tree_save"
  24 external load_tree : string ->  int -> tree = "caml_xml_tree_load"
  25
  26 external nullt : unit -> 'a node = "caml_xml_tree_nullt"
  27
  28 let nil : 'a node = Obj.magic (-1)
  29
  30 external text_get_tc_text : tree -> [`Text] node -> string = "caml_text_collection_get_text"
  31
  32 external text_is_empty : tree -> [`Text ] node -> bool = "caml_text_collection_empty_text"
  33
  34 let text_is_empty t n =
  35   (equal_node nil n) || text_is_empty t n
  36
  37
  38
  39 external text_is_contains : tree -> string -> bool = "caml_text_collection_is_contains"
  40 external text_count_contains : tree -> string -> int = "caml_text_collection_count_contains"
  41 external text_count : tree -> string -> int = "caml_text_collection_count"
  42 external text_contains : tree -> string -> [`Text ] node array = "caml_text_collection_contains"
  43 external text_unsorted_contains : tree -> string -> unit = "caml_text_collection_unsorted_contains"
  44 external text_get_cached_text : tree -> [`Text] node -> string = "caml_text_collection_get_cached_text"
  45
  46
  47 external tree_serialize : tree -> string -> unit = "caml_xml_tree_serialize"
  48
  49 external tree_unserialize : string -> tree = "caml_xml_tree_unserialize"
  50
  51 external tree_root : tree -> [`Tree] node = "caml_xml_tree_root"
  52
  53 let tree_is_nil x = equal_node x nil
  54
  55 external tree_parent : tree -> [`Tree] node -> [`Tree] node = "caml_xml_tree_parent"
  56 external tree_parent_doc : tree -> [`Text ] node -> [`Tree ] node = "caml_xml_tree_parent_doc"
  57 external tree_prev_doc : tree -> [`Text ] node -> [`Tree ] node = "caml_xml_tree_prev_doc"
  58 external tree_first_child : tree -> [`Tree] node -> [`Tree] node = "caml_xml_tree_first_child"
  59 external tree_tagged_child : tree -> [`Tree] node -> Tag.t -> [`Tree] node = "caml_xml_tree_tagged_child"
  60 external tree_next_sibling : tree -> [`Tree] node -> [`Tree] node = "caml_xml_tree_next_sibling"
  61 external tree_tagged_sibling : tree -> [`Tree] node -> Tag.t -> [`Tree] node = "caml_xml_tree_tagged_sibling"
  62
  63 external tree_prev_sibling : tree -> [`Tree] node -> [`Tree] node = "caml_xml_tree_prev_sibling"
  64 external tree_is_leaf : tree -> [`Tree] node -> bool = "caml_xml_tree_is_leaf"
  65 external tree_last_child : tree -> [`Tree] node -> [`Tree] node = "caml_xml_tree_last_child"
  66 external tree_is_first_child : tree -> [`Tree] node -> bool = "caml_xml_tree_is_first_child"
  67
  68 (*    external tag : tree -> [`Tree ] node -> T = "caml_xml_tree_tag"*)
  69 external tree_tag_id : tree -> [`Tree ] node -> Tag.t = "caml_xml_tree_tag_id"
  70
  71
  72 let tree_is_last t n = equal_node nil (tree_next_sibling t n)
  73
  74 external tree_prev_text : tree -> [`Tree] node -> [`Text ] node = "caml_xml_tree_prev_text"
  75
  76 external tree_my_text : tree -> [`Tree] node -> [`Text ] node = "caml_xml_tree_my_text"
  77 external tree_next_text : tree -> [`Tree] node -> [`Text ] node = "caml_xml_tree_next_text"
  78 external tree_doc_ids : tree -> [`Tree ] node -> [`Text ] node * [`Text ] node = "caml_xml_tree_doc_ids"
  79
  80 let text_size tree = int_of_node (snd ( tree_doc_ids tree (Obj.magic 0) ))
  81
  82 let text_get_cached_text t x =
  83   if x == -1 then ""
  84   else
  85      text_get_cached_text t x
  86
  87
  88 external tree_text_xml_id : tree -> [`Text ] node -> int = "caml_xml_tree_text_xml_id"
  89 external tree_node_xml_id : tree -> [`Tree ] node -> int = "caml_xml_tree_node_xml_id"
  90 external tree_is_ancestor : tree -> [`Tree ] node -> [`Tree ] node -> bool = "caml_xml_tree_is_ancestor"
  91 external tree_tagged_desc : tree -> [`Tree ] node -> Tag.t -> [`Tree ] node = "caml_xml_tree_tagged_desc"
  92 external tree_tagged_foll_below : tree -> [`Tree ] node -> Tag.t -> [`Tree ] node -> [`Tree ] node = "caml_xml_tree_tagged_foll_below"
  93 external tree_subtree_tags : tree -> [`Tree ] node -> Tag.t -> int = "caml_xml_tree_subtree_tags"
  94
  95
  96
  97 type int_vector
  98 external int_vector_alloc : int -> int_vector = "caml_int_vector_alloc"
  99 external int_vector_length : int_vector -> int = "caml_int_vector_length"
 100 external int_vector_set : int_vector -> int -> int -> unit = "caml_int_vector_set"
 101
 102 external tree_select_child : tree -> [`Tree ] node -> int_vector -> [`Tree] node = "caml_xml_tree_select_child"
 103 external tree_select_foll_sibling : tree -> [`Tree ] node -> int_vector -> [`Tree] node = "caml_xml_tree_select_foll_sibling"
 104 external tree_select_desc : tree -> [`Tree ] node -> int_vector -> [`Tree] node = "caml_xml_tree_select_desc"
 105 external tree_select_foll_below : tree -> [`Tree ] node -> int_vector -> [`Tree] node -> [`Tree] node = "caml_xml_tree_select_foll_below"
 106
 107
 108 module HPtset = Hashtbl.Make(Ptset.Int)
 109
 110 let vector_htbl = HPtset.create MED_H_SIZE
 111
 112 let ptset_to_vector s =
 113   try
 114     HPtset.find vector_htbl s
 115   with
 116       Not_found ->
 117         let v = int_vector_alloc (Ptset.Int.cardinal s) in
 118         let _ = Ptset.Int.fold (fun e i -> int_vector_set v i e;i+1) s 0 in
 119           HPtset.add vector_htbl s v; v
 120
 121
 122 type t = { doc : tree;
 123            node : [`Tree] node;
 124            ttable : (Tag.t,(Ptset.Int.t*Ptset.Int.t)) Hashtbl.t;
 125          }
 126
 127 let text_size t = text_size t.doc
 128
 129 module MemUnion = Hashtbl.Make (struct
 130       type t = Ptset.Int.t*Ptset.Int.t
 131       let equal (x,y) (z,t) = (Ptset.Int.equal x z)&&(Ptset.Int.equal y t)
 132       let equal a b = equal a b || equal b a
 133       let hash (x,y) =   (* commutative hash *)
 134         let x = Ptset.Int.hash x
 135         and y = Ptset.Int.hash y
 136         in
 137           if x < y then HASHINT2(x,y) else HASHINT2(y,x)
 138     end)
 139
 140 let collect_tags tree =
 141   let h_union = MemUnion.create BIG_H_SIZE in
 142   let pt_cup s1 s2 =
 143       try
 144         MemUnion.find h_union (s1,s2)
 145       with
 146         | Not_found -> let s = Ptset.Int.union s1 s2
 147           in
 148             MemUnion.add h_union (s1,s2) s;s
 149   in
 150   let h_add = Hashtbl.create BIG_H_SIZE in
 151   let pt_add t s =
 152     let k = HASHINT2(Tag.hash t,Ptset.Int.hash s) in
 153       try
 154         Hashtbl.find h_add k
 155       with
 156       | Not_found -> let r = Ptset.Int.add t s in
 157           Hashtbl.add h_add k r;r
 158   in
 159   let h = Hashtbl.create BIG_H_SIZE in
 160   let update t sb sa =
 161     let sbelow,safter =
 162       try
 163         Hashtbl.find h t
 164       with
 165         | Not_found ->
 166             (Ptset.Int.empty,Ptset.Int.empty)
 167     in
 168       Hashtbl.replace h t (pt_cup sbelow sb, pt_cup safter sa)
 169   in
 170   let rec loop id acc =
 171     if equal_node id nil
 172     then (Ptset.Int.empty,acc)
 173     else
 174       let below2,after2 = loop (tree_next_sibling tree id) acc in
 175       let below1,after1 = loop (tree_first_child tree id) after2 in
 176       let tag = tree_tag_id tree id in
 177         update tag below1 after2;
 178         pt_add tag (pt_cup below1 below2), (pt_add tag after1)
 179   in
 180     let _ = loop (tree_root tree) Ptset.Int.empty in h
 181
 182
 183
 184
 185
 186 let contains_array = ref [| |]
 187 let contains_index = Hashtbl.create 4096
 188 let in_array _ i =
 189   try
 190     Hashtbl.find contains_index i
 191   with
 192       Not_found -> false
 193
 194 let init_contains t s =
 195   let a = text_contains t.doc s
 196   in
 197     Array.fast_sort (compare) a;
 198     contains_array := a;
 199     Array.iter (fun x -> Hashtbl.add contains_index x true) !contains_array
 200
 201 let count_contains t s = text_count_contains t.doc s
 202 let unsorted_contains t s = text_unsorted_contains t.doc s
 203
 204 let init_naive_contains t s =
 205   let i,j = tree_doc_ids t.doc (tree_root t.doc)
 206   in
 207   let regexp = Str.regexp_string s in
 208   let matching arg =
 209     try
 210       let _ = Str.search_forward regexp arg 0;
 211       in true
 212     with _ -> false
 213   in
 214   let rec loop n acc l =
 215     if n >= j then acc,l
 216     else
 217       let s = text_get_cached_text t.doc n
 218       in
 219         if matching s
 220         then loop (n+1) (n::acc) (l+1)
 221         else loop (n+1) acc l
 222   in
 223   let acc,l = loop i [] 0 in
 224   let a = Array.create l nil in
 225   let _ = List.fold_left (fun cpt e -> a.(cpt) <- e; (cpt-1)) (l-1) acc
 226   in
 227     contains_array := a
 228
 229
 230
 231 module DocIdSet = struct
 232   include Set.Make (struct type t = [`Text] node
 233                            let compare = compare_node end)
 234
 235 end
 236 let is_nil t = t.node == nil
 237
 238 let is_node t = t.node != nil
 239
 240 let node_of_t t  =
 241   let _ = Tag.init (Obj.magic t) in
 242   let table = collect_tags t
 243   in
 244     { doc= t;
 245       node = tree_root t;
 246       ttable = table;
 247     }
 248 let finalize _ = Printf.eprintf "Release the string list !\n%!"
 249 ;;
 250
 251 let parse f str =
 252   node_of_t
 253     (f str
 254        !Options.sample_factor
 255        !Options.index_empty_texts
 256        !Options.disable_text_collection)
 257
 258 let parse_xml_uri str = parse parse_xml_uri str
 259 let parse_xml_string str =  parse parse_xml_string str
 260
 261
 262 external pool : tree -> Tag.pool = "%identity"
 263
 264 let save t str = (save_tree t.doc str)
 265 ;;
 266
 267 let load ?(sample=64) str =
 268   node_of_t (load_tree str sample)
 269
 270
 271
 272
 273 let tag_pool t = pool t.doc
 274
 275 let compare a b = a.node - b.node
 276
 277 let equal a b = a.node == b.node
 278
 279 let nts = function
 280     -1 -> "Nil"
 281   | i -> Printf.sprintf "Node (%i)"  i
 282
 283 let dump_node t = nts t.node
 284
 285 let mk_nil t = { t with node = nil }
 286 let root n = { n with node = tree_root n.doc }
 287
 288 let is_root n = n.node == (tree_root n.doc)
 289
 290 let is_left n = tree_is_first_child n.doc n.node
 291
 292 let is_below_right t1 t2 = tree_is_ancestor t1.doc (tree_parent t1.doc t1.node) t2.node
 293
 294 let parent n =  { n with node = tree_parent n.doc n.node }
 295
 296 let first_child n = { n with node = tree_first_child n.doc n.node }
 297 let tagged_child tag n  =  { n with node = tree_tagged_child n.doc n.node tag }
 298 let select_child ts n  =  { n with node = tree_select_child n.doc n.node (ptset_to_vector ts) }
 299
 300 let next_sibling n = { n with node = tree_next_sibling n.doc n.node }
 301 let tagged_sibling tag n  =  { n with node = tree_tagged_sibling n.doc n.node tag }
 302 let select_sibling ts n  =  { n with node = tree_select_foll_sibling n.doc n.node (ptset_to_vector ts) }
 303
 304 let next_sibling_ctx n _ = next_sibling n
 305 let tagged_sibling_ctx tag n  _ = tagged_sibling tag n
 306 let select_sibling_ctx ts n  _ = select_sibling ts n
 307
 308 let id t = tree_node_xml_id t.doc t.node
 309
 310 let tag t = if t.node == nil then Tag.nullt else tree_tag_id t.doc t.node
 311
 312 let tagged_desc tag n = { n with node = tree_tagged_desc n.doc n.node tag }
 313 let select_desc ts n  =  { n with node = tree_select_desc n.doc n.node (ptset_to_vector ts) }
 314
 315 let tagged_foll_ctx tag t ctx =
 316   { t with node = tree_tagged_foll_below t.doc t.node tag ctx.node }
 317 let select_foll_ctx ts n ctx  =  { n with node = tree_select_foll_below n.doc n.node (ptset_to_vector ts) ctx.node }
 318
 319 let last_idx = ref 0
 320 let array_find a i j =
 321   let l = Array.length a in
 322   let rec loop idx x y =
 323     if x > y || idx >= l then nil
 324         else
 325           if a.(idx) >= x then if a.(idx) > y then nil else (last_idx := idx;a.(idx))
 326           else loop (idx+1) x y
 327   in
 328     if a.(0) > j || a.(l-1) < i then nil
 329     else loop !last_idx i j
 330
 331
 332
 333   let count t s = text_count t.doc s
 334
 335   let print_xml_fast outc t =
 336     let rec loop ?(print_right=true) t =
 337       if t.node != nil
 338       then
 339         let tagid = tree_tag_id t.doc t.node in
 340           if tagid==Tag.pcdata
 341           then output_string outc (text_get_cached_text t.doc t.node);
 342           if print_right
 343           then loop (next_sibling t)
 344
 345           else
 346             let tagstr = Tag.to_string tagid in
 347             let l = first_child t
 348             and r = next_sibling t
 349             in
 350               output_char outc  '<';
 351               output_string outc  tagstr;
 352               if l.node == nil then output_string outc  "/>"
 353               else
 354                 if (tag l) == Tag.attribute then
 355                   begin
 356                     loop_attributes (first_child l);
 357                     if (next_sibling l).node == nil then output_string outc  "/>"
 358                     else
 359                       begin
 360                         output_char outc  '>';
 361                         loop (next_sibling l);
 362                         output_string outc  "</";
 363                         output_string outc  tagstr;
 364                         output_char outc '>';
 365                       end;
 366                   end
 367                 else
 368                   begin
 369                     output_char outc  '>';
 370                     loop l;
 371                     output_string outc "</";
 372                     output_string outc tagstr;
 373                     output_char outc '>';
 374                   end;
 375               if print_right then loop r
 376     and loop_attributes a =
 377       let s = (Tag.to_string (tag a)) in
 378       let attname = String.sub s 3 ((String.length s) -3) in
 379         output_char outc ' ';
 380         output_string outc attname;
 381         output_string outc "=\"";
 382         output_string outc (text_get_cached_text t.doc
 383                               (tree_my_text a.doc (first_child a).node));
 384         output_char outc '"';
 385         loop_attributes (next_sibling a)
 386     in
 387         loop ~print_right:false t
 388
 389
 390     let print_xml_fast outc t =
 391       if (tag t) = Tag.document_node then
 392         print_xml_fast outc (first_child t)
 393       else print_xml_fast outc t
 394
 395
 396 let tags_below t tag =
 397   fst(Hashtbl.find t.ttable tag)
 398
 399 let tags_after t tag =
 400   snd(Hashtbl.find t.ttable tag)
 401
 402 let tags t tag = Hashtbl.find t.ttable tag
 403
 404
 405 let rec binary_parent t =
 406   if tree_is_first_child t.doc t.node
 407   then { t with node = tree_parent t.doc t.node }
 408   else { t with node = tree_prev_sibling t.doc t.node }
 409
 410 let doc_ids (t:t) : (int*int) =
 411   (Obj.magic (tree_doc_ids t.doc t.node))
 412
 413 let subtree_tags t tag =
 414   if t.node == nil then 0 else
 415     tree_subtree_tags t.doc t.node tag
 416
 417 let get_text t =
 418   let tid = tree_my_text t.doc t.node in
 419     if tid == nil then "" else
 420       let a, b = tree_doc_ids t.doc (tree_root t.doc) in
 421       let _ = Printf.eprintf "Trying to take text %i of node %i in %i %i\n%!" tid t.node a b in
 422         text_get_cached_text t.doc tid
 423
 424
 425 let dump_tree fmt t =
 426   let rec loop tree n =
 427     if tree != nil then
 428       let tag = (tree_tag_id t.doc tree ) in
 429       let tagstr = Tag.to_string tag in
 430         let tab = String.make n ' ' in
 431
 432           if tag == Tag.pcdata || tag == Tag.attribute_data
 433           then
 434             Format.fprintf fmt "%s<%s>%s</%s>\n"
 435               tab tagstr (text_get_cached_text t.doc (tree_my_text t.doc tree)) tagstr
 436           else begin
 437             Format.fprintf fmt "%s<%s>\n" tab tagstr;
 438             loop (tree_first_child t.doc tree) (n+2);
 439             Format.fprintf fmt "%s</%s>\n%!" tab tagstr;
 440           end;
 441           loop (tree_next_sibling t.doc tree) n
 442   in
 443     loop (tree_root t.doc) 0
 444 ;;
 445
 446