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-02-14 17:15:58 CET by Kim Nguyen>
  18 *)
  19
  20 open Ast
  21 open Auto
  22 open Utils
  23
  24 let mk_atom l b q =
  25   Ata.SFormula.atom_ (Ata.Move.make (l,b,q))
  26
  27 let ( => ) a b = (a, b)
  28 let ( ** ) l q = mk_atom l true q
  29 let ( ++ ) a b = Ata.SFormula.or_ a b
  30 let ( %% ) a b = Ata.SFormula.and_ a b
  31 let ( @: ) a b = StateSet.add a b
  32
  33 (* [compile_axis_test axis test q phi trans states] Takes an xpath
  34    [axis] and node [test], a formula [phi], a list of [trans]itions
  35    and a set of [states] and returns a formula [phi'], a new set of
  36    transitions, and a new set of states such that [phi'] holds iff
  37    there exists a node reachable through [axis]::[test] where [phi]
  38    holds.
  39 *)
  40
  41 let compile_axis_test axis test phi trans states =
  42   let q = State.make () in
  43   let phi, trans, states =
  44     match axis with
  45     | Self ->
  46           (`Epsilon ** q),
  47           (q, [  test => phi ]) :: trans,
  48           states
  49
  50     | Child ->
  51         (`Left ** q),
  52       (q, [ test => phi;
  53             QNameSet.any => (`Right ** q) ]) :: trans,
  54       states
  55
  56     | Descendant self ->
  57         (if self then (`Epsilon ** q) else (`Left ** q)),
  58       (q, [ test => phi;
  59             QNameSet.any => (`Left ** q) %% (`Right ** q) ]) :: trans,
  60       states
  61
  62     | Parent ->
  63         let q' = State.make () in
  64         let move = (`Up1 ** q) ++ (`Up2 ** q') in
  65         move,
  66         (q, [ test => phi ])
  67         :: (q', [ QNameSet.any => move ]) :: trans,
  68         (q' @: states)
  69
  70     | Ancestor self ->
  71         let q' = State.make () in
  72         let move = (`Up1 ** q) ++ (`Up2 ** q') in
  73         (if self then (`Epsilon ** q) else move),
  74         (q, [ test => phi;
  75               QNameSet.any => move ])
  76         :: (q', [ QNameSet.any => move ]) :: trans,
  77         (q' @: states)
  78
  79     | FollowingSibling | PrecedingSibling ->
  80         let move =
  81           if axis = PrecedingSibling then
  82             (`Up2 ** q)
  83           else (`Right ** q)
  84         in
  85         move,
  86         (q, [ test => phi;
  87               QNameSet.any => move ]) :: trans,
  88         states
  89
  90     | Attribute ->
  91         let q' = State.make () in
  92         let test = if QNameSet.is_finite test then
  93             QNameSet.fold (fun tag acc -> QNameSet.add (QName.add_attribute_prefix tag) acc)
  94               test QNameSet.empty
  95           else test
  96         in
  97         (`Left ** q),
  98         (q, [ QNameSet.singleton QName.attribute_map => (`Left ** q') ])
  99         :: (q', [ test => phi;
 100                   QNameSet.any => (`Right ** q') ]) :: trans,
 101         (q' @:states)
 102     | _ -> assert false
 103
 104   in
 105   phi, trans, q @: states
 106 ;;
 107 let rec compile_expr e trans states =
 108   match e with
 109   | Binop (e1, (And|Or as op), e2) ->
 110       let phi1, trans1, states1 = compile_expr e1 trans states in
 111       let phi2, trans2, states2 = compile_expr e2 trans1 states1 in
 112       (if op = Or then phi1 ++ phi2 else phi1 %% phi2),
 113       trans2,
 114       states2
 115   | Fun_call (f, [ e0 ]) when (QName.to_string f) = "not" ->
 116       let phi, trans0, states0 = compile_expr e0 trans states in
 117       (Ata.SFormula.not_ phi),
 118       trans0,
 119       states0
 120   | Path p -> compile_path p trans states
 121
 122   | _ -> assert false
 123 and compile_path paths trans states =
 124   List.fold_left (fun (aphi, atrans, astates) p ->
 125     let phi, ntrans, nstates = compile_single_path p atrans astates in
 126     (Ata.SFormula.or_ phi aphi),
 127     ntrans,
 128     nstates) (Ata.SFormula.false_,trans,states) paths
 129
 130 and compile_single_path p trans states =
 131   let steps =
 132     match p with
 133     | Absolute steps ->
 134         (Ancestor false, QNameSet.singleton QName.document, [])::steps
 135     | Relative steps -> steps
 136   in
 137   compile_step_list steps trans states
 138 and compile_step_list l trans states =
 139   match l with
 140     [] -> Ata.SFormula.true_, trans, states
 141   | (axis, test, elist) :: ll ->
 142       let phi0, trans0, states0 = compile_step_list ll trans states in
 143       let phi1, trans1, states1 =
 144         compile_axis_test axis test phi0 trans0 states0
 145       in
 146       List.fold_left (fun (aphi, atrans, astates) e ->
 147         let ephi, etrans, estates = compile_expr e atrans astates in
 148         aphi %% ephi, etrans, estates) (phi1, trans1, states1) elist