src/compile.ml

   1 open Ata
   2 open XPath.Ast
   3
   4 type text_query = [ `Prefix | `Suffix | `Equals | `Contains ]
   5
   6 type tri_state = [ `Unknown | `Yes | `No ]
   7
   8 let pr_tri_state fmt v =
   9   Format.fprintf fmt "%s"
  10     (match v with
  11       | `Unknown -> "`Unknown"
  12       | `Yes -> "`Yes"
  13       | `No -> "`No")
  14 ;;
  15
  16
  17 type info = {
  18   trans : Transition.t list;
  19   states : StateSet.t;
  20   marking_states : StateSet.t;
  21   bottom_states : StateSet.t;
  22   last : State.t;
  23   bottom_up : tri_state;
  24   text_pred : (text_query * string) list }
  25
  26 let empty_info =
  27   { trans = [];
  28     states = StateSet.empty;
  29     marking_states = StateSet.empty;
  30     bottom_states = StateSet.empty;
  31     last = State.dummy;
  32     bottom_up = `Unknown;
  33     text_pred = [] }
  34
  35 open Formula.Infix
  36
  37 let mk_phi top phi loop = if top then phi *& loop else phi
  38
  39
  40 let rec compile_step toplevel (axis, test, _) state cont conf last =
  41   let test, cont =
  42     match test with
  43     | Simple t -> t, cont
  44     | Complex (t, p) -> t, Formula.and_ (Formula.pred_ p) cont
  45   in
  46   let marking = toplevel && last in
  47   let trans, new_cont =
  48     match axis with
  49     | Child ->
  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))],
  54         (`Left *+ state))
  55
  56     | FollowingSibling ->
  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))],
  61         (`Right *+ state))
  62
  63     | Descendant ->
  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)) *)
  70         ],
  71         (`Left *+ state))
  72
  73     | _ -> assert false
  74   in
  75   { conf with
  76     trans = trans@conf.trans;
  77     states = StateSet.add state conf.states;
  78     marking_states =
  79       if toplevel
  80       then StateSet.add state conf.marking_states
  81       else conf.marking_states }, new_cont
  82
  83 and compile_step_list toplevel sl conf =
  84   match sl with
  85     [] ->
  86       let state = State.make () in
  87       let phi = `Left *+ state in
  88       let loop = (`Left *+ state) *& (`Right *+ state) in
  89       true,
  90       phi,
  91       { conf with
  92         states = StateSet.add state conf.states;
  93         bottom_states = StateSet.add state conf.bottom_states;
  94         trans =
  95           let trans =
  96             Transition.make (state, TagSet.any, false, loop)
  97           in
  98           trans :: conf.trans }
  99
 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
 104     let conf, new_cont =
 105       compile_step toplevel step state (pred *& cont) conf last
 106     in
 107     let conf =
 108       if toplevel && last then
 109         { conf with last = state }
 110       else
 111         conf
 112     in false, new_cont, conf
 113
 114 and compile_predicate predicate conf =
 115   match predicate with
 116   | Or(p1, p2) ->
 117
 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 }
 121
 122   | And(p1, p2) ->
 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 }
 126
 127   | Not p ->
 128     let cont, conf = compile_predicate p conf in
 129     Formula.not_ cont, { conf with bottom_up = `No  }
 130
 131   | Expr e -> compile_expr e conf
 132
 133 and append_path p s =
 134   match p with
 135   | Relative sl -> Relative (sl @ [s])
 136   | Absolute sl -> Absolute (sl @ [s])
 137   | AbsoluteDoS sl -> AbsoluteDoS (sl @ [s])
 138
 139 and compile_expr expr conf =
 140   match expr with
 141   | True -> Formula.true_, conf
 142   | False -> Formula.false_, conf
 143   | Path p ->
 144     let phi, conf = compile_path false p conf in
 145     phi, { conf with
 146       bottom_up =
 147         match conf.bottom_up with
 148         | `Yes -> `Yes
 149         | _ -> `No }
 150
 151   | Function(fn,
 152              [ Path(Relative [(Self, Simple (n), Expr True)]);
 153                String s ]) when n == TagSet.node ->
 154
 155     let f =
 156       match fn with
 157       | "contains" -> `Contains
 158       | "equals" -> `Equals
 159       | "starts-with" -> `Prefix
 160       | "ends-with" -> `Suffix
 161       | _ -> failwith ("Unknown function : " ^ fn)
 162     in
 163     let pred = Tree.mk_pred f s in
 164     let phi, conf' =
 165       compile_expr
 166         (Path (Relative [(Child,
 167                           Complex(TagSet.pcdata, pred),
 168                           Expr True)]))
 169         conf
 170     in
 171     phi,
 172     { conf' with
 173       text_pred = (f,s) :: conf'.text_pred;
 174       bottom_up =
 175         match conf.bottom_up with
 176         | `Unknown -> `Yes
 177         | _ -> `No }
 178
 179   | _ -> assert false
 180
 181 and compile_path toplevel p conf =
 182   let sl =
 183     match p with
 184     | Relative sl -> sl
 185     | Absolute sl ->
 186       let prefix = Child,
 187         Simple (TagSet.singleton Tag.document_node),
 188         Expr True
 189       in prefix :: sl
 190
 191     | AbsoluteDoS sl ->
 192       (Descendant, (Simple TagSet.node), Expr True)::sl
 193   in
 194   let _, cont, conf = compile_step_list toplevel sl conf in
 195   cont, conf
 196
 197 let compile path =
 198   let cont, conf = compile_path true path empty_info in
 199   let init, _ = Formula.st cont in
 200   let get t s =
 201     try Hashtbl.find t s with Not_found -> []
 202   in
 203   let table = Hashtbl.create 13 in
 204   List.iter
 205     (fun tr ->
 206       let q, ts, _, _ = Transition.node tr in
 207       let l = get table q in
 208       Hashtbl.replace table q ((ts, tr)::l))
 209     conf.trans;
 210   let auto = {
 211     id = Oo.id (object end);
 212     Ata.states = conf.states;
 213     init = init;
 214     Ata.last = conf.last;
 215     trans = table;
 216     Ata.marking_states = conf.marking_states;
 217     Ata.topdown_marking_states = conf.marking_states;
 218     Ata.bottom_states =
 219       StateSet.union conf.bottom_states conf.marking_states;
 220     Ata.true_states = conf.bottom_states }
 221   in
 222   auto,
 223   (if conf.bottom_up = `Yes then Some conf.text_pred else None)