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         ],
  70         (`Left *+ state))
  71
  72     | _ -> assert false
  73   in
  74   { conf with
  75     trans = trans@conf.trans;
  76     states = StateSet.add state conf.states;
  77     marking_states =
  78       if toplevel
  79       then StateSet.add state conf.marking_states
  80       else conf.marking_states }, new_cont
  81
  82 and compile_step_list toplevel sl conf =
  83   match sl with
  84     [] ->
  85       let state = State.make () in
  86       let phi = `Left *+ state in
  87       let loop = (`Left *+ state) *& (`Right *+ state) in
  88       true,
  89       phi,
  90       { conf with
  91         states = StateSet.add state conf.states;
  92         bottom_states = StateSet.add state conf.bottom_states;
  93         trans =
  94           let trans =
  95             Transition.make (state, TagSet.any, false, loop)
  96           in
  97           trans :: conf.trans }
  98
  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
 103     let conf, new_cont =
 104       compile_step toplevel step state (pred *& cont) conf last
 105     in
 106     let conf =
 107       if toplevel && last then
 108         { conf with last = state }
 109       else
 110         conf
 111     in false, new_cont, conf
 112
 113 and compile_predicate predicate conf =
 114   match predicate with
 115   | Or(p1, p2) ->
 116
 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 }
 120
 121   | And(p1, p2) ->
 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 }
 125
 126   | Not p ->
 127     let cont, conf = compile_predicate p conf in
 128     Formula.not_ cont, { conf with bottom_up = `No  }
 129
 130   | Expr e -> compile_expr e conf
 131
 132 and append_path p s =
 133   match p with
 134   | Relative sl -> Relative (sl @ [s])
 135   | Absolute sl -> Absolute (sl @ [s])
 136   | AbsoluteDoS sl -> AbsoluteDoS (sl @ [s])
 137
 138 and compile_expr expr conf =
 139   match expr with
 140   | True -> Formula.true_, conf
 141   | False -> Formula.false_, conf
 142   | Path p ->
 143     let phi, conf = compile_path false p conf in
 144     phi, { conf with
 145       bottom_up =
 146         match conf.bottom_up with
 147         | `Yes -> `Yes
 148         | _ -> `No }
 149
 150   | Function(fn,
 151              [ Path(Relative [(Self, Simple (n), Expr True)]);
 152                String s ]) when n == TagSet.node ->
 153
 154     let f =
 155       match fn with
 156       | "contains" -> `Contains
 157       | "equals" -> `Equals
 158       | "starts-with" -> `Prefix
 159       | "ends-with" -> `Suffix
 160       | _ -> failwith ("Unknown function : " ^ fn)
 161     in
 162     let pred = Tree.mk_pred f s in
 163     let phi, conf' =
 164       compile_expr
 165         (Path (Relative [(Child,
 166                           Complex(TagSet.pcdata, pred),
 167                           Expr True)]))
 168         conf
 169     in
 170     phi,
 171     { conf' with
 172       text_pred = (f,s) :: conf'.text_pred;
 173       bottom_up =
 174         match conf.bottom_up with
 175         | `Unknown -> `Yes
 176         | _ -> `No }
 177
 178   | _ -> assert false
 179
 180 and compile_path toplevel p conf =
 181   let sl =
 182     match p with
 183     | Relative sl -> sl
 184     | Absolute sl ->
 185       let prefix = Child,
 186         Simple (TagSet.singleton Tag.document_node),
 187         Expr True
 188       in prefix :: sl
 189
 190     | AbsoluteDoS sl ->
 191       (Descendant, (Simple TagSet.node), Expr True)::sl
 192   in
 193   let _, cont, conf = compile_step_list toplevel sl conf in
 194   cont, conf
 195
 196 let compile path =
 197   let cont, conf = compile_path true path empty_info in
 198   let init, _ = Formula.st cont in
 199   let get t s =
 200     try Hashtbl.find t s with Not_found -> []
 201   in
 202   let table = Hashtbl.create 13 in
 203   List.iter
 204     (fun tr ->
 205       let q, ts, _, _ = Transition.node tr in
 206       let l = get table q in
 207       Hashtbl.replace table q ((ts, tr)::l))
 208     conf.trans;
 209   let auto = {
 210     id = Oo.id (object end);
 211     Ata.states = conf.states;
 212     init = init;
 213     Ata.last = conf.last;
 214     trans = table;
 215     Ata.marking_states = conf.marking_states;
 216     Ata.topdown_marking_states = conf.marking_states;
 217     Ata.bottom_states =
 218       StateSet.union conf.bottom_states conf.marking_states;
 219     Ata.true_states = conf.bottom_states }
 220   in
 221   auto,
 222   (if conf.bottom_up = `Yes then Some conf.text_pred else None)