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