packages feed

TCache 0.10.0.4 → 0.10.0.5

raw patch · 8 files changed

+293/−55 lines, 8 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

- Data.TCache.Memoization: instance [overlap ok] Indexable String
+ Data.Persistent.IDynamic: (!>) :: c -> String -> c
+ Data.Persistent.IDynamic: DLeft :: !(ByteString, (Context, ByteString)) -> IDynType
+ Data.Persistent.IDynamic: DRight :: !a -> IDynType
+ Data.Persistent.IDynamic: IDyn :: (IORef IDynType) -> IDynamic
+ Data.Persistent.IDynamic: Save :: ByteString -> Save
+ Data.Persistent.IDynamic: data IDynType
+ Data.Persistent.IDynamic: data IDynamic
+ Data.Persistent.IDynamic: dynPrefix :: [Char]
+ Data.Persistent.IDynamic: dynPrefixSp :: ByteString
+ Data.Persistent.IDynamic: errorfied :: [Char] -> [Char] -> t
+ Data.Persistent.IDynamic: fromIDyn :: (Typeable a, Serialize a) => IDynamic -> a
+ Data.Persistent.IDynamic: instance [incoherent] Serialize IDynamic
+ Data.Persistent.IDynamic: instance [incoherent] Serialize Save
+ Data.Persistent.IDynamic: instance [incoherent] Show IDynamic
+ Data.Persistent.IDynamic: instance [incoherent] Typeable IDynType
+ Data.Persistent.IDynamic: instance [incoherent] Typeable IDynamic
+ Data.Persistent.IDynamic: instance [incoherent] Typeable Save
+ Data.Persistent.IDynamic: newtype Save
+ Data.Persistent.IDynamic: notreified :: ByteString
+ Data.Persistent.IDynamic: reifyM :: (Typeable a, Serialize a) => IDynamic -> a -> IO a
+ Data.Persistent.IDynamic: safeFromIDyn :: (Typeable a, Serialize a) => IDynamic -> Maybe a
+ Data.Persistent.IDynamic: toIDyn :: (Typeable a, Serialize a) => a -> IDynamic
+ Data.Persistent.IDynamic: tosave :: IDynamic -> IDynamic
+ Data.TCache: flushKey :: String -> STM ()
+ Data.TCache: invalidateKey :: String -> STM ()
+ Data.TCache.Defs: instance [overlap ok] Indexable ()
+ Data.TCache.Defs: instance [overlap ok] Indexable Int
+ Data.TCache.Defs: instance [overlap ok] Indexable Integer
+ Data.TCache.Defs: instance [overlap ok] Indexable String
+ Data.TCache.Memoization: flushCached :: String -> IO ()

Files

