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 (***********************************************************************)
16 #load "pa_extend.cmo";;
20 type path = Absolute of step list | AbsoluteDoS of step list| Relative of step list
21 and step = axis * test *predicate
22 and axis = Self | Attribute | Child | Descendant | DescendantOrSelf | FollowingSibling
23 | Parent | Ancestor | AncestorOrSelf | PrecedingSibling | Preceding | Following
25 and test = Simple of QNameSet.t
28 and predicate = Or of predicate*predicate
29 | And of predicate*predicate
32 and expression = Path of path
33 | Function of string*expression list
40 let text = QNameSet.singleton QName.text
41 let node = QNameSet.any
44 QNameSet.from_list [ QName.text;
48 let t_text = Simple text
49 let t_node = Simple node
50 let t_star = Simple star
54 let pp fmt = Format.fprintf fmt
55 let print_list printer fmt sep l =
58 | [e] -> printer fmt e
59 | e::es -> printer fmt e; List.iter (fun x -> pp fmt sep;printer fmt x) es
64 | Absolute l -> pp fmt "/"; l
65 | AbsoluteDoS l -> pp fmt "/";
66 print_step fmt (DescendantOrSelf,Simple QNameSet.any,Expr True);
70 Pretty.print_list ~sep:"/" print_step fmt l
71 and print_step fmt (axis, test, predicate) =
72 print_axis fmt axis;pp fmt "::";print_test fmt test;
75 | _ -> pp fmt "["; print_predicate fmt predicate; pp fmt "]"
76 and print_axis fmt a = pp fmt "%s" (match a with
79 | Descendant -> "descendant"
80 | DescendantOrSelf -> "descendant-or-self"
81 | FollowingSibling -> "following-sibling"
82 | Attribute -> "attribute"
83 | Ancestor -> "ancestor"
84 | AncestorOrSelf -> "ancestor-or-self"
85 | PrecedingSibling -> "preceding-sibling"
89 and print_test fmt ts =
91 pp fmt "%s" (List.assoc ts
96 Not_found -> pp fmt "%s"
98 Simple t -> if QNameSet.is_finite t
99 then QName.to_string (QNameSet.choose t)
103 and print_predicate fmt = function
104 | Or(p,q) -> print_predicate fmt p; pp fmt " or "; print_predicate fmt q
105 | And(p,q) -> print_predicate fmt p; pp fmt " and "; print_predicate fmt q
106 | Not p -> pp fmt "not "; print_predicate fmt p
107 | Expr e -> print_expression fmt e
109 and print_expression fmt = function
110 | Path p -> print fmt p
113 Pretty.print_list ~sep:"," print_expression fmt l;
115 | Int i -> pp fmt "%i" i
116 | String s -> pp fmt "\"%s\"" s
117 | t -> pp fmt "%b" (t== True)
124 let predopt = function None -> Expr True | Some p -> p
126 module Gram = Camlp4.Struct.Grammar.Static.Make(Ulexer)
127 let query = Gram.Entry.mk "query"
129 exception Error of Gram.Loc.t*string
130 let test_of_keyword t loc =
135 | "and" | "not" | "or" -> QNameSet.singleton (QName.of_string t)
136 | _ -> raise (Error(loc,"Invalid test name "^t ))
138 let axis_to_string a = let r = Format.str_formatter in
139 print_axis r a; Format.flush_str_formatter()
148 query : [ [ p = path; `EOI -> p ]]
152 [ "//" ; l = slist -> AbsoluteDoS (List.rev l) ]
153 | [ "/" ; l = slist -> Absolute (List.rev l) ]
154 | [ l = slist -> Relative (List.rev l) ]
159 [ l = slist ;"/"; s = step -> s @ l ]
160 | [ l = slist ; "//"; s = step -> s@[(DescendantOrSelf, t_node ,Expr True)]@l]
165 (* yurk, this is done to parse stuff like
166 a/b/descendant/a where descendant is actually a tag name :(
167 if OPT is None then this is a child::descendant if not, this is a real axis name
171 [ axis = axis ; o = OPT ["::" ; t = test -> t ] ; p = top_pred ->
174 | Some(t) -> (axis,t,p)
175 | None -> (Child,Simple (QNameSet.singleton (QName.of_string (axis_to_string axis))),p)
177 | Following -> [ (DescendantOrSelf,t,p);
178 (FollowingSibling, t_star,Expr(True));
179 (Ancestor, t_star ,Expr(True)) ]
181 | Preceding -> [ (DescendantOrSelf,t,p);
182 (PrecedingSibling,t_star,Expr(True));
183 (Ancestor,t_star,Expr(True)) ]
188 | [ "." ; p = top_pred -> [(Self, t_node,p)] ]
189 | [ ".." ; p = top_pred -> [(Parent,t_star,p)] ]
190 | [ test = test; p = top_pred -> [(Child,test, p)] ]
191 | [ att = ATT ; p = top_pred ->
193 | "*" -> [(Attribute,t_star,p)]
194 | _ -> [(Attribute, Simple (QNameSet.singleton (QName.of_string att)) ,p )]]
198 [ p = OPT [ "["; p=predicate ;"]" -> p ] -> predopt p ]
202 [ "self" -> Self | "child" -> Child | "descendant" -> Descendant
203 | "descendant-or-self" -> DescendantOrSelf
204 | "ancestor-or-self" -> AncestorOrSelf
205 | "following-sibling" -> FollowingSibling
206 | "attribute" -> Attribute
208 | "ancestor" -> Ancestor
209 | "preceding-sibling" -> PrecedingSibling
210 | "preceding" -> Preceding
211 | "following" -> Following
217 [ s = KWD -> Simple (test_of_keyword s _loc) ]
218 | [ t = TAG -> Simple (QNameSet.singleton (QName.of_string t)) ]
224 [ p = predicate; "or"; q = predicate -> Or(p,q) ]
225 | [ p = predicate; "and"; q = predicate -> And(p,q) ]
226 | [ "not" ; p = predicate -> Not p ]
227 | [ "("; p = predicate ;")" -> p ]
228 | [ e = expression -> Expr e ]
232 [ f = TAG; "("; args = LIST0 expression SEP "," ; ")" -> Function(f,args)]
233 | [ `INT(i) -> Int (i) ]
234 | [ s = STRING -> String s ]
235 | [ p = path -> Path p ]
236 | [ "("; e = expression ; ")" -> e ]
245 query : [ [ p = location_path; `EOI -> p ]]
250 [ "/" ; l = OPT relative_location_path ->
251 let l = match l with None -> [] | Some l' -> l' in Absolute l ]
252 | [ l = relative_location_path -> Relative l ]
253 | [ l = abbrev_absolute_location_path -> l ]
258 relative_location_path : [
259 [ s = step -> [ s ] ]
260 | [ l = relative_location_path ; "/"; s = step -> l @ [ s ] ]
261 | [ l = abbrev_relative_location_path -> l ]
267 [ a = axis_specifier ; n = node_test ; p = OPT predicate ->
268 let p = match p with Some p' -> p' | None -> Expr(True) in
271 | [ a = abbrev_step -> a ]
275 [ a = axis_name ; "::" -> a ]
276 | [ a = abbrev_axis_specifier -> a ]
280 [ "self" -> Self | "child" -> Child | "descendant" -> Descendant
281 | "descendant-or-self" -> DescendantOrSelf
282 | "ancestor-or-self" -> AncestorOrSelf
283 | "following-sibling" -> FollowingSibling
284 | "attribute" -> Attribute
286 | "ancestor" -> Ancestor
287 | "preceding-sibling" -> PrecedingSibling
288 | "preceding" -> Preceding
289 | "following" -> Following
294 [ n = name_test -> n ]
295 | [ n = node_type ; "("; ")" -> n ]
296 (* | [ "processing-instruction" ; "(" ... ")" ] *)
300 [ "*" -> Simple(TagSet.star) ]
301 | [ t = axis_name -> Simple(TagSet.singleton (Tag.tag (axis_to_string t))) ]
302 | [ t = TAG -> Simple(TagSet.singleton (Tag.tag t)) ]
306 [ "text" -> Simple(TagSet.pcdata) ]
307 | [ "node" -> Simple(TagSet.node) ]
311 [ "["; e = expr ; "]" -> e ]
314 abbrev_absolute_location_path : [
315 [ "//"; l = relative_location_path -> AbsoluteDoS l ]
318 abbrev_relative_location_path : [
319 [ l = relative_location_path; "//"; s = step ->
320 l @ [ (DescendantOrSelf,Simple(TagSet.node),Expr(True)); s ]
325 [ "." -> (Self, Simple(TagSet.node), Expr(True)) ]
326 | [ ".." -> (Parent, Simple(TagSet.node), Expr(True)) ]
329 abbrev_axis_specifier: [
330 [ a = OPT "@" -> match a with None -> Attribute | _ -> Child ]
338 [ "("; e = expr ; ")" -> e ]
339 | [ s = STRING -> Expr (String s) ]
340 | [ `INT(i) -> Expr (Int (i)) ]
341 | [ f = TAG; "("; args = LIST0 expr SEP "," ; ")" ->
342 Expr(Function(f, List.map (function Expr e -> e | _ -> assert false) args))]
347 [ o1 = or_expr ; "or" ; o2 = and_expr -> Or(o1, o2) ]
348 | [ a = and_expr -> a ]
353 [ a1 = and_expr; "and"; a2 = unary_expr -> And(a1, a2) ]
354 | [ p = unary_expr -> p ]
358 [ l = location_path -> Expr(Path l) ]
359 | [ "not"; "("; e = expr ; ")" -> Not e ]
360 | [ p = primary_expr -> p ]
369 let parse_string = Gram.parse_string query (Ulexer.Loc.mk "<string>")
370 let parse_file fd = parse_string (input_line fd)
373 let parse_string = Parser.parse_string
374 let parse_file = Parser.parse_file