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 +148/−0
- Data/TCache.hs +43/−11
- Data/TCache/Defs.hs +20/−4
- Data/TCache/IndexQuery.hs +6/−2
- Data/TCache/IndexText.hs +49/−26
- Data/TCache/Memoization.hs +21/−8
- TCache.cabal +5/−3
- demos/IndexQuery.hs +1/−1
+ 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