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-09 19:17:26 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 self ->
  74         ((if self then F.stay q else 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
  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 %% phi_attr;
 105               QNameSet.any => move ]) :: trans,
 106         states
 107
 108     | Attribute ->
 109         (F.first_child q,
 110          (q, [ test => phi %% F.is_attribute;
 111                QNameSet.any => F.next_sibling q]) :: trans,
 112          states)
 113     | _ -> assert false
 114
 115   in
 116   phi', trans', q @: states'
 117
 118
 119 let compile_rev_axis_test block_attr axis test phi trans states =
 120   match axis with
 121   | Attribute ->
 122       compile_axis_test
 123         ~block_attr:false Parent test phi trans states
 124   | _ -> compile_axis_test
 125       ~block_attr:block_attr (invert_axis axis) test phi trans states
 126
 127 let rec compile_expr e trans states =
 128   match e with
 129   | Binop (e1, (And|Or as op), e2) ->
 130       let phi1, trans1, states1 = compile_expr e1 trans states in
 131       let phi2, trans2, states2 = compile_expr e2 trans1 states1 in
 132       (if op = Or then phi1 ++ phi2 else phi1 %% phi2),
 133       trans2,
 134       states2
 135   | Fun_call (f, [ e0 ]) when (QName.to_string f) = "not" ->
 136       let phi, trans0, states0 = compile_expr e0 trans states in
 137       (Ata.SFormula.not_ phi),
 138       trans0,
 139       states0
 140   | Path p -> compile_path p trans states
 141
 142   | _ -> assert false
 143 and compile_path paths trans states =
 144   List.fold_left (fun (aphi, atrans, astates) p ->
 145     let phi, ntrans, nstates = compile_single_path p atrans astates in
 146     (Ata.SFormula.or_ phi aphi),
 147     ntrans,
 148     nstates) (Ata.SFormula.false_,trans,states) paths
 149
 150 and compile_single_path p trans states =
 151   let steps =
 152     match p with
 153     | Absolute steps ->
 154         (Ancestor false, QNameSet.singleton QName.document, [])::steps
 155     | Relative steps -> steps
 156   in
 157   compile_step_list steps trans states
 158
 159 and compile_step_list l trans states =
 160   match l with
 161   | [] -> Ata.SFormula.true_, trans, states
 162   | (axis, test, elist) :: ll ->
 163       let phi0, trans0, states0 = compile_step_list ll trans states in
 164       let phi1, trans1, states1 =
 165         compile_axis_test axis test phi0 trans0 states0
 166       in
 167       List.fold_left (fun (aphi, atrans, astates) e ->
 168         let ephi, etrans, estates = compile_expr e atrans astates in
 169         aphi %% ephi, etrans, estates) (phi1, trans1, states1) elist
 170
 171 let compile_top_level_step_list l trans states =
 172   let rec loop l trans states block_attr phi_above =
 173     match l with
 174     | (axis, test, elist) :: [] ->
 175         let phi0, trans0, states0 =
 176           compile_rev_axis_test
 177             block_attr axis QNameSet.any phi_above trans states
 178         in
 179         let phi1, trans1, states1 =
 180           List.fold_left (fun (aphi, atrans, astates) e ->
 181             let ephi, etrans, estates = compile_expr e atrans astates in
 182             aphi %% ephi, etrans, estates) (phi0, trans0, states0) elist
 183         in
 184         let phi' =
 185           if axis = Attribute then
 186             F.is_attribute
 187           else
 188             F.not_ F.is_attribute
 189         in
 190         let _, trans2, states2 =
 191           compile_axis_test Self test (phi1 %% phi') trans1 states1
 192           in
 193         let marking_state =
 194           StateSet.choose (StateSet.diff states2 states1)
 195         in
 196         marking_state, trans2, states2
 197     | (axis, test, elist) :: ll ->
 198         let phi0, trans0, states0 =
 199           compile_rev_axis_test
 200             block_attr axis QNameSet.any phi_above trans states
 201         in
 202         let phi1, trans1, states1 =
 203           compile_axis_test Self test phi0 trans0 states0
 204         in
 205           let phi2, trans2, states2 =
 206             List.fold_left (fun (aphi, atrans, astates) e ->
 207               let ephi, etrans, estates = compile_expr e atrans astates in
 208               aphi %% ephi, etrans, estates) (phi1, trans1, states1) elist
 209           in
 210           loop ll trans2 states2 (axis != Attribute) phi2
 211     | _ -> assert false
 212   in
 213   let phi0, trans0, states0 =
 214     compile_axis_test
 215       Self
 216       (QNameSet.singleton QName.document)
 217       Ata.SFormula.true_
 218       trans
 219       states
 220   in
 221   loop l trans0 states0 true phi0
 222 ;;
 223
 224
 225 let path p =
 226   let mstates, trans, states = List.fold_left (fun (ams, atrs, asts) p ->
 227     let ms, natrs, nasts =
 228       match p with
 229       | Absolute l | Relative l -> compile_top_level_step_list l atrs asts
 230     in
 231     (StateSet.add ms ams), natrs, nasts) (StateSet.empty, [], StateSet.empty) p
 232   in
 233   let a = Ata.create () in
 234   a.Ata.states <- states;
 235   a.Ata.selection_states <- mstates;
 236   List.iter (fun (q, l) ->
 237     List.iter (fun (lab, phi) ->
 238       Ata.add_trans a q lab phi
 239     ) l) trans;
 240   Ata.complete_transitions a;
 241   Ata.normalize_negations a;
 242   a