--- /dev/null
+(***********************************************************************)
+(* *)
+(* TAToo *)
+(* *)
+(* Kim Nguyen, LRI UMR8623 *)
+(* Université Paris-Sud & CNRS *)
+(* *)
+(* Copyright 2010-2012 Université Paris-Sud and Centre National de la *)
+(* Recherche Scientifique. All rights reserved. This file is *)
+(* distributed under the terms of the GNU Lesser General Public *)
+(* License, with the special exception on linking described in file *)
+(* ../LICENSE. *)
+(* *)
+(***********************************************************************)
+
+#load "pa_extend.cmo";;
+module Ast =
+struct
+
+ type path = Absolute of step list | AbsoluteDoS of step list| Relative of step list
+ and step = axis * test *predicate
+ and axis = Self | Attribute | Child | Descendant | DescendantOrSelf | FollowingSibling
+ | Parent | Ancestor | AncestorOrSelf | PrecedingSibling | Preceding | Following
+
+ and test = Simple of QNameSet.t
+
+
+ and predicate = Or of predicate*predicate
+ | And of predicate*predicate
+ | Not of predicate
+ | Expr of expression
+ and expression = Path of path
+ | Function of string*expression list
+ | Int of int
+ | String of string
+ | True | False
+ type t = path
+
+
+ let text = QNameSet.singleton QName.text
+ let node = QNameSet.any
+ let star =
+ QNameSet.complement (
+ QNameSet.from_list [ QName.text;
+ QName.document;
+ QName.cdata_section;
+ QName.comment])
+ let t_text = Simple text
+ let t_node = Simple node
+ let t_star = Simple star
+
+
+
+ let pp fmt = Format.fprintf fmt
+ let print_list printer fmt sep l =
+ match l with
+ [] -> ()
+ | [e] -> printer fmt e
+ | e::es -> printer fmt e; List.iter (fun x -> pp fmt sep;printer fmt x) es
+
+
+ let rec print fmt p =
+ let l = match p with
+ | Absolute l -> pp fmt "/"; l
+ | AbsoluteDoS l -> pp fmt "/";
+ print_step fmt (DescendantOrSelf,Simple QNameSet.any,Expr True);
+ pp fmt "/"; l
+ | Relative l -> l
+ in
+ Pretty.print_list ~sep:"/" print_step fmt l
+ and print_step fmt (axis, test, predicate) =
+ print_axis fmt axis;pp fmt "::";print_test fmt test;
+ match predicate with
+ Expr True -> ()
+ | _ -> pp fmt "["; print_predicate fmt predicate; pp fmt "]"
+ and print_axis fmt a = pp fmt "%s" (match a with
+ Self -> "self"
+ | Child -> "child"
+ | Descendant -> "descendant"
+ | DescendantOrSelf -> "descendant-or-self"
+ | FollowingSibling -> "following-sibling"
+ | Attribute -> "attribute"
+ | Ancestor -> "ancestor"
+ | AncestorOrSelf -> "ancestor-or-self"
+ | PrecedingSibling -> "preceding-sibling"
+ | Parent -> "parent"
+ | _ -> assert false
+ )
+ and print_test fmt ts =
+ try
+ pp fmt "%s" (List.assoc ts
+ [ t_text,"text()";
+ t_node,"node()";
+ t_star, "*" ] )
+ with
+ Not_found -> pp fmt "%s"
+ (match ts with
+ Simple t -> if QNameSet.is_finite t
+ then QName.to_string (QNameSet.choose t)
+ else "<INFINITE>"
+ )
+
+ and print_predicate fmt = function
+ | Or(p,q) -> print_predicate fmt p; pp fmt " or "; print_predicate fmt q
+ | And(p,q) -> print_predicate fmt p; pp fmt " and "; print_predicate fmt q
+ | Not p -> pp fmt "not "; print_predicate fmt p
+ | Expr e -> print_expression fmt e
+
+ and print_expression fmt = function
+ | Path p -> print fmt p
+ | Function (f,l) ->
+ pp fmt "%s(" f;
+ Pretty.print_list ~sep:"," print_expression fmt l;
+ pp fmt ")"
+ | Int i -> pp fmt "%i" i
+ | String s -> pp fmt "\"%s\"" s
+ | t -> pp fmt "%b" (t== True)
+
+end
+module Parser =
+struct
+ open Ast
+ open Ulexer
+ let predopt = function None -> Expr True | Some p -> p
+
+ module Gram = Camlp4.Struct.Grammar.Static.Make(Ulexer)
+ let query = Gram.Entry.mk "query"
+
+ exception Error of Gram.Loc.t*string
+ let test_of_keyword t loc =
+ match t with
+ | "text()" -> text
+ | "node()" -> node
+ | "*" -> star
+ | "and" | "not" | "or" -> QNameSet.singleton (QName.of_string t)
+ | _ -> raise (Error(loc,"Invalid test name "^t ))
+
+ let axis_to_string a = let r = Format.str_formatter in
+ print_axis r a; Format.flush_str_formatter()
+
+
+
+
+EXTEND Gram
+
+GLOBAL: query;
+
+ query : [ [ p = path; `EOI -> p ]]
+;
+
+ path : [
+ [ "//" ; l = slist -> AbsoluteDoS (List.rev l) ]
+ | [ "/" ; l = slist -> Absolute (List.rev l) ]
+ | [ l = slist -> Relative (List.rev l) ]
+ ]
+;
+
+slist: [
+ [ l = slist ;"/"; s = step -> s @ l ]
+| [ l = slist ; "//"; s = step -> s@[(DescendantOrSelf, t_node ,Expr True)]@l]
+| [ s = step -> s ]
+];
+
+step : [
+ (* yurk, this is done to parse stuff like
+ a/b/descendant/a where descendant is actually a tag name :(
+ if OPT is None then this is a child::descendant if not, this is a real axis name
+ *)
+
+
+[ axis = axis ; o = OPT ["::" ; t = test -> t ] ; p = top_pred ->
+ let a,t,p =
+ match o with
+ | Some(t) -> (axis,t,p)
+ | None -> (Child,Simple (QNameSet.singleton (QName.of_string (axis_to_string axis))),p)
+ in match a with
+ | Following -> [ (DescendantOrSelf,t,p);
+ (FollowingSibling, t_star,Expr(True));
+ (Ancestor, t_star ,Expr(True)) ]
+
+ | Preceding -> [ (DescendantOrSelf,t,p);
+ (PrecedingSibling,t_star,Expr(True));
+ (Ancestor,t_star,Expr(True)) ]
+ | _ -> [ a,t,p ]
+
+]
+
+| [ "." ; p = top_pred -> [(Self, t_node,p)] ]
+| [ ".." ; p = top_pred -> [(Parent,t_star,p)] ]
+| [ test = test; p = top_pred -> [(Child,test, p)] ]
+| [ att = ATT ; p = top_pred ->
+ match att with
+ | "*" -> [(Attribute,t_star,p)]
+ | _ -> [(Attribute, Simple (QNameSet.singleton (QName.of_string att)) ,p )]]
+]
+;
+top_pred : [
+ [ p = OPT [ "["; p=predicate ;"]" -> p ] -> predopt p ]
+]
+;
+axis : [
+ [ "self" -> Self | "child" -> Child | "descendant" -> Descendant
+ | "descendant-or-self" -> DescendantOrSelf
+ | "ancestor-or-self" -> AncestorOrSelf
+ | "following-sibling" -> FollowingSibling
+ | "attribute" -> Attribute
+ | "parent" -> Parent
+ | "ancestor" -> Ancestor
+ | "preceding-sibling" -> PrecedingSibling
+ | "preceding" -> Preceding
+ | "following" -> Following
+ ]
+
+
+];
+test : [
+ [ s = KWD -> Simple (test_of_keyword s _loc) ]
+| [ t = TAG -> Simple (QNameSet.singleton (QName.of_string t)) ]
+];
+
+
+predicate: [
+
+ [ p = predicate; "or"; q = predicate -> Or(p,q) ]
+| [ p = predicate; "and"; q = predicate -> And(p,q) ]
+| [ "not" ; p = predicate -> Not p ]
+| [ "("; p = predicate ;")" -> p ]
+| [ e = expression -> Expr e ]
+];
+
+expression: [
+ [ f = TAG; "("; args = LIST0 expression SEP "," ; ")" -> Function(f,args)]
+| [ `INT(i) -> Int (i) ]
+| [ s = STRING -> String s ]
+| [ p = path -> Path p ]
+| [ "("; e = expression ; ")" -> e ]
+]
+;
+END
+;;
+(*
+
+GLOBAL: query;
+
+ query : [ [ p = location_path; `EOI -> p ]]
+;
+
+
+ location_path : [
+ [ "/" ; l = OPT relative_location_path ->
+ let l = match l with None -> [] | Some l' -> l' in Absolute l ]
+ | [ l = relative_location_path -> Relative l ]
+ | [ l = abbrev_absolute_location_path -> l ]
+
+ ]
+;
+
+ relative_location_path : [
+ [ s = step -> [ s ] ]
+ | [ l = relative_location_path ; "/"; s = step -> l @ [ s ] ]
+ | [ l = abbrev_relative_location_path -> l ]
+ ]
+;
+
+
+ step : [
+ [ a = axis_specifier ; n = node_test ; p = OPT predicate ->
+ let p = match p with Some p' -> p' | None -> Expr(True) in
+ a, n, p
+ ]
+ | [ a = abbrev_step -> a ]
+ ]
+;
+ axis_specifier : [
+ [ a = axis_name ; "::" -> a ]
+ | [ a = abbrev_axis_specifier -> a ]
+ ];
+
+ axis_name : [
+ [ "self" -> Self | "child" -> Child | "descendant" -> Descendant
+ | "descendant-or-self" -> DescendantOrSelf
+ | "ancestor-or-self" -> AncestorOrSelf
+ | "following-sibling" -> FollowingSibling
+ | "attribute" -> Attribute
+ | "parent" -> Parent
+ | "ancestor" -> Ancestor
+ | "preceding-sibling" -> PrecedingSibling
+ | "preceding" -> Preceding
+ | "following" -> Following
+ ]
+ ]
+;
+ node_test : [
+ [ n = name_test -> n ]
+ | [ n = node_type ; "("; ")" -> n ]
+ (* | [ "processing-instruction" ; "(" ... ")" ] *)
+ ]
+;
+ name_test : [
+ [ "*" -> Simple(TagSet.star) ]
+ | [ t = axis_name -> Simple(TagSet.singleton (Tag.tag (axis_to_string t))) ]
+ | [ t = TAG -> Simple(TagSet.singleton (Tag.tag t)) ]
+ ]
+;
+ node_type : [
+ [ "text" -> Simple(TagSet.pcdata) ]
+ | [ "node" -> Simple(TagSet.node) ]
+ ]
+;
+ predicate : [
+ [ "["; e = expr ; "]" -> e ]
+ ]
+;
+ abbrev_absolute_location_path : [
+ [ "//"; l = relative_location_path -> AbsoluteDoS l ]
+ ];
+
+ abbrev_relative_location_path : [
+ [ l = relative_location_path; "//"; s = step ->
+ l @ [ (DescendantOrSelf,Simple(TagSet.node),Expr(True)); s ]
+ ]
+ ];
+
+ abbrev_step : [
+ [ "." -> (Self, Simple(TagSet.node), Expr(True)) ]
+ | [ ".." -> (Parent, Simple(TagSet.node), Expr(True)) ]
+ ];
+
+ abbrev_axis_specifier: [
+ [ a = OPT "@" -> match a with None -> Attribute | _ -> Child ]
+ ];
+
+ expr : [
+ [ o = or_expr -> o ]
+ ];
+
+ primary_expr : [
+ [ "("; e = expr ; ")" -> e ]
+ | [ s = STRING -> Expr (String s) ]
+ | [ `INT(i) -> Expr (Int (i)) ]
+ | [ f = TAG; "("; args = LIST0 expr SEP "," ; ")" ->
+ Expr(Function(f, List.map (function Expr e -> e | _ -> assert false) args))]
+ ]
+;
+
+ or_expr : [
+ [ o1 = or_expr ; "or" ; o2 = and_expr -> Or(o1, o2) ]
+ | [ a = and_expr -> a ]
+ ]
+ ;
+
+ and_expr : [
+ [ a1 = and_expr; "and"; a2 = unary_expr -> And(a1, a2) ]
+ | [ p = unary_expr -> p ]
+ ]
+;
+ unary_expr : [
+ [ l = location_path -> Expr(Path l) ]
+ | [ "not"; "("; e = expr ; ")" -> Not e ]
+ | [ p = primary_expr -> p ]
+
+ ];
+
+END
+;;
+
+*)
+
+ let parse = Gram.parse_string query (Ulexer.Loc.mk "<string>")
+end
+let parse = Parser.parse
projects / tatoo.git / blobdiff