-----------------------------------------------------------------------------
--
-- Module      :  Memoization
-- Copyright   :  Alberto GOmez Corona
-- License     :  BSD3
--
-- Maintainer  :  agocorona@gmail.com
-- Stability   :  Experimental
-- Portability :  Non portable (uses stablenames)
--
-- |
--
-----------------------------------------------------------------------------
{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-missing-signatures #-}
{-# LANGUAGE  DeriveDataTypeable
            , ExistentialQuantification
            , FlexibleInstances
            , TypeSynonymInstances  #-}
module Data.TCache.Memoization (writeCached,cachedByKey,cachedByKeySTM,flushCached,cachedp,addrStr,Executable(..))

where
import Data.Typeable
import Data.TCache
import Data.TCache.Defs(Indexable(..))
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

{-# NOINLINE context #-}
context :: HashTable RealWorld Int (StableName MFun, MFun, [ShowF], Int)
context = forall a. IO a -> a
unsafePerformIO IO Context
newContext

-- | given a string, return a key that can be used in Indexable instances
--  Of non persistent objects, such are cached objects (it changes fron execution to execution)
-- . It uses `addrHash`
addrStr :: a -> String
addrStr :: forall a. a -> String
addrStr a
x= String
"addr" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
hash
 where
 hash :: Int
hash = case forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall a. Context -> a -> IO (Either Int Int)
addrHash HashTable RealWorld Int (StableName MFun, MFun, [ShowF], Int)
context a
x of
   Right Int
x1 -> Int
x1
   Left Int
x1  -> Int
x1

-- | to execute a monad for the purpose of memoizing its result
class Executable m where
  execute:: m a -> a

instance Executable IO where
  execute :: forall a. IO a -> a
execute IO a
m = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$! forall {p} {p}. p -> p -> p
f1 IO a
m String
""
   where
   f1 :: p -> p -> p
f1 p
m1 p
_= p
m1

instance Executable Identity where
  execute :: forall a. Identity a -> a
execute (Identity a
x)= a
x

instance MonadIO Identity where
  liftIO :: forall a. IO a -> Identity a
liftIO IO a
f=  forall a. a -> Identity a
Identity forall a b. (a -> b) -> a -> b
$!  forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$! IO a
f


cachedKeyPrefix :: String
cachedKeyPrefix :: String
cachedKeyPrefix = String
"cached"

instance  (Indexable a) => IResource (Cached a  b) where
  keyResource :: Cached a b -> String
keyResource (Cached a
a  a -> m b
_ b
_ Integer
_)= String
cachedKeyPrefix forall a. [a] -> [a] -> [a]
++ forall a. Indexable a => a -> String
key a
a   -- ++ unsafePerformIO (addrStr f )

  writeResource :: Cached a b -> IO ()
writeResource Cached a b
_= forall (m :: * -> *) a. Monad m => a -> m a
return ()
  delResource :: Cached a b -> IO ()
delResource Cached a b
_= forall (m :: * -> *) a. Monad m => a -> m a
return ()
  readResourceByKey :: String -> IO (Maybe (Cached a b))
readResourceByKey String
_= forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing -- error $ "access By key is undefined for cached objects.key= " ++ k


  readResource :: Cached a b -> IO (Maybe (Cached a b))
readResource (Cached a
a a -> m b
f b
_ Integer
_)=do
   TOD Integer
tnow Integer
_ <- IO ClockTime
getClockTime
   let b :: b
b = forall (m :: * -> *) a. Executable m => m a -> a
execute forall a b. (a -> b) -> a -> b
$ a -> m b
f a
a
   forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b (m :: * -> *).
Executable m =>
a -> (a -> m b) -> b -> Integer -> Cached a b
Cached a
a a -> m b
f b
b Integer
tnow  -- !> "readRe"

--cache time f a=  do
--   TOD tnow _ <- getClockTime
--   let b = execute $ f a
--   withResources [] . const $ [Cached a f b tnow]     -- !> "writeRe"]
--
--cacheKey key time f= cache time (const  f) key

-- | memoize the result of a computation for a certain time. This is useful for  caching  costly data
-- such  web pages composed on the fly.
--
-- time == 0 means infinite

--getCachedRef :: (Indexable a,Typeable a, Typeable b) => a -> DBRef (Cached a b)
--getCachedRef x = getDBRef $ keyResource (Cached x (u u u) where u= undefined

writeCached
  :: (Typeable b, Typeable a, Indexable a, Executable m) =>
     a -> (a -> m b) -> b -> Integer -> STM ()
writeCached :: forall b a (m :: * -> *).
(Typeable b, Typeable a, Indexable a, Executable m) =>
a -> (a -> m b) -> b -> Integer -> STM ()
writeCached  a
a a -> m b
b b
c Integer
d=
    forall a x.
(IResource a, Typeable a) =>
[a] -> ([Maybe a] -> Resources a x) -> STM x
withSTMResources [] forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {p} {p}. p -> p -> p
const forall a b. (a -> b) -> a -> b
$ forall a. Resources a ()
resources{toAdd :: [Cached a b]
toAdd= [forall a b (m :: * -> *).
Executable m =>
a -> (a -> m b) -> b -> Integer -> Cached a b
Cached a
a a -> m b
b b
c Integer
d] }


cached ::  (Indexable a,Typeable a,  Typeable b, Executable m,MonadIO m) => Int -> (a -> m b) -> a  -> m b
cached :: forall a b (m :: * -> *).
(Indexable a, Typeable a, Typeable b, Executable m, MonadIO m) =>
Int -> (a -> m b) -> a -> m b
cached Int
time  a -> m b
f a
a= forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a b (m :: * -> *) p.
(Typeable a, Typeable b, Executable m, Indexable a, Integral p) =>
p -> (a -> m b) -> a -> STM b
cachedSTM Int
time a -> m b
f a
a

cachedSTM :: (Typeable a, Typeable b, Executable m, Indexable a, Integral p) => p -> (a -> m b) -> a -> STM b
cachedSTM :: forall a b (m :: * -> *) p.
(Typeable a, Typeable b, Executable m, Indexable a, Integral p) =>
p -> (a -> m b) -> a -> STM b
cachedSTM p
time a -> m b
f a
a= do
   let prot :: Cached a b
prot= forall a b (m :: * -> *).
Executable m =>
a -> (a -> m b) -> b -> Integer -> Cached a b
Cached a
a a -> m b
f forall a. HasCallStack => a
undefined forall a. HasCallStack => a
undefined
   let ref :: DBRef (Cached a b)
ref= forall a. (Typeable a, IResource a) => String -> DBRef a
getDBRef forall a b. (a -> b) -> a -> b
$ forall a. IResource a => a -> String
keyResource Cached a b
prot
   (Cached a
_ a -> m b
_ b
b Integer
t) <- forall a. (IResource a, Typeable a) => DBRef a -> STM (Maybe a)
readDBRef DBRef (Cached a b)
ref forall (m :: * -> *) b. Monad m => m (Maybe b) -> m b -> m b
`onNothing` forall {b}. (Typeable b, IResource b) => DBRef b -> b -> STM b
fillIt DBRef (Cached a b)
ref Cached a b
prot
   case p
time of
     p
0 -> forall (m :: * -> *) a. Monad m => a -> m a
return b
b
     p
_ -> do
           TOD Integer
tnow Integer
_ <- forall a. IO a -> STM a
unsafeIOToSTM IO ClockTime
getClockTime
           if Integer
tnow forall a. Num a => a -> a -> a
- Integer
t forall a. Ord a => a -> a -> Bool
>= forall a b. (Integral a, Num b) => a -> b
fromIntegral p
time
                      then do
                            Cached a
_ a -> m b
_ b
b1 Integer
_ <- forall {b}. (Typeable b, IResource b) => DBRef b -> b -> STM b
fillIt DBRef (Cached a b)
ref Cached a b
prot
                            forall (m :: * -> *) a. Monad m => a -> m a
return b
b1
                      else  forall (m :: * -> *) a. Monad m => a -> m a
return b
b
   where
   -- has been invalidated by flushCached
   fillIt :: DBRef b -> b -> STM b
fillIt DBRef b
ref b
proto= do
     let r :: b
r = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasCallStack => Maybe a -> a
fromJust forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. IResource a => a -> IO (Maybe a)
readResource b
proto   -- !> "fillIt"
     forall a. (IResource a, Typeable a) => DBRef a -> a -> STM ()
writeDBRef DBRef b
ref b
r
     forall (m :: * -> *) a. Monad m => a -> m a
return b
r

-- | Memoize the result of a computation for a certain time. A string 'key' is used to index the result
--
-- The Int parameter is the timeout, in second after the last evaluation, after which the cached value will be discarded and the expression will be evaluated again if demanded
-- . Time == 0 means no timeout
cachedByKey :: (Typeable a, Executable m,MonadIO m) => String -> Int ->  m a -> m a
cachedByKey :: forall a (m :: * -> *).
(Typeable a, Executable m, MonadIO m) =>
String -> Int -> m a -> m a
cachedByKey String
key1 Int
time  m a
f = forall a b (m :: * -> *).
(Indexable a, Typeable a, Typeable b, Executable m, MonadIO m) =>
Int -> (a -> m b) -> a -> m b
cached Int
time (forall {p} {p}. p -> p -> p
const m a
f) String
key1

cachedByKeySTM :: (Typeable a, Executable m) => String -> Int ->  m a -> STM a
cachedByKeySTM :: forall a (m :: * -> *).
(Typeable a, Executable m) =>
String -> Int -> m a -> STM a
cachedByKeySTM String
key1 Int
time  m a
f = forall a b (m :: * -> *) p.
(Typeable a, Typeable b, Executable m, Indexable a, Integral p) =>
p -> (a -> m b) -> a -> STM b
cachedSTM  Int
time (forall {p} {p}. p -> p -> p
const m a
f) String
key1

-- Flush the cached object indexed by the key
flushCached :: String -> IO ()
flushCached :: String -> IO ()
flushCached String
k= forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ String -> STM ()
invalidateKey forall a b. (a -> b) -> a -> b
$ String
cachedKeyPrefix forall a. [a] -> [a] -> [a]
++ String
k           -- !> "flushCached"

-- | a pure version of cached
cachedp :: (Indexable a,Typeable a,Typeable b) => (a ->b) -> a -> b
cachedp :: forall a b.
(Indexable a, Typeable a, Typeable b) =>
(a -> b) -> a -> b
cachedp a -> b
f a
k = forall (m :: * -> *) a. Executable m => m a -> a
execute forall a b. (a -> b) -> a -> b
$ forall a b (m :: * -> *).
(Indexable a, Typeable a, Typeable b, Executable m, MonadIO m) =>
Int -> (a -> m b) -> a -> m b
cached Int
0 (forall a. a -> Identity a
Identity forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f) a
k

--testmemo= do
--   let f x = "hi"++x  !> "exec1"
--   let f1 x= "h0"++x  !> "exec2"
--   let beacon=1
--   let beacon2=2
--   print $ cachedp f (addrStr "sfs")
--   print $ cachedp f (addrStr "sds")
--   print $ cachedp f1 (addrStr "ssdfddd")
--   print $ cachedp f1 (addrStr "sss")