-
open Ata
open XPath.Ast
bottom_states : StateSet.t;
last : State.t;
bottom_up : tri_state;
- text_pred : (text_query * string) list
-}
+ text_pred : (text_query * string) list }
let empty_info =
{ trans = [];
bottom_states = StateSet.empty;
last = State.dummy;
bottom_up = `Unknown;
- text_pred = []
- }
+ text_pred = [] }
open Formula.Infix
let mk_phi top phi loop = if top then phi *& loop else phi
-let log msg v1 v2 =
- let () = Format.eprintf "%a -> %a in %s\n%!"
- pr_tri_state v1
- pr_tri_state v2
- msg
- in v2
-
-let log _ _ v = v
-let rec compile_step toplevel ((axis, test, _) as _step) state cont conf last =
- let test, cont = match test with
+let rec compile_step toplevel (axis, test, _) state cont conf last =
+ let test, cont =
+ match test with
| Simple t -> t, cont
| Complex (t, p) -> t, Formula.and_ (Formula.pred_ p) cont
in
let marking = toplevel && last in
let trans, new_cont =
match axis with
- | Child ->
- let loop = `Right *+ state in
- let phi = mk_phi toplevel cont loop in
- ( [ (Transition.make (state, test, marking, phi));
- (Transition.make (state, TagSet.any, false, loop))],
- (`Left *+ state))
-
- | FollowingSibling ->
- let loop = `Right *+ state in
- let phi = mk_phi toplevel cont loop in
- ( [ (Transition.make (state, test, marking, phi));
- (Transition.make (state, TagSet.any, false, loop))],
- (`Right *+ state))
-
- | Descendant ->
- let loopfun = if toplevel then Formula.and_ else Formula.or_ in
- let loop = loopfun (`Left *+ state) (`Right *+ state) in
- let phi = mk_phi toplevel cont loop in
- ( [ (Transition.make (state, test, marking, phi));
- (Transition.make (state, TagSet.any, false, loop));
- (*(Transition.make (state, TagSet.any, false, `Right *+ state)) *)
- ],
- (`Left *+ state))
-
- | _ -> assert false
+ | Child ->
+ let loop = `Right *+ state in
+ let phi = mk_phi toplevel cont loop in
+ ( [ (Transition.make (state, test, marking, phi));
+ (Transition.make (state, TagSet.any, false, loop))],
+ (`Left *+ state))
+
+ | FollowingSibling ->
+ let loop = `Right *+ state in
+ let phi = mk_phi toplevel cont loop in
+ ( [ (Transition.make (state, test, marking, phi));
+ (Transition.make (state, TagSet.any, false, loop))],
+ (`Right *+ state))
+
+ | Descendant ->
+ let loopfun = if toplevel then Formula.and_ else Formula.or_ in
+ let loop = loopfun (`Left *+ state) (`Right *+ state) in
+ let phi = mk_phi toplevel cont loop in
+ ( [ (Transition.make (state, test, marking, phi));
+ (Transition.make (state, TagSet.any, false, loop));
+ (*(Transition.make (state, TagSet.any, false, `Right *+ state)) *)
+ ],
+ (`Left *+ state))
+
+ | _ -> assert false
in
- { conf with
- trans = trans@conf.trans;
- states = StateSet.add state conf.states;
- marking_states =
- if toplevel
- then StateSet.add state conf.marking_states
- else conf.marking_states
- }, new_cont
+ { conf with
+ trans = trans@conf.trans;
+ states = StateSet.add state conf.states;
+ marking_states =
+ if toplevel
+ then StateSet.add state conf.marking_states
+ else conf.marking_states }, new_cont
and compile_step_list toplevel sl conf =
match sl with
- [] ->
- let state = State.make () in
- let phi = `Left *+ state in
- let loop = (`Left *+ state) *& (`Right *+ state) in
- ( true,
- phi,
- { conf with
- states = StateSet.add state conf.states;
- bottom_states = StateSet.add state conf.bottom_states;
- trans = (Transition.make (state, TagSet.any, false, loop)) :: conf.trans;
- } )
- | (_, _, pred) as step :: sll ->
- let state = State.make () in
- let pred, conf = compile_predicate pred conf in
- let last, cont, conf = compile_step_list toplevel sll conf in
- let conf, new_cont = compile_step toplevel step state (pred *& cont) conf last in
- let conf = if toplevel && last then {conf with last = state} else conf in
- false, new_cont, conf
+ [] ->
+ let state = State.make () in
+ let phi = `Left *+ state in
+ let loop = (`Left *+ state) *& (`Right *+ state) in
+ true,
+ phi,
+ { conf with
+ states = StateSet.add state conf.states;
+ bottom_states = StateSet.add state conf.bottom_states;
+ trans =
+ let trans =
+ Transition.make (state, TagSet.any, false, loop)
+ in
+ trans :: conf.trans }
+
+ | (_, _, pred) as step :: sll ->
+ let state = State.make () in
+ let pred, conf = compile_predicate pred conf in
+ let last, cont, conf = compile_step_list toplevel sll conf in
+ let conf, new_cont =
+ compile_step toplevel step state (pred *& cont) conf last
+ in
+ let conf =
+ if toplevel && last then
+ { conf with last = state }
+ else
+ conf
+ in false, new_cont, conf
and compile_predicate predicate conf =
match predicate with
- | Or(p1, p2) ->
-
- let cont1, conf1 = compile_predicate p1 conf in
- let cont2, conf2 = compile_predicate p2 conf1 in
- cont1 +| cont2, { conf2 with bottom_up = `No
- }
- | And(p1, p2) ->
- let cont1, conf1 = compile_predicate p1 conf in
- let cont2, conf2 = compile_predicate p2 conf1 in
- cont1 *& cont2, { conf2 with bottom_up = `No
- }
- | Not p ->
- let cont, conf = compile_predicate p conf in
- Formula.not_ cont, { conf with bottom_up = `No
- }
- | Expr e ->
- compile_expr e conf
+ | Or(p1, p2) ->
+
+ let cont1, conf1 = compile_predicate p1 conf in
+ let cont2, conf2 = compile_predicate p2 conf1 in
+ cont1 +| cont2, { conf2 with bottom_up = `No }
+
+ | And(p1, p2) ->
+ let cont1, conf1 = compile_predicate p1 conf in
+ let cont2, conf2 = compile_predicate p2 conf1 in
+ cont1 *& cont2, { conf2 with bottom_up = `No }
+
+ | Not p ->
+ let cont, conf = compile_predicate p conf in
+ Formula.not_ cont, { conf with bottom_up = `No }
+
+ | Expr e -> compile_expr e conf
+
and append_path p s =
match p with
- | Relative sl -> Relative (sl @ [s])
- | Absolute sl -> Absolute (sl @ [s])
- | AbsoluteDoS sl -> AbsoluteDoS (sl @ [s])
+ | Relative sl -> Relative (sl @ [s])
+ | Absolute sl -> Absolute (sl @ [s])
+ | AbsoluteDoS sl -> AbsoluteDoS (sl @ [s])
and compile_expr expr conf =
match expr with
- | True -> Formula.true_, conf
- | False -> Formula.false_, conf
- | Path p ->
- let phi, conf = compile_path false p conf in
- phi, { conf with
- bottom_up = let v =
- match conf.bottom_up with
- | `Yes -> `Yes
- | _ -> `No
- in v
- }
- | Function(fn,
- [ Path(Relative
- [(Self, Simple (n), Expr True)]) ; String s ]) when n == TagSet.node ->
-
- let f =
- match fn with
- | "contains" -> `Contains
- | "equals" -> `Equals
- | "starts-with" -> `Prefix
- | "ends-with" -> `Suffix
- | _ -> failwith ("Unknown function : " ^ fn)
- in
- let pred = Tree.mk_pred f s in
- let phi, conf' =
- compile_expr (Path (Relative [(Child, Complex(TagSet.pcdata, pred), Expr True)])) conf
- in
- phi,
- { conf' with
- text_pred = (f,s) :: conf'.text_pred;
- bottom_up =
- let v =
- match conf.bottom_up with
- | `Unknown -> `Yes
- | _ -> `No
- in v
- }
- | _ -> assert false
+ | True -> Formula.true_, conf
+ | False -> Formula.false_, conf
+ | Path p ->
+ let phi, conf = compile_path false p conf in
+ phi, { conf with
+ bottom_up =
+ match conf.bottom_up with
+ | `Yes -> `Yes
+ | _ -> `No }
+
+ | Function(fn,
+ [ Path(Relative [(Self, Simple (n), Expr True)]);
+ String s ]) when n == TagSet.node ->
+
+ let f =
+ match fn with
+ | "contains" -> `Contains
+ | "equals" -> `Equals
+ | "starts-with" -> `Prefix
+ | "ends-with" -> `Suffix
+ | _ -> failwith ("Unknown function : " ^ fn)
+ in
+ let pred = Tree.mk_pred f s in
+ let phi, conf' =
+ compile_expr
+ (Path (Relative [(Child,
+ Complex(TagSet.pcdata, pred),
+ Expr True)]))
+ conf
+ in
+ phi,
+ { conf' with
+ text_pred = (f,s) :: conf'.text_pred;
+ bottom_up =
+ match conf.bottom_up with
+ | `Unknown -> `Yes
+ | _ -> `No }
+
+ | _ -> assert false
and compile_path toplevel p conf =
let sl =
match p with
- | Relative sl -> sl
- | Absolute sl -> (Child, Simple (TagSet.singleton Tag.document_node), Expr True)::sl
- | AbsoluteDoS sl ->
- (Descendant, (Simple TagSet.node), Expr True)::sl
+ | Relative sl -> sl
+ | Absolute sl ->
+ let prefix = Child,
+ Simple (TagSet.singleton Tag.document_node),
+ Expr True
+ in prefix :: sl
+
+ | AbsoluteDoS sl ->
+ (Descendant, (Simple TagSet.node), Expr True)::sl
in
let _, cont, conf = compile_step_list toplevel sl conf in
- cont, conf
-
-let is_topdown_loop q s =
- StateSet.cardinal (StateSet.remove q s) <= 1
-let rec remove_topdown_marking trans l last =
- match l with
- | [] -> last :: l
- | q :: ll ->
- let tr_list = Hashtbl.find trans q in
- if List.for_all
- (fun (_, t) ->
- let _, _, m, f = Transition.node t in
- let (_, _, stl), (_, _, str) = Formula.st f in
- not m && is_topdown_loop q stl && is_topdown_loop q str) tr_list
- then remove_topdown_marking trans ll q
- else last :: l
-
+ cont, conf
let compile path =
let cont, conf = compile_path true path empty_info in
let (_, _, init), _ = Formula.st cont in
let get t s =
- try
- Hashtbl.find t s
- with
- | Not_found -> []
+ try Hashtbl.find t s with Not_found -> []
in
let table = Hashtbl.create 13 in
- let () =
- List.iter (fun tr ->
- let q, ts, _, _ = Transition.node tr in
- let l = get table q in
- Hashtbl.replace table q ((ts, tr)::l)) conf.trans
- in
+ List.iter
+ (fun tr ->
+ let q, ts, _, _ = Transition.node tr in
+ let l = get table q in
+ Hashtbl.replace table q ((ts, tr)::l))
+ conf.trans;
let auto = {
id = Oo.id (object end);
Ata.states = conf.states;
trans = table;
Ata.marking_states = conf.marking_states;
Ata.topdown_marking_states = conf.marking_states;
- (* StateSet.from_list (
- remove_topdown_marking table
- (StateSet.elements conf.marking_states)
- (StateSet.min_elt init)
- ); *)
- Ata.bottom_states = StateSet.union conf.bottom_states conf.marking_states;
- Ata.true_states = conf.bottom_states;
- }
- in auto, (if conf.bottom_up = `Yes then Some conf.text_pred else None)
+ Ata.bottom_states =
+ StateSet.union conf.bottom_states conf.marking_states;
+ Ata.true_states = conf.bottom_states }
+ in
+ auto,
+ (if conf.bottom_up = `Yes then Some conf.text_pred else None)
projects / SXSI / xpathcomp.git / blobdiff