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