TCache 0.10.0.5 → 0.10.0.6

raw patch · 10 files changed

+142/−91 lines, 10 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• Data/Persistent/Collection.hs +15/−2
• Data/Persistent/IDynamic.hs +18/−13
• Data/TCache.hs +48/−6
• Data/TCache/Defs.hs +2/−2
• Data/TCache/IResource.hs +1/−2
• Data/TCache/IndexQuery.hs +2/−37
• Data/TCache/IndexText.hs +26/−14
• Data/TCache/Memoization.hs +28/−13
• TCache.cabal +1/−1
• demos/IndexQuery.hs +1/−1

@@ -16,13 +16,25 @@  Uses default persistence. See "Data.TCache.DefaultPersistence"  -}-+{-+NOTES+TODO:+data.persistent collection+ convertirlo en un tree+     añadiendo elementos node  Node (refQueue a)+ implementar un query language+    by key+    by attribute (addAttibute)+    by class+    xpath+ implementar un btree sobre el+-} module Data.Persistent.Collection ( RefQueue(..), getQRef, pop,popSTM,pick, flush, flushSTM, pickAll, pickAllSTM, push,pushSTM, pickElem, pickElemSTM,  readAll, readAllSTM,-deleteElem, deleteElemSTM,+deleteElem, deleteElemSTM,updateElem,updateElemSTM, unreadSTM,isEmpty,isEmptySTM ) where import Data.Typeable@@ -77,6 +89,7 @@ -- | A queue reference type RefQueue a= DBRef (Queue a) +-- | push an element at the top of the queue unreadSTM :: (Typeable a, Serialize a) => RefQueue a -> a -> STM () unreadSTM queue x= do     r <- readQRef queue

@@ -36,8 +36,8 @@ import Data.RefSerialize import Data.HashTable as HT -import Debug.Trace-(!>)= flip trace+--import Debug.Trace+--(!>)= flip trace  
 data IDynamic  =  IDyn  (IORef IDynType) deriving Typeable@@ -120,27 +120,32 @@ 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+          Left s -> error s
+          Right v -> v  -safeFromIDyn :: (Typeable a, Serialize a) => IDynamic -> Maybe a       
-safeFromIDyn (IDyn r)=unsafePerformIO $ do+safeFromIDyn :: (Typeable a, Serialize a) => IDynamic -> Either String a       
+safeFromIDyn (d@(IDyn r))= final where+ final= unsafePerformIO $ do   t<-  readIORef r   case t of-   DRight x ->  return $ cast x+   DRight x ->  return $ case cast x of+        Nothing -> Left $ "fromIDyn: unable to extract from "+                     ++ show d ++ " something of type: "+                     ++ (show . typeOf $ fromRight final)+        Just x  -> Right x+        where+        fromRight (Right x)= x +    DLeft (str, c) ->-    handle (\(e :: SomeException) ->  return Nothing) $  -- !> ("safeFromIDyn : "++ show e)) $+    handle (\(e :: SomeException) ->  return $ Left (show e)) $  -- !> ("safeFromIDyn : "++ show e)) $         do-          let v= runRC  c rreadp str !> unpack str+          let v= runRC  c rreadp str -- !> unpack str           writeIORef r $! DRight v -- !> ("***reified "++ unpack str)-          return $! Just v -- !>  ("*** end reified " ++ unpack str)+          return $! Right 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

