4 type text_query = [ `Prefix | `Suffix | `Equals | `Contains ]
6 type tri_state = [ `Unknown | `Yes | `No ]
8 let pr_tri_state fmt v =
9 Format.fprintf fmt "%s"
11 | `Unknown -> "`Unknown"
18 trans : Transition.t list;
20 marking_states : StateSet.t;
21 bottom_states : StateSet.t;
23 bottom_up : tri_state;
24 text_pred : (text_query * string) list }
28 states = StateSet.empty;
29 marking_states = StateSet.empty;
30 bottom_states = StateSet.empty;
37 let mk_phi top phi loop = if top then phi *& loop else phi
40 let rec compile_step toplevel (axis, test, _) state cont conf last =
44 | Complex (t, p) -> t, Formula.and_ (Formula.pred_ p) cont
46 let marking = toplevel && last in
50 let loop = `Right *+ state in
51 let phi = mk_phi toplevel cont loop in
52 ( [ (Transition.make (state, test, marking, phi));
53 (Transition.make (state, TagSet.any, false, loop))],
57 let loop = `Right *+ state in
58 let phi = mk_phi toplevel cont loop in
59 ( [ (Transition.make (state, test, marking, phi));
60 (Transition.make (state, TagSet.any, false, loop))],
64 let loopfun = if toplevel then Formula.and_ else Formula.or_ in
65 let loop = loopfun (`Left *+ state) (`Right *+ state) in
66 let phi = mk_phi toplevel cont loop in
67 ( [ (Transition.make (state, test, marking, phi));
68 (Transition.make (state, TagSet.any, false, loop));
75 trans = trans@conf.trans;
76 states = StateSet.add state conf.states;
79 then StateSet.add state conf.marking_states
80 else conf.marking_states }, new_cont
82 and compile_step_list toplevel sl conf =
85 let state = State.make () in
86 let phi = `Left *+ state in
87 let loop = (`Left *+ state) *& (`Right *+ state) in
91 states = StateSet.add state conf.states;
92 bottom_states = StateSet.add state conf.bottom_states;
95 Transition.make (state, TagSet.any, false, loop)
99 | (_, _, pred) as step :: sll ->
100 let state = State.make () in
101 let pred, conf = compile_predicate pred conf in
102 let last, cont, conf = compile_step_list toplevel sll conf in
104 compile_step toplevel step state (pred *& cont) conf last
107 if toplevel && last then
108 { conf with last = state }
111 in false, new_cont, conf
113 and compile_predicate predicate conf =
117 let cont1, conf1 = compile_predicate p1 conf in
118 let cont2, conf2 = compile_predicate p2 conf1 in
119 cont1 +| cont2, { conf2 with bottom_up = `No }
122 let cont1, conf1 = compile_predicate p1 conf in
123 let cont2, conf2 = compile_predicate p2 conf1 in
124 cont1 *& cont2, { conf2 with bottom_up = `No }
127 let cont, conf = compile_predicate p conf in
128 Formula.not_ cont, { conf with bottom_up = `No }
130 | Expr e -> compile_expr e conf
132 and append_path p s =
134 | Relative sl -> Relative (sl @ [s])
135 | Absolute sl -> Absolute (sl @ [s])
136 | AbsoluteDoS sl -> AbsoluteDoS (sl @ [s])
138 and compile_expr expr conf =
140 | True -> Formula.true_, conf
141 | False -> Formula.false_, conf
143 let phi, conf = compile_path false p conf in
146 match conf.bottom_up with
151 [ Path(Relative [(Self, Simple (n), Expr True)]);
152 String s ]) when n == TagSet.node ->
156 | "contains" -> `Contains
157 | "equals" -> `Equals
158 | "starts-with" -> `Prefix
159 | "ends-with" -> `Suffix
160 | _ -> failwith ("Unknown function : " ^ fn)
162 let pred = Tree.mk_pred f s in
165 (Path (Relative [(Child,
166 Complex(TagSet.pcdata, pred),
172 text_pred = (f,s) :: conf'.text_pred;
174 match conf.bottom_up with
180 and compile_path toplevel p conf =
186 Simple (TagSet.singleton Tag.document_node),
191 (Descendant, (Simple TagSet.node), Expr True)::sl
193 let _, cont, conf = compile_step_list toplevel sl conf in
197 let cont, conf = compile_path true path empty_info in
198 let init, _ = Formula.st cont in
200 try Hashtbl.find t s with Not_found -> []
202 let table = Hashtbl.create 13 in
205 let q, ts, _, _ = Transition.node tr in
206 let l = get table q in
207 Hashtbl.replace table q ((ts, tr)::l))
210 id = Oo.id (object end);
211 Ata.states = conf.states;
213 Ata.last = conf.last;
215 Ata.marking_states = conf.marking_states;
216 Ata.topdown_marking_states = conf.marking_states;
218 StateSet.union conf.bottom_states conf.marking_states;
219 Ata.true_states = conf.bottom_states }
222 (if conf.bottom_up = `Yes then Some conf.text_pred else None)