X-Git-Url: http://git.nguyen.vg/gitweb/?p=tatoo.git;a=blobdiff_plain;f=src%2Fxpath%2Fcompile.ml;h=7848b84ffec7407381836da1f33a571b4c3cd049;hp=a84a50f3d1358770715c171f032a4a3cb45c2211;hb=9d83bf3832f03462a5d1f451d96e8d30347bf363;hpb=e40191ae5c8931b10fffa350b7cf9141ccee2200

diff --git a/src/xpath/compile.ml b/src/xpath/compile.ml
index a84a50f..7848b84 100644
--- a/src/xpath/compile.ml
+++ b/src/xpath/compile.ml
@@ -14,89 +14,237 @@
 (***********************************************************************)
 
 (*
-  Time-stamp: <Last modified on 2013-02-12 08:32:59 CET by Kim Nguyen>
+  Time-stamp: <Last modified on 2013-03-10 12:28:07 CET by Kim Nguyen>
 *)
 
 open Ast
 open Auto
 open Utils
 
-let mk_atom l b q =
-  Ata.SFormula.atom_ (Ata.Move.make (l,b,q))
 
 let ( => ) a b = (a, b)
-let ( ** ) l q = mk_atom l true q
 let ( ++ ) a b = Ata.SFormula.or_ a b
 let ( %% ) a b = Ata.SFormula.and_ a b
 let ( @: ) a b = StateSet.add a b
+(*
+let add_attribute_prefix test =
+  if QNameSet.is_finite test then
+    QNameSet.fold (fun tag acc ->
+      QNameSet.add (QName.add_attribute_prefix tag) acc)
+      test QNameSet.empty
+  else test
+*)
 
+module F = Ata.SFormula
 
