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