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 (******************************************************************************)
8 #load "pa_extend.cmo";;
12 (* The steps are in reverse order !!!! *)
13 type path = Absolute of step list | AbsoluteDoS of step list| Relative of step list
14 and step = axis*test*predicate
15 and axis = Self | Attribute | Child | Descendant | DescendantOrSelf | FollowingSibling
16 | Parent | Ancestor | AncestorOrSelf | PrecedingSibling | Preceding | Following
20 and predicate = Or of predicate*predicate
21 | And of predicate*predicate
24 and expression = Path of path
25 | Function of string*expression list
34 let pp fmt = Format.fprintf fmt
35 let print_list printer fmt sep l =
38 | [e] -> printer fmt e
39 | e::es -> printer fmt e; List.iter (fun x -> pp fmt sep;printer fmt x) es
44 | Absolute l -> pp fmt "/"; l
45 | AbsoluteDoS l -> pp fmt "/";
46 print_step fmt (DescendantOrSelf,TagSet.node,Expr True);
50 print_list print_step fmt "/" (List.rev l)
51 and print_step fmt (axis,test,predicate) =
52 print_axis fmt axis;pp fmt "::";print_test fmt test;
53 pp fmt "["; print_predicate fmt predicate; pp fmt "]"
54 and print_axis fmt a = pp fmt "%s" (match a with
57 | Descendant -> "descendant"
58 | DescendantOrSelf -> "descendant-or-self"
59 | FollowingSibling -> "following-sibling"
60 | Attribute -> "attribute"
61 | Ancestor -> "ancestor"
62 | AncestorOrSelf -> "ancestor-or-self"
63 | PrecedingSibling -> "preceding-sibling"
67 and print_test fmt ts =
69 pp fmt "%s" (List.assoc ts
70 [ (TagSet.pcdata,"text()"); (TagSet.node,"node()");
73 Not_found -> pp fmt "%s"
74 (if TagSet.is_finite ts
75 then Tag.to_string (TagSet.choose ts)
78 and print_predicate fmt = function
79 | Or(p,q) -> print_predicate fmt p; pp fmt " or "; print_predicate fmt q
80 | And(p,q) -> print_predicate fmt p; pp fmt " and "; print_predicate fmt q
81 | Not p -> pp fmt "not "; print_predicate fmt p
82 | Expr e -> print_expression fmt e
84 and print_expression fmt = function
85 | Path p -> print fmt p
86 | Function (f,l) -> pp fmt "%s(" f;print_list print_expression fmt "," l;pp fmt ")"
87 | Int i -> pp fmt "%i" i
88 | String s -> pp fmt "\"%s\"" s
89 | t -> pp fmt "%b" (t== True)
96 let predopt = function None -> Expr True | Some p -> p
98 module Gram = Camlp4.Struct.Grammar.Static.Make(Ulexer)
99 let query = Gram.Entry.mk "query"
101 exception Error of Gram.Loc.t*string
102 let test_of_keyword t loc =
104 | "text()" -> TagSet.pcdata
105 | "node()" -> TagSet.node
107 | "and" | "not" | "or" -> TagSet.singleton (Tag.tag t)
108 | _ -> raise (Error(loc,"Invalid test name "^t ))
110 let axis_to_string a = let r = Format.str_formatter in
111 print_axis r a; Format.flush_str_formatter()
116 query : [ [ p = path; `EOI -> p ]]
120 [ "//" ; l = slist -> AbsoluteDoS l ]
121 | [ "/" ; l = slist -> Absolute l ]
122 | [ l = slist -> Relative l ]
127 [ l = slist ;"/"; s = step -> s@l ]
128 | [ l = slist ; "//"; s = step -> s@[(DescendantOrSelf, TagSet.node,Expr True)]@l]
133 (* yurk, this is done to parse stuff like
134 a/b/descendant/a where descendant is actually a tag name :(
135 if OPT is None then this is a child::descendant if not, this is a real axis name
137 [ axis = axis ; o = OPT ["::" ; t = test -> t ] ; p = top_pred ->
140 | Some(t) -> (axis,t,p)
141 | None -> (Child,TagSet.singleton (Tag.tag (axis_to_string axis)),p)
143 | Following -> [ (DescendantOrSelf,t,p);
144 (FollowingSibling,TagSet.star,Expr(True));
145 (Ancestor,TagSet.star,Expr(True)) ]
147 | Preceding -> [ (DescendantOrSelf,t,p);
148 (PrecedingSibling,TagSet.star,Expr(True));
149 (Ancestor,TagSet.star,Expr(True)) ]
154 | [ "." ; p = top_pred -> [(Self,TagSet.node,p)] ]
155 | [ ".." ; p = top_pred -> [(Parent,TagSet.star,p)] ]
156 | [ test = test; p = top_pred -> [(Child,test, p)] ]
157 | [ att = ATT ; p = top_pred ->
159 | "*" -> [(Attribute,TagSet.star,p)]
160 | _ -> [(Attribute, TagSet.singleton (Tag.tag att) ,p )]]
164 [ p = OPT [ "["; p=predicate ;"]" -> p ] -> predopt p ]
168 [ "self" -> Self | "child" -> Child | "descendant" -> Descendant
169 | "descendant-or-self" -> DescendantOrSelf
170 | "ancestor-or-self" -> AncestorOrSelf
171 | "following-sibling" -> FollowingSibling
172 | "attribute" -> Attribute
174 | "ancestor" -> Ancestor
175 | "preceding-sibling" -> PrecedingSibling
176 | "preceding" -> Preceding
177 | "following" -> Following
183 [ s = KWD -> test_of_keyword s _loc ]
184 | [ t = TAG -> TagSet.singleton (Tag.tag t) ]
189 [ p = predicate; "or"; q = predicate -> Or(p,q) ]
190 | [ p = predicate; "and"; q = predicate -> And(p,q) ]
191 | [ "not" ; p = predicate -> Not p ]
192 | [ "("; p = predicate ;")" -> p ]
193 | [ e = expression -> Expr e ]
197 [ f = TAG; "("; args = LIST0 expression SEP "," ; ")" -> Function(f,args)]
198 | [ `INT(i) -> Int (i) ]
199 | [ s = STRING -> String s ]
200 | [ p = path -> Path p ]
201 | [ "("; e = expression ; ")" -> e ]
206 let parse_string = Gram.parse_string query (Ulexer.Loc.mk "<string>")
207 let parse = Gram.parse_string query (Ulexer.Loc.mk "<string>")
211 module Compile = struct
214 type config = { st_root : Ata.state; (* state matching the root element (initial state) *)
215 st_univ : Ata.state; (* universal state accepting anything *)
216 st_from_root : Ata.state; (* state chaining the root and the current position *)
217 mutable final_state : Ptset.t;
218 mutable has_backward: bool;
219 (* To store transitions *)
220 (* Key is the from state, (i,l) -> i the number of the step and l the list of trs *)
221 tr_parent_loop : (Ata.state,int*(Ata.transition list)) Hashtbl.t;
222 tr : (Ata.state,int*(Ata.transition list)) Hashtbl.t;
223 tr_aux : (Ata.state,int*(Ata.transition list)) Hashtbl.t;
225 let dummy_conf = { st_root = -1;
228 final_state = Ptset.empty;
229 has_backward = false;
230 tr_parent_loop = Hashtbl.create 0;
231 tr = Hashtbl.create 0;
232 tr_aux = Hashtbl.create 0;
237 function (`Left|`Last) -> `Right
239 let _l = function (`Left|`Last) -> `Left
246 let add_trans num htr ((q,_,_,_,_) as tr) =
248 let (i,ltr) = Hashtbl.find htr q in
249 if List.exists (Ata.equal_trans tr) ltr
251 else Hashtbl.replace htr q (i,(tr::ltr))
253 | Not_found -> Hashtbl.add htr q (num,[tr])
255 exception Exit of Ata.state * Ata.transition list
256 let rec replace s f =
258 | Ata.Atom(_,b,q) when q = s -> if b then Ata.true_ else Ata.false_
259 | Ata.Or(f1,f2) -> (replace s f1) +| (replace s f2)
260 | Ata.And(f1,f2) -> (replace s f1) *& (replace s f2)
264 let or_self conf old_dst q_src q_dst dir test pred mark =
266 let (num,l) = Hashtbl.find conf.tr q_src in
267 let l2 = List.fold_left (fun acc (q,t,m,f,_) ->
271 (if mark then replace old_dst f else f)
273 (if mark then Ata.true_ else (_l dir) ** q_dst),
276 in Hashtbl.replace conf.tr q_src (num,l2)
280 let nst = Ata.mk_state
281 let att_or_str = TagSet.add Tag.pcdata TagSet.attribute
282 let vpush x y = (x,[]) :: y
285 | (z,r)::l -> (z,x::r) ::l
293 | (x,z::y) ::r -> z,(x,y)::r
296 let rec compile_step ?(existential=false) conf q_src dir ctx_path step num =
297 let ex = existential in
298 let axis,test,pred = step in
299 let is_last = dir = `Last in
300 let { st_root = q_root;
302 st_from_root = q_frm_root } = conf
304 let q_dst = Ata.mk_state() in
305 let p_st, p_anc, p_par, p_pre, p_num, p_f =
306 compile_pred conf q_src num ctx_path dir pred q_dst
309 let new_st,new_dst, new_ctx =
311 | Child | FollowingSibling | Descendant | DescendantOrSelf ->
313 if axis = DescendantOrSelf
316 or_self conf q_src (fst(vpop ctx_path)) q_dst dir test p_f (is_last && not(existential));
321 let t1 = ?< q_src><(test, is_last && not(ex))>=>
322 p_f *& (if is_last then Ata.true_ else (_l dir) ** q_dst) in
324 let _ = add_trans num conf.tr t1 in
327 let _ = if axis=Descendant then
328 add_trans num conf.tr_aux (
329 ?< q_src><@ ((if ex then TagSet.diff TagSet.star test
330 else TagSet.star),false,
331 if TagSet.is_finite test
333 if (Tree.Binary.is_node t)
335 let mytag = Tree.Binary.tag t in
336 TagSet.exists (fun tag ->
338 Tree.Binary.has_tagged_desc t tag
344 else `True )>=> `Left ** q_src )
347 ?< q_src><@ ((if ex then TagSet.diff TagSet.any test
348 else TagSet.any), false,
349 if axis=Descendant&&TagSet.is_finite test
350 then `True (*`Right(fun t ->
351 TagSet.exists (fun tag -> Tree.Binary.has_tagged_foll t tag)
354 if ex then ( Ata.atom_ `Left false q_src) *& `Right ** q_src
357 let _ = add_trans num conf.tr_aux t3
360 (if axis = FollowingSibling then hpush q_src ctx_path else vpush q_src ctx_path)
364 let q_dstreal = Ata.mk_state() in
365 (* attributes are always the first child *)
366 let t1 = ?< q_src><(TagSet.attribute,false)>=>
368 let t2 = ?< q_dst><(test, is_last && not(existential))>=>
369 if is_last then Ata.true_ else `Left ** q_dstreal in
370 let tsa = ?< q_dst><(TagSet.star, false)>=> `Right ** q_dst
372 add_trans num conf.tr t1;
373 add_trans num conf.tr_aux t2;
374 add_trans num conf.tr_aux tsa;
375 [q_dst;q_dstreal], q_dstreal,
378 | Ancestor | AncestorOrSelf ->
379 conf.has_backward <- true;
380 let up_states, new_ctx =
381 List.map (fst) ctx_path, (vpush q_root [])
383 let _ = if axis = AncestorOrSelf then
384 or_self conf q_src (fst(vpop ctx_path)) q_dst dir test p_f (is_last && not(existential));
386 let fc = List.fold_left (fun f s -> ((_l dir)**s +|f)) Ata.false_ up_states
388 let t1 = ?< q_frm_root><(test,is_last && (not existential) )>=>
389 (if is_last then Ata.true_ else (_l dir) ** q_dst) *& fc in
390 add_trans num conf.tr t1;
391 [q_dst ], q_dst, vpush q_frm_root new_ctx
394 conf.has_backward <- true;
397 | (a,_)::[] -> a, vpush q_root []
401 let t1 = ?< q_frm_root>< (test,is_last && (not existential)) >=>
402 (if is_last then Ata.true_ else (_l dir) ** q_dst) *& (_l dir) ** q_self in
403 add_trans num conf.tr t1;
404 [ q_dst ], q_dst, vpush q_frm_root new_ctx
408 (* todo change everything to Ptset *)
409 (Ptset.elements (Ptset.union p_st (Ptset.from_list new_st)),
413 and compile_path ?(existential=false) annot_path config q_src states idx ctx_path =
415 (fun (a_st,a_dst,anc_st,par_st,pre_st,ctx_path,num,has_backward) (step,dir) ->
416 let add_states,new_dst,new_ctx =
417 compile_step ~existential:existential config a_dst dir ctx_path step num
419 let new_states = Ptset.union (Ptset.from_list add_states) a_st in
420 let nanc_st,npar_st,npre_st,new_bw =
422 |PrecedingSibling,_,_ -> anc_st,par_st,Ptset.add a_dst pre_st,true
423 |(Parent|Ancestor|AncestorOrSelf),_,_ -> Ptset.add a_dst anc_st,par_st,pre_st,true
424 | _ -> anc_st,par_st,pre_st,has_backward
426 new_states,new_dst,nanc_st,npar_st,npre_st,new_ctx, num+1,new_bw
428 (states, q_src, Ptset.empty,Ptset.empty,Ptset.empty, ctx_path,idx, false )
431 and binop_ conf q_src idx ctx_path dir pred p1 p2 f ddst =
432 let a_st1,anc_st1,par_st1,pre_st1,idx1,f1 =
433 compile_pred conf q_src idx ctx_path dir p1 ddst in
434 let a_st2,anc_st2,par_st2,pre_st2,idx2,f2 =
435 compile_pred conf q_src idx1 ctx_path dir p2 ddst
437 Ptset.union a_st1 a_st2,
438 Ptset.union anc_st1 anc_st2,
439 Ptset.union par_st1 par_st2,
440 Ptset.union pre_st1 pre_st2,
443 and compile_pred conf q_src idx ctx_path dir pred qdst =
446 binop_ conf q_src idx ctx_path dir pred p1 p2 (( +| )) qdst
448 binop_ conf q_src idx ctx_path dir pred p1 p2 (( *& )) qdst
449 | Expr e -> compile_expr conf Ptset.empty q_src idx ctx_path dir e qdst
451 let a_st,anc_st,par_st,pre_st,idx,f =
452 compile_pred conf q_src idx ctx_path dir p qdst
453 in a_st,anc_st,par_st,pre_st,idx, Ata.not_ f
455 and compile_expr conf states q_src idx ctx_path dir e qdst =
458 let q = Ata.mk_state () in
459 let annot_path = match p with Relative(r) -> dirannot (List.rev r) | _ -> assert false in
460 let a_st,a_dst,anc_st,par_st,pre_st,_,idx,has_backward =
461 compile_path ~existential:true annot_path conf q states idx ctx_path
463 let ret_dir = match annot_path with
464 | ((FollowingSibling,_,_),_)::_ -> `Right
467 let _ = match annot_path with
468 | (((Parent|Ancestor|AncestorOrSelf),_,_),_)::_ -> conf.final_state <- Ptset.add qdst conf.final_state
471 (a_st,anc_st,par_st,pre_st,idx, ((ret_dir) ** q))
472 | True -> states,Ptset.empty,Ptset.empty,Ptset.empty,idx,Ata.true_
473 | False -> states,Ptset.empty,Ptset.empty,Ptset.empty,idx,Ata.false_
477 and dirannot = function
480 | p::(((FollowingSibling),_,_)::_ as l) -> (p,`Right)::(dirannot l)
481 | p::l -> (p,`Left) :: (dirannot l)
487 | Relative(steps) -> steps
488 | AbsoluteDoS(steps) -> steps@[(DescendantOrSelf,TagSet.node,Expr(True))]
490 let steps = List.rev steps in
491 let dirsteps = dirannot steps in
492 let config = { st_root = Ata.mk_state();
493 st_univ = Ata.mk_state();
494 final_state = Ptset.empty;
495 st_from_root = Ata.mk_state();
496 has_backward = false;
497 tr_parent_loop = Hashtbl.create 5;
498 tr = Hashtbl.create 5;
499 tr_aux = Hashtbl.create 5;
502 let q0 = Ata.mk_state() in
503 let states = Ptset.from_list [config.st_univ;config.st_root]
506 (* add_trans num config.tr_aux (mk_star config.st_from_root `Left config.st_univ config.st_from_root);
507 add_trans num config.tr_aux (mk_star config.st_from_root `Left config.st_from_root config.st_univ);
508 add_trans num config.tr_aux (mk_step config.st_no_nil (TagSet.add Tag.pcdata TagSet.star) `Left config.st_univ config.st_univ);
510 let a_st,a_dst,anc_st,par_st,pre_st,_,_,has_backward =
511 compile_path dirsteps config q0 states 0 [(config.st_root,[]) ]
514 ?< (config.st_root) >< (TagSet.star,false) >=>
515 (`Left** q0) *& (if config.has_backward then `Left ** config.st_from_root else Ata.true_)
517 add_trans num config.tr fst_tr;
518 if config.has_backward then begin
519 add_trans num config.tr_aux
520 (?< (config.st_from_root) >< (TagSet.star,false) >=> `Left ** config.st_from_root +|
521 `Right ** config.st_from_root);
522 add_trans num config.tr_aux
523 (?< (config.st_from_root) >< (TagSet.cup TagSet.pcdata TagSet.attribute,false) >=>
524 `Right ** config.st_from_root);
527 let phi = Hashtbl.create 37 in
528 let fadd = fun _ (_,l) -> List.iter (fun (s,t,m,f,p) ->
533 Hashtbl.replace phi s ((t,(m,f,p))::lt)
535 Hashtbl.iter (fadd) config.tr;
536 Hashtbl.iter (fadd) config.tr_aux;
537 Hashtbl.iter (fadd) config.tr_parent_loop;
539 let s = Ptset.union anc_st (Ptset.from_list [])
540 in if has_backward then Ptset.add config.st_from_root s else s
541 in { Ata.id = Oo.id (object end);
542 Ata.states = if has_backward then Ptset.add config.st_from_root a_st else a_st;
543 Ata.init = Ptset.singleton config.st_root;
544 Ata.final = Ptset.union anc_st config.final_state;
545 Ata.universal = Ptset.union anc_st config.final_state;
547 Ata.delta = Hashtbl.create 17;
548 Ata.sigma = Ata.HTagSet.create 17;