src/xpath/ast.ml

   1 (***********************************************************************)
   2 (*                                                                     *)
   3 (*                               TAToo                                 *)
   4 (*                                                                     *)
   5 (*                     Kim Nguyen, LRI UMR8623                         *)
   6 (*                   Université Paris-Sud & CNRS                       *)
   7 (*                                                                     *)
   8 (*  Copyright 2010-2012 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 10:59:20 CET by Kim Nguyen>
  18 *)
  19
  20 open Utils
  21
  22 type path = single_path list
  23 and single_path = Absolute of step list | Relative of step list
  24 and step = axis * test * expr list
  25 and axis = Self | Attribute | Child
  26            | Descendant of bool  (* true = descendant-or-self, false = descendant *)
  27            | FollowingSibling
  28            | Parent
  29            | Ancestor of bool (* true = ancestor-or-self, false = ancestor *)
  30            | PrecedingSibling
  31            | Preceding | Following
  32
  33 and test = QNameSet.t * Tree.Common.NodeKind.t
  34
  35 and binop = Eq | Neq | Lt | Gt | Lte | Gte | Or | And | Add | Sub | Mult | Div | Mod
  36 and unop =  Neg
  37 and expr =
  38   | Number of [ `Int of int | `Float of float ]
  39   | String of string
  40   | Fun_call of QName.t * expr list
  41   | Path of path
  42   | Binop of expr * binop * expr
  43   | Unop of unop * expr
  44
  45
  46 type t = path
  47
  48
  49 let text = QNameSet.singleton QName.text
  50 let node = QNameSet.any
  51 let star =
  52   QNameSet.complement (
  53     QNameSet.from_list [ QName.text;
  54                          QName.document;
  55                          QName.comment])
  56
  57
  58
  59 let pp fmt e = Format.fprintf fmt e
  60
  61 let prio e =
  62   match e with
  63   | Unop (Neg, _) -> 11
  64   | Path _ -> 10
  65   | Number _ | String _ | Fun_call _ -> 9
  66   | Binop (_,op,_) -> begin match op with
  67     | Lt | Lte | Gt | Gte -> 7
  68     | Neq | Eq -> 6
  69     | And -> 5
  70     | Or -> 4
  71     | Mult | Div | Mod -> 3
  72     | Add | Sub -> 2
  73   end
  74
  75 let print_binop fmt o =
  76   pp fmt "%s" begin match o with
  77   | Eq -> "="
  78   | Neq -> "!="
  79   | Lt -> "<"
  80   | Gt -> ">"
  81   | Lte -> "<="
  82   | Gte -> ">="
  83   | Or -> "or"
  84   | And -> "and"
  85   | Add -> "+"
  86   | Sub -> "-"
  87   | Mult -> "*"
  88   | Div -> "div"
  89   | Mod -> "mod"
  90   end
  91 let print_unop fmt o =
  92   pp fmt "%s" begin match o with
  93   | Neg -> "-"
  94   end
  95
  96 let rec print_path fmt p =
  97   Pretty.print_list ~sep:" | " print_single_path fmt p
  98
  99 and print_single_path fmt p =
 100   let l = match p with
 101   | Absolute l -> pp fmt "/"; l
 102   | Relative l -> l
 103   in
 104   Pretty.print_list ~sep:"/" print_step fmt l
 105
 106 and print_step fmt (axis, test, expr) =
 107   pp fmt "%a::%a" print_axis axis print_test test;
 108   match expr with
 109     [] -> ()
 110   | l -> pp fmt "[ ";
 111       Pretty.print_list ~sep:" ][ " print_expr fmt l;
 112       pp fmt " ]"
 113
 114 and print_axis fmt a = pp fmt "%s" begin
 115   match a with
 116     Self -> "self"
 117   | Child -> "child"
 118   | Descendant false -> "descendant"
 119   | Descendant true -> "descendant-or-self"
 120   | FollowingSibling -> "following-sibling"
 121   | Attribute -> "attribute"
 122   | Ancestor false -> "ancestor"
 123   | Ancestor true -> "ancestor-or-self"
 124   | PrecedingSibling -> "preceding-sibling"
 125   | Parent -> "parent"
 126   | Preceding -> "preceding"
 127   | Following -> "following"
 128 end
 129
 130 and print_test fmt (ts,kind) =
 131   let open Tree.Common.NodeKind in
 132     match kind with
 133       Text -> pp fmt "%s" "text()"
 134     | Element | Attribute ->
 135         pp fmt "%s" begin
 136           if ts == star then "*"
 137           else QName.to_string (QNameSet.choose ts)
 138         end
 139     | Comment -> pp fmt "%s" "comment()"
 140     | ProcessingInstruction ->
 141         pp fmt "processing-instruction(%s)"
 142           begin
 143             if ts == star then ""
 144             else "'" ^ (QName.to_string (QNameSet.choose ts)) ^ "'"
 145           end
 146     | Node -> pp fmt "%s" "node()"
 147     | Document -> pp fmt "%s" "<DOCUMENT>"
 148
 149 and print_expr fmt = function
 150 | Number (`Int(i)) -> pp fmt "%i" i
 151 | Number (`Float(f)) -> pp fmt "%f" f
 152 | String s -> pp fmt "'%S'" s
 153 | Fun_call (n, args) ->
 154     pp fmt "%a(" QName.print n;
 155     Pretty.print_list ~sep:", " print_expr fmt args;
 156     pp fmt ")"
 157 | Path p -> print_path fmt p
 158 | Binop (e1, op, e2) as e ->
 159     let pe = prio e in
 160     let need_par1 = prio e1 < pe in
 161     if need_par1 then pp fmt "(";
 162     pp fmt "%a" print_expr e1;
 163     if need_par1 then pp fmt ")";
 164     pp fmt " %a "  print_binop op;
 165     let need_par2 = prio e2 < pe in
 166     if need_par2 then pp fmt "(";
 167     pp fmt "%a" print_expr e2;
 168     if need_par2 then pp fmt ")"
 169 | Unop (op, e0) as e ->
 170     let need_par0 = prio e0 < prio e in
 171     print_unop fmt op;
 172     if need_par0 then pp fmt "(";
 173     print_expr fmt e0;
 174     if need_par0 then pp fmt ")"
 175
 176
 177
 178 let invert_axis = function
 179 | Self -> Self
 180 | Attribute -> Parent (* Improve *)
 181 | Child -> Parent
 182 | Descendant (b) -> Ancestor (b)
 183 | FollowingSibling -> PrecedingSibling
 184 | Parent -> Child
 185 | Ancestor (b) -> Descendant (b)
 186 | PrecedingSibling -> FollowingSibling
 187 | Preceding -> Following
 188 | Following -> Preceding
 189 ;;
 190