@@ -229,6 +229,49 @@ ,addTrigger  -- * Cache control+{-- |++The mechanism for dropping elements from the cache is too lazy. `flushDBRef`, for example+just delete the data element  from the TVar, but the TVar node+remains attached to the table so there is no decrement on the number of elements.+The element is garbage collected unless you have a direct reference to the element, not the DBRef+Note that you can still have a valid reference to this element, but this element  is no longer+in the cache. The usual thing is that you do not have it, and the element will be garbage+collected (but still there will be a NotRead entry for this key!!!). If the DBRef is read again, the+TCache will go to permanent storage to retrieve it.++clear opertions such `clearsyncCache` does something similar:  it does not delete the+element from the cache. It just inform the garbage collector that there is no longer necessary to maintain+the element in the cache. So if the element has no other references (maybe you keep a+variable that point to that DBRef) it will be GCollected.+If this is not possible, it will remain in the cache and will be treated as such,+until the DBRef is no longer referenced by the program. This is done by means of a weak pointer++All these complications are necessary because the programmer can  handle DBRefs directly,+so the cache has no complete control of the DBRef life cycle, short to speak.++a DBRef can be in the states:++- `Exist`:  it is in the cache++- `DoesNotExist`: neither is in the cache neither in storage: it is like a cached "notfound" to+speed up repeated failed requests++- `NotRead`:  may exist or not in permanent storage, but not in the cache+++In terms of Garbage collection it may be:++++1 - pending garbage collection:  attached to the hashtable by means of a weak pointer: delete it asap++2 - cached: attached by a direct pointer and a weak pointer: It is being cached+++clearsyncCache just pass elements from 2 to 1++--} ,flushDBRef ,flushKey ,invalidateKey@@ -365,13 +408,13 @@   instance  Show (DBRef a) where-  show (DBRef  key _)=   "getDBRef \""++ key ++ "\""+  show (DBRef  key _)=   "DBRef \""++ key ++ "\""  instance  (IResource a, Typeable a) => Read (DBRef a) where     readsPrec n str1= readit str        where        str = dropWhile isSpace str1-       readit ('g':'e':'t':'D':'B':'R':'e':'f':' ':'\"':str1)=+       readit ('D':'B':'R':'e':'f':' ':'\"':str1)=          let   (key,nstr) =  break (== '\"') str1          in  [( getDBRef key :: DBRef a, tail  nstr)]        readit  _ = []@@ -530,7 +573,7 @@ flushDBRef ::  (IResource a, Typeable a) =>DBRef a -> STM() flushDBRef (DBRef _ tv)=   writeTVar  tv  NotRead --- flush the element with the given key+-- | flush the element with the given key flushKey key=  do    (cache,time) <- unsafeIOToSTM $ readIORef refcache    c <- unsafeIOToSTM $ H.lookup cache key@@ -542,7 +585,7 @@             Nothing -> unsafeIOToSTM (finalize w)  >> flushKey key        Nothing   -> return () --- label the object as not existent in database+-- | label the object as not existent in database invalidateKey key=  do    (cache,time) <- unsafeIOToSTM $ readIORef refcache    c <- unsafeIOToSTM $ H.lookup cache key@@ -758,6 +801,7 @@   -- | Start the thread that periodically call `clearSyncCache` to clean and writes on the persistent storage.+-- it is indirecly set by means of `syncWrite`, since it is more higuer level. I recommend to use the latter -- Otherwise, 'syncCache' or `clearSyncCache` or `atomicallySync` must be invoked explicitly or no persistence will exist. -- Cache writes allways save a coherent state clearSyncCacheProc ::@@ -802,8 +846,6 @@ tvSyncWrite= unsafePerformIO $ newIORef  (Synchronous, Nothing)
  -- | Specify the cache synchronization policy with permanent storage. See `SyncMode` for details
--- 
-
 syncWrite::  SyncMode -> IO()
 syncWrite mode= do
      (_,thread) <- readIORef tvSyncWrite

@@ -65,8 +65,8 @@ class Indexable a where     key:: a -> String     defPath :: a -> String       -- ^ additional extension for default file paths.-                                -- IMPORTANT:  defPath must depend on the datatype, not the value (must be constant). Default is "TCacheData/"
-    defPath =  const "TCacheData/"+                                -- IMPORTANT:  defPath must depend on the datatype, not the value (must be constant). Default is ".tcachedata/"
+    defPath =  const ".tcachedata/"  --instance IResource a => Indexable a where --   key x= keyResource x

@@ -5,8 +5,7 @@ import Data.Typeable import System.IO.Unsafe import Control.Concurrent.STM-import Control.Concurrent-import System.Directory
+import Control.Concurrent
 import Control.Exception as Exception import System.IO
 import System.IO.Error