+ Data/Persistent/IDynamic.hs view
@@ -0,0 +1,148 @@+    {-# OPTIONS -XExistentialQuantification+            -XOverlappingInstances+            -XUndecidableInstances+            -XScopedTypeVariables+            -XDeriveDataTypeable+            -XTypeSynonymInstances+            -XIncoherentInstances+            -XOverloadedStrings+            -XMultiParamTypeClasses+            -XFunctionalDependencies+            -XFlexibleInstances #-}+{- |+IDynamic is a indexable and serializable version of Dynamic. (See @Data.Dynamic@). It is used as containers of objects+in the cache so any new datatype can be incrementally stored without recompilation.+IDimamic provices methods for safe casting,  besides serializaton, deserialirezation and retrieval by key.+-}
+module Data.Persistent.IDynamic where
+import Data.Typeable
+import Unsafe.Coerce
+import System.IO.Unsafe+import Data.TCache
+import Data.TCache.Defs+import Data.RefSerialize+import Data.Char (showLitChar)++import Data.ByteString.Lazy.Char8 as B+
+import Data.Word+import Numeric (showHex, readHex)+import Control.Exception(handle, SomeException, ErrorCall)+import Control.Monad(replicateM)+import Data.Word+import Control.Concurrent.MVar+import Data.IORef+import Data.Map as M(empty)+import Data.RefSerialize+import Data.HashTable as HT++import Debug.Trace+(!>)= flip trace++
+data IDynamic  =  IDyn  (IORef IDynType) deriving Typeable++data IDynType= forall a w r.(Typeable a, Serialize a)+               => DRight  !a+               |  DLeft  !(ByteString ,(Context, ByteString))+++               deriving Typeable++newtype Save= Save ByteString deriving Typeable+
+tosave d@(IDyn r)= unsafePerformIO $ do+   mr<- readIORef r+   case mr of+     DRight _ ->  return d+     DLeft (s,_) -> writeIORef r (DRight $ Save s) >> return d+++instance Serialize Save  where+  showp (Save s)= insertString s+  readp = error "readp not impremented for Save"++
+errorfied str str2= error $ str ++ ": IDynamic object not reified: "++ str2++
++dynPrefix= "Dyn"+dynPrefixSp= append  (pack dynPrefix) " "+notreified = pack $ dynPrefix ++" 0"++++instance Serialize IDynamic where++   showp (IDyn t)=+    case unsafePerformIO $ readIORef t of+     DRight x -> do+--          insertString $ pack dynPrefix+          c <- getWContext+          showpx  <-  rshowps x+--          showpText . fromIntegral $ B.length showpx+          showp $ unpack showpx++     DLeft (showpx,_) ->   --  error $ "IDynamic not reified :: "++  unpack showpx+--        insertString   notreified+          insertString  $ encode showpx+            where+            encode =   pack . show . unpack++   readp = lexeme (do+--      symbol dynPrefix+--      n <- readpText+--      s <- takep n++      s <- rreadp :: STR  String++      c <- getRContext+      return . IDyn . unsafePerformIO . newIORef $ DLeft ( pack s, c))+      <?> "IDynamic"+++
+instance Show  IDynamic where
+ show (IDyn r) =+    let t= unsafePerformIO $ readIORef r+    in case t of+      DRight x -> "IDyn " ++  ( unpack . runW $ showp  x)
+      DLeft (s, _) ->  "IDyns \"" ++ unpack s ++ "\""+++++
+toIDyn x= IDyn . unsafePerformIO . newIORef $ DRight x+
+ 
+fromIDyn :: (Typeable a , Serialize a)=> IDynamic -> a+fromIDyn x=r where+  r = case safeFromIDyn x of+          Nothing -> error $ "fromIDyn: casting failure for data "+                     ++ show x ++ " to type: "+                     ++ (show $ typeOf r)
+          Just v -> v+++safeFromIDyn :: (Typeable a, Serialize a) => IDynamic -> Maybe a       
+safeFromIDyn (IDyn r)=unsafePerformIO $ do+  t<-  readIORef r+  case t of+   DRight x ->  return $ cast x++   DLeft (str, c) ->+    handle (\(e :: SomeException) ->  return Nothing) $  -- !> ("safeFromIDyn : "++ show e)) $+        do+          let v= runRC  c rreadp str !> unpack str+          writeIORef r $! DRight v -- !> ("***reified "++ unpack str)+          return $! Just v -- !>  ("*** end reified " ++ unpack str)+++--main= print (safeFromIDyn $ IDyn $ unsafePerformIO $ newIORef $ DLeft $ (pack "1", (unsafePerformIO $ HT.new (==) HT.hashInt, pack "")) :: Maybe Int)++reifyM :: (Typeable a,Serialize a) => IDynamic -> a -> IO a+reifyM dyn v = do+   let v'= fromIDyn dyn+   return $ v' `seq` v'
Data/TCache.hs view
@@ -230,6 +230,8 @@  -- * Cache control ,flushDBRef+,flushKey+,invalidateKey ,flushAll ,Cache ,setCache@@ -260,7 +262,7 @@ import Data.TCache.Defs import Data.TCache.IResource import Data.TCache.Triggers-import Control.Exception(handle,assert, bracket, SomeException)+import Control.Exception import Data.Typeable import System.Time import System.Mem@@ -269,8 +271,8 @@ import Control.Concurrent.MVar import Control.Exception(catch, throw,evaluate) -import Debug.Trace-(!>) = flip trace+--import Debug.Trace+--(!>) = flip trace  -- there are two references to the DBRef here -- The Maybe one keeps it alive until the cache releases it for *Resources@@ -528,7 +530,31 @@ flushDBRef ::  (IResource a, Typeable a) =>DBRef a -> STM() flushDBRef (DBRef _ tv)=   writeTVar  tv  NotRead +-- flush the element with the given key+flushKey key=  do+   (cache,time) <- unsafeIOToSTM $ readIORef refcache+   c <- unsafeIOToSTM $ H.lookup cache key+   case c of+       Just  (CacheElem _ w) -> do+          mr <- unsafeIOToSTM $ deRefWeak w+          case mr of+            Just (DBRef k tv) -> writeTVar  tv  NotRead+            Nothing -> unsafeIOToSTM (finalize w)  >> flushKey key+       Nothing   -> return () +-- label the object as not existent in database+invalidateKey key=  do+   (cache,time) <- unsafeIOToSTM $ readIORef refcache+   c <- unsafeIOToSTM $ H.lookup cache key+   case c of+       Just  (CacheElem _ w) -> do+          mr <- unsafeIOToSTM $ deRefWeak w+          case mr of+            Just (DBRef k tv) -> writeTVar  tv  DoNotExist+            Nothing -> unsafeIOToSTM (finalize w)  >> flushKey key+       Nothing   -> return ()++ -- | drops the entire cache. flushAll :: STM () flushAll = do@@ -539,7 +565,7 @@  del cache ( _ , CacheElem _ w)= do       mr <- unsafeIOToSTM $ deRefWeak w       case mr of-        Just (DBRef _  tv) ->  writeTVar tv DoNotExist+        Just (DBRef _  tv) ->  writeTVar tv NotRead         Nothing -> unsafeIOToSTM (finalize w)  @@ -585,6 +611,7 @@ -- | Update of a single object in the cache -- -- @withResource r f= 'withResources' [r] (\[mr]-> [f mr])@+{-# INLINE withResource #-} withResource:: (IResource  a, Typeable a)   => a  -> (Maybe a-> a)  -> IO () withResource r f= withResources [r] (\[mr]-> [f mr]) @@ -592,6 +619,7 @@ -- |  To atomically add/modify many objects in the cache -- -- @ withResources rs f=  atomically $ 'withSTMResources' rs f1 >> return() where   f1 mrs= let as= f mrs in  Resources  as [] ()@+{-# INLINE withResources #-} withResources:: (IResource a,Typeable a)=> [a]-> ([Maybe a]-> [a])-> IO () withResources rs f=  atomically $ withSTMResources rs f1 >> return() where      f1 mrs= let as= f mrs in  Resources  as [] ()@@ -599,12 +627,14 @@ -- | To read a resource from the cache. -- -- @getResource r= do{mr<- 'getResources' [r];return $! head mr}@+{-# INLINE getResource #-} getResource:: (IResource a, Typeable a)=>a-> IO (Maybe a) getResource r= do{mr<- getResources [r];return $! head mr}  -- | To read a list of resources from the cache if they exist -- --  | @getResources rs= atomically $ 'withSTMResources' rs f1 where  f1 mrs= Resources  [] [] mrs@+{-# INLINE getResources #-} getResources:: (IResource a, Typeable a)=>[a]-> IO [Maybe a] getResources rs= atomically $ withSTMResources rs f1 where   f1 mrs= Resources  [] [] mrs@@ -613,17 +643,19 @@ -- | Delete the   resource from cache and from persistent storage. -- -- @ deleteResource r= 'deleteResources' [r] @+{-# INLINE deleteResource #-} deleteResource :: (IResource a, Typeable a) => a -> IO () deleteResource r= deleteResources [r]  -- | Delete the list of resources from cache and from persistent storage. -- -- @  deleteResources rs= atomically $ 'withSTMResources' rs f1 where  f1 mrs = Resources  [] (catMaybes mrs) ()@+{-# INLINE deleteResources #-} deleteResources :: (IResource a, Typeable a) => [a] -> IO () deleteResources rs= atomically $ withSTMResources rs f1 where    f1 mrs = resources {toDelete=catMaybes mrs} -+{-# INLINE takeDBRefs #-} takeDBRefs :: (IResource a, Typeable a) => [a] -> Ht  -> CheckTPVarFlags -> STM [Maybe (DBRef a)] takeDBRefs rs cache addToHash=  mapM (takeDBRef cache addToHash)  rs @@ -631,7 +663,6 @@ {-# NOINLINE takeDBRef #-} takeDBRef :: (IResource a, Typeable a) =>  Ht  -> CheckTPVarFlags -> a -> STM(Maybe (DBRef a)) takeDBRef cache flags x =do-    let  keyr= keyResource x    c <- unsafeIOToSTM $ H.lookup cache keyr    case c of@@ -667,8 +698,8 @@   -	 + releaseTPVars :: (IResource a,Typeable a)=> [a] -> Ht  -> STM () releaseTPVars rs cache = mapM_  (releaseTPVar cache)  rs @@ -903,16 +934,17 @@  -- | Assures that the IO computation finalizes no matter if the STM transaction -- is aborted or retried. The IO computation run in a different thread.--- The STM transaction wait until the completion of the IO procedure (or retry as usual)--- it can be retried if the embedding STM computation is retried+-- The STM transaction wait until the completion of the IO procedure (or retry as usual).+--+-- It can be retried if the embedding STM computation is retried -- so the IO computation must be idempotent. -- Exceptions are bubbled up to the STM transaction safeIOToSTM :: IO a -> STM a safeIOToSTM req= unsafeIOToSTM  $ do   tv   <- newEmptyMVar-  forkIO $ (req >>= putMVar  tv . Right)+  forkIO $ (req  >>= putMVar  tv . Right)           `Control.Exception.catch`-          (\(e :: SomeException) -> putMVar tv (Left e))+          (\(e :: SomeException) -> putMVar tv $ Left e )   r <- takeMVar tv   case r of    Right x -> return x
Data/TCache/Defs.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE   ScopedTypeVariables, DeriveDataTypeable #-}+{-# LANGUAGE   TypeSynonymInstances, FlexibleInstances, ScopedTypeVariables, DeriveDataTypeable #-}  {- | some internal definitions. To use default persistence, use 'Data.TCache.DefaultPersistence' instead -}@@ -42,7 +42,7 @@ castErr a= r where   r= case cast a of       Nothing -> error $ "Type error: " ++ (show $ typeOf a) ++ " does not match "++ (show $ typeOf r)-                          ++ "\nThis means that objects of these two types have the same key \nor the retrieved object type is not the stored one for the same key\n"+                          ++ "\nThis means that objects of these two types have the same key \nor the retrieved object type is not the previously stored one for the same key\n"       Just x  -> x  @@ -71,6 +71,21 @@ --instance IResource a => Indexable a where --   key x= keyResource x ++instance Indexable String where+  key= id++instance Indexable Int where+  key= show++instance Indexable Integer where+  key= show+++instance Indexable () where+  key _= "void"++ {- | Serialize is an alternative to the IResource class for defining persistence in TCache. The deserialization must be as lazy as possible. serialization/deserialization are not performance critical in TCache@@ -166,19 +181,20 @@            hPutStrLn stderr $ "defaultDelResource:  " ++ show e ++  " in file: " ++ filename ++ " retrying"
 --           threadDelay 100000     --`debug` ("otherwise " ++ show e)            defaultDelete filename+ 
  defReadResourceByKey k= iox where     iox= do       let Persist f _ _ = setPersist  x-      f  file >>= return . fmap  deserialize . castErr+      f  file >>=  evaluate . fmap  deserialize       where       file= defPath x ++ k       x= undefined `asTypeOf` (fromJust $ unsafePerformIO iox)  defWriteResource s= do       let Persist _ f _ = setPersist  s-      f (defPath s ++ key s) $ castErr $ serialize s+      f (defPath s ++ key s) $ serialize s  defDelResource s= do       let Persist _ _ f = setPersist s
Data/TCache/IndexQuery.hs view
@@ -41,7 +41,7 @@    atomically $  mapM_ 'newDBRef' [Car bruce \"Bat Mobile\", Car bruce \"Porsche\"]    r \<- atomically $ cname '.==.' \"Porsche\"    print r-   r \<- atomically $ 'select' (cname, owner) $  (owner '.==.' bruce) '.&&.' (cname '.>=.' \"Bat Mobile\")+   r \<- atomically $ 'select' (cname, owner) $  owner '.==.' bruce '.&&.' cname '.>=.' \"Bat Mobile\"    print r @ @@ -241,10 +241,10 @@        return dbrefs      (.>.)  field value= retrieve field value (>)-    (.>=.) field value= retrieve field value (>=)     (.<.)  field value= retrieve field value (<)     (.<=.)  field value= retrieve field value (<=) +    (.>=.) field value= retrieve field value (>=)  join:: (Queriable rec v, Queriable rec' v)        =>(v->v-> Bool) -> (rec -> v) -> (rec' -> v) -> STM[([DBRef rec], [DBRef rec'])]@@ -270,6 +270,8 @@     (.<=.)= join (<=)     (.<.) = join (<) +infixr 5 .==., .>., .>=., .<=., .<.+ class SetOperations set set'  setResult | set set' -> setResult where   (.||.) :: STM set -> STM set' -> STM setResult   (.&&.) :: STM set -> STM set' -> STM setResult@@ -286,6 +288,8 @@      ys <- fys      return $ union xs ys +infixr 4 .&&.+infixr 3 .||.  instance SetOperations  (JoinData a a') [DBRef a] (JoinData a a') where     (.&&.) fxs fys= do
Data/TCache/IndexText.hs view
@@ -11,11 +11,13 @@ so that it is possible to ask for the registers that contains a given element in the given field (with `containsElem`) -An example of full text search i before and after an update in the text field+An example of full text search and element search in a list in combination+using the `.&&.` operator defined in "indexQuery".+before and after the update of the register   @-data Doc= Doc{title, body :: String} deriving (Read,Show, Typeable)+data Doc= Doc{title :: String , authors :: [String], body :: String} deriving (Read,Show, Typeable) instance Indexable Doc where   key Doc{title=t}= t @@ -25,17 +27,31 @@  main= do   'indexText'  body T.pack-  let doc= Doc{title=  "title", body=  \"hola que tal estamos\"}+  'indexList' authors  (map T.pack)++  let doc= Doc{title=  \"title\", authors=[\"john\",\"Lewis\"], body=  \"Hi, how are you\"}   rdoc <- atomically $ newDBRef doc-  r1 <- atomically $ select title $ body \`'contains'\` \"hola que tal\"++  r0 <- atomically $ `select` title $ authors \``containsElem`\` \"Lewis\"+  print r0++  r1 <- atomically $ `select` title $ body \``contains`\` \"how are you\"   print r1 -  atomically $ 'writeDBRef' rdoc  doc{ body=  "que tal"}-  r <- atomically $ 'select' title $ body  \`'contains'\` \"hola que tal\"-  print r-  if  r1 == [title doc] then print \"OK\" else print \"FAIL\"-  if  r== [] then print \"OK\" else print \"FAIL\"+  r2 <- atomically $ `select` body $ body \``contains`\` \"how are you\" .&&. authors `containsElem` "john"+  print r2++  atomically $ writeDBRef rdoc  doc{ body=  \"what's up\"}++  r3 <- atomically $ 'select' title $ body  \`'contains'\` \"how are you\"+  print r3++  if  r0== r1 && r1== [title doc] then print \"OK\" else print \"FAIL\"+  if  r3== [] then print \"OK\" else print \"FAIL\" @+++ -}  module Data.TCache.IndexText(indexText, indexList,  contains, containsElem) where@@ -45,7 +61,7 @@ import qualified Data.Text.Lazy as T import Data.Typeable import qualified Data.Map as M-import Data.Maybe (catMaybes)+import Data.Maybe import Data.Bits import System.Mem.StableName import Data.List((\\))@@ -54,8 +70,10 @@ import Data.Char import Control.Concurrent(threadDelay) import Data.ByteString.Lazy.Char8(pack, unpack)---import Debug.Trace +import Debug.Trace+(!>)= flip trace+ data IndexText=  IndexText         { fieldType :: !String         , lastDoc :: Int@@ -94,23 +112,28 @@ add ref t key w = op ref t setBit w key del ref t key w = op ref t clearBit w key -op refIndex t set w key =  do- if T.length w <3-  then return ()-  else do+op refIndex t set ws key =  do    mindex <- readDBRef refIndex+   let mindex'= process mindex  ws+   writeDBRef refIndex $ fromJust mindex'++ where+ process mindex []= mindex+ process mindex (w:ws)=    case mindex of-       Nothing -> writeDBRef refIndex $ IndexText t 0 (M.singleton key 0) (M.singleton  0 key) (M.singleton w 1)+       Nothing ->  process (Just $ IndexText t 0 (M.singleton key 0) (M.singleton  0 key) (M.singleton w 1)) ws        Just (IndexText t n mapSI mapIS map) -> do-        let (docLocation,n', mapSI')= case M.lookup key mapSI  of-               Nothing  -> let n'= n+1 in (n', n', M.insert key n' mapSI)  -- new Document-               Just m -> (m,n, mapSI)         -- already indexed document+        let (docLocation,n', mapSI',mapIS')= case M.lookup key mapSI  of+               Nothing  -> let n'= n+1 in (n', n'+                                          , M.insert key n' mapSI+                                          , M.insert n' key mapIS)  -- new Document+               Just m -> (m,n, mapSI,mapIS)         -- already indexed document          case M.lookup w map of          Nothing ->    --new word-            writeDBRef refIndex $ IndexText t  n mapSI mapIS (M.insert w (set 0 docLocation) map)+            process (Just $ IndexText t  n' mapSI' mapIS' (M.insert w (set 0 docLocation) map)) ws          Just integer ->  -- word already indexed-               writeDBRef refIndex $ IndexText t n mapSI mapIS $ M.insert w (set integer docLocation) map+            process (Just $ IndexText t n' mapSI' mapIS' $ M.insert w (set integer docLocation) map) ws  -- | start a trigger to index the contents of a register field indexText@@ -137,8 +160,8 @@   f1=  do    moldreg <- readDBRef dbref    case ( moldreg,  mreg) of-      (Nothing, Just reg)    -> mapM_ (add refIndex t (keyResource reg))    .  convert $ sel reg-      (Just oldreg, Nothing) -> mapM_ (del refIndex t (keyResource oldreg)) .  convert $ sel oldreg+      (Nothing, Just reg)    -> add refIndex t (keyResource reg)    .  convert $ sel reg+      (Just oldreg, Nothing) -> del refIndex t (keyResource oldreg) . convert $ sel oldreg       (Just oldreg, Just reg) -> do         st  <- unsafeIOToSTM $ makeStableName $ sel oldreg -- test if field         st' <- unsafeIOToSTM $ makeStableName $ sel reg    -- has changed@@ -150,8 +173,8 @@             let wrds'= convert $ sel reg             let new=  wrds' \\ wrds             let old= wrds \\ wrds'-            mapM (del refIndex t key) old-            mapM (add refIndex t key) new+            del refIndex t key old+            add refIndex t key new             return()    where    [t1,t2]=  typeRepArgs $! typeOf sel@@ -177,7 +200,7 @@             let wordsr = catMaybes $ map (\n -> M.lookup n mmapIntString) $ catMaybes mns             return $ map getDBRef wordsr -words1= T.split (\c -> isSeparator c || c=='\n' || isPunctuation c )+words1= filter ( (<) 2 . T.length) . T.split (\c -> isSeparator c || c=='\n' || isPunctuation c )  -- | return the DBRefs whose fields include all the words of length three or more in the requested text contents contains
Data/TCache/Memoization.hs view
@@ -15,7 +15,7 @@             , ExistentialQuantification             , FlexibleInstances             , TypeSynonymInstances  #-}-module Data.TCache.Memoization (cachedByKey,cachedp,addrStr,Executable(..))+module Data.TCache.Memoization (cachedByKey,flushCached,cachedp,addrStr,Executable(..))  where import Data.Typeable@@ -55,40 +55,50 @@   execute (Identity x)= x  instance MonadIO Identity where-  liftIO= Identity . unsafePerformIO+  liftIO f=  Identity $! unsafePerformIO $! f +cachedKeyPrefix = "cached"+ instance  (Indexable a, Typeable a) => IResource (Cached a  b) where-  keyResource ch@(Cached a  f _ _)= "cached"++key a -- ++ unsafePerformIO (addrStr f )  --`debug` ("k="++ show k)+  keyResource ch@(Cached a  f _ _)= cachedKeyPrefix ++ key a  -- ++ unsafePerformIO (addrStr f )  --`debug` ("k="++ show k)    writeResource _= return ()   delResource _= return ()-  readResourceByKey= error "access By Indexable is undefined for chached objects"+  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 -instance Indexable String where-   key= id + -- | 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 cached ::  (Indexable a, Typeable a, Typeable b, Executable m,MonadIO m) => Int -> (a -> m b) -> a  -> m b cached time  f a=  do-   cho@(Cached _ _ b t)  <- liftIO $ getResource ( (Cached a f undefined undefined )) >>= return . fromJust+   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 time /=0 && tnow - t > fromIntegral time+           if tnow - t > fromIntegral time                       then do                           liftIO $ deleteResource cho                           cached time f a                       else  return b+   where+   -- has been invalidated by flushCached+   fillIt proto= do+   r <- return . fromJust =<< readResource proto+   withResources [] $ const [r]+   return 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@@ -96,6 +106,9 @@ cachedByKey :: (Typeable a, Executable m,MonadIO m) => String -> Int ->  m a -> m a cachedByKey key time  f = cached  time (\_ -> f) key +-- Flush the cached object indexed by the key+flushCached :: String -> IO ()+flushCached k= atomically $ invalidateKey $ cachedKeyPrefix ++ k  -- | a pure version of cached cachedp :: (Indexable a,Typeable a,Typeable b) => (a ->b) -> a -> b
TCache.cabal view
@@ -1,5 +1,5 @@ name: TCache-version: 0.10.0.4+version: 0.10.0.5 cabal-version: >= 1.6 build-type: Simple license: BSD3@@ -7,8 +7,7 @@ maintainer: agocorona@gmail.com synopsis: A Transactional cache with user-defined persistence description: TCache is a transactional cache with configurable persitence. It allows conventional-             STM transactions for objects that syncronize  with-             their user defined storages.+             STM transactions for objects that syncronize  with their user-defined storages.              State in memory and into permanent storage is transactionally coherent.              .              The package implements serializable STM references, access by key and by record field value, triggers,@@ -18,7 +17,9 @@              .              See "Data.TCache" for details +             This release fixes some bugs in the module IndexText + category: Data, Database author: Alberto Gómez Corona tested-with: GHC ==7.0.3@@ -42,6 +43,7 @@                      Data.TCache.Defs Data.TCache.IResource Data.TCache.IndexQuery                      Data.TCache.IndexText Data.TCache.Memoization Data.TCache.Triggers                      Data.Persistent.Collection+                     Data.Persistent.IDynamic     exposed: True     buildable: True     extensions: OverlappingInstances UndecidableInstances
demos/IndexQuery.hs view
@@ -32,7 +32,7 @@    r <- atomically $ cname .>=. "Bat Mobile"    print r -   r <- atomically $ select (cname, owner) $  (owner .==. bruce)  .&&. (cname .==. "Bat Mobile")+   r <- atomically $ select (cname, owner) $  owner .==. bruce  .&&. cname .==. "Bat Mobile"    print r