src/compile.ml

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