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

diff --git a/src/xpath/compile.ml b/src/xpath/compile.ml
index 783d7f1..7848b84 100644
--- a/src/xpath/compile.ml
+++ b/src/xpath/compile.ml
@@ -14,21 +14,37 @@
 (***********************************************************************)
 
 (*
-  Time-stamp: <Last modified on 2013-02-14 17:15:58 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 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
@@ -38,39 +54,49 @@ let ( @: ) a b = StateSet.add a b
    holds.
 *)
 
-let compile_axis_test axis test phi trans states =
+let compile_axis_test ?(block_attr=true) axis test phi trans states =
   let q = State.make () in
-  let phi, trans, states =
+  let phi_attr = if block_attr then F.not_ F.is_attribute else F.true_ in
+  let phi', trans', states' =
     match axis with
     | Self ->
-          (`Epsilon ** q),
-          (q, [  test => phi ]) :: trans,
-          states
+        (F.stay q,
+         (q, [  test => phi ]) :: trans,
+         states)
 
     | Child ->
-        (`Left ** q),
-      (q, [ test => phi;
-            QNameSet.any => (`Right ** q) ]) :: trans,
-      states
+        (F.first_child q,
+         (q, [ test => phi %% phi_attr;
+               QNameSet.any => F.next_sibling q ]) :: trans,
+         states)
 
-    | Descendant self ->
-        (if self then (`Epsilon ** q) else (`Left ** q)),
-      (q, [ test => phi;
-            QNameSet.any => (`Left ** q) %% (`Right ** 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 = (`Up1 ** q) ++ (`Up2 ** q') in
-        move,
-        (q, [ test => phi ])
-        :: (q', [ QNameSet.any => move ]) :: trans,
-        (q' @: states)
+        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 = (`Up1 ** q) ++ (`Up2 ** q') in
-        (if self then (`Epsilon ** q) else move),
+        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,
@@ -79,31 +105,33 @@ let compile_axis_test axis test phi trans states =
     | FollowingSibling | PrecedingSibling ->
         let move =
           if axis = PrecedingSibling then
-            (`Up2 ** q)
-          else (`Right ** q)
+            F.previous_sibling q
+          else F.next_sibling q
         in
         move,
-        (q, [ test => phi;
+        (q, [ test => phi %% phi_attr;
               QNameSet.any => move ]) :: trans,
         states
 
     | Attribute ->
-        let q' = State.make () in
-        let 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
-        in
-        (`Left ** q),
-        (q, [ QNameSet.singleton QName.attribute_map => (`Left ** q') ])
-        :: (q', [ test => phi;
-                  QNameSet.any => (`Right ** q') ]) :: trans,
-        (q' @:states)
+        (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
-;;
+  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) ->
@@ -135,9 +163,10 @@ and compile_single_path p trans states =
     | 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
+  | [] -> Ata.SFormula.true_, trans, states
   | (axis, test, elist) :: ll ->
       let phi0, trans0, states0 = compile_step_list ll trans states in
       let phi1, trans1, states1 =
@@ -146,3 +175,76 @@ and compile_step_list l trans states =
       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