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