tagSet.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 module type S =
   8 sig
   9   module S : Set.S
  10   type t = private Finite of S.t | CoFinite of S.t
  11   exception InfiniteTagSet
  12   val empty : t
  13   val any : t
  14   val is_empty : t -> bool
  15   val is_any : t -> bool
  16   val is_finite : t -> bool
  17   val singleton : S.elt -> t
  18   val mem : S.elt -> t -> bool
  19   val add : S.elt -> t -> t
  20   val remove : S.elt -> t -> t
  21   val cup : t -> t -> t
  22   val cap : t -> t -> t
  23   val diff : t -> t -> t
  24   val neg : t -> t
  25   val compare : t -> t -> int
  26   val subset : t -> t -> bool
  27   val kind_split : t list -> t * t
  28   val fold : (S.elt -> 'a -> 'a) -> t -> 'a -> 'a
  29   val for_all : (S.elt -> bool) -> t -> bool
  30   val exists : (S.elt -> bool) -> t -> bool
  31   val filter : (S.elt -> bool) -> t -> S.t
  32   val partition : (S.elt -> bool) -> t -> S.t * S.t
  33   val cardinal : t -> int
  34   val elements : t -> S.elt list
  35   val from_list : S.elt list -> t
  36   val choose : t -> S.elt
  37 end
  38
  39 module Make (Symbol : Set.OrderedType) =
  40 struct
  41   module S = Set.Make(Symbol)
  42   type t = Finite of S.t | CoFinite of S.t
  43
  44   exception InfiniteTagSet
  45
  46   let empty = Finite S.empty
  47   let any = CoFinite S.empty
  48
  49   let is_empty =  function
  50       Finite s when S.is_empty s -> true
  51     | _ -> false
  52   let is_any = function
  53       CoFinite s when S.is_empty s -> true
  54     | _ -> false
  55   let is_finite = function
  56     | Finite _ -> true | _ -> false
  57
  58   let mem x = function Finite s -> S.mem x s
  59     | CoFinite s -> not (S.mem x s)
  60
  61   let singleton x = Finite (S.singleton x)
  62   let add e = function
  63     | Finite s -> Finite (S.add e s)
  64     | CoFinite s -> CoFinite (S.remove e s)
  65   let remove e = function
  66     | Finite s -> Finite (S.remove e s)
  67     | CoFinite s -> CoFinite (S.add e s)
  68
  69   let cup s t = match (s,t) with
  70     | Finite s, Finite t -> Finite (S.union s t)
  71     | CoFinite s, CoFinite t -> CoFinite ( S.inter s t)
  72     | Finite s, CoFinite t -> CoFinite (S.diff t s)
  73     | CoFinite s, Finite t-> CoFinite (S.diff s t)
  74
  75   let cap s t = match (s,t) with
  76     | Finite s, Finite t -> Finite (S.inter s t)
  77     | CoFinite s, CoFinite t -> CoFinite (S.union s t)
  78     | Finite s, CoFinite t -> Finite (S.diff s t)
  79     | CoFinite s, Finite t-> Finite (S.diff t s)
  80
  81   let diff s t = match (s,t) with
  82     | Finite s, Finite t -> Finite (S.diff s t)
  83     | Finite s, CoFinite t -> Finite(S.inter s t)
  84     | CoFinite s, Finite t -> CoFinite(S.union t s)
  85     | CoFinite s, CoFinite t -> Finite (S.diff t s)
  86
  87   let neg = function
  88     | Finite s -> CoFinite s
  89     | CoFinite s -> Finite s
  90
  91   let compare s t = match (s,t) with
  92     | Finite s , Finite t -> S.compare s t
  93     | CoFinite s , CoFinite t -> S.compare s t
  94     | Finite _, CoFinite _ -> -1
  95     | CoFinite _, Finite _ -> 1
  96
  97   let subset s t = match (s,t) with
  98     | Finite s , Finite t -> S.subset s t
  99     | CoFinite s , CoFinite t -> S.subset t s
 100     | Finite s, CoFinite t -> S.is_empty (S.inter s t)
 101     | CoFinite _, Finite _ -> false
 102
 103         (* given a  list l of type t list,
 104            returns two sets (f,c) where :
 105            - f is the union of all the finite sets of l
 106            - c is the union of all the cofinite sets of l
 107            - f and c are disjoint
 108            Invariant : cup f c = List.fold_left cup empty l
 109
 110            We treat the CoFinite part explicitely :
 111         *)
 112
 113   let kind_split l =
 114
 115     let rec next_finite_cofinite facc cacc = function
 116       | [] -> Finite facc, CoFinite (S.diff cacc facc)
 117       | Finite s ::r -> next_finite_cofinite (S.union s facc) cacc r
 118       | CoFinite _ ::r when S.is_empty cacc -> next_finite_cofinite facc cacc r
 119       | CoFinite s ::r -> next_finite_cofinite facc (S.inter cacc s) r
 120     in
 121     let rec first_cofinite facc = function
 122       | [] -> empty,empty
 123       | Finite s :: r-> first_cofinite (S.union s facc) r
 124       | CoFinite s :: r -> next_finite_cofinite facc s r
 125     in
 126       first_cofinite S.empty l
 127
 128   let fold f t a = match t with
 129     | Finite s -> S.fold f s a
 130     | CoFinite _ -> raise InfiniteTagSet
 131
 132   let for_all f = function
 133     | Finite s -> S.for_all f s
 134     | CoFinite _ -> raise InfiniteTagSet
 135
 136   let exists f = function
 137     | Finite s -> S.exists f s
 138     | CoFinite _ -> raise InfiniteTagSet
 139
 140   let filter f = function
 141     | Finite s -> S.filter f s
 142     | CoFinite _ -> raise InfiniteTagSet
 143
 144   let partition f = function
 145     | Finite s -> S.partition f s
 146     | CoFinite _ -> raise InfiniteTagSet
 147
 148   let cardinal = function
 149     | Finite s -> S.cardinal s
 150     | CoFinite _ -> raise InfiniteTagSet
 151
 152   let elements = function
 153     | Finite s -> S.elements s
 154     | CoFinite _ -> raise InfiniteTagSet
 155
 156   let from_list l =
 157     Finite(List.fold_left (fun x a -> S.add a x ) S.empty l)
 158
 159   let choose = function
 160       Finite s -> S.choose s
 161     | _ -> raise InfiniteTagSet
 162
 163 end
 164
 165 module Xml =
 166 struct
 167   include Make(Tag)
 168   let star = diff any (from_list [ Tag.pcdata; Tag.attribute ])
 169   let node = remove Tag.attribute any
 170   let pcdata = singleton Tag.pcdata
 171   let attribute = singleton Tag.attribute
 172 end