-let compile_axis_test ax tst inq trs sts =
-  match ax with
-  | Self ->
-      let outq = State.make () in
-      outq,
-      (inq, [ tst =>  (`Epsilon ** outq ) ]) :: trs,
-      outq @: sts
-
-  | Child ->
-      let outq = State.make () in
-      let outq' = State.make () in
-      outq',
-      (inq, [ QNameSet.any => (`Left ** outq)])
-      :: (outq, [ tst => (`Epsilon ** outq');
-                  QNameSet.any => (`Right ** outq) ])
-      :: trs,
-      outq @: (outq' @: sts)
-
-  | Descendant | DescendantOrSelf ->
-      let dir = if ax = Descendant then `Left else `Epsilon in
-      let outq = State.make () in
-      let outq' = State.make () in
-      outq',
-      (inq, [ QNameSet.any => (dir ** outq)])
-      :: (outq, [ tst =>  (`Epsilon ** outq');
-                  QNameSet.any => ((`Left ** outq) ++ (`Right ** outq))
-                ])
-      :: trs,
-      outq @: (outq' @: sts)
-
-  | Parent ->
-      let outq = State.make () in
-      let outq' = State.make () in
-      let outq'' = State.make () in
-      let move = (`Up1 ** outq') ++ (`Up2 ** outq) in
-      outq'',
-      (inq, [QNameSet.any => move ])
-      :: (outq, [ QNameSet.any => move ])
-      :: (outq', [ tst => (`Epsilon ** outq'') ])
-      :: trs,
-      outq @: (outq' @: (outq'' @: sts))
-
-  | Ancestor | AncestorOrSelf ->
-      let outq = State.make () in
-      let outq' = State.make () in
-      let outq'' = State.make () in
-      let move =
-        (if ax = Ancestor then (`Up1 ** outq')
-         else (`Epsilon ** outq')) ++ (`Up1 ** outq) ++ (`Up2 ** outq)
-      in
-      outq'',
-      (inq, [QNameSet.any => move  ])
-      :: (outq, [ QNameSet.any => move ])
-      :: (outq', [ tst => (`Epsilon ** outq'') ])
-      :: trs,
-      outq @: (outq' @: (outq'' @: sts))
-
-  | FollowingSibling | PrecedingSibling ->
-      let outq = State.make () in
-      let outq' = State.make () in
-      let dir = if ax = FollowingSibling then `Right else `Up2 in
-      outq',
-      (inq, [ QNameSet.any => (dir ** outq) ])
-      :: (outq, [ tst => (`Epsilon ** outq');
-                  QNameSet.any => (dir ** outq) ])
-      :: trs,
-      outq @: (outq' @: sts)
+
+let node_set = QNameSet.remove QName.document QNameSet.any
+let star_set = QNameSet.diff QNameSet.any (
+  List.fold_right (QNameSet.add)
+    [ QName.document; QName.text; QName.attribute_map ]
+    QNameSet.empty)
+let attribute = QNameSet.singleton QName.attribute_map
+let root_set = QNameSet.singleton QName.document
+
+(* [compile_axis_test axis test q phi trans states] Takes an xpath
+   [axis] and node [test], a formula [phi], a list of [trans]itions
+   and a set of [states] and returns a formula [phi'], a new set of
+   transitions, and a new set of states such that [phi'] holds iff
+   there exists a node reachable through [axis]::[test] where [phi]
+   holds.
+*)
+
+let compile_axis_test ?(block_attr=true) axis test phi trans states =
+  let q = State.make () in
+  let phi_attr = if block_attr then F.not_ F.is_attribute else F.true_ in
+  let phi', trans', states' =
+    match axis with
+    | Self ->
+        (F.stay q,
+         (q, [  test => phi ]) :: trans,
+         states)
+
+    | Child ->
+        (F.first_child q,
+         (q, [ test => phi %% phi_attr;
+               QNameSet.any => F.next_sibling q ]) :: trans,
+         states)
+
+    | Descendant false ->
+        (F.first_child q,
+         (q, [ test => phi %% phi_attr;
+               QNameSet.any => F.first_child q ++ F.next_sibling q;
+             ]) :: trans,
+         states)
+    | Descendant true ->
+        let q' = State.make () in
+        (F.or_ (F.stay q) (F.first_child q'),
+         (q', [ test => phi %% phi_attr;
+               QNameSet.any => F.first_child q' ++ F.next_sibling q';
+             ])::
+         (q, [ test => phi %% phi_attr]):: trans,
+         states)
+
+    | Parent ->
+        let q' = State.make () in
+        let move = F.parent q ++ F.previous_sibling q' in
+        (move,
+         (q, [ test => phi ])
+         :: (q', [ QNameSet.any => move ]) :: trans,
+         (q' @: states))
+
+    | Ancestor self ->
+        let q' = State.make () in
+        let move = F.parent q ++ F.previous_sibling q' in
+        (if self then F.stay q else move),
+        (q, [ test => phi;
+              QNameSet.any => move ])
+        :: (q', [ QNameSet.any => move ]) :: trans,
+        (q' @: states)
+
+    | FollowingSibling | PrecedingSibling ->
+        let move =
+          if axis = PrecedingSibling then
+            F.previous_sibling q
+          else F.next_sibling q
+        in
+        move,
+        (q, [ test => phi %% phi_attr;
+              QNameSet.any => move ]) :: trans,
+        states
+
+    | Attribute ->
+        (F.first_child q,
+         (q, [ test => phi %% F.is_attribute;
+               QNameSet.any => F.next_sibling q]) :: trans,
+         states)
+    | _ -> assert false
+
+  in
+  phi', trans', q @: states'
+
+
+let compile_rev_axis_test block_attr axis test phi trans states =
+  match axis with
+  | Attribute ->
+      compile_axis_test
+        ~block_attr:false Parent test phi trans states
+  | _ -> compile_axis_test
+      ~block_attr:block_attr (invert_axis axis) test phi trans states
+
+let rec compile_expr e trans states =
+  match e with
+  | Binop (e1, (And|Or as op), e2) ->
+      let phi1, trans1, states1 = compile_expr e1 trans states in
+      let phi2, trans2, states2 = compile_expr e2 trans1 states1 in
+      (if op = Or then phi1 ++ phi2 else phi1 %% phi2),
+      trans2,
+      states2
+  | Fun_call (f, [ e0 ]) when (QName.to_string f) = "not" ->
+      let phi, trans0, states0 = compile_expr e0 trans states in
+      (Ata.SFormula.not_ phi),
+      trans0,
+      states0
+  | Path p -> compile_path p trans states
 
   | _ -> assert false
+and compile_path paths trans states =
+  List.fold_left (fun (aphi, atrans, astates) p ->
+    let phi, ntrans, nstates = compile_single_path p atrans astates in
+    (Ata.SFormula.or_ phi aphi),
+    ntrans,
+    nstates) (Ata.SFormula.false_,trans,states) paths
+
+and compile_single_path p trans states =
+  let steps =
+    match p with
+    | Absolute steps ->
+        (Ancestor false, QNameSet.singleton QName.document, [])::steps
+    | Relative steps -> steps
+  in
+  compile_step_list steps trans states
+
+and compile_step_list l trans states =
+  match l with
+  | [] -> Ata.SFormula.true_, trans, states
+  | (axis, test, elist) :: ll ->
+      let phi0, trans0, states0 = compile_step_list ll trans states in
+      let phi1, trans1, states1 =
+        compile_axis_test axis test phi0 trans0 states0
+      in
+      List.fold_left (fun (aphi, atrans, astates) e ->
+        let ephi, etrans, estates = compile_expr e atrans astates in
+        aphi %% ephi, etrans, estates) (phi1, trans1, states1) elist
+
+let compile_top_level_step_list l trans states =
+  let rec loop l trans states block_attr phi_above =
+    match l with
+    | (axis, test, elist) :: [] ->
+        let phi0, trans0, states0 =
+          compile_rev_axis_test
+            block_attr axis QNameSet.any phi_above trans states
+        in
+        let phi1, trans1, states1 =
+          List.fold_left (fun (aphi, atrans, astates) e ->
+            let ephi, etrans, estates = compile_expr e atrans astates in
+            aphi %% ephi, etrans, estates) (phi0, trans0, states0) elist
+        in
+        let phi' =
+          if axis = Attribute then
+            F.is_attribute
+          else
+            F.not_ F.is_attribute
+        in
+        let _, trans2, states2 =
+          compile_axis_test Self test (phi1 %% phi') trans1 states1
+          in
+        let marking_state =
+          StateSet.choose (StateSet.diff states2 states1)
+        in
+        marking_state, trans2, states2
+    | (axis, test, elist) :: ll ->
+        let phi0, trans0, states0 =
+          compile_rev_axis_test
+            block_attr axis QNameSet.any phi_above trans states
+        in
+        let phi1, trans1, states1 =
+          compile_axis_test Self test phi0 trans0 states0
+        in
+          let phi2, trans2, states2 =
+            List.fold_left (fun (aphi, atrans, astates) e ->
+              let ephi, etrans, estates = compile_expr e atrans astates in
+              aphi %% ephi, etrans, estates) (phi1, trans1, states1) elist
+          in
+          loop ll trans2 states2 (axis != Attribute) phi2
+    | _ -> assert false
+  in
+  let phi0, trans0, states0 =
+    compile_axis_test
+      Self
+      (QNameSet.singleton QName.document)
+      Ata.SFormula.true_
+      trans
+      states
+  in
+  loop l trans0 states0 true phi0
+;;
+
+
+let path p =
+  let mstates, trans, states = List.fold_left (fun (ams, atrs, asts) p ->
+    let ms, natrs, nasts =
+      match p with
+      | Absolute l | Relative l -> compile_top_level_step_list l atrs asts
+    in
+    (StateSet.add ms ams), natrs, nasts) (StateSet.empty, [], StateSet.empty) p
+  in
+  let a = Ata.create () in
+  a.Ata.states <- states;
+  a.Ata.selection_states <- mstates;
+  List.iter (fun (q, l) ->
+    List.iter (fun (lab, phi) ->
+      Ata.add_trans a q lab phi
+    ) l) trans;
+  Ata.complete_transitions a;
+  Ata.normalize_negations a;
+  a