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) ->
268 (q,TagSet.cap t test,mark,
269 (if mark then replace old_dst f else f)
271 (if mark then Ata.true_ else (_l dir) ** q_dst))::acc)
273 in Hashtbl.replace conf.tr q_src (num,l2)
277 let nst = Ata.mk_state
278 let att_or_str = TagSet.add Tag.pcdata TagSet.attribute
279 let vpush x y = (x,[]) :: y
282 | (z,r)::l -> (z,x::r) ::l
290 | (x,z::y) ::r -> z,(x,y)::r
293 let rec compile_step ?(existential=false) conf q_src dir ctx_path step num =
294 let ex = existential in
295 let axis,test,pred = step in
296 let is_last = dir = `Last in
297 let { st_root = q_root;
299 st_from_root = q_frm_root } = conf
301 let q_dst = Ata.mk_state() in
302 let p_st, p_anc, p_par, p_pre, p_num, p_f =
303 compile_pred conf q_src num ctx_path dir pred q_dst
306 let new_st,new_dst, new_ctx =
308 | Child | FollowingSibling | Descendant | DescendantOrSelf ->
310 if axis = DescendantOrSelf
312 or_self conf q_src (fst(vpop ctx_path)) q_dst dir test p_f (is_last && not(existential));
316 let t1 = ?< q_src><(test, is_last && not(existential))>=>
317 p_f *& (if is_last then Ata.true_ else (_l dir) ** q_dst) in
318 let t2 = ?< q_src><(TagSet.star, false)>=>
319 (if axis=Descendant then `Left ** q_src +|`Right ** q_src
320 else `Right ** q_src) in
321 let tsa = ?< q_src><(att_or_str, false)>=> `Right ** q_src
323 add_trans num conf.tr t1;
324 add_trans num conf.tr_aux t2;
325 add_trans num conf.tr_aux tsa;
327 (if axis = FollowingSibling then hpush q_src ctx_path else vpush q_src ctx_path)
331 let q_dstreal = Ata.mk_state() in
332 (* attributes are always the first child *)
333 let t1 = ?< q_src><(TagSet.attribute,false)>=>
335 let t2 = ?< q_dst><(test, is_last && not(existential))>=>
336 if is_last then Ata.true_ else `Left ** q_dstreal in
337 let tsa = ?< q_dst><(TagSet.star, false)>=> `Right ** q_dst
339 add_trans num conf.tr t1;
340 add_trans num conf.tr_aux t2;
341 add_trans num conf.tr_aux tsa;
342 [q_dst;q_dstreal], q_dstreal,
345 | Ancestor | AncestorOrSelf ->
346 conf.has_backward <- true;
347 let up_states, new_ctx =
348 List.map (fst) ctx_path, (vpush q_root [])
350 let _ = if axis = AncestorOrSelf then
351 or_self conf q_src (fst(vpop ctx_path)) q_dst dir test p_f (is_last && not(existential));
353 let fc = List.fold_left (fun f s -> ((_l dir)**s +|f)) Ata.false_ up_states
355 let t1 = ?< q_frm_root><(test,is_last && (not existential) )>=>
356 (if is_last then Ata.true_ else (_l dir) ** q_dst) *& fc in
357 add_trans num conf.tr t1;
358 [q_dst ], q_dst, vpush q_frm_root new_ctx
361 conf.has_backward <- true;
364 | (a,_)::[] -> a, vpush q_root []
368 let t1 = ?< q_frm_root>< (test,is_last && (not existential)) >=>
369 (if is_last then Ata.true_ else (_l dir) ** q_dst) *& (_l dir) ** q_self in
370 add_trans num conf.tr t1;
371 [ q_dst ], q_dst, vpush q_frm_root new_ctx
375 (* todo change everything to Ptset *)
376 (Ptset.elements (Ptset.union p_st (Ptset.from_list new_st)),
380 and compile_path ?(existential=false) annot_path config q_src states idx ctx_path =
382 (fun (a_st,a_dst,anc_st,par_st,pre_st,ctx_path,num,has_backward) (step,dir) ->
383 let add_states,new_dst,new_ctx =
384 compile_step ~existential:existential config a_dst dir ctx_path step num
386 let new_states = Ptset.union (Ptset.from_list add_states) a_st in
387 let nanc_st,npar_st,npre_st,new_bw =
389 |PrecedingSibling,_,_ -> anc_st,par_st,Ptset.add a_dst pre_st,true
390 |(Parent|Ancestor|AncestorOrSelf),_,_ -> Ptset.add a_dst anc_st,par_st,pre_st,true
391 | _ -> anc_st,par_st,pre_st,has_backward
393 new_states,new_dst,nanc_st,npar_st,npre_st,new_ctx, num+1,new_bw
395 (states, q_src, Ptset.empty,Ptset.empty,Ptset.empty, ctx_path,idx, false )
398 and binop_ conf q_src idx ctx_path dir pred p1 p2 f ddst =
399 let a_st1,anc_st1,par_st1,pre_st1,idx1,f1 =
400 compile_pred conf q_src idx ctx_path dir p1 ddst in
401 let a_st2,anc_st2,par_st2,pre_st2,idx2,f2 =
402 compile_pred conf q_src idx1 ctx_path dir p2 ddst
404 Ptset.union a_st1 a_st2,
405 Ptset.union anc_st1 anc_st2,
406 Ptset.union par_st1 par_st2,
407 Ptset.union pre_st1 pre_st2,
410 and compile_pred conf q_src idx ctx_path dir pred qdst =
413 binop_ conf q_src idx ctx_path dir pred p1 p2 (( +| )) qdst
415 binop_ conf q_src idx ctx_path dir pred p1 p2 (( *& )) qdst
416 | Expr e -> compile_expr conf Ptset.empty q_src idx ctx_path dir e qdst
418 let a_st,anc_st,par_st,pre_st,idx,f =
419 compile_pred conf q_src idx ctx_path dir p qdst
420 in a_st,anc_st,par_st,pre_st,idx, Ata.not_ f
422 and compile_expr conf states q_src idx ctx_path dir e qdst =
425 let q = Ata.mk_state () in
426 let annot_path = match p with Relative(r) -> dirannot (List.rev r) | _ -> assert false in
427 let a_st,a_dst,anc_st,par_st,pre_st,_,idx,has_backward =
428 compile_path ~existential:true annot_path conf q states idx ctx_path
430 let ret_dir = match annot_path with
431 | ((FollowingSibling,_,_),_)::_ -> `Right
434 let _ = match annot_path with
435 | (((Parent|Ancestor|AncestorOrSelf),_,_),_)::_ -> conf.final_state <- Ptset.add qdst conf.final_state
438 (a_st,anc_st,par_st,pre_st,idx, ((ret_dir) ** q))
439 | True -> states,Ptset.empty,Ptset.empty,Ptset.empty,idx,Ata.true_
440 | False -> states,Ptset.empty,Ptset.empty,Ptset.empty,idx,Ata.false_
444 and dirannot = function
447 | p::(((FollowingSibling),_,_)::_ as l) -> (p,`Right)::(dirannot l)
448 | p::l -> (p,`Left) :: (dirannot l)
454 | Relative(steps) -> steps
455 | AbsoluteDoS(steps) -> steps@[(DescendantOrSelf,TagSet.node,Expr(True))]
457 let steps = List.rev steps in
458 let dirsteps = dirannot steps in
459 let config = { st_root = Ata.mk_state();
460 st_univ = Ata.mk_state();
461 final_state = Ptset.empty;
462 st_from_root = Ata.mk_state();
463 has_backward = false;
464 tr_parent_loop = Hashtbl.create 5;
465 tr = Hashtbl.create 5;
466 tr_aux = Hashtbl.create 5;
469 let q0 = Ata.mk_state() in
470 let states = Ptset.from_list [config.st_univ;config.st_root]
473 (* add_trans num config.tr_aux (mk_star config.st_from_root `Left config.st_univ config.st_from_root);
474 add_trans num config.tr_aux (mk_star config.st_from_root `Left config.st_from_root config.st_univ);
475 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);
477 let a_st,a_dst,anc_st,par_st,pre_st,_,_,has_backward =
478 compile_path dirsteps config q0 states 0 [(config.st_root,[]) ]
481 ?< (config.st_root) >< (TagSet.star,false) >=>
482 (`Left** q0) *& (if config.has_backward then `Left ** config.st_from_root else Ata.true_)
484 add_trans num config.tr fst_tr;
485 if config.has_backward then begin
486 add_trans num config.tr_aux
487 (?< (config.st_from_root) >< (TagSet.star,false) >=> `Left ** config.st_from_root +|
488 `Right ** config.st_from_root);
489 add_trans num config.tr_aux
490 (?< (config.st_from_root) >< (TagSet.cup TagSet.pcdata TagSet.attribute,false) >=>
491 `Right ** config.st_from_root);
494 let phi = Hashtbl.create 37 in
495 let fadd = fun _ (_,l) -> List.iter (fun (s,t,m,f) -> Hashtbl.add phi (t,s) (m,f)) l in
496 Hashtbl.iter (fadd) config.tr;
497 Hashtbl.iter (fadd) config.tr_aux;
498 Hashtbl.iter (fadd) config.tr_parent_loop;
500 let s = Ptset.union anc_st (Ptset.from_list [a_dst;config.st_univ])
501 in if has_backward then s else Ptset.add config.st_from_root s
502 in { Ata.id = Oo.id (object end);
504 Ata.init = Ptset.singleton config.st_root;
505 Ata.final = Ptset.union anc_st config.final_state;
506 Ata.universal = Ptset.union anc_st config.final_state;
508 Ata.delta = Hashtbl.create 17;
509 Ata.properties = Hashtbl.create 0;