1 (***********************************************************************)
5 (* Kim Nguyen, LRI UMR8623 *)
6 (* Université Paris-Sud & CNRS *)
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 *)
14 (***********************************************************************)
17 Time-stamp: <Last modified on 2013-03-13 10:59:20 CET by Kim Nguyen>
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 *)
29 | Ancestor of bool (* true = ancestor-or-self, false = ancestor *)
31 | Preceding | Following
33 and test = QNameSet.t * Tree.Common.NodeKind.t
35 and binop = Eq | Neq | Lt | Gt | Lte | Gte | Or | And | Add | Sub | Mult | Div | Mod
38 | Number of [ `Int of int | `Float of float ]
40 | Fun_call of QName.t * expr list
42 | Binop of expr * binop * expr
49 let text = QNameSet.singleton QName.text
50 let node = QNameSet.any
53 QNameSet.from_list [ QName.text;
59 let pp fmt e = Format.fprintf fmt e
65 | Number _ | String _ | Fun_call _ -> 9
66 | Binop (_,op,_) -> begin match op with
67 | Lt | Lte | Gt | Gte -> 7
71 | Mult | Div | Mod -> 3
75 let print_binop fmt o =
76 pp fmt "%s" begin match o with
91 let print_unop fmt o =
92 pp fmt "%s" begin match o with
96 let rec print_path fmt p =
97 Pretty.print_list ~sep:" | " print_single_path fmt p
99 and print_single_path fmt p =
101 | Absolute l -> pp fmt "/"; l
104 Pretty.print_list ~sep:"/" print_step fmt l
106 and print_step fmt (axis, test, expr) =
107 pp fmt "%a::%a" print_axis axis print_test test;
111 Pretty.print_list ~sep:" ][ " print_expr fmt l;
114 and print_axis fmt a = pp fmt "%s" begin
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"
126 | Preceding -> "preceding"
127 | Following -> "following"
130 and print_test fmt (ts,kind) =
131 let open Tree.Common.NodeKind in
133 Text -> pp fmt "%s" "text()"
134 | Element | Attribute ->
136 if ts == star then "*"
137 else QName.to_string (QNameSet.choose ts)
139 | Comment -> pp fmt "%s" "comment()"
140 | ProcessingInstruction ->
141 pp fmt "processing-instruction(%s)"
143 if ts == star then ""
144 else "'" ^ (QName.to_string (QNameSet.choose ts)) ^ "'"
146 | Node -> pp fmt "%s" "node()"
147 | Document -> pp fmt "%s" "<DOCUMENT>"
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;
157 | Path p -> print_path fmt p
158 | Binop (e1, op, e2) as e ->
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
172 if need_par0 then pp fmt "(";
174 if need_par0 then pp fmt ")"
178 let invert_axis = function
180 | Attribute -> Parent (* Improve *)
182 | Descendant (b) -> Ancestor (b)
183 | FollowingSibling -> PrecedingSibling
185 | Ancestor (b) -> Descendant (b)
186 | PrecedingSibling -> FollowingSibling
187 | Preceding -> Following
188 | Following -> Preceding