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