src/xPath.ml

   1 #load "pa_extend.cmo";;
   2 let contains = ref None
   3 module Ast =
   4 struct
   5
   6   type path = Absolute of step list | AbsoluteDoS of step list| Relative of step list
   7   and step = axis * test *predicate
   8   and axis = Self | Attribute | Child | Descendant | DescendantOrSelf | FollowingSibling
   9              | Parent | Ancestor | AncestorOrSelf | PrecedingSibling | Preceding | Following
  10
  11   and test = Simple of TagSet.t
  12              | Complex of TagSet.t * Tree.Predicate.t
  13
  14   and predicate = Or of predicate*predicate
  15                   | And of predicate*predicate
  16                   | Not of predicate
  17                   | Expr of expression
  18   and expression =  Path of path
  19                     | Function of string*expression list
  20                     | Int of int
  21                     | String of string
  22                     | True | False
  23   type t = path
  24
  25
  26
  27
  28   let pp fmt = Format.fprintf fmt
  29   let print_list printer fmt sep l =
  30     match l with
  31         [] -> ()
  32       | [e] -> printer fmt e
  33       | e::es -> printer fmt e; List.iter (fun x -> pp fmt sep;printer fmt x) es
  34
  35
  36   let rec print fmt p =
  37     let l = match p with
  38       | Absolute l -> pp fmt "/"; l
  39       | AbsoluteDoS l -> pp fmt "/";
  40           print_step fmt (DescendantOrSelf,Simple TagSet.node,Expr True);
  41           pp fmt "/"; l
  42       | Relative l -> l
  43     in
  44       Pretty.print_list ~sep:"/" print_step fmt l
  45   and print_step fmt (axis, test, predicate) =
  46     print_axis fmt axis;pp fmt "::";print_test fmt test;
  47     match predicate with
  48         Expr True -> ()
  49       |  _ -> pp fmt "["; print_predicate fmt predicate; pp fmt "]"
  50   and print_axis fmt a = pp fmt "%s" (match a with
  51                                           Self -> "self"
  52                                         | Child -> "child"
  53                                         | Descendant -> "descendant"
  54                                         | DescendantOrSelf -> "descendant-or-self"
  55                                         | FollowingSibling -> "following-sibling"
  56                                         | Attribute -> "attribute"
  57                                         | Ancestor -> "ancestor"
  58                                         | AncestorOrSelf -> "ancestor-or-self"
  59                                         | PrecedingSibling -> "preceding-sibling"
  60                                         | Parent -> "parent"
  61                                         | _ -> assert false
  62                                      )
  63   and print_test fmt ts =
  64     try
  65       pp fmt "%s" (List.assoc ts
  66                      [ (Simple (TagSet.pcdata),"text()");
  67                        (Simple (TagSet.node),"node()");
  68                        (Simple (TagSet.star),"*")])
  69     with
  70         Not_found -> pp fmt "%s"
  71           (match ts with
  72               Simple t | Complex (t, _) -> if TagSet.is_finite t
  73                 then Tag.to_string (TagSet.choose t)
  74                 else "<INFINITE>"
  75           )
  76
  77   and print_predicate fmt = function
  78     | Or(p,q) -> print_predicate fmt p; pp fmt " or "; print_predicate fmt q
  79     | And(p,q) -> print_predicate fmt p; pp fmt " and "; print_predicate fmt q
  80     | Not p -> pp fmt "not "; print_predicate fmt p
  81     | Expr e -> print_expression fmt e
  82
  83   and print_expression fmt = function
  84     | Path p -> print fmt p
  85     | Function (f,l) ->
  86         pp fmt "%s(" f;
  87         Pretty.print_list ~sep:"," print_expression fmt l;
  88         pp fmt ")"
  89     | Int i -> pp fmt "%i" i
  90     | String s -> pp fmt "\"%s\"" s
  91     | t -> pp fmt "%b" (t== True)
  92
  93 end
  94 module Parser =
  95 struct
  96   open Ast
  97   open Ulexer
  98   let predopt = function None -> Expr True | Some p -> p
  99
 100   module Gram =  Camlp4.Struct.Grammar.Static.Make(Ulexer)
 101   let query = Gram.Entry.mk "query"
 102
 103   exception Error of Gram.Loc.t*string
 104   let test_of_keyword t loc =
 105     match t with
 106       | "text()" -> TagSet.pcdata
 107       | "node()" -> TagSet.node
 108       | "*" -> TagSet.star
 109       | "and" | "not" | "or" -> TagSet.singleton (Tag.tag t)
 110       | _ -> raise (Error(loc,"Invalid test name "^t ))
 111
 112   let axis_to_string a = let r = Format.str_formatter in
 113     print_axis r a; Format.flush_str_formatter()
 114
 115
 116   let t_star = Simple TagSet.star
 117   let t_node = Simple TagSet.node
 118   let t_text = Simple TagSet.pcdata
 119
 120 EXTEND Gram
 121
 122 GLOBAL: query;
 123
 124  query : [ [ p = path; `EOI -> p ]]
 125 ;
 126
 127  path : [
 128    [ "//" ; l = slist -> AbsoluteDoS (List.rev l) ]
 129  | [ "/" ; l = slist -> Absolute (List.rev l) ]
 130  | [ l = slist  -> Relative (List.rev l) ]
 131  ]
 132 ;
 133
 134 slist: [
 135   [ l = slist ;"/"; s = step -> s @ l ]
 136 | [ l = slist ; "//"; s = step -> s@[(DescendantOrSelf, t_node ,Expr True)]@l]
 137 | [ s = step ->  s ]
 138 ];
 139
 140 step : [
 141   (* yurk, this is done to parse stuff like
 142      a/b/descendant/a where descendant is actually a tag name :(
 143      if OPT is None then this is a child::descendant if not, this is a real axis name
 144   *)
 145
 146
 147 [ axis = axis ; o = OPT ["::" ; t = test -> t ] ; p = top_pred  ->
 148     let a,t,p =
 149       match o with
 150         | Some(t) ->  (axis,t,p)
 151         | None -> (Child,Simple (TagSet.singleton (Tag.tag (axis_to_string axis))),p)
 152     in match a with
 153       | Following -> [ (DescendantOrSelf,t,p);
 154                        (FollowingSibling, t_star,Expr(True));
 155                        (Ancestor, t_star ,Expr(True)) ]
 156
 157       | Preceding -> [ (DescendantOrSelf,t,p);
 158                        (PrecedingSibling,t_star,Expr(True));
 159                        (Ancestor,t_star,Expr(True)) ]
 160       | _ -> [ a,t,p ]
 161
 162 ]
 163
 164 | [ "." ; p = top_pred ->  [(Self, t_node,p)]  ]
 165 | [ ".." ; p = top_pred ->  [(Parent,t_star,p)]  ]
 166 | [ test = test; p = top_pred  -> [(Child,test, p)] ]
 167 | [ att = ATT ; p = top_pred ->
 168       match att with
 169         | "*" -> [(Attribute,t_star,p)]
 170         | _ ->  [(Attribute, Simple (TagSet.singleton (Tag.tag att)) ,p )]]
 171 ]
 172 ;
 173 top_pred  : [
 174   [ p = OPT [ "["; p=predicate ;"]" -> p ] -> predopt p ]
 175 ]
 176 ;
 177 axis : [
 178   [ "self" -> Self | "child" -> Child | "descendant" -> Descendant
 179       | "descendant-or-self" -> DescendantOrSelf
 180       | "ancestor-or-self" -> AncestorOrSelf
 181       | "following-sibling" -> FollowingSibling
 182       | "attribute" -> Attribute
 183       | "parent" -> Parent
 184       | "ancestor" -> Ancestor
 185       | "preceding-sibling" -> PrecedingSibling
 186       | "preceding" -> Preceding
 187       | "following" -> Following
 188   ]
 189
 190
 191 ];
 192 test : [
 193   [ s = KWD -> Simple (test_of_keyword s _loc) ]
 194 | [ t = TAG -> Simple (TagSet.singleton (Tag.tag t)) ]
 195 ];
 196
 197
 198 predicate: [
 199
 200  [ p = predicate; "or"; q = predicate -> Or(p,q) ]
 201 | [ p = predicate; "and"; q = predicate -> And(p,q) ]
 202 | [ "not" ; p = predicate -> Not p ]
 203 | [ "("; p = predicate ;")" -> p ]
 204 |  [ e = expression -> Expr e ]
 205 ];
 206
 207 expression: [
 208   [ f = TAG; "("; args = LIST0 expression SEP "," ; ")" -> Function(f,args)]
 209 | [ `INT(i) -> Int (i) ]
 210 | [ s = STRING -> String s ]
 211 | [ p = path -> Path p ]
 212 | [ "("; e = expression ; ")" -> e ]
 213 ]
 214 ;
 215 END
 216 ;;
 217 (*
 218
 219 GLOBAL: query;
 220
 221  query : [ [ p = location_path; `EOI -> p ]]
 222 ;
 223
 224
 225  location_path : [
 226   [ "/" ; l = OPT relative_location_path ->
 227          let l = match l with None -> [] | Some l' -> l' in Absolute l ]
 228  |  [ l = relative_location_path -> Relative l ]
 229  | [ l = abbrev_absolute_location_path -> l ]
 230
 231  ]
 232 ;
 233
 234  relative_location_path : [
 235    [ s = step -> [ s ] ]
 236  | [ l = relative_location_path ; "/"; s = step -> l @ [ s ] ]
 237  | [ l = abbrev_relative_location_path -> l ]
 238  ]
 239 ;
 240
 241
 242  step : [
 243    [ a = axis_specifier ; n = node_test ; p = OPT predicate ->
 244       let p = match p with Some p' -> p' | None -> Expr(True) in
 245             a, n, p
 246    ]
 247  | [ a = abbrev_step -> a ]
 248  ]
 249 ;
 250  axis_specifier : [
 251    [ a = axis_name ; "::" -> a ]
 252  | [ a = abbrev_axis_specifier -> a ]
 253  ];
 254
 255  axis_name : [
 256   [ "self" -> Self | "child" -> Child | "descendant" -> Descendant
 257       | "descendant-or-self" -> DescendantOrSelf
 258       | "ancestor-or-self" -> AncestorOrSelf
 259       | "following-sibling" -> FollowingSibling
 260       | "attribute" -> Attribute
 261       | "parent" -> Parent
 262       | "ancestor" -> Ancestor
 263       | "preceding-sibling" -> PrecedingSibling
 264       | "preceding" -> Preceding
 265       | "following" -> Following
 266   ]
 267  ]
 268 ;
 269  node_test : [
 270    [ n = name_test -> n ]
 271  | [ n = node_type ; "("; ")" -> n ]
 272  (* | [ "processing-instruction" ; "(" ... ")" ] *)
 273  ]
 274 ;
 275  name_test : [
 276    [ "*" -> Simple(TagSet.star) ]
 277  | [ t = axis_name -> Simple(TagSet.singleton (Tag.tag (axis_to_string t))) ]
 278  | [ t = TAG -> Simple(TagSet.singleton (Tag.tag t)) ]
 279  ]
 280 ;
 281  node_type : [
 282    [ "text" -> Simple(TagSet.pcdata) ]
 283  | [ "node" -> Simple(TagSet.node) ]
 284  ]
 285 ;
 286  predicate : [
 287    [ "["; e = expr ; "]" -> e ]
 288  ]
 289 ;
 290  abbrev_absolute_location_path : [
 291    [ "//"; l = relative_location_path -> AbsoluteDoS l ]
 292  ];
 293
 294  abbrev_relative_location_path : [
 295    [  l = relative_location_path; "//"; s = step ->
 296    l @ [ (DescendantOrSelf,Simple(TagSet.node),Expr(True)); s ]
 297    ]
 298  ];
 299
 300  abbrev_step : [
 301    [ "." -> (Self, Simple(TagSet.node), Expr(True)) ]
 302  | [ ".." -> (Parent, Simple(TagSet.node), Expr(True)) ]
 303  ];
 304
 305  abbrev_axis_specifier: [
 306    [ a = OPT "@" -> match a with None -> Attribute | _ -> Child ]
 307  ];
 308
 309  expr : [
 310    [ o = or_expr -> o ]
 311  ];
 312
 313  primary_expr : [
 314    [ "("; e = expr ; ")" -> e ]
 315  | [ s = STRING -> Expr (String s) ]
 316  | [ `INT(i) -> Expr (Int (i)) ]
 317  | [ f = TAG; "("; args = LIST0 expr SEP "," ; ")" ->
 318     Expr(Function(f, List.map (function Expr e -> e | _ -> assert false) args))]
 319  ]
 320 ;
 321
 322  or_expr : [
 323     [ o1 = or_expr ; "or" ; o2 = and_expr -> Or(o1, o2) ]
 324  |  [ a = and_expr -> a ]
 325  ]
 326  ;
 327
 328  and_expr : [
 329    [ a1 = and_expr; "and"; a2 = unary_expr -> And(a1, a2) ]
 330  | [ p = unary_expr -> p ]
 331  ]
 332 ;
 333  unary_expr : [
 334    [ l = location_path  -> Expr(Path l) ]
 335  | [ "not"; "("; e = expr ; ")" -> Not e ]
 336  | [ p = primary_expr ->  p ]
 337
 338  ];
 339
 340 END
 341 ;;
 342
 343 *)
 344   let parse = Gram.parse_string query (Ulexer.Loc.mk "<string>")
 345 end
 346 include Parser