src/xPath.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 module Ast =
  16 struct
  17
  18   type path = single_path list
  19   and single_path = Absolute of step list | Relative of step list
  20   and step = axis * test * expr list
  21   and axis = Self | Attribute | Child | Descendant | DescendantOrSelf | FollowingSibling
  22              | Parent | Ancestor | AncestorOrSelf | PrecedingSibling | Preceding | Following
  23
  24   and test = Simple of QNameSet.t
  25
  26   and binop = Eq | Neq | Lt | Gt | Lte | Gte | Or | And | Add | Sub | Mult | Div | Mod
  27   and unop =  Neg
  28   and expr =
  29     | Number of [ `Int of int | `Float of float ]
  30     | String of string
  31     | Fun_call of QName.t * expr list
  32     | Path of path
  33     | Binop of expr * binop * expr
  34     | Unop of unop * expr
  35
  36
  37   type t = path
  38
  39
  40   let text = QNameSet.singleton QName.text
  41   let node = QNameSet.any
  42   let star =
  43     QNameSet.complement (
  44       QNameSet.from_list [ QName.text;
  45                          QName.document;
  46                          QName.cdata_section;
  47                          QName.comment])
  48   let t_text = Simple text
  49   let t_node = Simple node
  50   let t_star = Simple star
  51
  52
  53
  54   let pp fmt e = Format.fprintf fmt e
  55
  56   let prio e = 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" (match a with
 109       Self -> "self"
 110     | Child -> "child"
 111     | Descendant -> "descendant"
 112     | DescendantOrSelf -> "descendant-or-self"
 113     | FollowingSibling -> "following-sibling"
 114     | Attribute -> "attribute"
 115     | Ancestor -> "ancestor"
 116     | AncestorOrSelf -> "ancestor-or-self"
 117     | PrecedingSibling -> "preceding-sibling"
 118     | Parent -> "parent"
 119     | Preceding -> "preceding"
 120     | Following -> "following"
 121   )
 122   and print_test fmt ts =
 123     try
 124       pp fmt "%s" (List.assoc ts
 125                      [ t_text,"text()";
 126                        t_node,"node()";
 127                        t_star, "*" ] )
 128     with
 129       Not_found -> pp fmt "%s"
 130         (match ts with
 131           Simple t -> if QNameSet.is_finite t
 132             then QName.to_string (QNameSet.choose t)
 133             else "<INFINITE>"
 134         )
 135
 136   and print_expr fmt = function
 137     | Number (`Int(i)) -> pp fmt "%i" i
 138     | Number (`Float(f)) -> pp fmt "%f" f
 139     | String s -> pp fmt "'%S'" s
 140     | Fun_call (n, args) ->
 141         pp fmt "%a(" QName.print n;
 142         Pretty.print_list ~sep:", " print_expr fmt args;
 143         pp fmt ")"
 144     | Path p -> print_path fmt p
 145     | Binop (e1, op, e2) as e ->
 146         let pe = prio e in
 147         let need_par1 = prio e1 < pe in
 148         if need_par1 then pp fmt "(";
 149         pp fmt "%a" print_expr e1;
 150         if need_par1 then pp fmt ")";
 151         pp fmt " %a "  print_binop op;
 152         let need_par2 = prio e2 < pe in
 153         if need_par2 then pp fmt "(";
 154         pp fmt "%a" print_expr e2;
 155         if need_par2 then pp fmt ")"
 156     | Unop (op, e0) as e ->
 157         let need_par0 = prio e0 < prio e in
 158         print_unop fmt op;
 159         if need_par0 then pp fmt "(";
 160         print_expr fmt e0;
 161         if need_par0 then pp fmt ")"
 162
 163 end