haskell-awk-1.2: src/Data/Cache.hs
{-# LANGUAGE PackageImports #-}
-- | A generic caching interface.
--
-- The intent is to support many concrete implementations,
-- and to use specify caching policies using combinators.
--
-- Note that even though we _support_ many concrete implementations,
-- for simplicity we only provide one based on an association-list.
module Data.Cache where
import Control.Monad
import "mtl" Control.Monad.Trans
import Control.Monad.Trans.State
import Data.Maybe
-- $setup
-- >>> let verboseLength xs = liftIO (putStrLn xs) >> return (length xs)
-- >>> let cachedLength c xs = cached c xs (verboseLength xs)
-- >>> let testC c = mapM (cachedLength c) (words "one two one two testing testing")
-- Implementation notes: the `m` is a monad transformer stack, mostly StateT's,
-- holding the state of the cache. The combinators extend caches by adding more
-- state and code around the base object. This is analogous to the Decorator
-- pattern in OO, except each modification to `m` is visible in the type.
data Cache m k a = Cache
{ readCache :: k -> m (Maybe a)
, writeCache :: k -> a -> m Bool -- ^ False if full
, clearCache :: m ()
, clearFromCache :: k -> m ()
}
-- | Tries to avoid executing this computation in the future by storing it in
-- the cache.
cached :: Monad m => Cache m k a -> k -> m a -> m a
cached c k computeSlowly = do
r <- readCache c k
case r of
Just x -> return x
Nothing -> do
x <- computeSlowly
_ <- writeCache c k x
return x
-- implementations
-- | A dummy cache which never caches anything.
--
-- Semantically equivalent to `finiteCache 0 $ assocCache`, except for the `m`.
--
-- >>> withNullCache testC
-- one
-- two
-- one
-- two
-- testing
-- testing
-- [3,3,3,3,7,7]
nullCache :: Monad m => Cache m k a
nullCache = Cache
{ readCache = \_ -> return Nothing
, writeCache = \_ _ -> return False -- always full!
, clearCache = return ()
, clearFromCache = \_ -> return ()
}
withNullCache :: Monad m => (Cache m k v -> m a) -> m a
withNullCache body = body nullCache
-- | A very inefficient example implementation.
--
-- >>> withAssocCache testC
-- one
-- two
-- testing
-- [3,3,3,3,7,7]
assocCache :: (Monad m, Eq k) => Cache (StateT [(k,a)] m) k a
assocCache = Cache
{ readCache = \k -> liftM (lookup k) $ get
, writeCache = \k v -> modify ((k,v):)
>> return True -- never full.
, clearCache = put []
, clearFromCache = \k -> modify $ filter $ (/= k) . fst
}
withAssocCache :: (Monad m, Eq k)
=> (Cache (StateT [(k,v)] m) k v -> StateT [(k,v)] m a)
-> m a
withAssocCache body = evalStateT (body assocCache) []
-- decorators
-- | Only cache the first `n` requests (use n=-1 for unlimited).
-- Combine with a cache policy in order to reuse those `n` slots.
--
-- >>> withAssocCache $ withFiniteCache 2 $ testC
-- one
-- two
-- testing
-- testing
-- [3,3,3,3,7,7]
--
-- >>> withAssocCache $ withFiniteCache 1 $ testC
-- one
-- two
-- two
-- testing
-- testing
-- [3,3,3,3,7,7]
--
-- >>> withAssocCache $ withFiniteCache 0 $ testC
-- one
-- two
-- one
-- two
-- testing
-- testing
-- [3,3,3,3,7,7]
--
-- >>> withAssocCache $ withFiniteCache (-1) $ testC
-- one
-- two
-- testing
-- [3,3,3,3,7,7]
finiteCache :: Monad m => Int -> Cache m k a -> Cache (StateT Int m) k a
finiteCache n c = Cache
{ readCache = \k -> (lift $ readCache c k )
, writeCache = \k v -> do
alreadyFull <- isFull
if alreadyFull
then return False
else do
r <- lift $ writeCache c k v
when r incr
return r
, clearCache = put 0 >> (lift $ clearCache c )
, clearFromCache = \k -> decr >> (lift $ clearFromCache c k )
}
where
isFull = liftM (== n) $ get
incr = modify (+1)
decr = modify (subtract 1)
withFiniteCache :: Monad m
=> Int
-> (Cache (StateT Int m) k v -> StateT Int m a)
-> (Cache m k v -> m a)
withFiniteCache n body c = evalStateT (body $ finiteCache n c) 0
-- | An example cache-policy implementation: Least-Recently-Used.
--
-- >>> withAssocCache $ withFiniteCache 2 $ withLruCache testC
-- one
-- two
-- testing
-- [3,3,3,3,7,7]
--
-- >>> withAssocCache $ withFiniteCache 1 $ withLruCache testC
-- one
-- two
-- one
-- two
-- testing
-- [3,3,3,3,7,7]
--
-- >>> withAssocCache $ withFiniteCache 0 $ withLruCache testC
-- one
-- two
-- one
-- two
-- testing
-- testing
-- [3,3,3,3,7,7]
lruCache :: (Monad m, Eq k) => Cache m k a -> Cache (StateT [k] m) k a
lruCache c = Cache
{ readCache = \k -> do
r <- lift $ readCache c k
when (isJust r) $ touch k
return r
, writeCache = \k v -> do
r <- lift $ writeCache c k v
if r
then return True
else do
makeRoom
lift $ writeCache c k v
, clearCache = (lift $ clearCache c )
, clearFromCache = \k -> remove k >> (lift $ clearFromCache c k )
}
where
touch k = write k
makeRoom = do
mostRecentlyUsed <- get
case mostRecentlyUsed of
(k:ks) -> do
put ks
lift $ clearFromCache c k
[] -> do
-- the cache is both full and empty? try to reset.
lift $ clearCache c
write k = modify (k:)
remove k = modify $ filter (/= k)
withLruCache :: (Monad m, Eq k)
=> (Cache (StateT [k] m) k v -> StateT [k] m a)
-> (Cache m k v -> m a)
withLruCache body c = evalStateT (body $ lruCache c) []
-- | An extreme version of the LRU strategy.
--
-- Semantically equivalent to `lruCache . finiteCache 1`, except for the `m`.
--
-- >>> withAssocCache $ withSingletonCache testC
-- one
-- two
-- one
-- two
-- testing
-- [3,3,3,3,7,7]
singletonCache :: (Monad m, Eq k) => Cache m k a -> Cache m k a
singletonCache c = c { writeCache = go }
where
go k mx = clearCache c >> writeCache c k mx
withSingletonCache :: (Monad m, Eq k)
=> (Cache m k v -> m a)
-> (Cache m k v -> m a)
withSingletonCache body c = body (singletonCache c)