module Data.TCache.Memoization (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)
import Debug.Trace
(!>)= flip trace
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, Typeable a) => IResource (Cached a b) where
keyResource ch@(Cached a f _ _)= cachedKeyPrefix ++ key a
writeResource _= return ()
delResource _= return ()
readResourceByKey= error "access By Indexable is undefined for cached objects"
readResource (Cached a f _ _)=do
TOD tnow _ <- getClockTime
let b = execute $ f a
return . Just $ Cached a f b tnow
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