src/xpath/compile.ml

   1 (***********************************************************************)
   2 (*                                                                     *)
   3 (*                               TAToo                                 *)
   4 (*                                                                     *)
   5 (*                     Kim Nguyen, LRI UMR8623                         *)
   6 (*                   Université Paris-Sud & CNRS                       *)
   7 (*                                                                     *)
   8 (*  Copyright 2010-2013 Université Paris-Sud and Centre National de la *)
   9 (*  Recherche Scientifique. All rights reserved.  This file is         *)
  10 (*  distributed under the terms of the GNU Lesser General Public       *)
  11 (*  License, with the special exception on linking described in file   *)
  12 (*  ../LICENSE.                                                        *)
  13 (*                                                                     *)
  14 (***********************************************************************)
  15
  16 (*
  17   Time-stamp: <Last modified on 2013-03-13 11:02:32 CET by Kim Nguyen>
  18 *)
  19
  20 open Ast
  21 open Auto
  22 open Utils
  23
  24
  25 let ( => ) a b = (a, b)
  26 let ( ++ ) a b = Ata.SFormula.or_ a b
  27 let ( %% ) a b = Ata.SFormula.and_ a b
  28 let ( @: ) a b = StateSet.add a b
  29
  30 module F = Ata.SFormula
  31
  32
  33 let node_set = QNameSet.remove QName.document QNameSet.any
  34 let star_set = QNameSet.diff QNameSet.any (
  35   List.fold_right (QNameSet.add)
  36     [ QName.document; QName.text; QName.comment ]
  37     QNameSet.empty)
  38 let root_set = QNameSet.singleton QName.document
  39
  40 (* [compile_axis_test axis test q phi trans states] Takes an xpath
  41    [axis] and node [test], a formula [phi], a list of [trans]itions
  42    and a set of [states] and returns a formula [phi'], a new set of
  43    transitions, and a new set of states such that [phi'] holds iff
  44    there exists a node reachable through [axis]::[test] where [phi]
  45    holds.
  46 *)
  47
  48 let compile_axis_test axis (test,kind) phi trans states =
  49   let q = State.make () in
  50   let phi = match kind with
  51     Tree.Common.NodeKind.Node -> phi
  52   | _ -> phi %% F.mk_kind kind
  53   in
  54   let phi', trans', states' =
  55     match axis with
  56     | Self ->
  57         (F.stay q,
  58          (q, [  test => phi ]) :: trans,
  59          states)
  60
  61     | Child ->
  62         (F.first_child q,
  63          (q, [ test => phi;
  64                QNameSet.any => F.next_sibling q ]) :: trans,
  65          states)
  66
  67     | Descendant false ->
  68         (F.first_child q,
  69          (q, [ test => phi;
  70                QNameSet.any => F.first_child q ++ F.next_sibling q;
  71              ]) :: trans,
  72          states)
  73     | Descendant true ->
  74         let q' = State.make () in
  75         (F.or_ (F.stay q) (F.first_child q'),
  76          (q', [ test => phi;
  77                QNameSet.any => F.first_child q' ++ F.next_sibling q';
  78              ])::
  79          (q, [ test => phi]):: trans,
  80          states)
  81
  82     | Parent ->
  83         let q' = State.make () in
  84         let move = F.parent q ++ F.previous_sibling q' in
  85         (move,
  86          (q, [ test => phi ])
  87          :: (q', [ QNameSet.any => move ]) :: trans,
  88          (q' @: states))
  89
  90     | Ancestor self ->
  91         let q' = State.make () in
  92         let move = F.parent q ++ F.previous_sibling q' in
  93         (if self then F.stay q else move),
  94         (q, [ test => phi;
  95               QNameSet.any => move ])
  96         :: (q', [ QNameSet.any => move ]) :: trans,
  97         (q' @: states)
  98
  99     | FollowingSibling | PrecedingSibling ->
 100         let move =
 101           if axis = PrecedingSibling then
 102             F.previous_sibling q
 103           else F.next_sibling q
 104         in
 105         move,
 106         (q, [ test => phi;
 107               QNameSet.any => move ]) :: trans,
 108         states
 109
 110     | Attribute ->
 111         (F.first_child q,
 112          (q, [ test => phi;
 113                QNameSet.any => F.next_sibling q]) :: trans,
 114          states)
 115     | _ -> assert false
 116
 117   in
 118   phi', trans', q @: states'
 119
 120 let rec compile_expr e trans states =
 121   match e with
 122   | Binop (e1, (And|Or as op), e2) ->
 123       let phi1, trans1, states1 = compile_expr e1 trans states in
 124       let phi2, trans2, states2 = compile_expr e2 trans1 states1 in
 125       (if op = Or then phi1 ++ phi2 else phi1 %% phi2),
 126       trans2,
 127       states2
 128   | Fun_call (f, [ e0 ]) when (QName.to_string f) = "not" ->
 129       let phi, trans0, states0 = compile_expr e0 trans states in
 130       (Ata.SFormula.not_ phi),
 131       trans0,
 132       states0
 133   | Path p -> compile_path p trans states
 134
 135   | _ -> assert false
 136 and compile_path paths trans states =
 137   List.fold_left (fun (aphi, atrans, astates) p ->
 138     let phi, ntrans, nstates = compile_single_path p atrans astates in
 139     (Ata.SFormula.or_ phi aphi),
 140     ntrans,
 141     nstates) (Ata.SFormula.false_,trans,states) paths
 142
 143 and compile_single_path p trans states =
 144   let steps =
 145     match p with
 146     | Absolute steps ->
 147         (Ancestor false, (QNameSet.singleton QName.document,
 148                           Tree.Common.NodeKind.Node), [])
 149         :: steps
 150     | Relative steps -> steps
 151   in
 152   compile_step_list steps trans states
 153
 154 and compile_step_list l trans states =
 155   match l with
 156   | [] -> Ata.SFormula.true_, trans, states
 157   | (axis, test, elist) :: ll ->
 158       let phi0, trans0, states0 = compile_step_list ll trans states in
 159       let phi1, trans1, states1 =
 160         compile_axis_test axis test phi0 trans0 states0
 161       in
 162       List.fold_left (fun (aphi, atrans, astates) e ->
 163         let ephi, etrans, estates = compile_expr e atrans astates in
 164         aphi %% ephi, etrans, estates) (phi1, trans1, states1) elist
 165
 166 (**
 167    Compile the top-level XPath query in reverse (doing downward
 168    to the last top-level state):
 169    /a0::t0[p0]/.../an-1::tn-1[pn-1]/an::tn[pn] becomes:
 170    self::node()[ pn and
 171    self::tn[pn]/inv(an)::(tn-1)[pn-1]/.../inv(a1)::t0[p0]/inv(a0)::document()]
 172
 173    /child::a/attribute::b
 174    self::@b/parent::a/parent::doc()
 175 *)
 176
 177 let compile_top_level_step_list l trans states =
 178   let rec loop l trans states phi_above =
 179     match l with
 180     | [] -> assert false
 181     | (axis, (test,kind), elist) :: ll ->
 182         let phi0, trans0, states0 =
 183           compile_axis_test (invert_axis axis)
 184             (QNameSet.any, Tree.Common.NodeKind.Node)
 185             phi_above trans states
 186         in
 187         (* Only select attribute nodes if the previous axis
 188            is attribute *)
 189         let phi0 =
 190           if axis != Attribute then
 191             phi0 %% (Ata.SFormula.not_ Ata.SFormula.is_attribute)
 192           else phi0
 193         in
 194         match ll with
 195           [] ->
 196             let phi1, trans1, states1 =
 197               List.fold_left (fun (aphi, atrans, astates) e ->
 198                 let ephi, etrans, estates = compile_expr e atrans astates in
 199                 aphi %% ephi, etrans, estates) (phi0, trans0, states0) elist
 200             in
 201             let _, trans2, states2 =
 202               compile_axis_test Self (test,kind) phi1 trans1 states1
 203             in
 204             let marking_state =
 205               StateSet.choose (StateSet.diff states2 states1)
 206             in
 207             marking_state, trans2, states2
 208         | _ ->
 209             let phi1, trans1, states1 =
 210               compile_axis_test Self (test,kind) phi0 trans0 states0
 211             in
 212             let phi2, trans2, states2 =
 213               List.fold_left (fun (aphi, atrans, astates) e ->
 214                 let ephi, etrans, estates = compile_expr e atrans astates in
 215                 aphi %% ephi, etrans, estates) (phi1, trans1, states1) elist
 216             in
 217             loop ll trans2 states2  phi2
 218   in
 219   let phi0, trans0, states0 =
 220     compile_axis_test
 221       Self
 222       (QNameSet.singleton QName.document, Tree.Common.NodeKind.Node)
 223       Ata.SFormula.true_
 224       trans
 225       states
 226   in
 227   loop l trans0 states0 phi0
 228 ;;
 229
 230 let path p =
 231   let mstates, trans, states = List.fold_left (fun (ams, atrs, asts) p ->
 232     let ms, natrs, nasts =
 233       match p with
 234       | Absolute l | Relative l -> compile_top_level_step_list l atrs asts
 235     in
 236     (StateSet.add ms ams), natrs, nasts) (StateSet.empty, [], StateSet.empty) p
 237   in
 238   let a = Ata.create () in
 239   a.Ata.states <- states;
 240   a.Ata.selection_states <- mstates;
 241   List.iter (fun (q, l) ->
 242     List.iter (fun (lab, phi) ->
 243       Ata.add_trans a q lab phi
 244     ) l) trans;
 245   Ata.complete_transitions a;
 246   Ata.normalize_negations a;
 247   a