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