module Data.IxSet
(
IxSet,
Indexable(..),
Proxy(..),
noCalcs,
inferIxSet,
ixSet,
ixFun,
ixGen,
IndexOp,
change,
insert,
delete,
updateIx,
deleteIx,
fromSet,
fromList,
toSet,
toList,
toAscList,
toDescList,
getOne,
getOneOr,
size,
null,
(&&&),
(|||),
union,
intersection,
(@=),
(@<),
(@>),
(@<=),
(@>=),
(@><),
(@>=<),
(@><=),
(@>=<=),
(@+),
(@*),
getEQ,
getLT,
getGT,
getLTE,
getGTE,
getRange,
groupBy,
groupAscBy,
groupDescBy,
flatten,
flattenWithCalcs,
stats
)
where
import Prelude hiding (null)
import Control.Arrow (first, second)
import Data.Generics (Data, gmapQ)
import qualified Data.Generics.SYB.WithClass.Basics as SYBWC
import qualified Data.IxSet.Ix as Ix
import Data.IxSet.Ix (Ix(Ix))
import qualified Data.List as List
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (fromMaybe)
import Data.Monoid (Monoid(mempty, mappend))
import Data.SafeCopy (SafeCopy(..), contain, safeGet, safePut)
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Typeable (Typeable, cast, typeOf)
import Language.Haskell.TH as TH
data Proxy a = Proxy
mkProxy :: a -> Proxy a
mkProxy _ = Proxy
asProxyType :: a -> Proxy a -> a
asProxyType a _ = a
data IxSet a = IxSet [Ix a]
deriving (Data, Typeable)
ixSet :: [Ix a] -> IxSet a
ixSet = IxSet
ixFun :: forall a b . (Ord b,Typeable b) => (a -> [b]) -> Ix a
ixFun f = Ix Map.empty f
ixGen :: forall a b . (Data a,Ord b,Typeable b) => Proxy b -> Ix a
ixGen _example = ixFun (flatten :: a -> [b])
showTypeOf :: (Typeable a) => a -> String
showTypeOf x = showsPrec 11 (typeOf x) []
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 indexes, this is a bug in the library"
_ == _ = error "comparing sets without indexes, this is a bug in the library"
instance (Eq a,Ord a,Typeable a) => Ord (IxSet a) where
compare a b = compare (toSet a) (toSet b)
instance (SafeCopy a, Ord a, Typeable a, Indexable a) => SafeCopy (IxSet a) where
putCopy = contain . safePut . toList
getCopy = contain $ fmap fromList safeGet
instance ( SYBWC.Data ctx a
, SYBWC.Data ctx [a]
, SYBWC.Sat (ctx (IxSet a))
, SYBWC.Sat (ctx [a])
, Indexable a
, Data a
, Ord a
)
=> SYBWC.Data ctx (IxSet a) where
gfoldl _ f z ixset = z fromList `f` toList ixset
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 (Ord a,Show a) => Show (IxSet a) where
showsPrec prec = showsPrec prec . toSet
instance (Ord a,Read a,Typeable a,Indexable a) => Read (IxSet a) where
readsPrec n = map (first fromSet) . readsPrec n
class Indexable a where
empty :: IxSet a
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 = List.foldl' appT (conT typeName) (map varT names)
#if MIN_VERSION_template_haskell(2,4,0)
mkCtx = classP
#else
mkType con = foldl appT (conT con)
mkCtx = mkType
#endif
dataCtxConQ = [mkCtx ''Data [varT name] | name <- names]
fullContext = do
dataCtxCon <- sequence dataCtxConQ
return (context ++ dataCtxCon)
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 = (conE 'Ix) `appE`
(sigE (varE 'Map.empty) (forallT binders (return context) $
appT (appT (conT ''Map) (conT n))
(appT (conT ''Set) typeCon))) `appE`
(varE 'flattenWithCalcs `appE` varE calName)
in do i <- instanceD (fullContext)
(conT ''Indexable `appT` typeCon)
[valD (varP 'empty) (normalB [| ixSet $(listE (map mkEntryPoint entryPoints)) |]) []]
let ixType = appT (conT ''IxSet) typeCon
ixType' <- tySynD (mkName ixset) binders ixType
return $ [i, ixType']
_ -> error "IxSet.inferIxSet calInfo unexpected match"
instanceD' :: CxtQ -> TypeQ -> Q [Dec] -> DecQ
instanceD' ctxt ty decs =
do decs' <- decs
let decs'' = filter (not . isSigD) decs'
instanceD ctxt ty (map return decs'')
isSigD :: Dec -> Bool
isSigD (SigD _ _) = True
isSigD _ = False
#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)
flattenWithCalcs :: (Data c,Typeable a, Data a, Typeable b) => (a -> c) -> a -> [b]
flattenWithCalcs calcs x = flatten (x,calcs x)
change :: (Typeable a,Indexable a,Ord a) =>
IndexOp -> a -> IxSet a -> IxSet a
change op x (IxSet indexes) =
IxSet v
where
v = zipWith update (True:repeat False) indexes
update firstindex (Ix index flatten2) = Ix index' flatten2
where
key = (undefined :: Map key (Set a) -> key) index
ds = flatten2 x
ii m dkey = op dkey x m
index' = if firstindex && List.null ds
then error $ "Happstack.Data.IxSet.change: all values must appear in first declared index " ++ showTypeOf key ++ " of " ++ showTypeOf x
else List.foldl' ii index ds
insertList :: (Typeable a,Indexable a,Ord a)
=> [a] -> IxSet a -> IxSet a
insertList xs (IxSet indexes) =
IxSet v
where
v = zipWith update (True:repeat False) indexes
update firstindex (Ix index flatten2) = Ix index' flatten2
where
key = (undefined :: Map key (Set a) -> key) index
flattencheck x
| firstindex = case flatten2 x of
[] -> error $ "Happstack.Data.IxSet.change: all values must appear in first declared index " ++ showTypeOf key ++ " of " ++ showTypeOf x
res -> res
| otherwise = flatten2 x
dss = [(k,x) | x <- xs, k <- flattencheck x]
index' = Ix.insertList dss index
insertMapOfSets :: (Typeable a, Ord a,Indexable a,Typeable key,Ord key)
=> Map key (Set a) -> IxSet a -> IxSet a
insertMapOfSets originalindex (IxSet indexes) =
IxSet v
where
v = map update indexes
xs = concatMap Set.toList (Map.elems originalindex)
update (Ix index flatten2) = Ix index' flatten2
where
dss = [(k,x) | x <- xs, k <- flatten2 x]
index' = case cast originalindex of
Just originalindex' ->
let dssf = filter (\(k,_v) -> not (Map.member k originalindex')) dss
in Ix.insertList dssf originalindex'
Nothing -> Ix.insertList dss index
insert :: (Typeable a, Ord a,Indexable a) => a -> IxSet a -> IxSet a
insert = change Ix.insert
delete :: (Typeable a, Ord a,Indexable a) => a -> IxSet a -> IxSet a
delete = change Ix.delete
updateIx :: (Indexable a, Ord a, Typeable 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, Ord a, Typeable 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 (Ix ix _:_)) = List.foldl' Set.union Set.empty (Map.elems ix)
toSet (IxSet []) = Set.empty
fromSet :: (Indexable a, Ord a, Typeable a) => Set a -> IxSet a
fromSet = fromList . Set.toList
fromList :: (Indexable a, Ord a, Typeable a) => [a] -> IxSet a
fromList list = insertList list empty
size :: Ord a => IxSet a -> Int
size = Set.size . toSet
toList :: Ord a => IxSet a -> [a]
toList = Set.toList . toSet
toAscList :: forall k a. (Indexable a, Typeable a, Typeable k) => Proxy k -> IxSet a -> [a]
toAscList _ ixset = concatMap snd (groupAscBy ixset :: [(k, [a])])
toDescList :: forall k a. (Indexable a, Typeable a, Typeable k) => Proxy k -> IxSet a -> [a]
toDescList _ ixset = concatMap snd (groupDescBy ixset :: [(k, [a])])
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, Typeable a, Indexable a) => IxSet a -> IxSet a -> IxSet a
(&&&) = intersection
(|||) :: (Ord a, Typeable a, Indexable a) => IxSet a -> IxSet a -> IxSet a
(|||) = union
infixr 5 &&&
infixr 5 |||
union :: (Ord a, Typeable a, Indexable a) => IxSet a -> IxSet a -> IxSet a
union (IxSet x1) (IxSet x2) = IxSet indexes'
where
indexes' = zipWith union' x1 x2
union' (Ix a f) (Ix b _) =
case cast b of
Nothing -> error "IxSet.union: indexes out of order"
Just b' -> Ix (Ix.union a b') f
intersection :: (Ord a, Typeable a, Indexable a) => IxSet a -> IxSet a -> IxSet a
intersection (IxSet x1) (IxSet x2) = IxSet indexes'
where
indexes' = zipWith intersection' x1 x2
intersection' (Ix a f) (Ix b _) =
case cast b of
Nothing -> error "IxSet.intersection: indexes out of order"
Just b' -> Ix (Ix.intersection a b') f
(@=) :: (Indexable a, Typeable a, Ord a, Typeable k)
=> IxSet a -> k -> IxSet a
ix @= v = getEQ v ix
(@<) :: (Indexable a, Typeable a, Ord a, Typeable k)
=> IxSet a -> k -> IxSet a
ix @< v = getLT v ix
(@>) :: (Indexable a, Typeable a, Ord a, Typeable k)
=> IxSet a -> k -> IxSet a
ix @> v = getGT v ix
(@<=) :: (Indexable a, Typeable a, Ord a, Typeable k)
=> IxSet a -> k -> IxSet a
ix @<= v = getLTE v ix
(@>=) :: (Indexable a, Typeable a, Ord a, Typeable k)
=> IxSet a -> k -> IxSet a
ix @>= v = getGTE v ix
(@><) :: (Indexable a, Typeable a, Ord a, Typeable k)
=> IxSet a -> (k, k) -> IxSet a
ix @>< (v1,v2) = getLT v2 $ getGT v1 ix
(@>=<) :: (Indexable a, Typeable a, Ord a, Typeable k)
=> IxSet a -> (k, k) -> IxSet a
ix @>=< (v1,v2) = getLT v2 $ getGTE v1 ix
(@><=) :: (Indexable a, Typeable a, Ord a, Typeable k)
=> IxSet a -> (k, k) -> IxSet a
ix @><= (v1,v2) = getLTE v2 $ getGT v1 ix
(@>=<=) :: (Indexable a, Typeable a, Ord a, Typeable k)
=> IxSet a -> (k, k) -> IxSet a
ix @>=<= (v1,v2) = getLTE v2 $ getGTE v1 ix
(@+) :: (Indexable a, Typeable a, Ord a, Typeable k)
=> IxSet a -> [k] -> IxSet a
ix @+ list = List.foldl' union empty $ map (ix @=) list
(@*) :: (Indexable a, Typeable a, Ord a, Typeable k)
=> IxSet a -> [k] -> IxSet a
ix @* list = List.foldl' intersection ix $ map (ix @=) list
getEQ :: (Indexable a, Typeable a, Ord a, Typeable k)
=> k -> IxSet a -> IxSet a
getEQ = getOrd EQ
getLT :: (Indexable a, Typeable a, Ord a, Typeable k)
=> k -> IxSet a -> IxSet a
getLT = getOrd LT
getGT :: (Indexable a, Typeable a, Ord a, Typeable k)
=> k -> IxSet a -> IxSet a
getGT = getOrd GT
getLTE :: (Indexable a, Typeable a, Ord a, Typeable k)
=> k -> IxSet a -> IxSet a
getLTE = getOrd2 True True False
getGTE :: (Indexable a, Typeable a, Ord a, Typeable k)
=> k -> IxSet a -> IxSet a
getGTE = getOrd2 False True True
getRange :: (Indexable a, Typeable k, Ord a, Typeable 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 indexes) = collect indexes
where
collect [] = []
collect (Ix index _:is) = maybe (collect is) f (cast index)
f = map (second Set.toList) . Map.toList
groupAscBy :: (Typeable k,Typeable t) => IxSet t -> [(k, [t])]
groupAscBy (IxSet indexes) = collect indexes
where
collect [] = []
collect (Ix index _:is) = maybe (collect is) f (cast index)
f = map (second Set.toAscList) . Map.toAscList
groupDescBy :: (Typeable k,Typeable t) => IxSet t -> [(k, [t])]
groupDescBy (IxSet indexes) = collect indexes
where
collect [] = []
collect (Ix index _:is) = maybe (collect is) f (cast index)
f = map (second Set.toAscList) . Map.toDescList
getOrd :: (Indexable a, Ord a, Typeable 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, Ord a, Typeable a, Typeable k)
=> Bool -> Bool -> Bool -> k -> IxSet a -> IxSet a
getOrd2 inclt inceq incgt v ixset@(IxSet indexes) = collect indexes
where
collect [] = error $ "IxSet: there is no index " ++ showTypeOf v ++
" in " ++ showTypeOf ixset
collect (Ix index _:is) = maybe (collect is) f $ cast v
where
f v'' = insertMapOfSets result empty
where
(lt',eq',gt') = Map.splitLookup v'' index
ltgt = Map.unionWith Set.union lt gt
result = case eq of
Just eqset -> Map.insertWith Set.union v'' eqset ltgt
Nothing -> ltgt
lt = if inclt
then lt'
else Map.empty
gt = if incgt
then gt'
else Map.empty
eq = if inceq
then eq'
else Nothing
instance (Indexable a, Typeable a, Ord a) => Monoid (IxSet a) where
mempty = empty
mappend = union
stats :: (Ord a) => IxSet a -> (Int,Int,Int,Int)
stats (IxSet indexes) = (no_elements,no_indexes,no_keys,no_values)
where
no_elements = size (IxSet indexes)
no_indexes = length indexes
no_keys = sum [Map.size m | Ix m _ <- indexes]
no_values = sum [sum [Set.size s | s <- Map.elems m] | Ix m _ <- indexes]