module Data.GMap.CacheKeys
(
CacheKeys
,cacheKeys
,uncacheKeys
) where
import Prelude hiding (foldr,map,filter,lookup)
import Data.GMap
import qualified Data.Monoid as M (Monoid(..))
import qualified Data.Foldable as F (Foldable(..))
import Data.Typeable
import qualified Data.List as L
import GHC.Base hiding (map)
import qualified Text.Read as R
data CacheKeys mp k a = CacheKeys !(mp (k,a))
instance (Map mp k) => Map (CacheKeys mp k) k where
empty = emptyCacheKeys
singleton = singletonCacheKeys
pair = pairCacheKeys
nonEmpty = nonEmptyCacheKeys
status = statusCacheKeys
addSize = addSizeCacheKeys
lookup = lookupCacheKeys
lookupCont = lookupContCacheKeys
alter = alterCacheKeys
insertWith = insertWithCacheKeys
insertWith' = insertWithCacheKeys'
insertMaybe = insertMaybeCacheKeys
fromAssocsWith = fromAssocsWithCacheKeys
fromAssocsMaybe = fromAssocsMaybeCacheKeys
delete = deleteCacheKeys
adjustWith = adjustWithCacheKeys
adjustWith' = adjustWithCacheKeys'
adjustMaybe = adjustMaybeCacheKeys
venn = vennCacheKeys
venn' = vennCacheKeys'
vennMaybe = vennMaybeCacheKeys
union = unionCacheKeys
union' = unionCacheKeys'
unionMaybe = unionMaybeCacheKeys
disjointUnion = disjointUnionCacheKeys
intersection = intersectionCacheKeys
intersection' = intersectionCacheKeys'
intersectionMaybe = intersectionMaybeCacheKeys
difference = differenceCacheKeys
differenceMaybe = differenceMaybeCacheKeys
isSubsetOf = isSubsetOfCacheKeys
isSubmapOf = isSubmapOfCacheKeys
map = mapCacheKeys
map' = mapCacheKeys'
mapMaybe = mapMaybeCacheKeys
mapWithKey = mapWithKeyCacheKeys
mapWithKey' = mapWithKeyCacheKeys'
filter = filterCacheKeys
foldKeys = foldKeysCacheKeys
foldElems = foldElemsCacheKeys
foldAssocs = foldAssocsCacheKeys
foldKeys' = foldKeysCacheKeys'
foldElems' = foldElemsCacheKeys'
foldAssocs' = foldAssocsCacheKeys'
foldElemsUInt = foldElemsUIntCacheKeys
valid = validCacheKeys
instance (OrderedMap mp k) => OrderedMap (CacheKeys mp k) k where
compareKey = compareKeyCacheKeys
fromAssocsAscWith = fromAssocsAscWithCacheKeys
fromAssocsDescWith = fromAssocsDescWithCacheKeys
fromAssocsAscMaybe = fromAssocsAscMaybeCacheKeys
fromAssocsDescMaybe = fromAssocsDescMaybeCacheKeys
foldElemsAsc = foldElemsAscCacheKeys
foldElemsDesc = foldElemsDescCacheKeys
foldKeysAsc = foldKeysAscCacheKeys
foldKeysDesc = foldKeysDescCacheKeys
foldAssocsAsc = foldAssocsAscCacheKeys
foldAssocsDesc = foldAssocsDescCacheKeys
foldElemsAsc' = foldElemsAscCacheKeys'
foldElemsDesc' = foldElemsDescCacheKeys'
foldKeysAsc' = foldKeysAscCacheKeys'
foldKeysDesc' = foldKeysDescCacheKeys'
foldAssocsAsc' = foldAssocsAscCacheKeys'
foldAssocsDesc' = foldAssocsDescCacheKeys'
cacheKeys :: Map mp k => mp a -> CacheKeys mp k a
cacheKeys mp = CacheKeys (mapWithKey' (,) mp)
uncacheKeys :: Map mp k => CacheKeys mp k a -> mp a
uncacheKeys (CacheKeys mp) = map' snd mp
on :: (c -> d) -> (a -> b -> c) -> a -> b -> d
on f g a b = f $ g a b
emptyCacheKeys = CacheKeys empty
singletonCacheKeys k a = CacheKeys (singleton k (k,a))
pairCacheKeys k1 k2 = (cacheKeys `on`) `fmap` (pair k1 k2)
nonEmptyCacheKeys (CacheKeys kmp) = CacheKeys `fmap` (nonEmpty kmp)
statusCacheKeys (CacheKeys kmp) =
case (status kmp) of
None -> None
One k (_,a) -> One k a
Many -> Many
addSizeCacheKeys (CacheKeys kmp) = addSize kmp
lookupCacheKeys k (CacheKeys kmp) = snd `fmap` (lookup k kmp)
lookupContCacheKeys f k (CacheKeys kmp) = lookupCont (f . snd) k kmp
withKey f (k,a) = let a' = f a in a' `seq` (k,a')
withKeyMaybe f (k,a) = do
a' <- f a
return (a' `seq` (k,a'))
withMaybeKeyMaybe f k mka = (\a' -> (k,a')) `fmap` (f (snd `fmap` mka))
alterCacheKeys f k (CacheKeys kmp) = CacheKeys (alter (withMaybeKeyMaybe f k) k kmp)
insertWithCacheKeys f k a (CacheKeys kmp) = CacheKeys (insertWith (withKey f) k (k,a) kmp)
insertWithCacheKeys' f k a (CacheKeys kmp) = CacheKeys (insertWith' (withKey f) k (a `seq` (k,a)) kmp)
insertMaybeCacheKeys f k a (CacheKeys kmp) = CacheKeys (insertMaybe (withKeyMaybe f) k (k,a) kmp)
deleteCacheKeys k (CacheKeys kmp) = CacheKeys (delete k kmp)
adjustWithCacheKeys f k (CacheKeys kmp) = CacheKeys (adjustWith (withKey f) k kmp)
adjustWithCacheKeys' f k (CacheKeys kmp) = CacheKeys (adjustWith' (withKey f) k kmp)
adjustMaybeCacheKeys f k (CacheKeys kmp) = CacheKeys (adjustMaybe (withKeyMaybe f) k kmp)
withKey2 f (k,a1) (_,a2) = let a' = f a1 a2 in a' `seq` (k,f a1 a2)
withKeyMaybe2 f (k,a1) (_,a2) = (\ a -> a `seq` (k,a)) `fmap` (f a1 a2)
vennCacheKeys f (CacheKeys kmp1) (CacheKeys kmp2) = (CacheKeys leftDiff, CacheKeys inter, CacheKeys rightDiff)
where (leftDiff,inter,rightDiff) = venn (withKey2 f) kmp1 kmp2
vennCacheKeys' f (CacheKeys kmp1) (CacheKeys kmp2) = (CacheKeys leftDiff, CacheKeys inter, CacheKeys rightDiff)
where (leftDiff,inter,rightDiff) = venn' (withKey2 f) kmp1 kmp2
vennMaybeCacheKeys f (CacheKeys kmp1) (CacheKeys kmp2) = (CacheKeys leftDiff, CacheKeys inter, CacheKeys rightDiff)
where (leftDiff,inter,rightDiff) = vennMaybe (withKeyMaybe2 f) kmp1 kmp2
unionCacheKeys f (CacheKeys kmp1) (CacheKeys kmp2) = CacheKeys (union (withKey2 f) kmp1 kmp2)
unionCacheKeys' f (CacheKeys kmp1) (CacheKeys kmp2) = CacheKeys (union' (withKey2 f) kmp1 kmp2)
unionMaybeCacheKeys f (CacheKeys kmp1) (CacheKeys kmp2) = CacheKeys (unionMaybe (withKeyMaybe2 f) kmp1 kmp2)
disjointUnionCacheKeys (CacheKeys kmp1) (CacheKeys kmp2) = CacheKeys (disjointUnion kmp1 kmp2)
intersectionCacheKeys f (CacheKeys kmp1) (CacheKeys kmp2) = CacheKeys (intersection (withKey2 f) kmp1 kmp2)
intersectionCacheKeys' f (CacheKeys kmp1) (CacheKeys kmp2) = CacheKeys (intersection' (withKey2 f) kmp1 kmp2)
intersectionMaybeCacheKeys f (CacheKeys kmp1) (CacheKeys kmp2) = CacheKeys (intersectionMaybe (withKeyMaybe2 f) kmp1 kmp2)
differenceCacheKeys (CacheKeys kmp1) (CacheKeys kmp2) = CacheKeys (difference kmp1 kmp2)
differenceMaybeCacheKeys f (CacheKeys kmp1) (CacheKeys kmp2) = CacheKeys (differenceMaybe (withKeyMaybe2 f) kmp1 kmp2)
onAssoc f (_,a) = f a
onAssoc2 f (_,a) (_,b) = f a b
isSubsetOfCacheKeys (CacheKeys kmp1) (CacheKeys kmp2) = isSubsetOf kmp1 kmp2
isSubmapOfCacheKeys f (CacheKeys kmp1) (CacheKeys kmp2) = isSubmapOf (onAssoc2 f) kmp1 kmp2
mapCacheKeys f (CacheKeys kmp) = CacheKeys (map (withKey f) kmp)
mapCacheKeys' f (CacheKeys kmp) = CacheKeys (map' (withKey f) kmp)
mapMaybeCacheKeys f (CacheKeys kmp) = CacheKeys (mapMaybe (withKeyMaybe f) kmp)
mapWithKeyCacheKeys f (CacheKeys kmp) = CacheKeys (map (\(k,a) -> (k,f k a)) kmp)
mapWithKeyCacheKeys' f (CacheKeys kmp) = CacheKeys (map' (\(k,a) -> let a' = f k a in a' `seq` (k,a')) kmp)
filterCacheKeys f (CacheKeys kmp) = CacheKeys (filter (onAssoc f) kmp)
foldElemsUIntCacheKeys f b (CacheKeys kmp) = foldElemsUInt (onAssoc f) b kmp
validCacheKeys (CacheKeys kmp) = valid kmp
compareKeyCacheKeys cachemp k1 k2 = compareKey (innermp cachemp) k1 k2
where innermp :: CacheKeys mp k a -> mp a
innermp _ = undefined
fromAssocsWithCacheKeys f kas = CacheKeys (fromAssocsWith (withKey2 f) [(k,(k,a)) | (k,a) <- kas])
fromAssocsMaybeCacheKeys f kas = CacheKeys (fromAssocsMaybe (withKeyMaybe2 f) [(k,(k,a)) | (k,a) <- kas])
fromAssocsAscWithCacheKeys f kas = CacheKeys (fromAssocsAscWith (withKey2 f) [(k,(k,a)) | (k,a) <- kas])
fromAssocsDescWithCacheKeys f kas = CacheKeys (fromAssocsDescWith (withKey2 f) [(k,(k,a)) | (k,a) <- kas])
fromAssocsAscMaybeCacheKeys f kas = CacheKeys (fromAssocsAscMaybe (withKeyMaybe2 f) [(k,(k,a)) | (k,a) <- kas])
fromAssocsDescMaybeCacheKeys f kas = CacheKeys (fromAssocsDescMaybe (withKeyMaybe2 f) [(k,(k,a)) | (k,a) <- kas])
foldKeysCacheKeys f b (CacheKeys kmp) = foldKeys f b kmp
foldKeysCacheKeys' f b (CacheKeys kmp) = foldKeys' f b kmp
foldKeysAscCacheKeys f b (CacheKeys kmp) = foldKeysAsc f b kmp
foldKeysDescCacheKeys f b (CacheKeys kmp) = foldKeysDesc f b kmp
foldKeysAscCacheKeys' f b (CacheKeys kmp) = foldKeysAsc' f b kmp
foldKeysDescCacheKeys' f b (CacheKeys kmp) = foldKeysDesc' f b kmp
foldElemsCacheKeys f b (CacheKeys kmp) = foldElems (onAssoc f) b kmp
foldElemsCacheKeys' f b (CacheKeys kmp) = foldElems' (onAssoc f) b kmp
foldElemsAscCacheKeys f b (CacheKeys kmp) = foldElemsAsc (onAssoc f) b kmp
foldElemsDescCacheKeys f b (CacheKeys kmp) = foldElemsDesc (onAssoc f) b kmp
foldElemsAscCacheKeys' f b (CacheKeys kmp) = foldElemsAsc' (onAssoc f) b kmp
foldElemsDescCacheKeys' f b (CacheKeys kmp) = foldElemsDesc' (onAssoc f) b kmp
foldAssocsCacheKeys f b (CacheKeys kmp) = foldElems (uncurry f) b kmp
foldAssocsCacheKeys' f b (CacheKeys kmp) = foldElems' (uncurry f) b kmp
foldAssocsAscCacheKeys f b (CacheKeys kmp) = foldElemsAsc (uncurry f) b kmp
foldAssocsDescCacheKeys f b (CacheKeys kmp) = foldElemsDesc (uncurry f) b kmp
foldAssocsAscCacheKeys' f b (CacheKeys kmp) = foldElemsAsc' (uncurry f) b kmp
foldAssocsDescCacheKeys' f b (CacheKeys kmp) = foldElemsDesc' (uncurry f) b kmp
instance (Eq (mp (k,a))) => Eq (CacheKeys mp k a) where
(CacheKeys kmp1) == (CacheKeys kmp2) = (kmp1 == kmp2)
instance (Ord (mp (k,a))) => Ord (CacheKeys mp k a) where
compare (CacheKeys kmp1) (CacheKeys kmp2) = compare kmp1 kmp2
instance (Show k, Show a, Map mp k) => Show (CacheKeys mp k a) where
showsPrec d mp = showParen (d > 10) $
showString "fromAssocs " . shows (assocs mp)
instance (Read k, Read a, Map mp k) => R.Read (CacheKeys mp k a) where
readPrec = R.parens $ R.prec 10 $ do R.Ident "fromAssocs" <- R.lexP
xs <- R.readPrec
return (fromAssocs xs)
readListPrec = R.readListPrecDefault
instance (Typeable1 mp) => Typeable1 (CacheKeys mp k) where
typeOf1 m = mkTyConApp (mkTyCon "Data.GMap.CacheKeys.CacheKeys") [typeOf1 innermp]
where CacheKeys innermp = m
instance (Typeable1 (CacheKeys mp k), Typeable a) => Typeable (CacheKeys mp k a) where
typeOf = typeOfDefault
instance (Map mp k) => Functor (CacheKeys mp k) where
fmap = mapCacheKeys
instance (Map mp k, M.Monoid a) => M.Monoid (CacheKeys mp k a) where
mempty = emptyCacheKeys
mappend map0 map1 = unionCacheKeys M.mappend map0 map1
mconcat maps = L.foldr (unionCacheKeys M.mappend) emptyCacheKeys maps
instance (Map mp k) => F.Foldable (CacheKeys mp k) where
fold mp = foldElemsCacheKeys M.mappend M.mempty mp
foldMap f mp = foldElemsCacheKeys (\a b -> M.mappend (f a) b) M.mempty mp
foldr f b0 mp = foldElemsCacheKeys f b0 mp
foldl f b0 mp = foldElemsCacheKeys (flip f) b0 mp