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 #load "pa_extend.cmo";;
   8 let contains = ref None
   9 module Ast =
  10 struct
  11   (* The steps are in reverse order !!!! *)
  12   type path = Absolute of step list | AbsoluteDoS of step list| Relative of step list
  13   and step = axis*test*predicate
  14   and axis = Self | Attribute | Child | Descendant | DescendantOrSelf | FollowingSibling
  15              | Parent | Ancestor | AncestorOrSelf | PrecedingSibling | Preceding | Following
  16
  17   and test = TagSet.t
  18
  19   and predicate = Or of predicate*predicate
  20                   | And of predicate*predicate
  21                   | Not of predicate
  22                   | Expr of expression
  23   and expression =  Path of path
  24                     | Function of string*expression list
  25                     | Int of int
  26                     | String of string
  27                     | True | False
  28   type t = path
  29
  30
  31
  32
  33   let pp fmt = Format.fprintf fmt
  34   let print_list printer fmt sep l =
  35     match l with
  36         [] -> ()
  37       | [e] -> printer fmt e
  38       | e::es -> printer fmt e; List.iter (fun x -> pp fmt sep;printer fmt x) es
  39
  40
  41   let rec print fmt p =
  42     let l = match p with
  43       | Absolute l -> pp fmt "/"; l
  44       | AbsoluteDoS l -> pp fmt "/";
  45           print_step fmt (DescendantOrSelf,TagSet.node,Expr True);
  46           pp fmt "/"; l
  47       | Relative l -> l
  48     in
  49       print_list print_step fmt "/" (List.rev l)
  50   and print_step fmt (axis,test,predicate) =
  51     print_axis fmt axis;pp fmt "::";print_test fmt test;
  52     pp fmt "["; print_predicate fmt predicate; pp fmt "]"
  53   and print_axis fmt a = pp fmt "%s" (match a with
  54                                           Self -> "self"
  55                                         | Child -> "child"
  56                                         | Descendant -> "descendant"
  57                                         | DescendantOrSelf -> "descendant-or-self"
  58                                         | FollowingSibling -> "following-sibling"
  59                                         | Attribute -> "attribute"
  60                                         | Ancestor -> "ancestor"
  61                                         | AncestorOrSelf -> "ancestor-or-self"
  62                                         | PrecedingSibling -> "preceding-sibling"
  63                                         | Parent -> "parent"
  64                                         | _ -> assert false
  65                                      )
  66   and print_test fmt ts =
  67     try
  68       pp fmt "%s" (List.assoc ts
  69                      [ (TagSet.pcdata,"text()"); (TagSet.node,"node()");
  70                        (TagSet.star),"*"])
  71     with
  72         Not_found -> pp fmt "%s"
  73           (if TagSet.is_finite ts
  74            then Tag.to_string (TagSet.choose ts)
  75            else "<INFINITE>")
  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) -> pp fmt "%s(" f;print_list print_expression fmt "," l;pp fmt ")"
  86     | Int i -> pp fmt "%i" i
  87     | String s -> pp fmt "\"%s\"" s
  88     | t -> pp fmt "%b" (t== True)
  89
  90 end
  91 module Parser =
  92 struct
  93   open Ast
  94   open Ulexer
  95   let predopt = function None -> Expr True | Some p -> p
  96
  97   module Gram =  Camlp4.Struct.Grammar.Static.Make(Ulexer)
  98   let query = Gram.Entry.mk "query"
  99
 100   exception Error of Gram.Loc.t*string
 101   let test_of_keyword t loc =
 102     match t with
 103       | "text()" -> TagSet.pcdata
 104       | "node()" -> TagSet.node
 105       | "*" -> TagSet.star
 106       | "and" | "not" | "or" -> TagSet.singleton (Tag.tag t)
 107       | _ -> raise (Error(loc,"Invalid test name "^t ))
 108
 109   let axis_to_string a = let r = Format.str_formatter in
 110     print_axis r a; Format.flush_str_formatter()
 111 EXTEND Gram
 112
 113 GLOBAL: query;
 114
 115  query : [ [ p = path; `EOI -> p ]]
 116 ;
 117
 118  path : [
 119    [ "//" ; l = slist -> AbsoluteDoS l ]
 120  | [ "/" ; l = slist -> Absolute l ]
 121  | [ l = slist  -> Relative l ]
 122  ]
 123 ;
 124
 125 slist: [
 126   [ l = slist ;"/"; s = step -> s@l ]
 127 | [ l = slist ; "//"; s = step -> s@[(DescendantOrSelf, TagSet.node,Expr True)]@l]
 128 | [ s = step ->  s ]
 129 ];
 130
 131 step : [
 132   (* yurk, this is done to parse stuff like
 133      a/b/descendant/a where descendant is actually a tag name :(
 134      if OPT is None then this is a child::descendant if not, this is a real axis name
 135   *)
 136 [ axis = axis ; o = OPT ["::" ; t = test -> t ] ; p = top_pred  ->
 137     let a,t,p =
 138       match o with
 139         | Some(t) ->  (axis,t,p)
 140         | None -> (Child,TagSet.singleton (Tag.tag (axis_to_string axis)),p)
 141     in match a with
 142       | Following -> [ (DescendantOrSelf,t,p);
 143                        (FollowingSibling,TagSet.star,Expr(True));
 144                        (Ancestor,TagSet.star,Expr(True)) ]
 145
 146       | Preceding -> [ (DescendantOrSelf,t,p);
 147                        (PrecedingSibling,TagSet.star,Expr(True));
 148                        (Ancestor,TagSet.star,Expr(True)) ]
 149       | _ -> [ a,t,p ]
 150
 151 ]
 152
 153 | [ "." ; p = top_pred ->  [(Self,TagSet.node,p)]  ]
 154 | [ ".." ; p = top_pred ->  [(Parent,TagSet.star,p)]  ]
 155 | [ "contains"; "(" ; s = STRING ; ")";p=top_pred -> [
 156       let _ = contains := Some((`CONTAINS,s)) in  (Child,TagSet.singleton Tag.pcdata, p)]
 157   ]
 158 | [ "equals"; "(" ; s = STRING ; ")";p=top_pred -> [
 159       let _ = contains := Some((`EQUALS,s)) in  (Child,TagSet.singleton Tag.pcdata, p)]
 160   ]
 161 | [ "startswith"; "(" ; s = STRING ; ")";p=top_pred -> [
 162       let _ = contains := Some((`STARTSWITH,s)) in  (Child,TagSet.singleton Tag.pcdata, p)]
 163   ]
 164 | [ "endswith"; "(" ; s = STRING ; ")";p=top_pred -> [
 165       let _ = contains := Some((`ENDSWITH,s)) in  (Child,TagSet.singleton Tag.pcdata, p)]
 166   ]
 167 | [ test = test; p = top_pred  -> [(Child,test, p)] ]
 168 | [ att = ATT ; p = top_pred ->
 169       match att with
 170         | "*" -> [(Attribute,TagSet.star,p)]
 171         | _ ->  [(Attribute, TagSet.singleton (Tag.tag att) ,p )]]
 172 ]
 173 ;
 174 top_pred  : [
 175   [ p = OPT [ "["; p=predicate ;"]" -> p ] -> predopt p ]
 176 ]
 177 ;
 178 axis : [
 179   [ "self" -> Self | "child" -> Child | "descendant" -> Descendant
 180       | "descendant-or-self" -> DescendantOrSelf
 181       | "ancestor-or-self" -> AncestorOrSelf
 182       | "following-sibling" -> FollowingSibling
 183       | "attribute" -> Attribute
 184       | "parent" -> Parent
 185       | "ancestor" -> Ancestor
 186       | "preceding-sibling" -> PrecedingSibling
 187       | "preceding" -> Preceding
 188       | "following" -> Following
 189   ]
 190
 191
 192 ];
 193 test : [
 194   [ s = KWD -> test_of_keyword s _loc  ]
 195 | [ t = TAG -> TagSet.singleton (Tag.tag t) ]
 196 ];
 197
 198
 199 predicate: [
 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   let parse_string = Gram.parse_string query (Ulexer.Loc.mk "<string>")
 218   let parse = Gram.parse_string query (Ulexer.Loc.mk "<string>")
 219 end
 220
 221
 222 module Compile = struct
 223 open Ast
 224 type transition = Ata.State.t*TagSet.t*Ata.Transition.t
 225
 226 type config = { st_root : Ata.State.t; (* state matching the root element (initial state) *)
 227                 st_univ : Ata.State.t; (* universal state accepting anything *)
 228                 st_from_root : Ata.State.t; (* state chaining the root and the current position *)
 229                 mutable final_state : Ata.StateSet.t;
 230                 mutable has_backward: bool;
 231                 (* To store transitions *)
 232                 (* Key is the from state, (i,l) -> i the number of the step and l the list of trs *)
 233                 tr_parent_loop : (Ata.State.t,int*(transition list)) Hashtbl.t;
 234                 tr : (Ata.State.t,int*(transition list)) Hashtbl.t;
 235                 tr_aux : (Ata.State.t,int*(transition list)) Hashtbl.t;
 236                 mutable entry_points : (Tag.t*Ata.StateSet.t) list;
 237                 mutable  contains : string option;
 238                 mutable univ_states : Ata.State.t list;
 239                 mutable starstate : Ata.StateSet.t option;
 240               }
 241 let dummy_conf = { st_root = -1;
 242                    st_univ = -1;
 243                    st_from_root = -1;
 244                    final_state = Ata.StateSet.empty;
 245                    has_backward = false;
 246                    tr_parent_loop = Hashtbl.create 0;
 247                    tr = Hashtbl.create 0;
 248                    tr_aux = Hashtbl.create 0;
 249                    entry_points = [];
 250                    contains = None;
 251                    univ_states = [];
 252                    starstate = None;
 253                  }
 254
 255
 256 let _r =
 257   function (`Left|`Last) -> `Right
 258     | `Right -> `Left
 259     | `RRight -> `LLeft
 260     | `LLeft -> `RRight
 261
 262
 263 let _l =
 264   function (`Left|`Last) -> `Left
 265     | `Right -> `Right
 266     | `RRight -> `RRight
 267     | `LLeft -> `LLeft
 268
 269
 270 open Ata.Transition.Infix
 271 open Ata.Formula.Infix
 272
 273
 274 (* Todo : fix *)
 275 let add_trans num htr ((q,ts,_)as tr) =
 276   Hashtbl.add htr q (num,[tr])
 277
 278 let vpush x y = (x,[]) :: y
 279 let hpush x y =
 280   match y with
 281     | (z,r)::l -> (z,x::r) ::l
 282     | _ -> assert false
 283
 284 let vpop = function
 285     (x,_)::r -> x,r
 286   | _ -> assert false
 287
 288 let hpop = function
 289   | (x,z::y) ::r -> z,(x,y)::r
 290   | _-> assert false
 291
 292 let rec compile_step  ?(existential=false) conf q_src dir ctx_path nrec step num  =
 293   let ex = existential in
 294   let axis,test,pred = step  in
 295   let is_last = dir = `Last in
 296   let { st_root = q_root;
 297         st_univ = q_univ;
 298         st_from_root = q_frm_root } = conf
 299   in
 300   let q_dst = Ata.State.make() in
 301   let p_st, p_anc, p_par, p_pre, p_num, p_f =
 302     compile_pred conf q_src num ctx_path dir pred q_dst
 303   in
 304   let new_st,new_dst, new_ctx =
 305   match axis with
 306     | Child | Descendant ->
 307         if (TagSet.is_finite test)
 308         then conf.entry_points <- (TagSet.choose test,Ata.StateSet.singleton q_src)::conf.entry_points;
 309         let left,right =
 310           if nrec then `LLeft,`RRight
 311           else `Left,`Right
 312         in
 313         let _ = if is_last && axis=Descendant && TagSet.equal test TagSet.star
 314         then conf.starstate <- Some(Ata.StateSet.singleton q_src)
 315         in
 316         let t1,ldst = ?< q_src><(test, is_last && not(ex))>=>
 317           p_f *& ( if is_last then Ata.Formula.true_ else  (_l left) *+ q_dst),
 318           ( if is_last then [] else [q_dst])
 319         in
 320
 321         let _ = add_trans num conf.tr t1 in
 322         let _ = if axis=Descendant then
 323           add_trans num conf.tr_aux (
 324             ?< q_src><@ ((if ex||nrec then TagSet.diff TagSet.star test
 325                           else TagSet.star),false)>=>
 326               (if TagSet.equal test TagSet.star then
 327                 `Left else `LLeft) *+ q_src )
 328         in
 329         let t3 =
 330           ?< q_src><@ ((if ex then TagSet.diff  TagSet.any test
 331                         else TagSet.any), false)>=>
 332             (if axis=Descendant && (not (TagSet.equal test TagSet.star)) then
 333                `RRight else `Right) *+ q_src
 334         in
 335         let _ = add_trans num conf.tr_aux t3
 336         in
 337           ldst, q_dst,
 338         (if axis = FollowingSibling then hpush q_src ctx_path else vpush q_src ctx_path)
 339
 340
 341     | Attribute ->
 342         let q_dstreal = Ata.State.make() in
 343           (* attributes are always the first child *)
 344         let t1 = ?< q_src><(TagSet.attribute,false)>=>
 345           `Left *+ q_dst  in
 346         let t2 = ?< q_dst><(test, is_last && not(existential))>=>
 347           if is_last then Ata.Formula.true_ else `Left *+ q_dstreal in
 348         let tsa = ?< q_dst><(TagSet.star, false)>=> `Right *+ q_dst
 349         in
 350           add_trans num conf.tr t1;
 351           add_trans num conf.tr_aux t2;
 352           add_trans num conf.tr_aux tsa;
 353           [q_dst;q_dstreal], q_dstreal,
 354         ctx_path
 355
 356
 357     | _ -> assert false
 358   in
 359     (* todo change everything to Ata.StateSet *)
 360     (Ata.StateSet.elements (Ata.StateSet.union p_st (Ata.StateSet.from_list new_st)),
 361      new_dst,
 362      new_ctx)
 363 and is_rec  = function
 364     [] -> false
 365   | ((axis,_,_),_)::_ ->
 366       match axis with
 367           Descendant | Ancestor -> true
 368         | _ -> false
 369
 370 and compile_path ?(existential=false) annot_path config q_src states idx ctx_path =
 371   List.fold_left
 372     (fun (a_st,a_dst,anc_st,par_st,pre_st,ctx_path,num,has_backward,a_isrec) (step,dir) ->
 373        let add_states,new_dst,new_ctx =
 374          compile_step ~existential:existential config a_dst dir ctx_path (is_rec a_isrec) step num
 375        in
 376        let new_states = Ata.StateSet.union (Ata.StateSet.from_list add_states) a_st in
 377        let nanc_st,npar_st,npre_st,new_bw =
 378          match step with
 379            |PrecedingSibling,_,_ -> anc_st,par_st,Ata.StateSet.add a_dst pre_st,true
 380            |(Parent|Ancestor|AncestorOrSelf),_,_ -> Ata.StateSet.add a_dst anc_st,par_st,pre_st,true
 381            | _ -> anc_st,par_st,pre_st,has_backward
 382        in
 383          new_states,new_dst,nanc_st,npar_st,npre_st,new_ctx, num+1,new_bw,(match a_isrec with [] -> [] | _::r -> r)
 384     )
 385     (states, q_src, Ata.StateSet.empty,Ata.StateSet.empty,Ata.StateSet.empty, ctx_path,idx, false,(List.tl annot_path) )
 386     annot_path
 387
 388 and binop_ conf q_src idx ctx_path dir pred p1 p2 f ddst =
 389   let a_st1,anc_st1,par_st1,pre_st1,idx1,f1 =
 390     compile_pred conf q_src idx ctx_path dir p1 ddst in
 391   let a_st2,anc_st2,par_st2,pre_st2,idx2,f2 =
 392     compile_pred conf q_src idx1 ctx_path dir p2 ddst
 393   in
 394         Ata.StateSet.union a_st1 a_st2,
 395         Ata.StateSet.union anc_st1 anc_st2,
 396         Ata.StateSet.union par_st1 par_st2,
 397         Ata.StateSet.union pre_st1 pre_st2,
 398         idx2, (f f1 f2)
 399
 400 and compile_pred conf q_src idx ctx_path dir pred qdst =
 401   match pred with
 402     | Or(p1,p2) ->
 403         binop_ conf q_src idx ctx_path dir pred p1 p2 (( +| )) qdst
 404     | And(p1,p2) ->
 405         binop_ conf q_src idx ctx_path dir pred p1 p2 (( *& )) qdst
 406     | Expr e -> compile_expr conf Ata.StateSet.empty q_src idx ctx_path dir e qdst
 407     | Not(p) ->
 408         let a_st,anc_st,par_st,pre_st,idx,f =
 409           compile_pred conf q_src idx ctx_path dir p qdst
 410         in a_st,anc_st,par_st,pre_st,idx, Ata.Formula.not_ f
 411
 412 and compile_expr conf states q_src idx ctx_path dir e qdst =
 413   match e with
 414     | Path (p) ->
 415         let q = Ata.State.make () in
 416         let annot_path = match p with Relative(r) -> dirannot (List.rev r) | _ -> assert false in
 417         let a_st,a_dst,anc_st,par_st,pre_st,_,idx,has_backward,_ =
 418             compile_path ~existential:true annot_path conf q states idx ctx_path
 419         in
 420         let ret_dir = match annot_path with
 421           | ((FollowingSibling,_,_),_)::_ -> `Right
 422           | _ -> `Left
 423         in
 424         let _ = match annot_path with
 425           | (((Parent|Ancestor|AncestorOrSelf),_,_),_)::_ -> conf.final_state <- Ata.StateSet.add qdst conf.final_state
 426           | _ -> ()
 427         in let _ = conf.univ_states <- a_dst::conf.univ_states in
 428           (a_st,anc_st,par_st,pre_st,idx, ((ret_dir) *+ q))
 429     | True -> states,Ata.StateSet.empty,Ata.StateSet.empty,Ata.StateSet.empty,idx,Ata.Formula.true_
 430     | False -> states,Ata.StateSet.empty,Ata.StateSet.empty,Ata.StateSet.empty,idx,Ata.Formula.false_
 431     | _ -> assert false
 432
 433
 434 and dirannot = function
 435     [] -> []
 436   | [p]  -> [p,`Last]
 437   | p::(((FollowingSibling),_,_)::_ as l) -> (p,`Right)::(dirannot l)
 438   | p::l -> (p,`Left) :: (dirannot l)
 439
 440 let compile ?(querystring="") path =
 441   let steps =
 442   match path with
 443     | Absolute(steps)
 444     | Relative(steps) -> steps
 445     | AbsoluteDoS(steps) -> steps@[(DescendantOrSelf,TagSet.node,Expr(True))]
 446   in
 447         let steps = List.rev steps in
 448         let dirsteps = dirannot steps in
 449         let config = { st_root = Ata.State.make();
 450                        st_univ = Ata.State.make();
 451                        final_state = Ata.StateSet.empty;
 452                        st_from_root =  Ata.State.make();
 453                        has_backward = false;
 454                        tr_parent_loop = Hashtbl.create 5;
 455                        tr = Hashtbl.create 5;
 456                        tr_aux =  Hashtbl.create 5;
 457                        entry_points = [];
 458                        contains = None;
 459                        univ_states = [];
 460                        starstate = None;
 461                      }
 462         in
 463         let q0 = Ata.State.make() in
 464         let states = Ata.StateSet.from_list [config.st_univ;config.st_root]
 465         in
 466         let num = 0 in
 467         (* add_trans num config.tr_aux (mk_star config.st_from_root `Left config.st_univ config.st_from_root);
 468              add_trans num config.tr_aux (mk_star config.st_from_root `Left config.st_from_root config.st_univ);
 469              add_trans num config.tr_aux (mk_step config.st_no_nil (TagSet.add Tag.pcdata TagSet.star) `Left config.st_univ config.st_univ);
 470           *)
 471           let a_st,a_dst,anc_st,par_st,pre_st,_,_,has_backward,_ =
 472             compile_path dirsteps config q0 states 0 [(config.st_root,[]) ]
 473           in
 474           let fst_tr =
 475             ?< (config.st_root) >< (TagSet.singleton (Tag.tag ""),false) >=>
 476               ((if is_rec dirsteps then `LLeft else `Left)*+ q0) *& (if config.has_backward then `LLeft *+ config.st_from_root else Ata.Formula.true_)
 477           in
 478             add_trans num config.tr fst_tr;
 479             if config.has_backward then begin
 480               add_trans num config.tr_aux
 481                 (?< (config.st_from_root) >< (TagSet.star,false) >=> `LLeft *+ config.st_from_root);
 482               add_trans num config.tr_aux
 483                 (?< (config.st_from_root) >< (TagSet.any,false) >=>
 484                      `RRight *+ config.st_from_root);
 485
 486             end;
 487           let phi = Hashtbl.create 37 in
 488           let fadd = fun _ (_,l) -> List.iter (fun (s,t,tr) ->
 489                                                  let lt = try
 490                                                    Hashtbl.find phi s
 491                                                  with Not_found -> []
 492                                                  in
 493                                                    Hashtbl.replace phi s ((t,tr)::lt)
 494                                               ) l in
 495             Hashtbl.iter (fadd) config.tr;
 496             Hashtbl.iter (fadd) config.tr_aux;
 497             Hashtbl.iter (fadd) config.tr_parent_loop;
 498             let final =
 499               let s = anc_st
 500               in if has_backward then Ata.StateSet.add config.st_from_root s else s
 501             in { Ata.id = Oo.id (object end);
 502                  Ata.states = Hashtbl.fold (fun q _ acc -> Ata.StateSet.add q acc) phi Ata.StateSet.empty;
 503                  Ata.init = Ata.StateSet.singleton config.st_root;
 504                  Ata.trans = phi;
 505                  Ata.starstate = config.starstate;
 506                  Ata.query_string = querystring;
 507                },config.entry_points,!contains
 508
 509
 510 end