-(******************************************************************************)
-(* SXSI : XPath evaluator *)
-(* Kim Nguyen (Kim.Nguyen@nicta.com.au) *)
-(* Copyright NICTA 2008 *)
-(* Distributed under the terms of the LGPL (see LICENCE) *)
-(******************************************************************************)
-module type S =
-sig
- module S : Set.S
- type t = private Finite of S.t | CoFinite of S.t
- exception InfiniteTagSet
- val empty : t
- val any : t
- val is_empty : t -> bool
- val is_any : t -> bool
- val is_finite : t -> bool
- val singleton : S.elt -> t
- val mem : S.elt -> t -> bool
- val add : S.elt -> t -> t
- val remove : S.elt -> t -> t
- val cup : t -> t -> t
- val cap : t -> t -> t
- val diff : t -> t -> t
- val neg : t -> t
- val compare : t -> t -> int
- val subset : t -> t -> bool
- val kind_split : t list -> t * t
- val fold : (S.elt -> 'a -> 'a) -> t -> 'a -> 'a
- val for_all : (S.elt -> bool) -> t -> bool
- val exists : (S.elt -> bool) -> t -> bool
- val filter : (S.elt -> bool) -> t -> S.t
- val partition : (S.elt -> bool) -> t -> S.t * S.t
- val cardinal : t -> int
- val elements : t -> S.elt list
- val from_list : S.elt list -> t
- val choose : t -> S.elt
-end
+include FiniteCofinite.Make(Ptset)
-module Make (Symbol : Set.OrderedType) =
-struct
- module S = Set.Make(Symbol)
- type t = Finite of S.t | CoFinite of S.t
-
- exception InfiniteTagSet
-
- let empty = Finite S.empty
- let any = CoFinite S.empty
-
- let is_empty = function
- Finite s when S.is_empty s -> true
- | _ -> false
- let is_any = function
- CoFinite s when S.is_empty s -> true
- | _ -> false
- let is_finite = function
- | Finite _ -> true | _ -> false
-
- let mem x = function Finite s -> S.mem x s
- | CoFinite s -> not (S.mem x s)
-
- let singleton x = Finite (S.singleton x)
- let add e = function
- | Finite s -> Finite (S.add e s)
- | CoFinite s -> CoFinite (S.remove e s)
- let remove e = function
- | Finite s -> Finite (S.remove e s)
- | CoFinite s -> CoFinite (S.add e s)
-
- let cup s t = match (s,t) with
- | Finite s, Finite t -> Finite (S.union s t)
- | CoFinite s, CoFinite t -> CoFinite ( S.inter s t)
- | Finite s, CoFinite t -> CoFinite (S.diff t s)
- | CoFinite s, Finite t-> CoFinite (S.diff s t)
-
- let cap s t = match (s,t) with
- | Finite s, Finite t -> Finite (S.inter s t)
- | CoFinite s, CoFinite t -> CoFinite (S.union s t)
- | Finite s, CoFinite t -> Finite (S.diff s t)
- | CoFinite s, Finite t-> Finite (S.diff t s)
-
- let diff s t = match (s,t) with
- | Finite s, Finite t -> Finite (S.diff s t)
- | Finite s, CoFinite t -> Finite(S.inter s t)
- | CoFinite s, Finite t -> CoFinite(S.union t s)
- | CoFinite s, CoFinite t -> Finite (S.diff t s)
-
- let neg = function
- | Finite s -> CoFinite s
- | CoFinite s -> Finite s
-
- let compare s t = match (s,t) with
- | Finite s , Finite t -> S.compare s t
- | CoFinite s , CoFinite t -> S.compare s t
- | Finite _, CoFinite _ -> -1
- | CoFinite _, Finite _ -> 1
-
- let subset s t = match (s,t) with
- | Finite s , Finite t -> S.subset s t
- | CoFinite s , CoFinite t -> S.subset t s
- | Finite s, CoFinite t -> S.is_empty (S.inter s t)
- | CoFinite _, Finite _ -> false
-
- (* given a list l of type t list,
- returns two sets (f,c) where :
- - f is the union of all the finite sets of l
- - c is the union of all the cofinite sets of l
- - f and c are disjoint
- Invariant : cup f c = List.fold_left cup empty l
-
- We treat the CoFinite part explicitely :
- *)
-
- let kind_split l =
-
- let rec next_finite_cofinite facc cacc = function
- | [] -> Finite facc, CoFinite (S.diff cacc facc)
- | Finite s ::r -> next_finite_cofinite (S.union s facc) cacc r
- | CoFinite _ ::r when S.is_empty cacc -> next_finite_cofinite facc cacc r
- | CoFinite s ::r -> next_finite_cofinite facc (S.inter cacc s) r
- in
- let rec first_cofinite facc = function
- | [] -> empty,empty
- | Finite s :: r-> first_cofinite (S.union s facc) r
- | CoFinite s :: r -> next_finite_cofinite facc s r
- in
- first_cofinite S.empty l
-
- let fold f t a = match t with
- | Finite s -> S.fold f s a
- | CoFinite _ -> raise InfiniteTagSet
-
- let for_all f = function
- | Finite s -> S.for_all f s
- | CoFinite _ -> raise InfiniteTagSet
-
- let exists f = function
- | Finite s -> S.exists f s
- | CoFinite _ -> raise InfiniteTagSet
-
- let filter f = function
- | Finite s -> S.filter f s
- | CoFinite _ -> raise InfiniteTagSet
-
- let partition f = function
- | Finite s -> S.partition f s
- | CoFinite _ -> raise InfiniteTagSet
-
- let cardinal = function
- | Finite s -> S.cardinal s
- | CoFinite _ -> raise InfiniteTagSet
-
- let elements = function
- | Finite s -> S.elements s
- | CoFinite _ -> raise InfiniteTagSet
-
- let from_list l =
- Finite(List.fold_left (fun x a -> S.add a x ) S.empty l)
-
- let choose = function
- Finite s -> S.choose s
- | _ -> raise InfiniteTagSet
-
-end
-
-module Xml =
-struct
- include Make(Tag)
- let star = diff any (from_list [ Tag.pcdata; Tag.attribute ])
- let node = remove Tag.attribute any
- let pcdata = singleton Tag.pcdata
- let attribute = singleton Tag.attribute
-end
+let tag t = singleton t
+let pcdata = singleton Tag.pcdata
+let attribute = singleton Tag.attribute
+let star = diff any (cup pcdata attribute)
+let node = neg attribute
(* Copyright NICTA 2008 *)
(* Distributed under the terms of the LGPL (see LICENCE) *)
(******************************************************************************)
-
-
INCLUDE "debug.ml";;
#load "pa_extend.cmo";;
-
module Ast =
struct
-
-type path = Absolute of step list | AbsoluteDoS of step list| Relative of step list
-and step = axis*test*predicate
-and axis = Self | Attribute | Child | Descendant | DescendantOrSelf | FollowingSibling
- | Parent
-
-and test = TagSet.Xml.t
-
-and predicate = Or of predicate*predicate
- | And of predicate*predicate
- | Not of predicate
- | Expr of expression
-and expression = Path of path
- | Function of string*expression list
- | Int of int
- | String of string
- | True | False
-type t = path
+ (* The steps are in reverse order !!!! *)
+ type path = Absolute of step list | AbsoluteDoS of step list| Relative of step list
+ and step = axis*test*predicate
+ and axis = Self | Attribute | Child | Descendant | DescendantOrSelf | FollowingSibling
+ | Parent | Ancestor | AncestorOrSelf | PrecedingSibling | Preceding | Following
+
+ and test = TagSet.t
+
+ and predicate = Or of predicate*predicate
+ | And of predicate*predicate
+ | Not of predicate
+ | Expr of expression
+ and expression = Path of path
+ | Function of string*expression list
+ | Int of int
+ | String of string
+ | True | False
+ type t = path
+
-let pp fmt = Format.fprintf fmt
-let print_list printer fmt sep l =
- match l with
- [] -> ()
- | [e] -> printer fmt e
- | e::es -> printer fmt e; List.iter (fun x -> pp fmt sep;printer fmt x) es
-
-
-let rec print fmt p =
- let l = match p with
- | Absolute l -> pp fmt "/"; l
- | AbsoluteDoS l -> pp fmt "/";
- print_step fmt (DescendantOrSelf,TagSet.Xml.node,Expr True);
- pp fmt "/"; l
- | Relative l -> l
- in
- print_list print_step fmt "/" (List.rev l)
-and print_step fmt (axis,test,predicate) =
+
+ let pp fmt = Format.fprintf fmt
+ let print_list printer fmt sep l =
+ match l with
+ [] -> ()
+ | [e] -> printer fmt e
+ | e::es -> printer fmt e; List.iter (fun x -> pp fmt sep;printer fmt x) es
+
+
+ let rec print fmt p =
+ let l = match p with
+ | Absolute l -> pp fmt "/"; l
+ | AbsoluteDoS l -> pp fmt "/";
+ print_step fmt (DescendantOrSelf,TagSet.node,Expr True);
+ pp fmt "/"; l
+ | Relative l -> l
+ in
+ print_list print_step fmt "/" (List.rev l)
+ and print_step fmt (axis,test,predicate) =
print_axis fmt axis;pp fmt "::";print_test fmt test;
- pp fmt "["; print_predicate fmt predicate; pp fmt "]"
-and print_axis fmt a = pp fmt "%s" (match a with
- Self -> "self"
- | Child -> "child"
- | Descendant -> "descendant"
- | DescendantOrSelf -> "descendant-or-self"
- | FollowingSibling -> "following-sibling"
- | Attribute -> "attribute"
- | Parent -> "parent")
-and print_test fmt ts =
- try
- pp fmt "%s" (List.assoc ts
- [ (TagSet.Xml.pcdata,"text()"); (TagSet.Xml.node,"node()");
- (TagSet.Xml.star),"*"])
- with
- Not_found -> pp fmt "%s"
- (if TagSet.Xml.is_finite ts
- then Tag.to_string (TagSet.Xml.choose ts)
- else "<INFINITE>")
-
-and print_predicate fmt = function
- | Or(p,q) -> print_predicate fmt p; pp fmt " or "; print_predicate fmt q
- | And(p,q) -> print_predicate fmt p; pp fmt " and "; print_predicate fmt q
- | Not p -> pp fmt "not "; print_predicate fmt p
- | Expr e -> print_expression fmt e
-
-and print_expression fmt = function
- | Path p -> print fmt p
- | Function (f,l) -> pp fmt "%s(" f;print_list print_expression fmt "," l;pp fmt ")"
- | Int i -> pp fmt "%i" i
- | String s -> pp fmt "\"%s\"" s
- | t -> pp fmt "%b" (t== True)
+ pp fmt "["; print_predicate fmt predicate; pp fmt "]"
+ and print_axis fmt a = pp fmt "%s" (match a with
+ Self -> "self"
+ | Child -> "child"
+ | Descendant -> "descendant"
+ | DescendantOrSelf -> "descendant-or-self"
+ | FollowingSibling -> "following-sibling"
+ | Attribute -> "attribute"
+ | Ancestor -> "ancestor"
+ | AncestorOrSelf -> "ancestor-or-self"
+ | PrecedingSibling -> "preceding-sibling"
+ | Parent -> "parent"
+ | _ -> assert false
+ )
+ and print_test fmt ts =
+ try
+ pp fmt "%s" (List.assoc ts
+ [ (TagSet.pcdata,"text()"); (TagSet.node,"node()");
+ (TagSet.star),"*"])
+ with
+ Not_found -> pp fmt "%s"
+ (if TagSet.is_finite ts
+ then Tag.to_string (TagSet.choose ts)
+ else "<INFINITE>")
+
+ and print_predicate fmt = function
+ | Or(p,q) -> print_predicate fmt p; pp fmt " or "; print_predicate fmt q
+ | And(p,q) -> print_predicate fmt p; pp fmt " and "; print_predicate fmt q
+ | Not p -> pp fmt "not "; print_predicate fmt p
+ | Expr e -> print_expression fmt e
+ and print_expression fmt = function
+ | Path p -> print fmt p
+ | Function (f,l) -> pp fmt "%s(" f;print_list print_expression fmt "," l;pp fmt ")"
+ | Int i -> pp fmt "%i" i
+ | String s -> pp fmt "\"%s\"" s
+ | t -> pp fmt "%b" (t== True)
+
end
module Parser =
struct
exception Error of Gram.Loc.t*string
let test_of_keyword t loc =
match t with
- | "text()" -> TagSet.Xml.pcdata
- | "node()" -> TagSet.Xml.node
- | "*" -> TagSet.Xml.star
- | "and" | "not" | "or" -> TagSet.Xml.singleton (Tag.tag t)
+ | "text()" -> TagSet.pcdata
+ | "node()" -> TagSet.node
+ | "*" -> TagSet.star
+ | "and" | "not" | "or" -> TagSet.singleton (Tag.tag t)
| _ -> raise (Error(loc,"Invalid test name "^t ))
let axis_to_string a = let r = Format.str_formatter in
;
slist: [
- [ l = slist ;"/"; s = step -> s::l ]
-| [ l = slist ; "//"; s = step -> s::(DescendantOrSelf,TagSet.Xml.node,Expr True)::l]
-| [ s = step -> [ s ] ]
+ [ l = slist ;"/"; s = step -> s@l ]
+| [ l = slist ; "//"; s = step -> s@[(DescendantOrSelf, TagSet.node,Expr True)]@l]
+| [ s = step -> s ]
];
step : [
if OPT is None then this is a child::descendant if not, this is a real axis name
*)
[ axis = axis ; o = OPT ["::" ; t = test -> t ] ; p = top_pred ->
- match o with
- | Some(t) -> (axis,t,p)
- | None -> (Child,TagSet.Xml.singleton (Tag.tag (axis_to_string axis)),p) ]
+ let a,t,p =
+ match o with
+ | Some(t) -> (axis,t,p)
+ | None -> (Child,TagSet.singleton (Tag.tag (axis_to_string axis)),p)
+ in match a with
+ | Following -> [ (DescendantOrSelf,t,p);
+ (FollowingSibling,TagSet.star,Expr(True));
+ (Ancestor,TagSet.star,Expr(True)) ]
+
+ | Preceding -> [ (DescendantOrSelf,t,p);
+ (PrecedingSibling,TagSet.star,Expr(True));
+ (Ancestor,TagSet.star,Expr(True)) ]
+ | _ -> [ a,t,p ]
+
+]
-| [ "." ; p = top_pred -> (Self,TagSet.Xml.node,p) ]
-| [ test = test; p = top_pred -> (Child,test, p) ]
+| [ "." ; p = top_pred -> [(Self,TagSet.node,p)] ]
+| [ ".." ; p = top_pred -> [(Parent,TagSet.star,p)] ]
+| [ test = test; p = top_pred -> [(Child,test, p)] ]
| [ att = ATT ; p = top_pred ->
match att with
- | "*" -> (Attribute,TagSet.Xml.star,p)
- | _ -> (Attribute, TagSet.Xml.singleton (Tag.tag att) ,p )]
+ | "*" -> [(Attribute,TagSet.star,p)]
+ | _ -> [(Attribute, TagSet.singleton (Tag.tag att) ,p )]]
]
;
top_pred : [
axis : [
[ "self" -> Self | "child" -> Child | "descendant" -> Descendant
| "descendant-or-self" -> DescendantOrSelf
+ | "ancestor-or-self" -> AncestorOrSelf
| "following-sibling" -> FollowingSibling
| "attribute" -> Attribute
| "parent" -> Parent
+ | "ancestor" -> Ancestor
+ | "preceding-sibling" -> PrecedingSibling
+ | "preceding" -> Preceding
+ | "following" -> Following
]
];
test : [
[ s = KWD -> test_of_keyword s _loc ]
-| [ t = TAG -> TagSet.Xml.singleton (Tag.tag t) ]
+| [ t = TAG -> TagSet.singleton (Tag.tag t) ]
];
let parse = Gram.parse_string query (Ulexer.Loc.mk "<string>")
end
-module Functions = struct
-
- type value = [ `NodeSet of Automaton.BST.t
- | `Int of int | `String of string
- | `Bool of bool | `True | `False ]
-
- type expr = [ value | `Call of (string*(expr list))
- | `Auto of Automaton.t | `Contains of expr list ]
-
- let count = function [`NodeSet(s) ] -> `Int(Automaton.BST.cardinal s)
- | _ -> failwith "count"
+module Compile = struct
+open Ast
+
+type config = { st_root : Ata.state; (* state matching the root element (initial state) *)
+ st_univ : Ata.state; (* universal state accepting anything *)
+ st_from_root : Ata.state; (* state chaining the root and the current position *)
+ mutable final_state : Ptset.t;
+ mutable has_backward: bool;
+ (* To store transitions *)
+ (* Key is the from state, (i,l) -> i the number of the step and l the list of trs *)
+ tr_parent_loop : (Ata.state,int*(Ata.transition list)) Hashtbl.t;
+ tr : (Ata.state,int*(Ata.transition list)) Hashtbl.t;
+ tr_aux : (Ata.state,int*(Ata.transition list)) Hashtbl.t;
+ }
+let dummy_conf = { st_root = -1;
+ st_univ = -1;
+ st_from_root = -1;
+ final_state = Ptset.empty;
+ has_backward = false;
+ tr_parent_loop = Hashtbl.create 0;
+ tr = Hashtbl.create 0;
+ tr_aux = Hashtbl.create 0;
+ }
+
+
+let _r =
+ function (`Left|`Last) -> `Right
+ | `Right -> `Left
+let _l = function (`Left|`Last) -> `Left
+ | `Right -> `Right
+
+
+open Ata.Transitions
+
+
+let add_trans num htr ((q,_,_,_) as tr) =
+ try
+ let (i,ltr) = Hashtbl.find htr q in
+ if List.exists (Ata.equal_trans tr) ltr
+ then ()
+ else Hashtbl.replace htr q (i,(tr::ltr))
+ with
+ | Not_found -> Hashtbl.add htr q (num,[tr])
+
+exception Exit of Ata.state * Ata.transition list
+let rec replace s f =
+ match f.Ata.pos with
+ | Ata.Atom(_,b,q,_) when q = s -> if b then Ata.true_ else Ata.false_
+ | Ata.Or(f1,f2) -> (replace s f1) +| (replace s f2)
+ | Ata.And(f1,f2) -> (replace s f1) *& (replace s f2)
+ | _ -> f
- let contains_old = function [`NodeSet(s) ; `String(str) ] ->
- `Bool(Automaton.BST.exists (fun tree -> Tree.Binary.contains_old tree str
- ) s)
- | _ -> failwith "contains_old"
-
- let equal = function [ `Int i; `Int j ] -> `Bool (i == j)
- |_ -> failwith "equal"
-
- let globals : (string*(value list -> value)) list = [
-
- ("count",count);
- ("equal",equal);
- ("contains_old",contains_old);
-]
-
- let text t = Tree.Binary.string (Tree.Binary.left t)
+let or_self conf old_dst q_src q_dst dir test pred mark =
+ try
+ let (num,l) = Hashtbl.find conf.tr q_src in
+ let l2 = List.fold_left (fun acc (q,t,m,f) ->
+ (q,TagSet.cap t test,mark,
+ (if mark then replace old_dst f else f)
+ *& pred *&
+ (if mark then Ata.true_ else (_l dir) ** q_dst))::acc)
+ l l
+ in Hashtbl.replace conf.tr q_src (num,l2)
+ with Not_found -> ()
+
+
+let nst = Ata.mk_state
+let att_or_str = TagSet.add Tag.pcdata TagSet.attribute
+let vpush x y = (x,[]) :: y
+let hpush x y =
+ match y with
+ | (z,r)::l -> (z,x::r) ::l
+ | _ -> assert false
+
+let vpop = function
+ (x,_)::r -> x,r
+ | _ -> assert false
+
+let hpop = function
+ | (x,z::y) ::r -> z,(x,y)::r
+ | _-> assert false
+
+let rec compile_step ?(existential=false) conf q_src dir ctx_path step num =
+ let ex = existential in
+ let axis,test,pred = step in
+ let is_last = dir = `Last in
+ let { st_root = q_root;
+ st_univ = q_univ;
+ st_from_root = q_frm_root } = conf
+ in
+ let q_dst = Ata.mk_state() in
+ let p_st, p_anc, p_par, p_pre, p_num, p_f =
+ compile_pred conf q_src num ctx_path dir pred q_dst
+ in
+ let new_st,new_dst, new_ctx =
+ match axis with
+ | Child | FollowingSibling | Descendant | DescendantOrSelf ->
+ let axis =
+ if axis = DescendantOrSelf
+ then begin
+ or_self conf q_src (fst(vpop ctx_path)) q_dst dir test p_f (is_last && not(existential));
+ Descendant end
+ else axis
+ in
+ let t1 = ?< q_src><(test, is_last && not(existential))>=>
+ p_f *& (if is_last then Ata.true_ else (_l dir) ** q_dst) in
+ let t2 = ?< q_src><(TagSet.star, false)>=>
+ (if axis=Descendant then `Left ** q_src +|`Right ** q_src
+ else `Right ** q_src) in
+ let tsa = ?< q_src><(att_or_str, false)>=> `Right ** q_src
+ in
+ add_trans num conf.tr t1;
+ add_trans num conf.tr_aux t2;
+ add_trans num conf.tr_aux tsa;
+ [q_dst], q_dst,
+ (if axis = FollowingSibling then hpush q_src ctx_path else vpush q_src ctx_path)
+
- let rec eval_expr tree (e:expr) : value = match e with
- | `Call (f,args) -> (List.assoc f globals) (List.map (eval_expr tree) args)
- | `Auto(a) -> `NodeSet(ignore (Automaton.BottomUp.accept a tree);
- a.Automaton.result)
- | `Contains(args) ->
- begin
- match args with
- [ `Auto(a); `String(s) ] ->
- let docs = try
- Hashtbl.find a.Automaton.contains s
- with
- | Not_found ->
- let r = Tree.Binary.contains tree s
- in
- (* Tree.Binary.DocIdSet.iter (fun id ->
- Printf.eprintf "%s matches %s\n%!" (Tree.Binary.get_string tree id) s) r; *)
-
- Hashtbl.add a.Automaton.contains s r;r
- in
- let _ = Automaton.BottomUp.accept ~strings:(Some docs) a tree
- in `NodeSet(a.Automaton.result)
- | _ -> failwith "contains invalid"
- end
- | #value as x -> x
-
- let truth_value =
- function `NodeSet s -> not (Automaton.BST.is_empty s)
- |`Bool(b) -> b
- | _ -> failwith "truth_value"
-
-end
-module Compile = struct
- open Ast
- open Automaton
-
-
- type direction = Left | Right | Final
- let (==>) a (b,c,d) = Transition.Label(a,b,c,d)
- let (@@) b (c,d) = (b,c,d)
-
- let star = TagSet.Xml.star
- let any = TagSet.Xml.any
- let notstar = TagSet.Xml.add Tag.pcdata (TagSet.Xml.add Tag.attribute TagSet.Xml.empty)
- let swap dir a b = match dir with
- | Left | Final -> (a,b)
- | Right -> (b,a)
-
- let split_dest q l =
- let rec aux ((qacc,nqacc) as acc) = function
- | [] -> acc
- | t::r ->
- aux (if State.equal (Transition.dest1 t) q
- || State.equal (Transition.dest2 t) q
- then t::qacc , nqacc
- else qacc , (t::nqacc)) r
- in
- aux ([],[]) l
-
-
- let mk_tag_t dir s ts q1 q2 = (s==> ts @@ (swap dir q1 q2));;
- let mk_self_trs ts acc l =
- List.fold_left
- (fun acc t ->
- let s = Transition.source t in
- let d1 = Transition.dest1 t in
- let d2 = Transition.dest2 t in
- let tself = (s ==> ts @@ (d1,d2)) in
- (Transition.cap t tself)::acc ) (acc) l
-
- let mk_pred_trs f acc l =
- List.fold_left
- (fun acc t ->
- let s = Transition.source t in
- let d1 = Transition.dest1 t in
- let d2 = Transition.dest2 t in
- let tself = Transition.External(s,f,d1,d2) in
- (Transition.cap t tself)::acc ) (acc) l
-
- let mk_dself_trs q' ts acc l =
- List.fold_left
- (fun acc t ->
- let t',s,d2 = match t with
- | Transition.Label(s,ts,_,d2) -> Transition.Label(s,ts,q',d2),s,d2
- | Transition.External (s,f,_,d2) -> Transition.External(s,f,q',d2),s,d2
+ | Attribute ->
+ let q_dstreal = Ata.mk_state() in
+ (* attributes are always the first child *)
+ let t1 = ?< q_src><(TagSet.attribute,false)>=>
+ `Left ** q_dst in
+ let t2 = ?< q_dst><(test, is_last && not(existential))>=>
+ if is_last then Ata.true_ else `Left ** q_dstreal in
+ let tsa = ?< q_dst><(TagSet.star, false)>=> `Right ** q_dst
+ in
+ add_trans num conf.tr t1;
+ add_trans num conf.tr_aux t2;
+ add_trans num conf.tr_aux tsa;
+ [q_dst;q_dstreal], q_dstreal,
+ ctx_path
+
+ | Ancestor | AncestorOrSelf ->
+ conf.has_backward <- true;
+ let up_states, new_ctx =
+ List.map (fst) ctx_path, (vpush q_root [])
+ in
+ let _ = if axis = AncestorOrSelf then
+ or_self conf q_src (fst(vpop ctx_path)) q_dst dir test p_f (is_last && not(existential));
+ in
+ let fc = List.fold_left (fun f s -> ((_l dir)**s +|f)) Ata.false_ up_states
+ in
+ let t1 = ?< q_frm_root><(test,is_last && (not existential) )>=>
+ (if is_last then Ata.true_ else (_l dir) ** q_dst) *& fc in
+ add_trans num conf.tr t1;
+ [q_dst ], q_dst, vpush q_frm_root new_ctx
+
+ | Parent ->
+ conf.has_backward <- true;
+ let q_self,new_ctx =
+ match ctx_path with
+ | (a,_)::[] -> a, vpush q_root []
+ | (a,_)::r -> a, r
+ | _ -> assert false
+ in
+ let t1 = ?< q_frm_root>< (test,is_last && (not existential)) >=>
+ (if is_last then Ata.true_ else (_l dir) ** q_dst) *& (_l dir) ** q_self in
+ add_trans num conf.tr t1;
+ [ q_dst ], q_dst, vpush q_frm_root new_ctx
+
+ | _ -> assert false
+ in
+ (* todo change everything to Ptset *)
+ (Ptset.elements (Ptset.union p_st (Ptset.from_list new_st)),
+ new_dst,
+ new_ctx)
+
+and compile_path ?(existential=false) annot_path config q_src states idx ctx_path =
+ List.fold_left
+ (fun (a_st,a_dst,anc_st,par_st,pre_st,ctx_path,num,has_backward) (step,dir) ->
+ let add_states,new_dst,new_ctx =
+ compile_step ~existential:existential config a_dst dir ctx_path step num
+ in
+ let new_states = Ptset.union (Ptset.from_list add_states) a_st in
+ let nanc_st,npar_st,npre_st,new_bw =
+ match step with
+ |PrecedingSibling,_,_ -> anc_st,par_st,Ptset.add a_dst pre_st,true
+ |(Parent|Ancestor|AncestorOrSelf),_,_ -> Ptset.add a_dst anc_st,par_st,pre_st,true
+ | _ -> anc_st,par_st,pre_st,has_backward
in
- let tself = (s ==> ts @@ (q',d2)) in
- (Transition.cap t' tself)::acc ) (acc) l
-
- let from_list = List.fold_left (fun acc e -> SSet.add e acc) SSet.empty
-
- let dir = function (FollowingSibling,_,_) -> Right
- | _ -> Left
-
- let rev_map_dir p =
- let rec map_dir (d,acc) = function
- | [] -> acc
- | s::r -> map_dir ((dir s),(s,d)::acc) r
- in
- let l =
- match p with
- | Absolute p
- | Relative p -> map_dir (Final,[]) p
- | AbsoluteDoS p ->
- let l = (map_dir (Final,[]) p)
- in ((DescendantOrSelf,TagSet.Xml.node,Expr True),dir (fst(List.hd l)))::l
- in ((Child,TagSet.Xml.node,Expr True),dir (fst(List.hd l)))::l
-
-
- let rec compile_step q dir trs final initial ignore (axis,test,pred) =
- let q' = State.mk() in
- let trs,final,initial = match axis,test with
- | Self,ts ->
- let tchange,tkeep = split_dest q trs in
- let trs' = mk_self_trs ts tkeep tchange in
- (trs',q::final,initial)
-
- | Child,ts ->
- (mk_tag_t dir q ts q' ignore) ::( q==> any @@ (ignore,q))::trs, q'::final,initial
-
- | Descendant,ts ->
- (mk_tag_t dir q ts q' ignore) ::
- (q==> star @@ (q,q))::(q==> notstar @@ (ignore,q))::trs,q'::final,initial
-
- | DescendantOrSelf,ts ->
- let tchange,tkeep = split_dest q trs in
- let trs' = mk_dself_trs q' ts trs tchange in
- (mk_tag_t dir q ts q' ignore) ::
- (q==> star @@ (q,q))::(q==> notstar @@ (ignore,q))::trs',q'::final,initial
-
- | FollowingSibling,ts ->
- (mk_tag_t dir q ts q' ignore) :: (q ==> any @@ (ignore,q))::trs,q'::final,initial
-
- (* q' is not returned and thus not added to the set of final states.
- It's ok since we should never be in a final state on a node
- <@> *)
-
- | Attribute,ts -> let q'' = State.mk() in
- (mk_tag_t Left q (TagSet.Xml.attribute) q' ignore)::
- (mk_tag_t Left q' (ts) q'' ignore)::( q==> any @@ (ignore,q))::trs, q''::q'::final,initial
-
- | Parent,ts -> let q'' = List.hd initial in
- (mk_tag_t Left q' (star) q q')::
- ( q'' ==> ts @@ (q',q''))::
- ( q'' ==> star @@ (q'',q''))::
- ( q'' ==> notstar @@ (ignore,q''))::trs,q'::q''::final,q''::initial
+ new_states,new_dst,nanc_st,npar_st,npre_st,new_ctx, num+1,new_bw
+ )
+ (states, q_src, Ptset.empty,Ptset.empty,Ptset.empty, ctx_path,idx, false )
+ annot_path
+
+and binop_ conf q_src idx ctx_path dir pred p1 p2 f ddst =
+ let a_st1,anc_st1,par_st1,pre_st1,idx1,f1 =
+ compile_pred conf q_src idx ctx_path dir p1 ddst in
+ let a_st2,anc_st2,par_st2,pre_st2,idx2,f2 =
+ compile_pred conf q_src idx1 ctx_path dir p2 ddst
+ in
+ Ptset.union a_st1 a_st2,
+ Ptset.union anc_st1 anc_st2,
+ Ptset.union par_st1 par_st2,
+ Ptset.union pre_st1 pre_st2,
+ idx2, (f f1 f2)
+
+and compile_pred conf q_src idx ctx_path dir pred qdst =
+ match pred with
+ | Or(p1,p2) ->
+ binop_ conf q_src idx ctx_path dir pred p1 p2 (( +| )) qdst
+ | And(p1,p2) ->
+ binop_ conf q_src idx ctx_path dir pred p1 p2 (( *& )) qdst
+ | Expr e -> compile_expr conf Ptset.empty q_src idx ctx_path dir e qdst
+ | Not(p) ->
+ let a_st,anc_st,par_st,pre_st,idx,f =
+ compile_pred conf q_src idx ctx_path dir p qdst
+ in a_st,anc_st,par_st,pre_st,idx, Ata.not_ f
+
+and compile_expr conf states q_src idx ctx_path dir e qdst =
+ match e with
+ | Path (p) ->
+ let q = Ata.mk_state () in
+ let annot_path = match p with Relative(r) -> dirannot (List.rev r) | _ -> assert false in
+ let a_st,a_dst,anc_st,par_st,pre_st,_,idx,has_backward =
+ compile_path ~existential:true annot_path conf q states idx ctx_path
+ in
+ let ret_dir = match annot_path with
+ | ((FollowingSibling,_,_),_)::_ -> `Right
+ | _ -> `Left
+ in
+ let _ = match annot_path with
+ | (((Parent|Ancestor|AncestorOrSelf),_,_),_)::_ -> conf.final_state <- Ptset.add qdst conf.final_state
+ | _ -> ()
+ in
+ (a_st,anc_st,par_st,pre_st,idx, ((ret_dir) ** q))
+ | True -> states,Ptset.empty,Ptset.empty,Ptset.empty,idx,Ata.true_
+ | False -> states,Ptset.empty,Ptset.empty,Ptset.empty,idx,Ata.false_
+ | _ -> assert false
+
+
+and dirannot = function
+ [] -> []
+ | [p] -> [p,`Last]
+ | p::(((FollowingSibling),_,_)::_ as l) -> (p,`Right)::(dirannot l)
+ | p::l -> (p,`Left) :: (dirannot l)
+
+let compile path =
+ let steps =
+ match path with
+ | Absolute(steps)
+ | Relative(steps) -> steps
+ | AbsoluteDoS(steps) -> steps@[(DescendantOrSelf,TagSet.node,Expr(True))]
+ in
+ let steps = List.rev steps in
+ let dirsteps = dirannot steps in
+ let config = { st_root = Ata.mk_state();
+ st_univ = Ata.mk_state();
+ final_state = Ptset.empty;
+ st_from_root = Ata.mk_state();
+ has_backward = false;
+ tr_parent_loop = Hashtbl.create 5;
+ tr = Hashtbl.create 5;
+ tr_aux = Hashtbl.create 5;
+ }
+ in
+ let q0 = Ata.mk_state() in
+ let states = Ptset.from_list [config.st_univ;config.st_root]
+ in
+ let num = 0 in
+ (* add_trans num config.tr_aux (mk_star config.st_from_root `Left config.st_univ config.st_from_root);
+ add_trans num config.tr_aux (mk_star config.st_from_root `Left config.st_from_root config.st_univ);
+ 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);
+ *)
+ let a_st,a_dst,anc_st,par_st,pre_st,_,_,has_backward =
+ compile_path dirsteps config q0 states 0 [(config.st_root,[]) ]
+ in
+ let fst_tr =
+ ?< (config.st_root) >< (TagSet.star,false) >=>
+ (`Left** q0) *& (if config.has_backward then `Left ** config.st_from_root else Ata.true_)
+ in
+ add_trans num config.tr fst_tr;
+ if config.has_backward then begin
+ add_trans num config.tr_aux
+ (?< (config.st_from_root) >< (TagSet.star,false) >=> `Left ** config.st_from_root +|
+ `Right ** config.st_from_root);
+ add_trans num config.tr_aux
+ (?< (config.st_from_root) >< (TagSet.cup TagSet.pcdata TagSet.attribute,false) >=>
+ `Right ** config.st_from_root);
- in
- let q_out = List.hd final in
- let tchange,tkeep = split_dest q_out trs in
- let trs' = compile_pred q_out tkeep tchange pred in
- (trs',final,initial)
-
- and compile_pred q_out tkeep tchange p =
- let rec pred_rec = function
-
- | Or(p1,p2) -> cup (pred_rec p1) (pred_rec p2)
- | And(p1,p2) -> cap (pred_rec p1) (pred_rec p2)
- | Not(p) -> neg (pred_rec p)
- | Expr e -> match compile_expr e with
- | `True -> `Label (TagSet.Xml.any)
- | `False -> `Label (TagSet.Xml.empty)
- | e -> `Fun (fun t -> Functions.truth_value (Functions.eval_expr t e))
-
- in match pred_rec p with
- `Fun f -> mk_pred_trs f tkeep tchange
- | `Label ts -> mk_self_trs ts tkeep tchange
-
- and compile_expr = function
- True -> `True
- | False -> `False
- | Path p -> `Auto(compile p)
- | Int i -> `Int i
- | String s -> `String s
- | Function ("contains",elist) ->`Contains(List.map compile_expr elist)
- | Function (f,elist) -> `Call(f,List.map compile_expr elist)
-
- and cup a b = match a,b with
- | `Label l1 , `Label l2 -> `Label(TagSet.Xml.cup l1 l2)
- | `Fun f1 , `Fun f2 -> `Fun (fun x -> (f1 x)||(f2 x))
- | `Fun f , `Label l | `Label l, `Fun f ->
- `Fun (fun x ->
- (TagSet.Xml.mem (Tree.Binary.tag x) l)
- || (f x))
-
- and cap a b = match a,b with
- | `Label l1, `Label l2 -> `Label (TagSet.Xml.cap l1 l2)
- | `Fun f1,`Fun f2 -> `Fun (fun x -> (f1 x)&&(f2 x))
- | `Fun f,`Label l | `Label l,`Fun f ->
- `Fun (fun x ->
- (TagSet.Xml.mem (Tree.Binary.tag x) l)
- && f x)
- and neg = function
- `Label l -> `Label(TagSet.Xml.neg l)
- | `Fun f -> `Fun (fun x -> not (f x))
-
- and compile p =
- let p = rev_map_dir p in
- let ignore = State.mk()
- in
- let q0 = State.mk() in
- let transitions = Transition.empty () in
- let tlist,qlist,initacc = List.fold_left
- (fun (tlist,qlist,initacc) (s,dir) ->
- let q = List.hd qlist in
- compile_step q dir tlist qlist initacc ignore s ) ([],[q0;ignore],[q0]) p
- in
- List.iter (Transition.add transitions) tlist;
- let qmark = List.hd qlist in
- { Automaton.mk() with
- initial = from_list initacc;
- final = from_list qlist;
- transitions = transitions;
- marking = from_list [qmark];
- ignore = from_list [qmark;ignore];
- }
+ end;
+ let phi = Hashtbl.create 37 in
+ let fadd = fun _ (_,l) -> List.iter (fun (s,t,m,f) -> Hashtbl.add phi (t,s) (m,f)) l in
+ Hashtbl.iter (fadd) config.tr;
+ Hashtbl.iter (fadd) config.tr_aux;
+ Hashtbl.iter (fadd) config.tr_parent_loop;
+ let final =
+ let s = Ptset.union anc_st (Ptset.from_list [a_dst;config.st_univ])
+ in if has_backward then s else Ptset.add config.st_from_root s
+ in { Ata.id = Oo.id (object end);
+ Ata.states = a_st;
+ Ata.init = Ptset.singleton config.st_root;
+ Ata.final = Ptset.union anc_st config.final_state;
+ Ata.universal = Ptset.union anc_st config.final_state;
+ Ata.phi = phi;
+ Ata.delta = Hashtbl.create 17;
+ Ata.properties = Hashtbl.create 0;
+ }
+
+
end
projects / SXSI / xpathcomp.git / commitdiff