module Data.TCache.Memoization (writeCached,cachedByKey,flushCached,cachedp,addrStr,Executable(..))
where
import Data.Typeable
import Data.TCache
import Data.TCache.Defs(Indexable(..))
import System.Mem.StableName
import System.IO.Unsafe
import System.Time
import Data.Maybe(fromJust)
import Control.Monad.Trans
import Control.Monad.Identity
import Data.RefSerialize(addrHash,newContext)
data Cached a b= forall m.Executable m => Cached a (a -> m b) b Integer deriving Typeable
context= unsafePerformIO newContext
addrStr x= "addr" ++ show hash
where
hash = case unsafePerformIO $ addrHash context x of
Right x -> x
Left x -> x
class Executable m where
execute:: m a -> a
instance Executable IO where
execute= unsafePerformIO
instance Executable Identity where
execute (Identity x)= x
instance MonadIO Identity where
liftIO f= Identity $! unsafePerformIO $! f
cachedKeyPrefix = "cached"
instance (Indexable a) => IResource (Cached a b) where
keyResource ch@(Cached a _ _ _)= cachedKeyPrefix ++ key a
writeResource _= return ()
delResource _= return ()
readResourceByKey k= error $ "access By key is undefined for cached objects.key= " ++ k
readResource (Cached a f _ _)=do
TOD tnow _ <- getClockTime
let b = execute $ f a
return . Just $ Cached a f b tnow
writeCached
:: (Typeable b, Typeable a, Indexable a, Executable m) =>
a -> (a -> m b) -> b -> Integer -> STM ()
writeCached a b c d=
withSTMResources [] . const $ resources{toAdd= [Cached a b c d] }
cached :: (Indexable a,Typeable a, Typeable b, Executable m,MonadIO m) => Int -> (a -> m b) -> a -> m b
cached time f a= do
let prot= Cached a f undefined undefined
cho@(Cached _ _ b t) <- liftIO $ getResource prot `onNothing` fillIt prot
case time of
0 -> return b
_ -> do
TOD tnow _ <- liftIO $ getClockTime
if tnow t > fromIntegral time
then do
liftIO $ deleteResource cho
cached time f a
else return b
where
fillIt proto= do
r <- return . fromJust =<< (readResource proto)
withResources [] $ const [r]
return r
cachedByKey :: (Typeable a, Executable m,MonadIO m) => String -> Int -> m a -> m a
cachedByKey key time f = cached time (\_ -> f) key
flushCached :: String -> IO ()
flushCached k= atomically $ invalidateKey $ cachedKeyPrefix ++ k
cachedp :: (Indexable a,Typeable a,Typeable b) => (a ->b) -> a -> b
cachedp f k = execute $ cached 0 (\x -> Identity $ f x) k