module Happstack.Data.IxSet
(
module Ix,
IxSet,
Indexable(..),
noCalcs,
inferIxSet,
ixSet,
IndexOp,
change,
insert,
delete,
updateIx,
deleteIx,
fromSet,
fromList,
toSet,
toList,
getOne,
getOneOr,
size,
null,
(&&&),
(|||),
union,
intersection,
(@=),
(@<),
(@>),
(@<=),
(@>=),
(@><),
(@>=<),
(@><=),
(@>=<=),
(@+),
(@*),
getEQ,
getLT,
getGT,
getLTE,
getGTE,
getRange,
groupBy,
getOrd,
stats
)
where
import qualified Happstack.Data.IxSet.Ix as Ix
import Happstack.Data.IxSet.Ix (Ix(Ix))
import Data.Generics (Data, gmapQ)
import Data.Maybe
import Data.Monoid
import Data.List (partition)
import qualified Data.List as List
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Set (Set)
import qualified Data.Set as Set
import Happstack.Util.Common
import Control.Monad.Reader
import Language.Haskell.TH as TH
import Happstack.Util.TH
import Happstack.Data
import qualified Data.Generics.SYB.WithClass.Basics as SYBWC
import Prelude hiding (null)
data IxSet a = IxSet [Ix a]
deriving (Data, Typeable)
ixSet :: [Ix a] -> IxSet a
ixSet = IxSet
instance (Eq a,Ord a,Typeable a) => Eq (IxSet a) where
IxSet (Ix a:_) == IxSet (Ix b:_) =
case cast b of
Just b' -> a==b'
Nothing -> error "trying to compare two sets with different types of first indices, this is a bug in library"
_ == _ = error "comparing sets without indices, this is a bug in library"
instance (Eq a,Ord a,Typeable a) => Ord (IxSet a) where
compare a b = compare (toSet a) (toSet b)
instance Version (IxSet a)
instance (Serialize a, Ord a, Data a, Indexable a b) => Serialize (IxSet a) where
putCopy = contain . safePut . toList
getCopy = contain $ liftM fromList safeGet
instance (SYBWC.Data ctx a, SYBWC.Sat (ctx (IxSet a)), SYBWC.Sat (ctx [a]),
Indexable a b, Data a, Ord a)
=> SYBWC.Data ctx (IxSet a) where
gfoldl _ f z (IxSet x) = z fromList `f` toList' x
toConstr _ (IxSet _) = ixSetConstr
gunfold _ k z c = case SYBWC.constrIndex c of
1 -> k (z fromList)
_ -> error "IxSet.SYBWC.Data.gunfold unexpected match"
dataTypeOf _ _ = ixSetDataType
ixSetConstr :: SYBWC.Constr
ixSetConstr = SYBWC.mkConstr ixSetDataType "IxSet" [] SYBWC.Prefix
ixSetDataType :: SYBWC.DataType
ixSetDataType = SYBWC.mkDataType "IxSet" [ixSetConstr]
instance (Indexable a b, Data a, Ord a, Default a) => Default (IxSet a) where
defaultValue = empty
instance (Ord a,Show a) => Show (IxSet a) where show = show . toSet
instance (Ord a,Read a,Data a,Indexable a b) => Read (IxSet a) where
readsPrec n = mapFst fromSet . readsPrec n
class (Data b) => Indexable a b | a -> b where
empty :: IxSet a
calcs :: a -> b
noCalcs :: t -> ()
noCalcs _ = ()
inferIxSet :: String -> TH.Name -> TH.Name -> [TH.Name] -> Q [Dec]
inferIxSet _ _ _ [] = error "inferIxSet needs at least one index"
inferIxSet ixset typeName calName entryPoints
= do calInfo <- reify calName
typeInfo <- reify typeName
let (context,binders) = case typeInfo of
TyConI (DataD ctxt _ nms _ _) -> (ctxt,nms)
TyConI (NewtypeD ctxt _ nms _ _) -> (ctxt,nms)
TyConI (TySynD _ nms _) -> ([],nms)
_ -> error "IxSet.inferIxSet typeInfo unexpected match"
names = map tyVarBndrToName binders
typeCon = foldl appT (conT typeName) (map varT names)
case calInfo of
VarI _ t _ _ ->
let calType = getCalType t
getCalType (ForallT _names _ t') = getCalType t'
getCalType (AppT (AppT ArrowT _) t') = t'
getCalType t' = error ("Unexpected type in getCalType: " ++ pprint t')
mkEntryPoint n = appE (conE 'Ix) (sigE (varE 'Map.empty) (forallT binders (return context) $
appT (appT (conT ''Map) (conT n)) (appT (conT ''Set) typeCon)))
in do i <- instanceD' (return context) (appT (appT (conT ''Indexable) typeCon) (return calType))
[d| empty :: IxSet a
empty = ixSet $(listE (map mkEntryPoint entryPoints))
calcs :: a -> b
calcs = $(varE calName) |]
let ixType = appT (conT ''IxSet) typeCon
ixType' <- tySynD (mkName ixset) binders ixType
return $ [i, ixType']
_ -> error "IxSet.inferIxSet calInfo unexpected match"
#if MIN_VERSION_template_haskell(2,4,0)
tyVarBndrToName :: TyVarBndr -> Name
tyVarBndrToName (PlainTV nm) = nm
tyVarBndrToName (KindedTV nm _) = nm
#else
tyVarBndrToName :: a -> a
tyVarBndrToName = id
#endif
type IndexOp =
forall k a. (Ord k,Ord a) => k -> a -> Map k (Set a) -> Map k (Set a)
flatten :: (Typeable a, Data a, Typeable b) => a -> [b]
flatten x = case cast x of
Just y -> case cast (y :: String) of
Just v -> [v]
Nothing -> []
Nothing -> case cast x of
Just v -> v : concat (gmapQ flatten x)
Nothing -> concat (gmapQ flatten x)
change :: (Data a, Ord a,Data b,Indexable a b) =>
IndexOp -> a -> IxSet a -> IxSet a
change op x (IxSet indices) =
IxSet v
where
v = zipWith update (True:repeat False) indices
a = (x,calcs x)
update firstindex (Ix index) = Ix index'
where
keyType = typeOf ((undefined :: Map key (Set a) -> key) index)
ds = flatten a
ii dkey = op dkey x
index' = if firstindex && List.null ds
then error $ "Happstack.Data.IxSet.change: all values must appear in first declared index " ++ show keyType ++ " of " ++ show (typeOf x)
else foldr ii index ds
insert :: (Data a, Ord a,Data b,Indexable a b) => a -> IxSet a -> IxSet a
insert = change Ix.insert
delete :: (Data a, Ord a,Data b,Indexable a b) => a -> IxSet a -> IxSet a
delete = change Ix.delete
updateIx :: (Indexable a b, Ord a, Data a, Typeable k)
=> k -> a -> IxSet a -> IxSet a
updateIx i new ixset = insert new $
maybe ixset (flip delete ixset) $
getOne $ ixset @= i
deleteIx :: (Indexable a b, Ord a, Data a, Typeable k)
=> k -> IxSet a -> IxSet a
deleteIx i ixset = maybe ixset (flip delete ixset) $
getOne $ ixset @= i
toSet :: Ord a => IxSet a -> Set a
toSet (IxSet idxs) = toSet' idxs
toSet' :: Ord a => [Ix a] -> Set a
toSet' (Ix ix:_) = Map.fold Set.union Set.empty ix
toSet' [] = Set.empty
fromSet :: (Indexable a b, Ord a, Data a) => Set a -> IxSet a
fromSet set = Set.fold insert empty set
fromSet' :: (Indexable a b, Ord a, Data a) => Set a -> IxSet a
fromSet' set = Set.fold insert empty set
fromList :: (Indexable a b, Ord a, Data a) => [a] -> IxSet a
fromList = fromSet . Set.fromList
size :: Ord a => IxSet a -> Int
size = Set.size . toSet
toList :: Ord a => IxSet a -> [a]
toList = Set.toList . toSet
toList' :: Ord a => [Ix a] -> [a]
toList' = Set.toList . toSet'
getOne :: Ord a => IxSet a -> Maybe a
getOne ixset = case toList ixset of
[x] -> Just x
_ -> Nothing
getOneOr :: Ord a => a -> IxSet a -> a
getOneOr def = fromMaybe def . getOne
null :: IxSet a -> Bool
null (IxSet (Ix ix:_)) = Map.null ix
null (IxSet []) = True
(&&&) :: (Ord a, Data a, Indexable a b) => IxSet a -> IxSet a -> IxSet a
(&&&) = intersection
(|||) :: (Ord a, Data a, Indexable a b) => IxSet a -> IxSet a -> IxSet a
(|||) = union
infixr 5 &&&
infixr 5 |||
union :: (Ord a, Data a, Indexable a b) => IxSet a -> IxSet a -> IxSet a
union x1 x2 = fromSet $ Set.union (toSet x1) (toSet x2)
intersection :: (Ord a, Data a, Indexable a b) => IxSet a -> IxSet a -> IxSet a
intersection x1 x2 = fromSet $ Set.intersection (toSet x1) (toSet x2)
(@=) :: (Indexable a b, Data a, Ord a, Typeable k)
=> IxSet a -> k -> IxSet a
ix @= v = getEQ v ix
(@<) :: (Indexable a b, Data a, Ord a, Typeable k)
=> IxSet a -> k -> IxSet a
ix @< v = getLT v ix
(@>) :: (Indexable a b, Data a, Ord a, Typeable k)
=> IxSet a -> k -> IxSet a
ix @> v = getGT v ix
(@<=) :: (Indexable a b, Data a, Ord a, Typeable k)
=> IxSet a -> k -> IxSet a
ix @<= v = getLTE v ix
(@>=) :: (Indexable a b, Data a, Ord a, Typeable k)
=> IxSet a -> k -> IxSet a
ix @>= v = getGTE v ix
(@><) :: (Indexable a b, Data a, Ord a, Typeable k)
=> IxSet a -> (k, k) -> IxSet a
ix @>< (v1,v2) = getLT v2 $ getGT v1 ix
(@>=<) :: (Indexable a b, Data a, Ord a, Typeable k)
=> IxSet a -> (k, k) -> IxSet a
ix @>=< (v1,v2) = getLT v2 $ getGTE v1 ix
(@><=) :: (Indexable a b, Data a, Ord a, Typeable k)
=> IxSet a -> (k, k) -> IxSet a
ix @><= (v1,v2) = getLTE v2 $ getGT v1 ix
(@>=<=) :: (Indexable a b, Data a, Ord a, Typeable k)
=> IxSet a -> (k, k) -> IxSet a
ix @>=<= (v1,v2) = getLTE v2 $ getGTE v1 ix
(@+) :: (Indexable a b, Data a, Ord a, Typeable k)
=> IxSet a -> [k] -> IxSet a
ix @+ list = foldr union empty $ map (ix @=) list
(@*) :: (Indexable a b, Data a, Ord a, Typeable k)
=> IxSet a -> [k] -> IxSet a
ix @* list = foldr intersection empty $ map (ix @=) list
getEQ :: (Indexable a b, Data a, Ord a, Typeable k)
=> k -> IxSet a -> IxSet a
getEQ = getOrd EQ
getLT :: (Indexable a b, Data a, Ord a, Typeable k)
=> k -> IxSet a -> IxSet a
getLT = getOrd LT
getGT :: (Indexable a b, Data a, Ord a, Typeable k)
=> k -> IxSet a -> IxSet a
getGT = getOrd GT
getLTE :: (Indexable a b, Data a, Ord a, Typeable k)
=> k -> IxSet a -> IxSet a
getLTE = getOrd2 True True False
getGTE :: (Indexable a b, Data a, Ord a, Typeable k)
=> k -> IxSet a -> IxSet a
getGTE = getOrd2 False True True
getRange :: (Indexable a b, Typeable k, Ord a, Data a)
=> k -> k -> IxSet a -> IxSet a
getRange k1 k2 ixset = getGTE k1 (getLT k2 ixset)
groupBy::(Typeable k,Typeable t) => IxSet t -> [(k, [t])]
groupBy (IxSet indices) = collect indices
where
collect [] = []
collect (Ix index:is) = maybe (collect is) f (cast index)
f = mapSnd Set.toList . Map.toList
getOrd :: (Indexable a b, Ord a, Data a, Typeable k)
=> Ordering -> k -> IxSet a -> IxSet a
getOrd LT = getOrd2 True False False
getOrd EQ = getOrd2 False True False
getOrd GT = getOrd2 False False True
getOrd2 :: (Indexable a b, Ord a, Data a, Typeable k)
=> Bool -> Bool -> Bool -> k -> IxSet a -> IxSet a
getOrd2 inclt inceq incgt v ixset@(IxSet indices) = collect indices
where
collect [] = error $ "IxSet: there is no index " ++ show (typeOf v) ++
" in " ++ show (typeOf ixset)
collect (Ix index:is) = maybe (collect is) f $ cast v
where
f v'' = foldr insert empty (lt ++ eq ++ gt)
where
(lt',eq',gt') = Map.splitLookup v'' index
lt = if inclt
then concatMap Set.toList $ Map.elems lt'
else []
gt = if incgt
then concatMap Set.toList $ Map.elems gt'
else []
eq = if inceq
then maybe [] Set.toList eq'
else []
instance (Indexable a b, Data a, Ord a) => Monoid (IxSet a) where
mempty = empty
mappend = union
stats :: (Ord a) => IxSet a -> (Int,Int,Int,Int)
stats (IxSet indices) = (no_elements,no_indices,no_keys,no_values)
where
no_elements = size (IxSet indices)
no_indices = length indices
no_keys = sum [Map.size m | Ix m <- indices]
no_values = sum [sum [Set.size s | s <- Map.elems m] | Ix m <- indices]