From 539b65f8df2521acb01f84fda63712b58d0fee2f Mon Sep 17 00:00:00 2001
From: "Alberto G. Corona" <agocorona@gmail.com>
Date: Mon, 13 May 2013 11:52:14 +0200
Subject: [PATCH] added cachedbyKeySTM, inproved memoization

---
 Data/TCache/IndexQuery.hs  |  5 ++---
 Data/TCache/Memoization.hs | 30 ++++++++++++++++++------------
 TCache.cabal               |  2 +-
 demos/DynamicSample.hs     | 10 ++++------
 demos/memoization.hs       | 15 +++++++++++++++
 5 files changed, 40 insertions(+), 22 deletions(-)
 create mode 100644 demos/memoization.hs

diff --git a/Data/TCache/IndexQuery.hs b/Data/TCache/IndexQuery.hs
index 90e9e65..a96e090 100644
--- a/Data/TCache/IndexQuery.hs
+++ b/Data/TCache/IndexQuery.hs
@@ -283,9 +283,8 @@ instance SetOperations  (JoinData a a') [DBRef a'] (JoinData a a') where
      return [(zs, union xs ys) | (zs,xs) <- xss]
 
 
--- |  return all  the (indexed) registers which has this field
-indexOf :: (Queriable reg a )
-                   => (reg -> a) -> STM [(a,[DBRef reg])]
+-- |  return all  the (indexed)  values which this field has and a DBRef pointer to the register
+indexOf :: (Queriable reg a) => (reg -> a) -> STM [(a,[DBRef reg])]
 indexOf selector= do
    let [one, two]= typeRepArgs $! typeOf selector
    let rindex= getDBRef $! keyIndex one two
diff --git a/Data/TCache/Memoization.hs b/Data/TCache/Memoization.hs
index df8455f..10e0c26 100644
--- a/Data/TCache/Memoization.hs
+++ b/Data/TCache/Memoization.hs
@@ -15,7 +15,7 @@
             , ExistentialQuantification
             , FlexibleInstances
             , TypeSynonymInstances  #-}
-module Data.TCache.Memoization (writeCached,cachedByKey,flushCached,cachedp,addrStr,Executable(..))
+module Data.TCache.Memoization (writeCached,cachedByKey,cachedByKeySTM,flushCached,cachedp,addrStr,Executable(..))
 
 where
 import Data.Typeable
@@ -64,7 +64,7 @@ instance  (Indexable a) => IResource (Cached a  b) where
 
   writeResource _= return ()
   delResource _= return ()
-  readResourceByKey k=   error $ "access By key is undefined for cached objects.key= " ++ k
+  readResourceByKey k= return Nothing -- error $ "access By key is undefined for cached objects.key= " ++ k
 
 
   readResource (Cached a f _ _)=do
@@ -95,24 +95,27 @@ writeCached  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
+cached time  f a= liftIO . atomically $ cachedSTM time f a
+
+cachedSTM time f a= do
    let prot= Cached a f undefined undefined
-   cho@(Cached _ _ b t)  <- liftIO $ getResource prot `onNothing` fillIt prot
+   let ref= getDBRef $ keyResource prot
+   cho@(Cached _ _ b t) <- readDBRef ref `onNothing` fillIt ref prot
    case time of
      0 -> return b
      _ -> do
-           TOD tnow _ <- liftIO $ getClockTime
-           if tnow - t > fromIntegral time
+           TOD tnow _ <- unsafeIOToSTM $ getClockTime
+           if tnow - t >= fromIntegral time
                       then do
-                          liftIO $ deleteResource cho
-                          cached time f a
+                            Cached _ _ b _ <- fillIt ref prot
+                            return b
                       else  return b
    where
    -- has been invalidated by flushCached
-   fillIt proto= do
-   r <- return . fromJust =<< (readResource proto)   -- !> "fillIt"
-   withResources [] $ const [r]
-   return r
+   fillIt ref proto= do
+     let r = unsafePerformIO $return . fromJust =<< readResource proto   -- !> "fillIt"
+     writeDBRef ref r
+     return r
 
 -- | Memoize the result of a computation for a certain time. A string 'key' is used to index the result
 --
@@ -121,6 +124,9 @@ cached time  f a=  do
 cachedByKey :: (Typeable a, Executable m,MonadIO m) => String -> Int ->  m a -> m a
 cachedByKey key time  f = cached  time (\_ -> f) key
 
+cachedByKeySTM :: (Typeable a, Executable m) => String -> Int ->  m a -> STM a
+cachedByKeySTM key time  f = cachedSTM  time (\_ -> f) key
+
 -- Flush the cached object indexed by the key
 flushCached :: String -> IO ()
 flushCached k= atomically $ invalidateKey $ cachedKeyPrefix ++ k           -- !> "flushCached"
diff --git a/TCache.cabal b/TCache.cabal
index d61ee3d..a98c609 100644
--- a/TCache.cabal
+++ b/TCache.cabal
@@ -1,5 +1,5 @@
 name: TCache
-version: 0.10.0.5
+version: 0.10.0.6
 cabal-version: >= 1.6
 build-type: Simple
 license: BSD3
diff --git a/demos/DynamicSample.hs b/demos/DynamicSample.hs
index 81448f9..7e13248 100644
--- a/demos/DynamicSample.hs
+++ b/demos/DynamicSample.hs
@@ -15,11 +15,9 @@ example of IDynamic usage.
 --two objects with two different datatypes: Int and String
 
 instance Indexable Int where     
-   key x=  show x
+   key =  show 
+
 
-  
-  
- 
 instance Indexable String where
    key x=  take 2 x
  
@@ -52,8 +50,8 @@ main= do
   -- to use heterogeneous data in the same transaction,
   -- use DBRef's:
   s <- atomically $ do
-        let refInt    = getDBRef $ keyResource x    :: DBRef Int
-            refString = getDBRef $ keyResource "ho" :: DBRef String
+        let refInt    = getDBRef $ key x    :: DBRef Int
+            refString = getDBRef $ key "ho" :: DBRef String
         i <- readDBRef refInt
         writeDBRef refString $ "hola, the retrieved value of x is " ++ show i
         s <- readDBRef refString
diff --git a/demos/memoization.hs b/demos/memoization.hs
new file mode 100644
index 0000000..b77b92e
--- /dev/null
+++ b/demos/memoization.hs
@@ -0,0 +1,15 @@
+import Data.TCache.Memoization
+import Data.TCache.DefaultPersistence
+import Control.Concurrent
+import System.Time
+
+
+
+main= do
+        cachedByKey "" 4 f >>= print
+        threadDelay 1000000
+        main
+
+f= do
+  TOD t _ <- getClockTime
+  return t