@@ -117,7 +117,7 @@   deserialize= read . unpack  -keyIndex treg tv= "Index " ++ show treg ++ show tv+keyIndex treg tv= "index " ++ show treg ++ show tv  instance (Typeable reg, Typeable a) => Indexable (Index reg a) where    key map= keyIndex typeofreg typeofa@@ -125,42 +125,7 @@        [typeofreg, typeofa]= typeRepArgs $! typeOf map  -{--instance (IResource reg,Typeable reg, Ord a,Read reg, Read a, Show reg, Show a) => Serializable (Index reg a) where-   serialize= show-   deserialize= read -instance  (Typeable reg, Typeable a, Read reg, Show reg-           , Read a, Show a, Ord a, IResource reg)-           => IResource (Index reg a) where-  keyResource = key-  writeResource s=do-      mf <- readIORef persistIndex-      case mf of Nothing ->  defaultWriteResource s ; Just (PersistIndex _ f _) ->   f $ serialize s--  readResourceByKey s= do-      mf <- readIORef persistIndex-      case mf of Nothing ->  defaultReadResourceByKey s; Just (PersistIndex f _ _) ->   f s >>= return . fmap  deserialize--  delResource s= do-      mf <- readIORef persistIndex-      case mf of Nothing ->  defaultDelResource s; Just (PersistIndex _ _ f) ->   f$ keyResource s---data PersistIndex= PersistIndex{-       readIndexByKey   ::  (String -> IO(Maybe String))-     , writeIndex       ::  (String -> IO())-     , deleteIndex      ::  (String -> IO())}--setPersistIndex ::  PersistIndex -> IO ()-setPersistIndex p = writeIORef persistIndex $ Just p---persistIndex :: IORef (Maybe PersistIndex)-persistIndex = unsafePerformIO $ newIORef Nothing---}- getIndex :: (Queriable reg a)    => ( reg -> a) -> a -> STM(DBRef (Index reg a), Index reg a,[DBRef reg]) getIndex selector val= do@@ -177,7 +142,7 @@    let index = case mindex of Just (Index index) ->  index; _ -> M.empty     let dbrefs= case M.lookup  val index of-        Just  dbrefs ->  dbrefs+        Just  dbrefs -> dbrefs         Nothing      -> []     return (rindex, Index index, dbrefs)

