src/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 INCLUDE "utils.ml"
   9
  10
  11 external init_lib : unit -> unit = "caml_init_lib"
  12
  13 exception CPlusPlusError of string
  14
  15 let () = Callback.register_exception "CPlusPlusError" (CPlusPlusError "")
  16
  17 let () =  init_lib ()
  18
  19 type node = [ `Tree ] Node.t
  20
  21 type tree
  22
  23 type bit_vector = string
  24
  25 external bool_of_int : int -> bool = "%identity"
  26
  27 let bit_vector_unsafe_get v i =
  28   bool_of_int
  29     (((Char.code (String.unsafe_get v (i lsr 3))) lsr (i land 7)) land 1)
  30
  31 type t = {
  32   doc : tree;
  33   elements: Ptset.Int.t;
  34   attributes: Ptset.Int.t;
  35   attribute_array : Tag.t array;
  36   children : Ptset.Int.t array;
  37   siblings : Ptset.Int.t array;
  38   descendants: Ptset.Int.t array;
  39   followings: Ptset.Int.t array;
  40 }
  41
  42
  43
  44 external parse_xml_uri : string -> int -> bool -> bool -> int -> tree = "caml_call_shredder_uri"
  45 external parse_xml_string :  string -> int -> bool -> bool -> int -> tree = "caml_call_shredder_string"
  46 external tree_print_xml_fast3 : tree -> [`Tree ] Node.t -> Unix.file_descr -> unit = "caml_xml_tree_print"
  47 let print_xml t n fd =
  48   tree_print_xml_fast3 t.doc n fd
  49
  50
  51 external tree_save : tree -> Unix.file_descr -> string -> unit = "caml_xml_tree_save"
  52 external tree_load : Unix.file_descr -> string -> bool -> int -> tree = "caml_xml_tree_load"
  53
  54 external nullt : unit -> 'a Node.t = "caml_xml_tree_nullt"
  55
  56 let nil : [`Tree ] Node.t = Node.nil
  57 let root : [`Tree ] Node.t = Node.null
  58
  59 type unordered_set
  60
  61 external unordered_set_alloc : int -> unordered_set = "caml_unordered_set_alloc"
  62 external unordered_set_length : unordered_set -> int = "caml_unordered_set_length"
  63 external unordered_set_insert : unordered_set -> int -> unit = "caml_unordered_set_set" "noalloc"
  64
  65 module HPtset = Hashtbl.Make(Ptset.Int)
  66
  67 let vector_htbl = HPtset.create MED_H_SIZE
  68
  69 let unordered_set_of_set s =
  70   try
  71     HPtset.find vector_htbl s
  72   with
  73       Not_found ->
  74         let v = unordered_set_alloc (Ptset.Int.cardinal s) in
  75         let _ = Ptset.Int.iter (fun e -> unordered_set_insert v e) s in
  76           HPtset.add vector_htbl s v; v
  77
  78 let ptset_to_vector = unordered_set_of_set
  79
  80 (** tree interface *)
  81
  82 external tree_root : tree -> [`Tree] Node.t = "caml_xml_tree_root"  "noalloc"
  83
  84
  85 external tree_first_child : tree -> [`Tree] Node.t -> [`Tree] Node.t = "caml_xml_tree_first_child" "noalloc"
  86 let first_child t n = tree_first_child t.doc n
  87
  88 external tree_first_element : tree -> [`Tree] Node.t -> [`Tree] Node.t = "caml_xml_tree_first_element" "noalloc"
  89 let first_element t n = tree_first_element t.doc n
  90
  91 external tree_tagged_child : tree -> [`Tree] Node.t -> Tag.t -> [`Tree] Node.t = "caml_xml_tree_tagged_child" "noalloc"
  92 let tagged_child t n tag = tree_tagged_child t.doc n tag
  93
  94 external tree_select_child : tree -> [`Tree ] Node.t -> unordered_set -> [`Tree] Node.t = "caml_xml_tree_select_child" "noalloc"
  95 let select_child t n tag_set = tree_select_child t.doc n tag_set
  96
  97 external tree_last_child : tree -> [`Tree] Node.t -> [`Tree] Node.t = "caml_xml_tree_last_child" "noalloc"
  98 let last_child t n = tree_last_child t.doc n
  99
 100
 101
 102 external tree_next_sibling : tree -> [`Tree] Node.t -> [`Tree] Node.t = "caml_xml_tree_next_sibling"  "noalloc"
 103 let next_sibling t n = tree_next_sibling t.doc n
 104
 105 external tree_next_element : tree -> [`Tree] Node.t -> [`Tree] Node.t = "caml_xml_tree_next_element"  "noalloc"
 106 let next_element t n = tree_next_element t.doc n
 107
 108 external tree_tagged_following_sibling : tree -> [`Tree] Node.t -> Tag.t -> [`Tree] Node.t = "caml_xml_tree_tagged_following_sibling" "noalloc"
 109 let tagged_following_sibling t n tag = tree_tagged_following_sibling t.doc n tag
 110
 111 external tree_select_following_sibling : tree -> [`Tree ] Node.t -> unordered_set -> [`Tree] Node.t = "caml_xml_tree_select_following_sibling" "noalloc"
 112 let select_following_sibling t n tag_set = tree_select_following_sibling t.doc n tag_set
 113
 114 external tree_prev_sibling : tree -> [`Tree] Node.t -> [`Tree] Node.t = "caml_xml_tree_prev_sibling" "noalloc"
 115 let prev_sibling t n = tree_prev_sibling t.doc n
 116
 117
 118
 119 external tree_tagged_descendant : tree -> [`Tree ] Node.t -> Tag.t -> [`Tree ] Node.t = "caml_xml_tree_tagged_descendant" "noalloc"
 120 let tagged_descendant t n tag = tree_tagged_descendant t.doc n tag
 121
 122 external tree_select_descendant : tree -> [`Tree ] Node.t -> unordered_set -> [`Tree] Node.t = "caml_xml_tree_select_descendant" "noalloc"
 123 let select_descendant t n tag_set = tree_select_descendant t.doc n tag_set
 124
 125 external tree_tagged_following_before : tree -> [`Tree ] Node.t -> Tag.t -> [`Tree ] Node.t -> [`Tree ] Node.t = "caml_xml_tree_tagged_following_before" "noalloc"
 126 let tagged_following_before t n tag ctx = tree_tagged_following_before t.doc n tag ctx
 127
 128 external tree_select_following_before : tree -> [`Tree ] Node.t -> unordered_set -> [`Tree] Node.t -> [`Tree] Node.t = "caml_xml_tree_select_following_before" "noalloc"
 129 let select_following_before t n tag_set ctx = tree_select_following_before t.doc n tag_set ctx
 130
 131 external tree_parent : tree -> [`Tree] Node.t -> [`Tree] Node.t = "caml_xml_tree_parent" "noalloc"
 132 let parent t n = tree_parent t.doc n
 133
 134 external tree_binary_parent : tree -> [`Tree] Node.t -> [`Tree] Node.t = "caml_xml_tree_binary_parent"
 135   "noalloc"
 136 let binary_parent t n = tree_binary_parent t.doc n
 137
 138
 139 external tree_tag : tree -> [`Tree] Node.t -> Tag.t = "caml_xml_tree_tag" "noalloc"
 140 let tag t n = tree_tag t.doc n
 141
 142 external tree_is_first_child : tree -> [ `Tree ] Node.t -> bool = "caml_xml_tree_is_first_child" "noalloc"
 143 let is_first_child t n = tree_is_first_child t.doc n
 144
 145 external tree_is_right_descendant : tree -> [ `Tree ] Node.t -> [`Tree] Node.t -> bool =
 146   "caml_xml_tree_is_right_descendant" "noalloc"
 147
 148 let is_right_descendant t n1 n2 = tree_is_right_descendant t.doc n1 n2
 149 ;;
 150
 151 let node_tags t = Ptset.Int.add Tag.document_node t.descendants.(Tag.document_node)
 152
 153 let attribute_tags t = t.attributes
 154
 155 let element_tags t = t.elements
 156
 157 let tags t tag =
 158   t.children.(tag), t.descendants.(tag), t.siblings.(tag), t.followings.(tag)
 159
 160 open Format
 161 let dump_tag_table t =
 162   eprintf "Child tags:\n%!";
 163   Array.iteri
 164     (fun tag set -> eprintf "%s: %a\n%!"
 165       (Tag.to_string tag) TagSet.print (TagSet.inj_positive set))
 166     t.children;
 167   eprintf "-----------------------------\n%!";
 168   eprintf "Descendant tags:\n%!";
 169   Array.iteri
 170     (fun tag set -> eprintf "%s: %a\n%!"
 171       (Tag.to_string tag) TagSet.print (TagSet.inj_positive set))
 172     t.descendants;
 173   eprintf "-----------------------------\n%!";
 174   eprintf "Sibling tags:\n%!";
 175   Array.iteri
 176     (fun tag set -> eprintf "%s: %a\n%!"
 177       (Tag.to_string tag) TagSet.print (TagSet.inj_positive set))
 178     t.siblings;
 179   eprintf "-----------------------------\n%!";
 180   eprintf "Following tags:\n%!";
 181   Array.iteri
 182     (fun tag set -> eprintf "%s: %a\n%!"
 183       (Tag.to_string tag) TagSet.print (TagSet.inj_positive set))
 184     t.followings;
 185    eprintf "-----------------------------\n%!"
 186
 187
 188 external tree_subtree_tags : tree -> [`Tree] Node.t -> Tag.t -> int = "caml_xml_tree_subtree_tags" "noalloc"
 189 let subtree_tags t n tag = tree_subtree_tags t.doc n tag
 190
 191 external tree_subtree_size : tree -> [`Tree] Node.t -> int = "caml_xml_tree_subtree_size" "noalloc"
 192 let subtree_size t n = tree_subtree_size t.doc n
 193
 194 let subtree_elements t node =
 195   let size = tree_subtree_size t.doc node - 1 in
 196     if size == 0 then 0
 197     else let size = size - (tree_subtree_tags t.doc node Tag.pcdata) in
 198       if size < 2 then size else
 199         let acc = ref size in
 200           for i = 0 to Array.length t.attribute_array - 1 do
 201             acc := !acc - tree_subtree_tags t.doc node t.attribute_array.(i)
 202           done;
 203           !acc
 204
 205 external tree_closing : tree -> [`Tree] Node.t -> [`Tree] Node.t = "caml_xml_tree_closing" "noalloc"
 206 let closing t n = tree_closing t.doc n
 207
 208 external tree_num_tags : tree -> int = "caml_xml_tree_num_tags" "noalloc"
 209 let num_tags t = tree_num_tags t.doc
 210
 211 external tree_size : tree -> int = "caml_xml_tree_size" "noalloc"
 212 let size t = tree_size t.doc
 213
 214
 215 let stats t =
 216   let tree = t.doc in
 217   let rec loop left node acc_d total_d num_leaves =
 218     if node == nil then
 219     (acc_d+total_d,if left then num_leaves+1 else num_leaves)
 220     else
 221     let d,td = loop true (tree_first_child tree node) (acc_d+1) total_d num_leaves in
 222     loop false (tree_next_sibling tree  node) (acc_d)  d td
 223   in
 224   let a,b = loop true root 0 0 0
 225   in
 226   Printf.eprintf "Average depth: %f, number of leaves %i\n%!" ((float_of_int a)/. (float_of_int b)) b
 227 ;;
 228
 229 module TagS =
 230   struct
 231     include Ptset.Make (
 232       struct type t = int
 233              type data = t
 234              external hash : t -> int = "%identity"
 235              external uid : t -> Uid.t = "%identity"
 236              external equal : t -> t -> bool = "%eq"
 237              external make : t -> int = "%identity"
 238              external node : t -> int = "%identity"
 239              external stats : unit -> unit = "%identity"
 240       end
 241     )
 242     let to_ptset s = fold (Ptset.Int.add) s Ptset.Int.empty
 243   end
 244
 245 module TSTSCache =
 246   Hashtbl.Make(struct type t = TagS.t * TagS.t
 247                       let hash (x, y) =
 248                         HASHINT2(Uid.to_int x.TagS.Node.id,
 249                                  Uid.to_int y.TagS.Node.id)
 250                       let equal u v =
 251                         let u1,u2 = u
 252                         and v1,v2 = v in
 253                           u1 == v1 && u2 == v2
 254                end)
 255 module TagTSCache =
 256   Hashtbl.Make(struct type t = Tag.t * TagS.t
 257                       let hash (x, y) =
 258                         HASHINT2(x, Uid.to_int y.TagS.Node.id)
 259                       let equal u v =
 260                         let u1,u2 = u
 261                         and v1,v2 = v in
 262                           u1 == v1 && u2 == v2
 263                end)
 264
 265 let add_cache = TagTSCache.create 1023
 266 let union_cache = TSTSCache.create 1023
 267 let subset_cache = TSTSCache.create 1023
 268
 269 let clear_cache () =
 270   TSTSCache.clear union_cache;
 271   TSTSCache.clear subset_cache;
 272   TagTSCache.clear add_cache
 273
 274 let _subset x y =
 275   (x == y) || (x == TagS.empty) ||
 276     if y == TagS.empty then false
 277     else
 278       let key = (x, y) in
 279         try
 280           TSTSCache.find subset_cache key
 281         with
 282           | Not_found ->
 283               let z = TagS.subset x y in
 284                 TSTSCache.add subset_cache key z; z
 285
 286 let order ((x, y) as z) =
 287   if x.TagS.Node.id <= y.TagS.Node.id then z
 288   else (y, x)
 289
 290 let _union x y =
 291   if _subset x y then y
 292   else if _subset y x then x
 293   else
 294    let key = order (x, y) in
 295      try
 296        TSTSCache.find union_cache key
 297     with
 298       | Not_found ->
 299           let z = TagS.union x y in
 300             TSTSCache.add union_cache key z; z
 301
 302 let _add t s =
 303   let key = (t,s) in
 304     try
 305       TagTSCache.find add_cache key
 306     with
 307       | Not_found ->
 308           let z = TagS.add t s in
 309             TagTSCache.add add_cache key z;z
 310
 311 let child_sibling_labels tree =
 312   let table_c = Array.create (tree_num_tags tree) TagS.empty in
 313   let table_n = Array.copy table_c in
 314   let rec loop node =
 315     if node == nil then TagS.empty
 316     else
 317       let children = loop (tree_first_child tree node) in
 318       let tag = tree_tag tree node in
 319       let () =
 320         let tc = table_c.(tag) in
 321         if _subset children tc then ()
 322         else table_c.(tag) <-  _union tc children
 323       in
 324       let siblings = loop (tree_next_sibling tree node) in
 325       let () =
 326         let tn = table_n.(tag) in
 327           if _subset siblings tn then ()
 328           else table_n.(tag) <- _union tn siblings
 329       in
 330         _add tag siblings
 331   in
 332     ignore (loop root);
 333     table_c, table_n
 334
 335 let descendant_labels tree =
 336   let table_d = Array.create (tree_num_tags tree) TagS.empty in
 337   let rec loop node =
 338     if node == nil then  TagS.empty else
 339       let d1 = loop (tree_first_child tree node) in
 340       let d2 = loop (tree_next_sibling tree node) in
 341       let tag = tree_tag tree node in
 342       let () =
 343         let td = table_d.(tag) in
 344           if _subset d1 td then ()
 345           else table_d.(tag) <- _union td d1;
 346       in
 347         _add tag (_union d1 d2)
 348   in
 349     ignore (loop root);
 350     table_d
 351
 352 let collect_labels tree =
 353   let table_f = Array.create (tree_num_tags tree) TagS.empty in
 354   let table_n = Array.copy table_f in
 355   let table_c = Array.copy table_f in
 356   let table_d = Array.copy table_f in
 357   let rec loop node foll_siblings descendants followings =
 358     if node == nil then foll_siblings, descendants, followings else
 359       let tag = tree_tag tree node in
 360       let () =
 361         let tf = table_f.(tag) in
 362           if _subset followings tf then ()
 363           else table_f.(tag) <- _union tf followings in
 364       let () =
 365         let tn = table_n.(tag) in
 366           if _subset foll_siblings tn then ()
 367           else table_n.(tag) <- _union tn foll_siblings in
 368       let children, n_descendants, n_followings =
 369         loop (tree_last_child tree node) TagS.empty TagS.empty followings
 370       in
 371       let () =
 372         let tc = table_c.(tag) in
 373           if _subset children tc then ()
 374           else table_c.(tag) <- _union tc children
 375       in
 376       let () =
 377         let td = table_d.(tag) in
 378           if _subset n_descendants td then ()
 379           else table_d.(tag) <- _union td n_descendants
 380       in
 381         loop (tree_prev_sibling tree node)
 382           (_add tag foll_siblings)
 383           (_add tag (_union n_descendants descendants))
 384           (_add tag n_followings)
 385   in
 386     ignore (loop root TagS.empty TagS.empty TagS.empty);
 387     table_f, table_n, table_c, table_d
 388
 389
 390 let is_nil t = t == nil
 391 let is_node t = t != nil
 392 let is_root t = t == root
 393
 394 let node_of_t t  =
 395   let _ = Tag.init (Obj.magic t) in
 396   let f, n, c, d = time collect_labels t ~msg:"Building tag relationship table" in
 397   let c = Array.map TagS.to_ptset c in
 398   let n = Array.map TagS.to_ptset n in
 399   let f = Array.map TagS.to_ptset f in
 400   let d = Array.map TagS.to_ptset d in
 401   let () = clear_cache () in
 402   let attributes = Ptset.Int.add Tag.attribute d.(Tag.attribute) in
 403   let elements = Ptset.Int.add Tag.document_node
 404     (Ptset.Int.remove Tag.pcdata
 405        (Ptset.Int.diff d.(Tag.document_node) attributes))
 406   in
 407     { doc= t;
 408       attributes = attributes;
 409       attribute_array = Array.of_list (Ptset.Int.elements attributes);
 410       elements = elements;
 411       children = c;
 412       siblings = n;
 413       descendants = d;
 414       followings = f
 415
 416     }
 417
 418 let parse f str =
 419   node_of_t
 420     (f str !Options.sample_factor
 421        !Options.index_empty_texts
 422        !Options.disable_text_collection
 423        !Options.text_index_type
 424     )
 425
 426 let parse_xml_uri str = parse parse_xml_uri str
 427 let parse_xml_string str =  parse parse_xml_string str
 428
 429 let size t = tree_size t.doc;;
 430
 431 external pool : tree -> Tag.pool = "%identity"
 432
 433 let magic_string = "SXSI_INDEX"
 434 let version_string = "3"
 435
 436 let pos fd =
 437   Unix.lseek fd 0  Unix.SEEK_CUR
 438
 439 let pr_pos fd = Printf.eprintf "At position %i\n%!" (pos fd)
 440
 441 let write fd s =
 442   let sl = String.length s in
 443   let ssl = Printf.sprintf "%020i" sl in
 444     ignore (Unix.write fd ssl 0 20);
 445     ignore (Unix.write fd s 0 (String.length s))
 446
 447 let rec really_read fd buffer start length =
 448   if length <= 0 then () else
 449     match Unix.read fd buffer start length with
 450         0 -> raise End_of_file
 451       | r -> really_read fd buffer (start + r) (length - r);;
 452
 453 let read fd =
 454   let buffer = String.create 20 in
 455   let _ =  really_read fd buffer 0 20 in
 456   let size = int_of_string buffer in
 457   let buffer = String.create size in
 458   let _ =  really_read fd buffer 0 size in
 459     buffer
 460
 461 let save_tag_table channel t =
 462   let t = Array.map (fun s -> Array.of_list (Ptset.Int.elements s)) t in
 463     Marshal.to_channel channel t []
 464
 465 let save t str =
 466   let fd = Unix.openfile str [ Unix.O_WRONLY;Unix.O_TRUNC;Unix.O_CREAT] 0o644 in
 467   let out_c = Unix.out_channel_of_descr fd in
 468   let _ = set_binary_mode_out out_c true in
 469     output_string out_c magic_string;
 470     output_char out_c '\n';
 471     output_string out_c version_string;
 472     output_char out_c '\n';
 473     save_tag_table out_c t.children;
 474     save_tag_table out_c t.siblings;
 475     save_tag_table out_c t.descendants;
 476     save_tag_table out_c t.followings;
 477     (* we need to move the fd to the correct position *)
 478     flush out_c;
 479     ignore (Unix.lseek fd (pos_out out_c) Unix.SEEK_SET);
 480     tree_save t.doc fd str;
 481     close_out out_c
 482 ;;
 483 let load_tag_table channel =
 484   let table : int array array = Marshal.from_channel channel in
 485     Array.map (fun a -> Ptset.Int.from_list (Array.to_list a)) table
 486
 487 let load ?(sample=64) ?(load_text=true) str =
 488   let fd = Unix.openfile str [ Unix.O_RDONLY ] 0o644 in
 489   let in_c = Unix.in_channel_of_descr fd in
 490   let _ = set_binary_mode_in in_c true in
 491   let load_table () =
 492     (let ms = input_line in_c in if ms <> magic_string then failwith "Invalid index file");
 493     (let vs = input_line in_c in if vs <> version_string then failwith "Invalid version file");
 494     let c = load_tag_table in_c in
 495     let s = load_tag_table in_c in
 496     let d = load_tag_table in_c in
 497     let f = load_tag_table in_c in
 498       c,s,d,f
 499   in
 500   let c, s, d, f = time ~msg:"Loading tag table"(load_table) () in
 501   ignore(Unix.lseek fd (pos_in in_c) Unix.SEEK_SET);
 502     let xml_tree = tree_load fd str load_text sample in
 503     let () = Tag.init (Obj.magic xml_tree) in
 504     let attributes = Ptset.Int.add Tag.attribute d.(Tag.attribute) in
 505     let elements = Ptset.Int.add Tag.document_node
 506       (Ptset.Int.remove Tag.pcdata
 507          (Ptset.Int.diff d.(Tag.document_node) attributes))
 508     in
 509     let tree = { doc = xml_tree;
 510                  attributes = attributes;
 511                  attribute_array = Array.of_list (Ptset.Int.elements attributes);
 512                  elements = elements;
 513                  children = c;
 514                  siblings = s;
 515                  descendants = d;
 516                  followings = f
 517              }
 518   in close_in in_c;
 519   tree
 520
 521
 522
 523
 524 let tag_pool t = pool t.doc
 525
 526 let equal a b = a == b
 527
 528 let nts = function
 529     -1 -> "Nil"
 530   | i -> Printf.sprintf "Node (%i)"  i
 531
 532 let dump_node t = nts (Node.to_int t)
 533
 534
 535
 536 type query_result = { bv : bit_vector;
 537                       pos : node array;
 538                     }
 539
 540 external tree_flush : tree -> Unix.file_descr -> unit = "caml_xml_tree_flush"
 541 let flush t fd = tree_flush t.doc fd
 542
 543 external text_prefix : tree -> string -> query_result = "caml_text_collection_prefix_bv"
 544 let text_prefix t s = text_prefix t.doc s
 545
 546 external text_suffix : tree -> string -> query_result = "caml_text_collection_suffix_bv"
 547 let text_suffix t s = text_suffix t.doc s
 548
 549 external text_equals : tree -> string -> query_result = "caml_text_collection_equals_bv"
 550 let text_equals t s = text_equals t.doc s
 551
 552 external text_contains : tree -> string -> query_result = "caml_text_collection_contains_bv"
 553 let text_contains t s = text_contains t.doc s
 554
 555
 556 module Predicate = Hcons.Make (
 557   struct
 558     type _t = t
 559     type t = (_t -> node -> bool) ref
 560     let hash t = Hashtbl.hash t
 561     let equal t1 t2 = t1 == t2
 562 end)
 563
 564 let string_of_query query =
 565     match query with
 566       | `Prefix -> "starts-with"
 567       | `Suffix -> "ends-with"
 568       | `Equals -> "equals"
 569       | `Contains -> "contains"
 570 ;;
 571
 572 let query_fun = function
 573       | `Prefix -> text_prefix
 574       | `Suffix -> text_suffix
 575       | `Equals -> text_equals
 576       | `Contains -> text_contains
 577 ;;
 578
 579 let _pred_cache = Hashtbl.create 17
 580 ;;
 581 let mk_pred query s =
 582   let f = query_fun query in
 583   let memo = ref (fun _ _ -> failwith "Undefined") in
 584   memo := begin fun tree node ->
 585     let results =
 586       try Hashtbl.find _pred_cache (query,s) with
 587           Not_found ->
 588             time ~count:1 ~msg:(Printf.sprintf "Computing text query %s(%s)"
 589                                   (string_of_query query) s)
 590               (f tree) s
 591     in
 592     let bv = results.bv in
 593     memo := begin fun _ n ->
 594       let b =
 595         bit_vector_unsafe_get bv (Node.to_int n)
 596       in
 597       D_TRACE_(Printf.eprintf "Result of memoized call to query %s is %b for node %i\n" s b (Node.to_int n));
 598       b
 599     end;
 600     let b = bit_vector_unsafe_get bv (Node.to_int node) in
 601     D_TRACE_(Printf.eprintf "Result is %b for node %i\n" b (Node.to_int node));
 602     b
 603   end;
 604   Predicate.make memo
 605
 606
 607 let full_text_prefix t s = (text_prefix t s).pos
 608
 609 let full_text_suffix t s = (text_suffix t s).pos
 610
 611 let full_text_equals t s = (text_equals t s).pos
 612
 613 let full_text_contains t s = (text_contains t s).pos
 614
 615 let full_text_query q t s =
 616   let res = (query_fun q) t s in
 617   Hashtbl.replace _pred_cache (q,s) res;
 618   res.pos