xPath.ml

   1 (******************************************************************************)
   2 (*  SXSI : XPath evaluator                                                    *)
   3 (*  Kim Nguyen (Kim.Nguyen@nicta.com.au)                                      *)
   4 (*  Copyright NICTA 2008                                                      *)
   5 (*  Distributed under the terms of the LGPL (see LICENCE)                     *)
   6 (******************************************************************************)
   7
   8
   9 INCLUDE "debug.ml";;
  10 #load "pa_extend.cmo";;
  11
  12
  13 module Ast =
  14 struct
  15
  16 type path = Absolute of step list | AbsoluteDoS of step list| Relative of step list
  17 and step = axis*test*predicate
  18 and axis = Self | Attribute | Child | Descendant | DescendantOrSelf | FollowingSibling
  19            | Parent
  20
  21 and test = TagSet.Xml.t
  22
  23 and predicate = Or of predicate*predicate
  24                 | And of predicate*predicate
  25                 | Not of predicate
  26                 | Expr of expression
  27 and expression =  Path of path
  28                 | Function of string*expression list
  29                 | Int of int
  30                 | String of string
  31                 | True | False
  32 type t = path
  33
  34
  35 let pp fmt = Format.fprintf fmt
  36 let print_list printer fmt sep l =
  37   match l with
  38       [] -> ()
  39     | [e] -> printer fmt e
  40     | e::es -> printer fmt e; List.iter (fun x -> pp fmt sep;printer fmt x) es
  41
  42
  43 let rec print fmt p =
  44   let l = match p with
  45     | Absolute l -> pp fmt "/"; l
  46     | AbsoluteDoS l -> pp fmt "/";
  47         print_step fmt (DescendantOrSelf,TagSet.Xml.node,Expr True);
  48         pp fmt "/"; l
  49     | Relative l -> l
  50   in
  51     print_list print_step fmt "/" (List.rev l)
  52 and print_step fmt (axis,test,predicate) =
  53     print_axis fmt axis;pp fmt "::";print_test fmt test;
  54   pp fmt "["; print_predicate fmt predicate; pp fmt "]"
  55 and print_axis fmt a = pp fmt "%s" (match a with
  56                                         Self -> "self"
  57                                       | Child -> "child"
  58                                       | Descendant -> "descendant"
  59                                       | DescendantOrSelf -> "descendant-or-self"
  60                                       | FollowingSibling -> "following-sibling"
  61                                       | Attribute -> "attribute"
  62                                       | Parent -> "parent")
  63 and print_test fmt ts =
  64   try
  65     pp fmt "%s" (List.assoc ts
  66                    [ (TagSet.Xml.pcdata,"text()"); (TagSet.Xml.node,"node()");
  67                      (TagSet.Xml.star),"*"])
  68   with
  69       Not_found -> pp fmt "%s"
  70         (if TagSet.Xml.is_finite ts
  71          then Tag.to_string (TagSet.Xml.choose ts)
  72          else "<INFINITE>")
  73
  74 and print_predicate fmt = function
  75   | Or(p,q) -> print_predicate fmt p; pp fmt " or "; print_predicate fmt q
  76   | And(p,q) -> print_predicate fmt p; pp fmt " and "; print_predicate fmt q
  77   | Not p -> pp fmt "not "; print_predicate fmt p
  78   | Expr e -> print_expression fmt e
  79
  80 and print_expression fmt = function
  81   | Path p -> print fmt p
  82   | Function (f,l) -> pp fmt "%s(" f;print_list print_expression fmt "," l;pp fmt ")"
  83   | Int i -> pp fmt "%i" i
  84   | String s -> pp fmt "\"%s\"" s
  85   | t -> pp fmt "%b" (t== True)
  86
  87 end
  88 module Parser =
  89 struct
  90   open Ast
  91   open Ulexer
  92   let predopt = function None -> Expr True | Some p -> p
  93
  94   module Gram =  Camlp4.Struct.Grammar.Static.Make(Ulexer)
  95   let query = Gram.Entry.mk "query"
  96
  97   exception Error of Gram.Loc.t*string
  98   let test_of_keyword t loc =
  99     match t with
 100       | "text()" -> TagSet.Xml.pcdata
 101       | "node()" -> TagSet.Xml.node
 102       | "*" -> TagSet.Xml.star
 103       | "and" | "not" | "or" -> TagSet.Xml.singleton (Tag.tag t)
 104       | _ -> raise (Error(loc,"Invalid test name "^t ))
 105
 106   let axis_to_string a = let r = Format.str_formatter in
 107     print_axis r a; Format.flush_str_formatter()
 108 EXTEND Gram
 109
 110 GLOBAL: query;
 111
 112  query : [ [ p = path; `EOI -> p ]]
 113 ;
 114
 115  path : [
 116    [ "//" ; l = slist -> AbsoluteDoS l ]
 117  | [ "/" ; l = slist -> Absolute l ]
 118  | [ l = slist  -> Relative l ]
 119  ]
 120 ;
 121
 122 slist: [
 123   [ l = slist ;"/"; s = step -> s::l ]
 124 | [ l = slist ; "//"; s = step -> s::(DescendantOrSelf,TagSet.Xml.node,Expr True)::l]
 125 | [ s = step -> [ s ] ]
 126 ];
 127
 128 step : [
 129   (* yurk, this is done to parse stuff like
 130      a/b/descendant/a where descendant is actually a tag name :(
 131      if OPT is None then this is a child::descendant if not, this is a real axis name
 132   *)
 133 [ axis = axis ; o = OPT ["::" ; t = test -> t ] ; p = top_pred  ->
 134     match o with
 135       | Some(t) ->  (axis,t,p)
 136       | None -> (Child,TagSet.Xml.singleton (Tag.tag (axis_to_string axis)),p) ]
 137
 138 | [ "." ; p = top_pred ->  (Self,TagSet.Xml.node,p)  ]
 139 | [ test = test; p = top_pred  -> (Child,test, p) ]
 140 | [ att = ATT ; p = top_pred ->
 141       match att with
 142         | "*" -> (Attribute,TagSet.Xml.star,p)
 143         | _ ->  (Attribute, TagSet.Xml.singleton (Tag.tag att) ,p )]
 144 ]
 145 ;
 146 top_pred  : [
 147   [ p = OPT [ "["; p=predicate ;"]" -> p ] -> predopt p ]
 148 ]
 149 ;
 150 axis : [
 151   [ "self" -> Self | "child" -> Child | "descendant" -> Descendant
 152       | "descendant-or-self" -> DescendantOrSelf
 153       | "following-sibling" -> FollowingSibling
 154       | "attribute" -> Attribute
 155       | "parent" -> Parent
 156   ]
 157
 158
 159 ];
 160 test : [
 161   [ s = KWD -> test_of_keyword s _loc  ]
 162 | [ t = TAG -> TagSet.Xml.singleton (Tag.tag t) ]
 163 ];
 164
 165
 166 predicate: [
 167   [ p = predicate; "or"; q = predicate -> Or(p,q) ]
 168 | [ p = predicate; "and"; q = predicate -> And(p,q) ]
 169 | [ "not" ; p = predicate -> Not p ]
 170 | [ "("; p = predicate ;")" -> p ]
 171 | [ e = expression -> Expr e ]
 172 ];
 173
 174 expression: [
 175   [ f = TAG; "("; args = LIST0 expression SEP "," ; ")" -> Function(f,args)]
 176 | [ `INT(i) -> Int (i) ]
 177 | [ s = STRING -> String s ]
 178 | [ p = path -> Path p ]
 179 | [ "("; e = expression ; ")" -> e ]
 180 ]
 181 ;
 182 END
 183 ;;
 184   let parse_string = Gram.parse_string query (Ulexer.Loc.mk "<string>")
 185   let parse = Gram.parse_string query (Ulexer.Loc.mk "<string>")
 186 end
 187
 188 module Functions = struct
 189
 190   type value = [ `NodeSet of Automaton.BST.t
 191   | `Int of int | `String of string
 192   | `Bool of bool | `True | `False ]
 193
 194   type expr = [ value | `Call of (string*(expr list))
 195   | `Auto of Automaton.t | `Contains of expr list ]
 196
 197
 198   let count = function [`NodeSet(s) ] -> `Int(Automaton.BST.cardinal s)
 199     | _ -> failwith "count"
 200
 201   let contains_old = function [`NodeSet(s) ; `String(str) ] ->
 202     `Bool(Automaton.BST.exists (fun tree -> Tree.Binary.contains_old tree str
 203                                ) s)
 204     | _ -> failwith "contains_old"
 205
 206   let equal = function [ `Int i; `Int j ] -> `Bool (i == j)
 207     |_ -> failwith "equal"
 208
 209   let globals : (string*(value list -> value)) list = [
 210
 211     ("count",count);
 212     ("equal",equal);
 213     ("contains_old",contains_old);
 214 ]
 215
 216   let text t = Tree.Binary.string (Tree.Binary.left t)
 217
 218
 219
 220   let rec eval_expr tree (e:expr) : value = match e with
 221     | `Call (f,args) -> (List.assoc f globals) (List.map (eval_expr tree) args)
 222     | `Auto(a) -> `NodeSet(ignore (Automaton.BottomUp.accept a tree);
 223                            a.Automaton.result)
 224     | `Contains(args) ->
 225         begin
 226           match args with
 227               [ `Auto(a); `String(s) ] ->
 228                 let docs = try
 229                   Hashtbl.find a.Automaton.contains s
 230                     with
 231                       | Not_found ->
 232                           let r = Tree.Binary.contains tree s
 233                           in
 234                             (* Tree.Binary.DocIdSet.iter (fun id ->
 235                                Printf.eprintf "%s matches %s\n%!" (Tree.Binary.get_string tree id) s) r; *)
 236
 237                             Hashtbl.add a.Automaton.contains s r;r
 238                 in
 239                 let _ = Automaton.BottomUp.accept ~strings:(Some docs) a tree
 240                 in `NodeSet(a.Automaton.result)
 241             | _ -> failwith "contains invalid"
 242         end
 243     | #value as x  -> x
 244
 245   let truth_value =
 246     function `NodeSet s -> not (Automaton.BST.is_empty s)
 247       |`Bool(b) -> b
 248       | _ -> failwith "truth_value"
 249
 250 end
 251 module Compile = struct
 252   open Ast
 253   open Automaton
 254
 255
 256   type direction = Left | Right | Final
 257   let (==>) a (b,c,d) = Transition.Label(a,b,c,d)
 258   let (@@) b (c,d) = (b,c,d)
 259
 260   let star = TagSet.Xml.star
 261   let any = TagSet.Xml.any
 262   let notstar = TagSet.Xml.add Tag.pcdata (TagSet.Xml.add Tag.attribute TagSet.Xml.empty)
 263   let swap dir a b = match dir with
 264     | Left | Final -> (a,b)
 265     | Right -> (b,a)
 266
 267   let split_dest q l =
 268     let rec aux ((qacc,nqacc) as acc) = function
 269       | [] -> acc
 270       | t::r ->
 271           aux (if State.equal (Transition.dest1 t) q
 272                  || State.equal (Transition.dest2 t) q
 273                then t::qacc , nqacc
 274                else qacc , (t::nqacc)) r
 275     in
 276       aux ([],[]) l
 277
 278
 279   let mk_tag_t dir s ts q1 q2 = (s==> ts @@ (swap dir q1 q2));;
 280   let mk_self_trs ts acc l =
 281     List.fold_left
 282       (fun acc t ->
 283          let s = Transition.source t in
 284          let d1 = Transition.dest1 t in
 285          let d2 = Transition.dest2 t in
 286          let tself = (s ==> ts @@ (d1,d2)) in
 287            (Transition.cap t tself)::acc ) (acc) l
 288
 289   let mk_pred_trs f acc l =
 290     List.fold_left
 291       (fun acc t ->
 292          let s = Transition.source t in
 293          let d1 = Transition.dest1 t in
 294          let d2 = Transition.dest2 t in
 295          let tself = Transition.External(s,f,d1,d2) in
 296            (Transition.cap t tself)::acc ) (acc) l
 297
 298   let mk_dself_trs q' ts acc l =
 299     List.fold_left
 300       (fun acc t ->
 301          let t',s,d2 = match t with
 302            | Transition.Label(s,ts,_,d2) -> Transition.Label(s,ts,q',d2),s,d2
 303            | Transition.External (s,f,_,d2) -> Transition.External(s,f,q',d2),s,d2
 304        in
 305          let tself = (s ==> ts @@ (q',d2)) in
 306            (Transition.cap t' tself)::acc ) (acc) l
 307
 308   let from_list = List.fold_left (fun acc e -> SSet.add e acc) SSet.empty
 309
 310   let dir = function (FollowingSibling,_,_) -> Right
 311     | _ -> Left
 312
 313   let rev_map_dir p =
 314     let rec map_dir (d,acc) = function
 315       | [] -> acc
 316       | s::r -> map_dir ((dir s),(s,d)::acc) r
 317     in
 318     let l =
 319       match p with
 320         | Absolute p
 321         | Relative p -> map_dir (Final,[]) p
 322         | AbsoluteDoS p ->
 323             let l = (map_dir (Final,[]) p)
 324             in ((DescendantOrSelf,TagSet.Xml.node,Expr True),dir (fst(List.hd l)))::l
 325   in ((Child,TagSet.Xml.node,Expr True),dir (fst(List.hd l)))::l
 326
 327
 328   let rec compile_step q dir trs final initial ignore (axis,test,pred) =
 329     let q' = State.mk() in
 330     let trs,final,initial =  match axis,test with
 331         | Self,ts ->
 332             let tchange,tkeep = split_dest q trs in
 333             let trs' = mk_self_trs ts tkeep tchange in
 334               (trs',q::final,initial)
 335
 336         | Child,ts ->
 337             (mk_tag_t dir q ts q' ignore) ::( q==> any @@ (ignore,q))::trs, q'::final,initial
 338
 339         | Descendant,ts ->
 340             (mk_tag_t dir q ts q' ignore) ::
 341               (q==> star @@ (q,q))::(q==> notstar @@ (ignore,q))::trs,q'::final,initial
 342
 343         | DescendantOrSelf,ts ->
 344             let tchange,tkeep = split_dest q trs in
 345             let trs' = mk_dself_trs q' ts trs tchange in
 346               (mk_tag_t dir q ts q' ignore) ::
 347                 (q==> star @@ (q,q))::(q==> notstar @@ (ignore,q))::trs',q'::final,initial
 348
 349         | FollowingSibling,ts ->
 350             (mk_tag_t dir q ts q' ignore) :: (q ==> any @@ (ignore,q))::trs,q'::final,initial
 351
 352               (* q' is not returned and thus not added to the set of final states.
 353                  It's ok since we should never be in a final state on a node
 354                  <@> *)
 355
 356         | Attribute,ts -> let q'' = State.mk() in
 357             (mk_tag_t Left q (TagSet.Xml.attribute) q' ignore)::
 358               (mk_tag_t Left q' (ts) q'' ignore)::( q==> any @@ (ignore,q))::trs, q''::q'::final,initial
 359
 360         | Parent,ts -> let q'' = List.hd initial in
 361             (mk_tag_t Left q' (star) q q')::
 362               ( q'' ==> ts @@ (q',q''))::
 363               ( q'' ==> star @@ (q'',q''))::
 364               ( q'' ==> notstar @@ (ignore,q''))::trs,q'::q''::final,q''::initial
 365
 366     in
 367     let q_out = List.hd final in
 368     let tchange,tkeep = split_dest q_out trs in
 369     let trs' = compile_pred q_out tkeep tchange pred in
 370       (trs',final,initial)
 371
 372   and compile_pred q_out tkeep tchange p =
 373     let rec pred_rec = function
 374
 375       | Or(p1,p2) -> cup (pred_rec p1) (pred_rec p2)
 376       | And(p1,p2) -> cap (pred_rec p1) (pred_rec p2)
 377       | Not(p) -> neg (pred_rec p)
 378       | Expr e -> match compile_expr e with
 379           | `True -> `Label (TagSet.Xml.any)
 380           | `False -> `Label (TagSet.Xml.empty)
 381           | e -> `Fun (fun t -> Functions.truth_value (Functions.eval_expr t e))
 382
 383     in match pred_rec p with
 384         `Fun f -> mk_pred_trs f tkeep tchange
 385       | `Label ts -> mk_self_trs ts tkeep tchange
 386
 387     and compile_expr = function
 388         True -> `True
 389       | False -> `False
 390       | Path p -> `Auto(compile p)
 391       | Int i -> `Int i
 392       | String s -> `String s
 393       | Function ("contains",elist) ->`Contains(List.map compile_expr elist)
 394       | Function (f,elist) -> `Call(f,List.map compile_expr elist)
 395
 396   and cup a b = match a,b with
 397     | `Label l1 , `Label l2 -> `Label(TagSet.Xml.cup l1 l2)
 398     | `Fun f1 , `Fun f2 -> `Fun (fun x -> (f1 x)||(f2 x))
 399     | `Fun f , `Label l | `Label l, `Fun f ->
 400         `Fun (fun x ->
 401                 (TagSet.Xml.mem (Tree.Binary.tag x) l)
 402                 || (f x))
 403
 404   and cap a b = match a,b with
 405     | `Label l1, `Label l2 -> `Label (TagSet.Xml.cap l1 l2)
 406     | `Fun f1,`Fun f2 -> `Fun (fun x -> (f1 x)&&(f2 x))
 407     | `Fun f,`Label l | `Label l,`Fun f ->
 408         `Fun (fun x ->
 409                 (TagSet.Xml.mem (Tree.Binary.tag x) l)
 410                 && f x)
 411   and neg = function
 412       `Label l -> `Label(TagSet.Xml.neg l)
 413     | `Fun f -> `Fun (fun x -> not (f x))
 414
 415   and compile p =
 416     let p = rev_map_dir p in
 417     let ignore = State.mk()
 418     in
 419     let q0 = State.mk() in
 420     let transitions = Transition.empty () in
 421     let tlist,qlist,initacc = List.fold_left
 422       (fun (tlist,qlist,initacc) (s,dir) ->
 423          let q = List.hd qlist in
 424            compile_step q dir tlist qlist initacc ignore s ) ([],[q0;ignore],[q0]) p
 425     in
 426       List.iter (Transition.add transitions) tlist;
 427       let qmark = List.hd qlist in
 428         { Automaton.mk() with
 429             initial = from_list initacc;
 430             final = from_list qlist;
 431             transitions = transitions;
 432             marking = from_list [qmark];
 433             ignore = from_list [qmark;ignore];
 434         }
 435 end