@@ -54,7 +54,7 @@  -} -module Data.TCache.IndexText(indexText, indexList,  contains, containsElem) where+module Data.TCache.IndexText(indexText, indexList,  contains, containsElem, allElemsOf) where import Data.TCache import Data.TCache.IndexQuery import Data.TCache.Defs@@ -70,9 +70,9 @@ import Data.Char import Control.Concurrent(threadDelay) import Data.ByteString.Lazy.Char8(pack, unpack)--import Debug.Trace-(!>)= flip trace+import Control.Monad+--import Debug.Trace+--(!>)= flip trace  data IndexText=  IndexText         { fieldType :: !String@@ -95,7 +95,7 @@   deserialize= read . unpack  instance  Indexable IndexText  where-   key (IndexText v _ _ _ _)=    "IndexText " ++ v+   key (IndexText v _ _ _ _)=    "indextext " ++ v  instance IResource IndexText where   keyResource = key@@ -141,7 +141,7 @@      => (a -> b)      -- ^ field to index      -> (b -> T.Text) -- ^ method to convert the field content to lazy Text (for example `pack` in case of String fields). This permits to index non Textual fields      -> IO ()-indexText sel convert= addTrigger (indext sel  (words1 . convert)) where+indexText sel convert= addTrigger (indext sel  (words1 . convert))  -- | trigger the indexation of list fields with elements convertible to Text indexList@@ -149,7 +149,7 @@      => (a -> b)      -- ^ field to index      -> (b -> [T.Text]) -- ^ method to convert a field element to Text (for example `pack . show` in case of elemets with Show instances)      -> IO ()-indexList sel convert= addTrigger (indext sel  convert) where+indexList sel convert= addTrigger (indext sel  convert)   indext :: (IResource a, Typeable a,Typeable b)@@ -173,8 +173,8 @@             let wrds'= convert $ sel reg             let new=  wrds' \\ wrds             let old= wrds \\ wrds'-            del refIndex t key old-            add refIndex t key new+            when(not $ null old) $ del refIndex t key old+            when(not $ null new) $ add refIndex t key new             return()    where    [t1,t2]=  typeRepArgs $! typeOf sel@@ -200,9 +200,21 @@             let wordsr = catMaybes $ map (\n -> M.lookup n mmapIntString) $ catMaybes mns             return $ map getDBRef wordsr -words1= filter ( (<) 2 . T.length) . T.split (\c -> isSeparator c || c=='\n' || isPunctuation c )+allElemsOf :: (IResource a, Typeable a, Typeable b) => (a -> b) -> STM [T.Text]+allElemsOf  sel  = do+    let [t1, t2]=  typeRepArgs $! typeOf sel+    let t=  show t1 ++ show t2+    let u= undefined+    mr <- withSTMResources [IndexText t u u u u]+       $ \[r] -> resources{toReturn= r}+    case mr of+      Nothing -> return []+      Just (IndexText t n _ _ map) -> return $ M.keys map --- | return the DBRefs whose fields include all the words of length three or more in the requested text contents+words1= filter filterWordt {-( (<) 2 . T.length)-} . T.split (\c -> isSeparator c || c=='\n' || isPunctuation c )++-- | return the DBRefs whose fields include all the words in the requested text contents.Except the+-- words  with less than three characters that are not digits or uppercase, that are filtered out before making the query contains   :: (IResource a, Typeable a, Typeable b)   =>( a -> b)      -- ^ field to search in@@ -212,8 +224,8 @@      [] -> return []      [w] -> containsElem sel w      ws  -> do-        let rs = map (containsElem sel) $ filter (\t -> length t >2) ws+        let rs = map (containsElem sel) $ filter filterWord ws         foldl (.&&.) (head rs)  (tail rs) --+filterWordt w= T.length w >2 || or (map (\c -> isUpper c || isDigit c) (T.unpack w))+filterWord w= length w >2 || or (map (\c -> isUpper c || isDigit c) w)

@@ -15,7 +15,7 @@             , ExistentialQuantification             , FlexibleInstances             , TypeSynonymInstances  #-}-module Data.TCache.Memoization (cachedByKey,flushCached,cachedp,addrStr,Executable(..))+module Data.TCache.Memoization (writeCached,cachedByKey,flushCached,cachedp,addrStr,Executable(..))  where import Data.Typeable@@ -28,8 +28,8 @@ import Control.Monad.Trans import Control.Monad.Identity import Data.RefSerialize(addrHash,newContext)-import Debug.Trace-(!>)= flip trace+--import Debug.Trace+--(!>)= flip trace  data Cached a b= forall m.Executable m => Cached a (a -> m b) b Integer deriving Typeable @@ -55,30 +55,46 @@   execute (Identity x)= x  instance MonadIO Identity where-  liftIO f=  Identity $! unsafePerformIO $! f+  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  -- ++ unsafePerformIO (addrStr f )  --`debug` ("k="++ show k)+instance  (Indexable a) => IResource (Cached a  b) where+  keyResource ch@(Cached a  _ _ _)= cachedKeyPrefix ++ key a   -- ++ unsafePerformIO (addrStr f )    writeResource _= return ()   delResource _= return ()-  readResourceByKey=   error "access By Indexable is undefined for cached objects"+  readResourceByKey k=   error $ "access By key is undefined for cached objects.key= " ++ k     readResource (Cached a f _ _)=do    TOD tnow _ <- getClockTime    let b = execute $ f a-   return . Just $ Cached a f b tnow-+   return . Just $ Cached a f b 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-cached ::  (Indexable a, Typeable a, Typeable b, Executable m,MonadIO m) => Int -> (a -> m b) -> a  -> m b++--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  a b c d=+    withSTMResources [] . const $ resources{toAdd= [Cached 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    let prot= Cached a f undefined undefined    cho@(Cached _ _ b t)  <- liftIO $ getResource prot `onNothing` fillIt prot@@ -94,11 +110,10 @@    where    -- has been invalidated by flushCached    fillIt proto= do-   r <- return . fromJust =<< readResource proto+   r <- return . fromJust =<< (readResource proto)   -- !> "fillIt"    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@@ -108,7 +123,7 @@  -- Flush the cached object indexed by the key flushCached :: String -> IO ()-flushCached k= atomically $ invalidateKey $ cachedKeyPrefix ++ k+flushCached k= atomically $ invalidateKey $ cachedKeyPrefix ++ k           -- !> "flushCached"  -- | a pure version of cached cachedp :: (Indexable a,Typeable a,Typeable b) => (a ->b) -> a -> b

@@ -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

@@ -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