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
  16 #load "pa_extend.cmo";;
  17 module Ast =
  18 struct
  19
  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
  24
  25   and test = Simple of QNameSet.t
  26
  27
  28   and predicate = Or of predicate*predicate
  29                   | And of predicate*predicate
  30                   | Not of predicate
  31                   | Expr of expression
  32   and expression =  Path of path
  33                     | Function of string*expression list
  34                     | Int of int
  35                     | String of string
  36                     | True | False
  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 = Format.fprintf fmt
  55   let print_list printer fmt sep l =
  56     match l with
  57       [] -> ()
  58       | [e] -> printer fmt e
  59       | e::es -> printer fmt e; List.iter (fun x -> pp fmt sep;printer fmt x) es
  60
  61
  62   let rec print fmt p =
  63     let l = match p with
  64       | Absolute l -> pp fmt "/"; l
  65       | AbsoluteDoS l -> pp fmt "/";
  66         print_step fmt (DescendantOrSelf,Simple QNameSet.any,Expr True);
  67         pp fmt "/"; l
  68       | Relative l -> l
  69     in
  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;
  73     match predicate with
  74       Expr True -> ()
  75       |  _ -> pp fmt "["; print_predicate fmt predicate; pp fmt "]"
  76   and print_axis fmt a = pp fmt "%s" (match a with
  77       Self -> "self"
  78     | Child -> "child"
  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"
  86     | Parent -> "parent"
  87     | _ -> assert false
  88   )
  89   and print_test fmt ts =
  90     try
  91       pp fmt "%s" (List.assoc ts
  92                      [ t_text,"text()";
  93                        t_node,"node()";
  94                        t_star, "*" ] )
  95     with
  96       Not_found -> pp fmt "%s"
  97         (match ts with
  98           Simple t -> if QNameSet.is_finite t
  99             then QName.to_string (QNameSet.choose t)
 100             else "<INFINITE>"
 101         )
 102
 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
 108
 109   and print_expression fmt = function
 110     | Path p -> print fmt p
 111     | Function (f,l) ->
 112       pp fmt "%s(" f;
 113       Pretty.print_list ~sep:"," print_expression fmt l;
 114       pp fmt ")"
 115     | Int i -> pp fmt "%i" i
 116     | String s -> pp fmt "\"%s\"" s
 117     | t -> pp fmt "%b" (t== True)
 118
 119 end
 120 module Parser =
 121 struct
 122   open Ast
 123   open Ulexer
 124   let predopt = function None -> Expr True | Some p -> p
 125
 126   module Gram =  Camlp4.Struct.Grammar.Static.Make(Ulexer)
 127   let query = Gram.Entry.mk "query"
 128
 129   exception Error of Gram.Loc.t*string
 130   let test_of_keyword t loc =
 131     match t with
 132       | "text()" -> text
 133       | "node()" -> node
 134       | "*" -> star
 135       | "and" | "not" | "or" -> QNameSet.singleton (QName.of_string t)
 136       | _ -> raise (Error(loc,"Invalid test name "^t ))
 137
 138   let axis_to_string a = let r = Format.str_formatter in
 139     print_axis r a; Format.flush_str_formatter()
 140
 141
 142
 143
 144 EXTEND Gram
 145
 146 GLOBAL: query;
 147
 148  query : [ [ p = path; `EOI -> p ]]
 149 ;
 150
 151  path : [
 152    [ "//" ; l = slist -> AbsoluteDoS (List.rev l) ]
 153  | [ "/" ; l = slist -> Absolute (List.rev l) ]
 154  | [ l = slist  -> Relative (List.rev l) ]
 155  ]
 156 ;
 157
 158 slist: [
 159   [ l = slist ;"/"; s = step -> s @ l ]
 160 | [ l = slist ; "//"; s = step -> s@[(DescendantOrSelf, t_node ,Expr True)]@l]
 161 | [ s = step ->  s ]
 162 ];
 163
 164 step : [
 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
 168   *)
 169
 170
 171 [ axis = axis ; o = OPT ["::" ; t = test -> t ] ; p = top_pred  ->
 172     let a,t,p =
 173       match o with
 174       | Some(t) ->  (axis,t,p)
 175       | None -> (Child,Simple (QNameSet.singleton (QName.of_string (axis_to_string axis))),p)
 176     in match a with
 177       | Following -> [ (DescendantOrSelf,t,p);
 178                (FollowingSibling, t_star,Expr(True));
 179                (Ancestor, t_star ,Expr(True)) ]
 180
 181       | Preceding -> [ (DescendantOrSelf,t,p);
 182                        (PrecedingSibling,t_star,Expr(True));
 183                        (Ancestor,t_star,Expr(True)) ]
 184       | _ -> [ a,t,p ]
 185
 186 ]
 187
 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 ->
 192       match att with
 193       | "*" -> [(Attribute,t_star,p)]
 194       | _ ->  [(Attribute, Simple (QNameSet.singleton (QName.of_string att)) ,p )]]
 195 ]
 196 ;
 197 top_pred  : [
 198   [ p = OPT [ "["; p=predicate ;"]" -> p ] -> predopt p ]
 199 ]
 200 ;
 201 axis : [
 202   [ "self" -> Self | "child" -> Child | "descendant" -> Descendant
 203       | "descendant-or-self" -> DescendantOrSelf
 204       | "ancestor-or-self" -> AncestorOrSelf
 205       | "following-sibling" -> FollowingSibling
 206       | "attribute" -> Attribute
 207       | "parent" -> Parent
 208       | "ancestor" -> Ancestor
 209       | "preceding-sibling" -> PrecedingSibling
 210       | "preceding" -> Preceding
 211       | "following" -> Following
 212   ]
 213
 214
 215 ];
 216 test : [
 217   [ s = KWD -> Simple (test_of_keyword s _loc) ]
 218 | [ t = TAG -> Simple (QNameSet.singleton (QName.of_string t)) ]
 219 ];
 220
 221
 222 predicate: [
 223
 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 ]
 229 ];
 230
 231 expression: [
 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 ]
 237 ]
 238 ;
 239 END
 240 ;;
 241 (*
 242
 243 GLOBAL: query;
 244
 245  query : [ [ p = location_path; `EOI -> p ]]
 246 ;
 247
 248
 249  location_path : [
 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 ]
 254
 255  ]
 256 ;
 257
 258  relative_location_path : [
 259    [ s = step -> [ s ] ]
 260  | [ l = relative_location_path ; "/"; s = step -> l @ [ s ] ]
 261  | [ l = abbrev_relative_location_path -> l ]
 262  ]
 263 ;
 264
 265
 266  step : [
 267    [ a = axis_specifier ; n = node_test ; p = OPT predicate ->
 268       let p = match p with Some p' -> p' | None -> Expr(True) in
 269             a, n, p
 270    ]
 271  | [ a = abbrev_step -> a ]
 272  ]
 273 ;
 274  axis_specifier : [
 275    [ a = axis_name ; "::" -> a ]
 276  | [ a = abbrev_axis_specifier -> a ]
 277  ];
 278
 279  axis_name : [
 280   [ "self" -> Self | "child" -> Child | "descendant" -> Descendant
 281       | "descendant-or-self" -> DescendantOrSelf
 282       | "ancestor-or-self" -> AncestorOrSelf
 283       | "following-sibling" -> FollowingSibling
 284       | "attribute" -> Attribute
 285       | "parent" -> Parent
 286       | "ancestor" -> Ancestor
 287       | "preceding-sibling" -> PrecedingSibling
 288       | "preceding" -> Preceding
 289       | "following" -> Following
 290   ]
 291  ]
 292 ;
 293  node_test : [
 294    [ n = name_test -> n ]
 295  | [ n = node_type ; "("; ")" -> n ]
 296  (* | [ "processing-instruction" ; "(" ... ")" ] *)
 297  ]
 298 ;
 299  name_test : [
 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)) ]
 303  ]
 304 ;
 305  node_type : [
 306    [ "text" -> Simple(TagSet.pcdata) ]
 307  | [ "node" -> Simple(TagSet.node) ]
 308  ]
 309 ;
 310  predicate : [
 311    [ "["; e = expr ; "]" -> e ]
 312  ]
 313 ;
 314  abbrev_absolute_location_path : [
 315    [ "//"; l = relative_location_path -> AbsoluteDoS l ]
 316  ];
 317
 318  abbrev_relative_location_path : [
 319    [  l = relative_location_path; "//"; s = step ->
 320    l @ [ (DescendantOrSelf,Simple(TagSet.node),Expr(True)); s ]
 321    ]
 322  ];
 323
 324  abbrev_step : [
 325    [ "." -> (Self, Simple(TagSet.node), Expr(True)) ]
 326  | [ ".." -> (Parent, Simple(TagSet.node), Expr(True)) ]
 327  ];
 328
 329  abbrev_axis_specifier: [
 330    [ a = OPT "@" -> match a with None -> Attribute | _ -> Child ]
 331  ];
 332
 333  expr : [
 334    [ o = or_expr -> o ]
 335  ];
 336
 337  primary_expr : [
 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))]
 343  ]
 344 ;
 345
 346  or_expr : [
 347     [ o1 = or_expr ; "or" ; o2 = and_expr -> Or(o1, o2) ]
 348  |  [ a = and_expr -> a ]
 349  ]
 350  ;
 351
 352  and_expr : [
 353    [ a1 = and_expr; "and"; a2 = unary_expr -> And(a1, a2) ]
 354  | [ p = unary_expr -> p ]
 355  ]
 356 ;
 357  unary_expr : [
 358    [ l = location_path  -> Expr(Path l) ]
 359  | [ "not"; "("; e = expr ; ")" -> Not e ]
 360  | [ p = primary_expr ->  p ]
 361
 362  ];
 363
 364 END
 365 ;;
 366
 367 *)
 368
 369   let parse_string = Gram.parse_string query (Ulexer.Loc.mk "<string>")
 370   let parse_file fd = parse_string (input_line fd)
 371
 372 end
 373 let parse_string = Parser.parse_string
 374 let parse_file = Parser.parse_file