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