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));
69 (*(Transition.make (state, TagSet.any, false, `Right *+ state)) *)
76 trans = trans@conf.trans;
77 states = StateSet.add state conf.states;
80 then StateSet.add state conf.marking_states
81 else conf.marking_states }, new_cont
83 and compile_step_list toplevel sl conf =
86 let state = State.make () in
87 let phi = `Left *+ state in
88 let loop = (`Left *+ state) *& (`Right *+ state) in
92 states = StateSet.add state conf.states;
93 bottom_states = StateSet.add state conf.bottom_states;
96 Transition.make (state, TagSet.any, false, loop)
100 | (_, _, pred) as step :: sll ->
101 let state = State.make () in
102 let pred, conf = compile_predicate pred conf in
103 let last, cont, conf = compile_step_list toplevel sll conf in
105 compile_step toplevel step state (pred *& cont) conf last
108 if toplevel && last then
109 { conf with last = state }
112 in false, new_cont, conf
114 and compile_predicate predicate conf =
118 let cont1, conf1 = compile_predicate p1 conf in
119 let cont2, conf2 = compile_predicate p2 conf1 in
120 cont1 +| cont2, { conf2 with bottom_up = `No }
123 let cont1, conf1 = compile_predicate p1 conf in
124 let cont2, conf2 = compile_predicate p2 conf1 in
125 cont1 *& cont2, { conf2 with bottom_up = `No }
128 let cont, conf = compile_predicate p conf in
129 Formula.not_ cont, { conf with bottom_up = `No }
131 | Expr e -> compile_expr e conf
133 and append_path p s =
135 | Relative sl -> Relative (sl @ [s])
136 | Absolute sl -> Absolute (sl @ [s])
137 | AbsoluteDoS sl -> AbsoluteDoS (sl @ [s])
139 and compile_expr expr conf =
141 | True -> Formula.true_, conf
142 | False -> Formula.false_, conf
144 let phi, conf = compile_path false p conf in
147 match conf.bottom_up with
152 [ Path(Relative [(Self, Simple (n), Expr True)]);
153 String s ]) when n == TagSet.node ->
157 | "contains" -> `Contains
158 | "equals" -> `Equals
159 | "starts-with" -> `Prefix
160 | "ends-with" -> `Suffix
161 | _ -> failwith ("Unknown function : " ^ fn)
163 let pred = Tree.mk_pred f s in
166 (Path (Relative [(Child,
167 Complex(TagSet.pcdata, pred),
173 text_pred = (f,s) :: conf'.text_pred;
175 match conf.bottom_up with
181 and compile_path toplevel p conf =
187 Simple (TagSet.singleton Tag.document_node),
192 (Descendant, (Simple TagSet.node), Expr True)::sl
194 let _, cont, conf = compile_step_list toplevel sl conf in
198 let cont, conf = compile_path true path empty_info in
199 let (_, _, init), _ = Formula.st cont in
201 try Hashtbl.find t s with Not_found -> []
203 let table = Hashtbl.create 13 in
206 let q, ts, _, _ = Transition.node tr in
207 let l = get table q in
208 Hashtbl.replace table q ((ts, tr)::l))
211 id = Oo.id (object end);
212 Ata.states = conf.states;
214 Ata.last = conf.last;
216 Ata.marking_states = conf.marking_states;
217 Ata.topdown_marking_states = conf.marking_states;
219 StateSet.union conf.bottom_states conf.marking_states;
220 Ata.true_states = conf.bottom_states }
223 (if conf.bottom_up = `Yes then Some conf.text_pred else None)