(******************************************************************************)
(*  SXSI : XPath evaluator                                                    *)
(*  Kim Nguyen (Kim.Nguyen@nicta.com.au)                                      *)
(*  Copyright NICTA 2008                                                      *)
(*  Distributed under the terms of the LGPL (see LICENCE)                     *)
(******************************************************************************)
module type S = 
sig
  module S : Set.S 
  type t = private Finite of S.t | CoFinite of S.t
  exception InfiniteTagSet
  val empty : t
  val any : t
  val is_empty : t -> bool
  val is_any : t -> bool
  val is_finite : t -> bool
  val singleton : S.elt -> t
  val mem : S.elt -> t -> bool
  val add : S.elt -> t -> t
  val remove : S.elt -> t -> t
  val cup : t -> t -> t
  val cap : t -> t -> t
  val diff : t -> t -> t
  val neg : t -> t
  val compare : t -> t -> int
  val subset : t -> t -> bool
  val kind_split : t list -> t * t
  val fold : (S.elt -> 'a -> 'a) -> t -> 'a -> 'a
  val for_all : (S.elt -> bool) -> t -> bool
  val exists : (S.elt -> bool) -> t -> bool
  val filter : (S.elt -> bool) -> t -> S.t
  val partition : (S.elt -> bool) -> t -> S.t * S.t
  val cardinal : t -> int
  val elements : t -> S.elt list
  val from_list : S.elt list -> t
  val choose : t -> S.elt
end

module Make (Symbol : Set.OrderedType) =
struct
  module S = Set.Make(Symbol)
  type t = Finite of S.t | CoFinite of S.t

  exception InfiniteTagSet

  let empty = Finite S.empty
  let any = CoFinite S.empty

  let is_empty =  function
      Finite s when S.is_empty s -> true
    | _ -> false
  let is_any = function
      CoFinite s when S.is_empty s -> true
    | _ -> false
  let is_finite = function
    | Finite _ -> true | _ -> false

  let mem x = function Finite s -> S.mem x s
    | CoFinite s -> not (S.mem x s)

  let singleton x = Finite (S.singleton x)
  let add e = function 
    | Finite s -> Finite (S.add e s)
    | CoFinite s -> CoFinite (S.remove e s)
  let remove e = function
    | Finite s -> Finite (S.remove e s)
    | CoFinite s -> CoFinite (S.add e s)
	
  let cup s t = match (s,t) with
    | Finite s, Finite t -> Finite (S.union s t)
    | CoFinite s, CoFinite t -> CoFinite ( S.inter s t)
    | Finite s, CoFinite t -> CoFinite (S.diff t s)
    | CoFinite s, Finite t-> CoFinite (S.diff s t)

  let cap s t = match (s,t) with
    | Finite s, Finite t -> Finite (S.inter s t)
    | CoFinite s, CoFinite t -> CoFinite (S.union s t)
    | Finite s, CoFinite t -> Finite (S.diff s t)
    | CoFinite s, Finite t-> Finite (S.diff t s)
	
  let diff s t = match (s,t) with
    | Finite s, Finite t -> Finite (S.diff s t)
    | Finite s, CoFinite t -> Finite(S.inter s t)
    | CoFinite s, Finite t -> CoFinite(S.union t s)
    | CoFinite s, CoFinite t -> Finite (S.diff t s)

  let neg = function 
    | Finite s -> CoFinite s
    | CoFinite s -> Finite s
	
  let compare s t = match (s,t) with
    | Finite s , Finite t -> S.compare s t
    | CoFinite s , CoFinite t -> S.compare s t
    | Finite _, CoFinite _ -> -1
    | CoFinite _, Finite _ -> 1
	
  let subset s t = match (s,t) with
    | Finite s , Finite t -> S.subset s t
    | CoFinite s , CoFinite t -> S.subset t s
    | Finite s, CoFinite t -> S.is_empty (S.inter s t)
    | CoFinite _, Finite _ -> false

	(* given a  list l of type t list, 
	   returns two sets (f,c) where :
	   - f is the union of all the finite sets of l
	   - c is the union of all the cofinite sets of l
	   - f and c are disjoint
	   Invariant : cup f c = List.fold_left cup empty l

	   We treat the CoFinite part explicitely :
	*)

  let kind_split l =
    
    let rec next_finite_cofinite facc cacc = function 
      | [] -> Finite facc, CoFinite (S.diff cacc facc)
      | Finite s ::r -> next_finite_cofinite (S.union s facc) cacc r
      | CoFinite _ ::r when S.is_empty cacc -> next_finite_cofinite facc cacc r
      | CoFinite s ::r -> next_finite_cofinite facc (S.inter cacc s) r
    in
    let rec first_cofinite facc = function
      | [] -> empty,empty
      | Finite s :: r-> first_cofinite (S.union s facc) r
      | CoFinite s :: r -> next_finite_cofinite facc s r  
    in
      first_cofinite S.empty l
	
  let fold f t a = match t with
    | Finite s -> S.fold f s a
    | CoFinite _ -> raise InfiniteTagSet

  let for_all f = function
    | Finite s -> S.for_all f s
    | CoFinite _ -> raise InfiniteTagSet

  let exists f = function
    | Finite s -> S.exists f s
    | CoFinite _ -> raise InfiniteTagSet

  let filter f = function
    | Finite s -> S.filter f s
    | CoFinite _ -> raise InfiniteTagSet

  let partition f = function
    | Finite s -> S.partition f s
    | CoFinite _ -> raise InfiniteTagSet

  let cardinal = function
    | Finite s -> S.cardinal s
    | CoFinite _ -> raise InfiniteTagSet

  let elements = function
    | Finite s -> S.elements s
    | CoFinite _ -> raise InfiniteTagSet
	
  let from_list l = 
    Finite(List.fold_left (fun x a -> S.add a x ) S.empty l)

  let choose = function
      Finite s -> S.choose s
    | _ -> raise InfiniteTagSet

end

module Xml =
struct
  include Make(Tag)
  let star = diff any (from_list [ Tag.pcdata; Tag.attribute ])
  let node = remove Tag.attribute any
  let pcdata = singleton Tag.pcdata
  let attribute = singleton Tag.attribute
end