TCache 0.12.1 → 0.13.3

raw patch · 27 files changed

+2511/−2296 lines, 27 filesdep +TCachedep ~RefSerializedep ~basesetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies added: TCache

Dependency ranges changed: RefSerialize, base

API changes (from Hackage documentation)

Files

• ChangeLog.md +12/−0
• Data/Persistent/Collection.hs +240/−250
• Data/Persistent/IDynamic.hs +150/−157
• Data/TCache.hs +1061/−1040
• Data/TCache/DefaultPersistence.hs +5/−12
• Data/TCache/Defs.hs +80/−65
• Data/TCache/IResource.hs +36/−182
• Data/TCache/IndexQuery.hs +54/−53
• Data/TCache/IndexText.hs +113/−99
• Data/TCache/Memoization.hs +155/−151
• Data/TCache/Triggers.hs +20/−21
• README.md +25/−0
• Setup.lhs +5/−5
• TCache.cabal +86/−85
• demos/DBRef.hs +62/−42
• demos/DynamicSample.hs +73/−0
• demos/IndexQuery.hs +0/−39
• demos/IndexText.hs +0/−30
• demos/basicSample.hs +48/−38
• demos/caching.hs +71/−18
• demos/indexQuery.hs +44/−0
• demos/indexText.hs +31/−0
• demos/memoization.hs +12/−9
• demos/pr.hs +23/−0
• demos/pushpop.hs +58/−0
• demos/testnewdbref.hs +34/−0
• demos/weakTest.hs +13/−0

@@ -0,0 +1,12 @@+* 0.13.x : (WIP) Major refaktoring and cleanups may break older code+* 0.12.1.0 : Dropped Data.Hashtable (deprecated). Now it uses the package hashtables+* 0.12.0.0 : space in index data in indexQuery.hs and IndexText.hs triggered errors in the AWS backend.  The space has been changed by \'-\'. So rename the "index *" files in the TCache folder in order to be recognized.  +* 0.11.0.0 : added setIndexParsist to define persistence for indexes by type. started the addition of readDBRefs, readResources and so on for simultaneous read, writes and deletes of objects of the same type.+* 0.10.2.0 : Added setDefaultPersist and modified the signature of setPersist in Data.TCache.DefaultPersistence. Fixed issues with ghc 7.6.3+* 0.10.0.0 : version add memoization and a persistent and transactional collection/queue.+* 0.10.0.8 : subversion add cachedByKeySTM+* 0.10.0.9 : fixed an error in clearSyncCacheProc and SynWrite Asynchronous that checked the cache continuously+* 0.9.0.4 : Solves a bug in the management of weak pointers that evaporated registers from the cache+* 0.9.0.3 : Solves a lost registers bug.+* 0.9.0.1 : Solves a bug when object keys generate invalid filenames, and includes changes in defaultPersistence to further separate serialization from input-output.+* 0.9.0.0 : Adds full-text indexing and search, which is incorporated into the experimental query language. It also changes the default Persistence mechanism. Now `ByteString`s are used for serialization and deserialization. A `Serializable` class and a `Persist` structure decouples serialization from `ByteString` and read/write to files. Both can be redefined separately, so the default persistence could be changed with `setPersist` to write to blobs in a databases, for example. Default persistence now no longer has to be in files.

@@ -1,250 +1,240 @@-{-# OPTIONS  -XDeriveDataTypeable
-             -XTypeSynonymInstances
-             -XMultiParamTypeClasses
-             -XExistentialQuantification
-             -XOverloadedStrings
-             -XFlexibleInstances
-             -XUndecidableInstances
-             -XFunctionalDependencies
-
-           #-}
-
-{- |
-A persistent, transactional collection with Queue interface as well as
- indexed access by key.
-
- 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,updateElem,updateElemSTM,
-unreadSTM,isEmpty,isEmptySTM
-) where
-import Data.Typeable
-import Control.Concurrent.STM(STM,atomically, retry)
-import Control.Monad
-import Data.TCache.DefaultPersistence
-
-import Data.TCache
-import System.IO.Unsafe
-import Data.RefSerialize
-import Data.ByteString.Lazy.Char8
-import Data.RefSerialize
-
-import Debug.Trace
-
-a !> b= trace b a
-
-
-
-
-instance Indexable (Queue a) where
-   key (Queue k  _ _)= queuePrefix ++ k
-
-
-
-
-data Queue a= Queue {name :: String, imp :: [a], out ::  [a]}  deriving (Typeable)
-
-
-
-instance Serialize a => Serialize (Queue a) where
-  showp (Queue n i o)= showp n >> showp i >> showp o
-  readp = return Queue `ap` readp `ap` readp `ap` readp
---    do
---       n <-   readp
---       i <-   readp
---       o <-   readp
---       return $ Queue n i o
-
-
-
-
-queuePrefix= "Queue#"
-lenQPrefix= Prelude.length queuePrefix
-
-
-
-instance   Serialize a => Serializable (Queue a ) where
-  serialize = runW . showp
-  deserialize = runR  readp
-
--- | 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
-    writeDBRef queue $ doit r
-    where
-    doit (Queue  n  imp out) =   Queue n  imp ( x : out)
-
-
--- | Check if the queue is empty
-isEmpty ::  (Typeable a, Serialize a) => RefQueue a -> IO Bool
-isEmpty = atomically . isEmptySTM
-
-isEmptySTM :: (Typeable a, Serialize a) => RefQueue a -> STM Bool
-isEmptySTM queue= do
-   r <- readDBRef queue
-   return $ case r of
-        Nothing  ->  True
-        Just (Queue _ [] []) -> True
-        _    ->  False
-
-
-
--- | Get the reference to new or existing queue trough its name
-getQRef ::  (Typeable a, Serialize a)  => String -> RefQueue a
-getQRef n = getDBRef . key $ Queue n undefined undefined
-
-
--- | Empty the queue (factually, it is deleted)
-flush ::   (Typeable a, Serialize a)  => RefQueue a -> IO ()
-flush = atomically . flushSTM
-
--- | Version in the STM monad
-flushSTM ::  (Typeable a, Serialize a)  => RefQueue a -> STM ()
-flushSTM tv= delDBRef tv
-
--- | Read  the first element in the queue and delete it (pop)
-pop
-      ::  (Typeable a, Serialize a)  => RefQueue a       -- ^ Queue name
-      -> IO a              -- ^ the returned elems
-pop tv = atomically $ popSTM tv
-
-
-readQRef :: (Typeable a, Serialize a)  => RefQueue a -> STM(Queue a)
-readQRef tv= do
-    mdx <- readDBRef tv
-    case mdx of
-     Nothing -> do
-            let q= Queue ( Prelude.drop lenQPrefix $ keyObjDBRef tv) [] []
-            writeDBRef tv q
-            return q
-     Just dx ->
-            return dx
-
--- | Version in the STM monad
-popSTM :: (Typeable a, Serialize a) =>  RefQueue a
-              -> STM  a
-popSTM tv=do
-    dx <- readQRef tv
-    doit  dx
-
-    where
-
-    doit (Queue n [x] [])= do
-                 writeDBRef tv $  (Queue n  [] [])
-                 return   x
-    doit (Queue _ [] []) =  retry
-    doit (Queue  n imp [])  =  doit  (Queue  n [] $ Prelude.reverse imp)
-    doit (Queue n imp  list ) = do
-                 writeDBRef tv  (Queue  n imp (Prelude.tail list ))
-                 return  $ Prelude.head list
-
---  | Read the first element in the queue but it does not delete it
-pick
-      ::  (Typeable a, Serialize a)  => RefQueue a       -- ^ Queue name
-      -> IO a              -- ^ the returned elems
-pick tv = atomically $ do
-    dx <- readQRef tv
-    doit dx
-    where
-    doit (Queue _ [x] [])= return   x
-    doit (Queue _ [] []) =  retry
-    doit (Queue  n imp [])  =  doit  (Queue  n [] $ Prelude.reverse imp)
-    doit (Queue n imp  list ) = return  $ Prelude.head list
-
--- | Push an element in the queue
-push  ::   (Typeable a, Serialize a)  => RefQueue a -> a -> IO ()
-push tv v = atomically $ pushSTM tv v
-
--- | Version in the STM monad
-pushSTM ::  (Typeable a, Serialize a)  => RefQueue a -> a -> STM ()
-pushSTM  tv   v=
-      readQRef tv  >>= \ ((Queue n  imp out))  -> writeDBRef tv  $ Queue n  (v : imp) out
-
--- | Return the list of all elements in the queue. The queue remains unchanged
-pickAll ::  (Typeable a, Serialize a)  => RefQueue a -> IO [a]
-pickAll= atomically  . pickAllSTM
-
--- | Version in the STM monad
-pickAllSTM :: (Typeable a, Serialize a)  => RefQueue a -> STM [a]
-pickAllSTM tv= do
-     (Queue name imp out) <- readQRef tv
-     return $ out ++ Prelude.reverse imp
-
--- | Return the first element in the queue that has the given key
-pickElem ::(Indexable a,Typeable a, Serialize a) => RefQueue a -> String -> IO(Maybe a)
-pickElem tv key= atomically $ pickElemSTM tv key
-
--- | Version in the STM monad
-pickElemSTM :: (Indexable a,Typeable a, Serialize a)
-                     => RefQueue a -> String -> STM(Maybe a)
-pickElemSTM tv key1=  do
-     Queue name imp out <- readQRef tv
-     let xs= out ++ Prelude.reverse imp
-     when (not $ Prelude.null imp) $ writeDBRef tv $ Queue name [] xs
-     case  Prelude.filter (\x-> key x == key1) xs of
-          []    -> return $ Nothing
-          (x:_) -> return $ Just  x
-
--- | Update the first element of the queue with a new element with the same key
-updateElem :: (Indexable a,Typeable a, Serialize a)
-                    => RefQueue a  -> a -> IO()
-updateElem tv x = atomically $ updateElemSTM tv  x
-
--- | Version in the STM monad
-updateElemSTM :: (Indexable a,Typeable a, Serialize a)
-                       => RefQueue a  -> a -> STM()
-updateElemSTM tv v= do
-     Queue name imp out <- readQRef tv
-     let xs= out ++ Prelude.reverse imp
-     let xs'= Prelude.map (\x -> if key x == n then v else x) xs
-     writeDBRef tv  $ Queue name [] xs'
-     where
-     n= key v
-
--- | Return the list of all elements in the queue and empty it
-readAll ::  (Typeable a, Serialize a) => RefQueue a -> IO [a]
-readAll= atomically  . readAllSTM
-
--- | A version in the STM monad
-readAllSTM ::  (Typeable a, Serialize a)  => RefQueue a -> STM [a]
-readAllSTM tv= do
-     Queue name imp out <- readQRef tv
-     writeDBRef tv  $ Queue name [] []
-     return $ out ++ Prelude.reverse imp
-
--- | Delete all the elements of the queue that has the key of the parameter passed
-deleteElem :: (Indexable a,Typeable a, Serialize a) => RefQueue a-> a -> IO ()
-deleteElem tv x= atomically $ deleteElemSTM tv x
-
--- | Verison in the STM monad
-deleteElemSTM :: (Typeable a, Serialize a,Indexable a) => RefQueue a-> a -> STM ()
-deleteElemSTM tv x= do
-     Queue name imp out <- readQRef tv
-     let xs= out ++ Prelude.reverse imp
-     writeDBRef tv $ Queue name [] $ Prelude.filter (\x-> key x /= k) xs
-     where
-     k=key x
-
+{-# LANGUAGE DeriveDataTypeable, TypeSynonymInstances,+  MultiParamTypeClasses, ExistentialQuantification,+  OverloadedStrings, FlexibleInstances, UndecidableInstances #-}++{- |+A persistent, transactional collection with Queue interface as well as+ indexed access by key.++ 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,updateElem,updateElemSTM,+unreadSTM,isEmpty,isEmptySTM+) where+import Data.Typeable+import Control.Concurrent.STM(STM,atomically, retry)+import Control.Monad+import Data.TCache.DefaultPersistence++import Data.TCache+import Data.RefSerialize++--import Debug.Trace+--(!>) :: a -> String -> a+--a !> b= trace b a+++++instance Indexable (Queue a) where+   key (Queue k  _ _)= queuePrefix ++ k+++++data Queue a= Queue String [a] [a]  deriving (Typeable)++++instance Serialize a => Serialize (Queue a) where+  showp (Queue n i o)= showp n >> showp i >> showp o+  readp = return Queue `ap` readp `ap` readp `ap` readp+--    do+--       n <-   readp+--       i <-   readp+--       o <-   readp+--       return $ Queue n i o++++queuePrefix :: String+queuePrefix= "Queue#"++lenQPrefix :: Int+lenQPrefix= Prelude.length queuePrefix++instance   Serialize a => Serializable (Queue a ) where+  serialize = runW . showp+  deserialize = runR  readp++-- | 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+    writeDBRef queue $ doit r+    where+    doit (Queue  n  imp out) =   Queue n  imp ( x : out)+++-- | Check if the queue is empty+isEmpty ::  (Typeable a, Serialize a) => RefQueue a -> IO Bool+isEmpty = atomically . isEmptySTM++isEmptySTM :: (Typeable a, Serialize a) => RefQueue a -> STM Bool+isEmptySTM queue= do+   r <- readDBRef queue+   return $ case r of+        Nothing  ->  True+        Just (Queue _ [] []) -> True+        _    ->  False++++-- | Get the reference to new or existing queue trough its name+getQRef ::  (Typeable a, Serialize a)  => String -> RefQueue a+getQRef n = getDBRef . key $ Queue n undefined undefined+++-- | Empty the queue (factually, it is deleted)+flush ::   (Typeable a, Serialize a)  => RefQueue a -> IO ()+flush = atomically . flushSTM++-- | Version in the STM monad+flushSTM ::  (Typeable a, Serialize a)  => RefQueue a -> STM ()+flushSTM = delDBRef++-- | Read  the first element in the queue and delete it (pop)+pop+      ::  (Typeable a, Serialize a)  => RefQueue a       -- ^ Queue name+      -> IO a              -- ^ the returned elems+pop tv = atomically $ popSTM tv+++readQRef :: (Typeable a, Serialize a)  => RefQueue a -> STM(Queue a)+readQRef tv= do+    mdx <- readDBRef tv+    case mdx of+     Nothing -> do+            let q= Queue ( Prelude.drop lenQPrefix $ keyObjDBRef tv) [] []+            writeDBRef tv q+            return q+     Just dx ->+            return dx++-- | Version in the STM monad+popSTM :: (Typeable a, Serialize a) =>  RefQueue a+              -> STM  a+popSTM tv=do+    dx <- readQRef tv+    doit  dx++    where++    doit (Queue n [x] [])= do+                 writeDBRef tv (Queue n  [] [])+                 return   x+    doit (Queue _ [] []) =  retry+    doit (Queue  n imp [])  =  doit  (Queue  n [] $ Prelude.reverse imp)+    doit (Queue n imp  list ) = do+                 writeDBRef tv  (Queue  n imp (Prelude.tail list ))+                 return  $ Prelude.head list++--  | Read the first element in the queue but it does not delete it+pick+      ::  (Typeable a, Serialize a)  => RefQueue a       -- ^ Queue name+      -> IO a              -- ^ the returned elems+pick tv = atomically $ do+    dx <- readQRef tv+    doit dx+    where+    doit (Queue _ [x] [])= return   x+    doit (Queue _ [] []) =  retry+    doit (Queue  n imp [])  =  doit  (Queue  n [] $ Prelude.reverse imp)+    doit (Queue _ _  list ) = return  $ Prelude.head list++-- | Push an element in the queue+push  ::   (Typeable a, Serialize a)  => RefQueue a -> a -> IO ()+push tv v = atomically $ pushSTM tv v++-- | Version in the STM monad+pushSTM ::  (Typeable a, Serialize a)  => RefQueue a -> a -> STM ()+pushSTM  tv   v=+      readQRef tv  >>= \ (Queue n  imp out)  -> writeDBRef tv  $ Queue n  (v : imp) out++-- | Return the list of all elements in the queue. The queue remains unchanged+pickAll ::  (Typeable a, Serialize a)  => RefQueue a -> IO [a]+pickAll= atomically  . pickAllSTM++-- | Version in the STM monad+pickAllSTM :: (Typeable a, Serialize a)  => RefQueue a -> STM [a]+pickAllSTM tv= do+     (Queue _ imp out) <- readQRef tv+     return $ out ++ Prelude.reverse imp++-- | Return the first element in the queue that has the given key+pickElem ::(Indexable a,Typeable a, Serialize a) => RefQueue a -> String -> IO(Maybe a)+pickElem tv k= atomically $ pickElemSTM tv k++-- | Version in the STM monad+pickElemSTM :: (Indexable a,Typeable a, Serialize a)+                     => RefQueue a -> String -> STM(Maybe a)+pickElemSTM tv key1 = do+  Queue name imp out <- readQRef tv+  let xs = out ++ Prelude.reverse imp+  unless (Prelude.null imp) $ writeDBRef tv $ Queue name [] xs+  case Prelude.filter (\x -> key x == key1) xs of+    [] -> return Nothing+    (x:_) -> return $ Just x++-- | Update the first element of the queue with a new element with the same key+updateElem :: (Indexable a,Typeable a, Serialize a)+                    => RefQueue a  -> a -> IO()+updateElem tv x = atomically $ updateElemSTM tv  x++-- | Version in the STM monad+updateElemSTM :: (Indexable a,Typeable a, Serialize a)+                       => RefQueue a  -> a -> STM()+updateElemSTM tv v= do+     Queue name imp out <- readQRef tv+     let xs= out ++ Prelude.reverse imp+     let xs'= Prelude.map (\x -> if key x == n then v else x) xs+     writeDBRef tv  $ Queue name [] xs'+     where+     n= key v++-- | Return the list of all elements in the queue and empty it+readAll ::  (Typeable a, Serialize a) => RefQueue a -> IO [a]+readAll= atomically  . readAllSTM++-- | A version in the STM monad+readAllSTM ::  (Typeable a, Serialize a)  => RefQueue a -> STM [a]+readAllSTM tv= do+     Queue name imp out <- readQRef tv+     writeDBRef tv  $ Queue name [] []+     return $ out ++ Prelude.reverse imp++-- | Delete all the elements of the queue that has the key of the parameter passed+deleteElem :: (Indexable a,Typeable a, Serialize a) => RefQueue a-> a -> IO ()+deleteElem tv x= atomically $ deleteElemSTM tv x++-- | Version in the STM monad+deleteElemSTM :: (Typeable a, Serialize a,Indexable a) => RefQueue a-> a -> STM ()+deleteElemSTM tv x= do+     Queue name imp out <- readQRef tv+     let xs= out ++ Prelude.reverse imp+     writeDBRef tv $ Queue name [] $ Prelude.filter (\x2-> key x2 /= k) xs+     where+     k=key x+

@@ -1,157 +1,150 @@-    {-# 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.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 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
-
--- | check if a (possibly polimorphic) value within a IDynamic value has the given serialization"
-serializedEqual (IDyn r) str= unsafePerformIO $ do
-  t <- readIORef r
-  case t of
-   DRight x -> return $ runW (showp x) == str   -- !> ("R "++ (show $ unpack $ runW (showp x)))
-   DLeft (str', _) -> return $ str== str'       -- !> ("L "++ (show $ unpack str' ))
-
-fromIDyn :: (Typeable a , Serialize a)=> IDynamic -> a
-fromIDyn x= case safeFromIDyn x of
-          Left  s -> error s
-          Right v -> v
-
-
-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 $ 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 $ Left (show e)) $  -- !> ("safeFromIDyn : "++ show e)) $
-        do
-          let v= runRC  c rreadp str    -- !> unpack str
-          writeIORef r $! DRight v      -- !> ("***reified "++ unpack str)
-          return $! Right v             -- !>  ("*** end reified " ++ unpack str)
-
-
-
-reifyM :: (Typeable a,Serialize a) => IDynamic -> a -> IO a
-reifyM dyn v = do
-   let v'= fromIDyn dyn
-   return $ v' `seq` v'
+{-# LANGUAGE ExistentialQuantification, UndecidableInstances,+      ScopedTypeVariables, DeriveDataTypeable, TypeSynonymInstances,+      IncoherentInstances, OverloadedStrings, MultiParamTypeClasses,+      FlexibleInstances #-}++{- |+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 System.IO.Unsafe++import Data.ByteString.Lazy.Char8 as B++import Control.Exception(handle, SomeException)+import Data.IORef+import Data.RefSerialize++--import Debug.Trace+--(!>)= flip trace+++newtype IDynamic  =  IDyn  (IORef IDynType) deriving Typeable++data IDynType= forall a.(Typeable a, Serialize a)+               => DRight !a+             |  DLeft  !(ByteString ,(Context, ByteString))+++               deriving Typeable++newtype Save= Save ByteString deriving Typeable++tosave :: IDynamic -> IDynamic+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 :: String -> String -> a+errorfied str str2= error $ str ++ ": IDynamic object not reified: "++ str2++++dynPrefix :: String+dynPrefix= "Dyn"++dynPrefixSp :: ByteString+dynPrefixSp= append  (pack dynPrefix) " "++notreified :: ByteString+notreified = pack $ dynPrefix ++" 0"++++instance Serialize IDynamic where++   showp (IDyn t)=+    case unsafePerformIO $ readIORef t of+     DRight x -> do+--          insertString $ pack dynPrefix+          _ <- 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 :: (Typeable a, Serialize a) => a -> IDynamic+toIDyn x= IDyn . unsafePerformIO . newIORef $ DRight x++-- | check if a (possibly polimorphic) value within a IDynamic value has the given serialization"+serializedEqual :: IDynamic -> ByteString -> Bool+serializedEqual (IDyn r) str= unsafePerformIO $ do+  t <- readIORef r+  case t of+   DRight x -> return $ runW (showp x) == str   -- !> ("R "++ (show $ unpack $ runW (showp x)))+   DLeft (str', _) -> return $ str== str'       -- !> ("L "++ (show $ unpack str' ))++fromIDyn :: (Typeable a , Serialize a)=> IDynamic -> a+fromIDyn x= case safeFromIDyn x of+          Left  s -> error s+          Right v -> v+++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 $+            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'+                  fromRight (Left _') = error "this will never happen?"+          DLeft (str, c) ->+            handle (\(e :: SomeException) -> return $ Left (show e)) $ -- !> ("safeFromIDyn : "++ show e)) $+             do+              let v = runRC c rreadp str -- !> unpack str+              writeIORef r $! DRight v -- !> ("***reified "++ unpack str)+              return (Right v)             -- !>  ("*** end reified " ++ unpack str)++++reifyM :: (Typeable a,Serialize a) => IDynamic -> a -> IO a+reifyM dyn _ = return $ fromIDyn dyn

@@ -1,1040 +1,1061 @@-{-# LANGUAGE ScopedTypeVariables, ExistentialQuantification, DeriveDataTypeable
-    , FlexibleInstances, UndecidableInstances #-}
-
-{- | TCache is a transactional cache with configurable persitence that permits
-STM transactions with objects that syncronize sincromous or asyncronously with
-their user defined storages. Default persistence in files is provided by default
-
- TCache implements ''DBRef' 's . They are persistent STM references  with a typical Haskell interface.
-simitar to TVars ('newDBRef', 'readDBRef', 'writeDBRef' etc) but with added. persistence
-. DBRefs are serializable, so they can be stored and retrieved.
-Because they are references,they point to other serializable registers.
-This permits persistent mutable Inter-object relations
-
-For simple transactions of lists of objects of the same type TCache implements
-inversion of control primitives 'withSTMResources' and variants, that call pure user defined code for registers update. Examples below.
-
-Triggers in "Data.TCache.Triggers" are user defined hooks that are called back on register updates.
-.They are used internally for indexing.
-
-"Data.TCache.IndexQuery" implements an straighforwards pure haskell type safe query language  based
- on register field relations. This module must be imported separately.
-
-"Data.TCache.IndexText" add full text search and content search to the query language
-
-"Data.TCache.DefaultPersistence" has instances for key indexation , serialization
- and default file persistence. The file persistence is more reliable, and the embedded IO reads inside STM transactions are safe.
-
-"Data.Persistent.Collection" implements a persistent, transactional collection with Queue interface as well as
- indexed access by key
-
--}
-
-
-
-
-module Data.TCache (
--- * Inherited from 'Control.Concurrent.STM' and variations
-
- atomically
- ,atomicallySync
- ,STM
- ,unsafeIOToSTM
- ,safeIOToSTM
-
--- * Operations with cached database references
-{-|  @DBRefs@ are persistent cached database references in the STM monad
-with read/write primitives, so the traditional syntax of Haskell STM references
-can be used for  interfacing with databases. As expected, the DBRefs are transactional,
- because they operate in the STM monad.
-
-A @DBRef@ is associated with its referred object trough its key.
-Since DBRefs are serializable, they can be elements of mutable cached objects themselves. They could point to other mutable objects
-and so on, so DBRefs can act as \"hardwired\" relations from mutable objects
-to other mutable objects in the database/cache. their referred objects are loaded, saved and flused
-to and from the cache automatically depending on the cache handling policies and the access needs
-
-
-@DBRefs@ are univocally identified by its pointed object keys, so they can be compared, ordered checked for equality so on.
-The creation of a DBRef, trough 'getDBRef' is pure. This permits an efficient lazy access to the
- registers trouth their DBRefs by lazy marshalling of the register content on demand.
-
-Example: Car registers have references to Person regiters
-
-@
-data Person= Person {pname :: String} deriving  (Show, Read, Eq, Typeable)
-data Car= Car{owner :: DBRef Person , cname:: String} deriving (Show, Read, Eq, Typeable)
-@
-
-
-Here the Car register point to the Person register trough the owner field
-
-To permit persistence and being refered with DBRefs, define the Indexable instance
-for these two register types:
-
-@
-instance Indexable Person where key Person{pname= n} = "Person " ++ n
-instance Indexable Car where key Car{cname= n} = "Car " ++ n
-@
-
-Now we create a DBRef to a Person whose name is \"Bruce\"
-
->>> let bruce =   getDBRef . key $ Person "Bruce" :: DBRef Person
-
->>> show bruce
->"DBRef \"Person bruce\""
-
->>> atomically (readDBRef bruce)
->Nothing
-
-'getDBRef' is pure and creates the reference, but not the referred object;
-To create both the reference and the DBRef, use 'newDBRef'.
-Lets create two Car's and its two Car DBRefs with bruce as owner:
-
->>> cars <- atomically $  mapM newDBRef [Car bruce "Bat Mobile", Car bruce "Porsche"]
-
->>> print cars
->[DBRef "Car Bat Mobile",DBRef "Car Porsche"]
-
->>> carRegs<- atomically $ mapM readDBRef cars
-> [Just (Car {owner = DBRef "Person bruce", cname = "Bat Mobile"})
-> ,Just (Car {owner = DBRef "Person bruce", cname = "Porsche"})]
-
-try to write with 'writeDBRef'
-
->>> atomically . writeDBRef bruce $ Person "Other"
->*** Exception: writeDBRef: law of key conservation broken: old , new= Person bruce , Person Other
-
-DBRef's can not be written with objects of different keys
-
->>> atomically . writeDBRef bruce $ Person "Bruce"
-
->>> let Just carReg1= head carRegs
-
-now from the Car register it is possible to recover the owner's register
-
->>> atomically $ readDBRef ( owner carReg1)
->Just (Person {pname = "bruce"})
-
-
-
-DBRefs, once the pointed cached object is looked up in the cache and found at creation, they does
-not perform any further cache lookup afterwards, so reads and writes from/to DBRefs are faster
-than *Resource(s) calls, which perform  cache lookups everytime the object is accessed
-
-DBRef's and @*Resource(s)@ primitives are completely interoperable. The latter operate implicitly with DBRef's
-
--}
-
-
-,DBRef
-,getDBRef
-,keyObjDBRef
-,newDBRef
---,newDBRefIO
-,readDBRef
-,readDBRefs
-,writeDBRef
-,delDBRef
-
--- * @IResource@ class
-{- | cached objects must be instances of IResource.
-Such instances can be implicitly derived trough auxiliary clasess for file persistence
--}
-,IResource(..)
-
--- * Operations with cached objects
-{- | implement inversion of control primitives where  the user defines the objects to retrive. The primitives
-then call a the defined function that, determines how to transform the objects retrieved,wich are sent
-back to the storage and a result is returned.
-
-In this example \"buy\" is a transaction where the user buy an item.
-The spent amount is increased and the stock of the product is decreased:
-
-@
-data  Data=   User{uname:: String, uid:: String, spent:: Int} |
-              Item{iname:: String, iid:: String, price:: Int, stock:: Int}
-              deriving (Read, Show)
-
-instance Indexable Data where
-        key   User{uid=id}= id
-        key   Item{iid=id}= id
-
-user `buy` item=  'withResources'[user,item] buyIt
- where
-    buyIt[Just us,Just it]
-       | stock it > 0= [us',it']
-       | otherwise   = error \"stock is empty for this product\"
-      where
-       us'= us{spent=spent us + price it}
-       it'= it{stock= stock it-1}
-    buyIt _ = error \"either the user or the item (or both) does not exist\"
-@
--}
-,Resources(..)  -- data definition used to communicate object Inserts and Deletes to the cache
-,resources      -- empty resources
-,withSTMResources
-,withResources
-,withResource
-,getResources
-,getResource
-,deleteResources
-,deleteResource
-
--- * Trigger operations
-{- | Trriggers are called just before an object of the given type is created, modified or deleted.
-The DBRef to the object and the new value is passed to the trigger.
-The called trigger function has two parameters: the DBRef being accesed
-(which still contains the old value), and the new value.
-If the content of the DBRef is being deleted, the second parameter is 'Nothing'.
-if the DBRef contains Nothing, then the object is being created
-
-Example:
-
-Every time a car is added, or deleted, the owner's list is updated.
-This is done by the user defined trigger addCar
-
-@
- addCar pcar (Just(Car powner _ )) = addToOwner powner pcar
- addCar pcar Nothing  = readDBRef pcar >>= \\(Just car)-> deleteOwner (owner car) pcar
-
- addToOwner powner pcar=do
-    Just owner <- readDBRef powner
-    writeDBRef powner owner{cars= nub $ pcar : cars owner}
-
- deleteOwner powner pcar= do
-   Just owner <- readDBRef powner
-   writeDBRef powner owner{cars= delete  pcar $ cars owner}
-
- main= do
-    'addTrigger' addCar
-    putStrLn \"create bruce's register with no cars\"
-    bruce \<- 'atomically' 'newDBRef' $ Person \"Bruce\" []
-    putStrLn \"add two car register with \\"bruce\\" as owner using the reference to the bruces register\"
-    let newcars= [Car bruce \"Bat Mobile\" , Car bruce \"Porsche\"]
-    insert newcars
-    Just bruceData \<- atomically $ 'readDBRef' bruce
-    putStrLn \"the trigger automatically updated the car references of the Bruce register\"
-    print . length $ cars bruceData
-    print bruceData
-@
-
-gives:
-
-> main
-> 2
-> Person {pname = "Bruce", cars = [DBRef "Car Porsche",DBRef "Car Bat Mobile"]}
-
--}
-
-,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
-,flushAll
-,Cache
-,setCache
-,newCache
---,refcache
-,syncCache
-,setConditions
-,clearSyncCache
-,numElems
-,syncWrite
-,SyncMode(..)
-,clearSyncCacheProc
-,defaultCheck
--- * Other
-,onNothing
-)
-where
-
-
-import GHC.Conc
-import Control.Monad(when)
-import qualified Data.HashTable.IO as H
-import Data.IORef
-import System.IO.Unsafe
-import System.IO(hPutStr, stderr)
-import Data.Maybe
-import Data.Char(isSpace)
-import Data.TCache.Defs
-import Data.TCache.IResource
-import Data.TCache.Triggers
-import Control.Exception
-import Data.Typeable
-import System.Time
-import System.Mem
-import System.Mem.Weak
-
-import Control.Concurrent.MVar
-import Control.Exception(catch, throw,evaluate)
-
---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
--- calls which does not reference dbrefs explicitly
--- The weak reference keeps the dbref alive until is it not referenced elsewere
-data CacheElem= forall a.(IResource a,Typeable a) => CacheElem (Maybe (DBRef a)) (Weak(DBRef a))
-
-type Ht = H.BasicHashTable   String  CacheElem
-
--- contains the hastable, last sync time
-type Cache = IORef (Ht , Integer)
-data CheckTPVarFlags= AddToHash | NoAddToHash
-
--- | Set the cache. this is useful for hot loaded modules that will update an existing cache. Experimental
-setCache :: Cache -> IO()
-setCache ref = readIORef ref >>= \ch -> writeIORef refcache ch
-
--- | The cache holder. stablished by default
-{-# NOINLINE refcache #-}
-refcache :: Cache
-refcache =unsafePerformIO $ newCache >>= newIORef
-
--- |   Creates a new cache. Experimental
-newCache  :: IO (Ht , Integer)
-newCache =do
-        c <- H.new  -- (==) H.hashString
-        return (c,0)
-
--- | Return the  total number of DBRefs in the cache. For debug purposes.
--- This does not count the number of objects in the cache since many of the DBRef
--- may not have the pointed object loaded. It's O(n).
-numElems :: IO Int
-numElems= do
-   (cache, _) <- readIORef refcache
-   elems <-   H.toList cache
-   return $ length elems
-
-{-# NOINLINE deRefWeakSTM #-}
-deRefWeakSTM = unsafeIOToSTM . deRefWeak
-
---deleteFromCache :: (IResource a, Typeable a) => DBRef a -> IO ()
---deleteFromCache (DBRef k tv)=   do
---    (cache, _) <- readIORef refcache
---    H.delete cache k    -- !> ("delete " ++ k)
-
-fixToCache :: (IResource a, Typeable a) => DBRef a -> IO ()
-fixToCache dbref@(DBRef k tv)= do
-       (cache, _) <- readIORef refcache
-       w <- mkWeakPtr dbref  $ Just $ fixToCache dbref
-       H.insert cache k (CacheElem (Just dbref) w)
-       return()
-
--- | Return the reference value. If it is not in the cache, it is fetched
--- from the database.
-readDBRef :: (IResource a, Typeable a)  => DBRef a -> STM (Maybe a)
-readDBRef dbref@(DBRef key  tv)= do
-  r <- readTVar tv
-  case r of
-   Exist (Elem x _ mt) -> do
-       t <- unsafeIOToSTM timeInteger
-       writeTVar tv  . Exist $ Elem x t mt
-       return $ Just x
-   DoNotExist -> return $ Nothing
-   NotRead ->  do
-       r <- safeIOToSTM $ readResourceByKey key
-       case r of
-         Nothing -> writeTVar tv DoNotExist >> return Nothing
-         Just x  -> do
-           t <- unsafeIOToSTM timeInteger
-           writeTVar tv $ Exist $ Elem  x t (-1)
-           return $ Just  x
-
--- | Read multiple DBRefs in a single request using the new 'readResourcesByKey'
-readDBRefs :: (IResource a, Typeable a)  => [DBRef a] -> STM [(Maybe a)]
-readDBRefs dbrefs= do
-  let mf (DBRef key  tv)= do
-      r <- readTVar tv
-      case r of
-        Exist (Elem x _ mt) -> do
-          t <- unsafeIOToSTM timeInteger
-          writeTVar tv  . Exist $ Elem x t mt
-          return $ Right $ Just x
-        DoNotExist -> return $ Right Nothing
-        NotRead ->  return $ Left key
-  inCache <- mapM mf dbrefs
-  let pairs = foldr(\pair@(x,dbr) xs -> case x of Left k -> pair:xs; _ -> xs ) [] $ zip inCache dbrefs
-  let (toReadKeys, dbrs) = unzip pairs
-  let fromLeft (Left k)= k
-      formLeft _ = error "this will never happen"
-  rs <- safeIOToSTM . readResourcesByKey $ map fromLeft toReadKeys
-  let processTVar (r, DBRef key  tv)= do
-           case r of
-             Nothing -> writeTVar tv DoNotExist
-             Just x  -> do
-               t <- unsafeIOToSTM timeInteger
-               writeTVar tv $ Exist $ Elem  x t (-1)
-
-  mapM_ processTVar $ zip rs dbrs
-  let mix (Right x:xs) ys   = x:mix xs ys
-      mix (Left _:xs) (y:ys)= y:mix xs ys
-
-  return $ mix inCache rs
-
--- | Write in the reference a value
--- The new key must be the same than the old key of the previous object stored
--- otherwise, an error "law of key conservation broken" will be raised
---
--- WARNING: the value to be written in the DBRef must be fully evaluated. Delayed evaluations at
--- serialization time can cause inconsistencies in the database.
--- In future releases this will be enforced.
-writeDBRef :: (IResource a, Typeable a)  => DBRef a -> a -> STM ()
-writeDBRef dbref@(DBRef key  tv) x= x `seq` do
- let newkey= keyResource x
- if newkey /= key
-   then  error $ "writeDBRef: law of key conservation broken: old , new= " ++ key ++ " , "++newkey
-   else do
-    applyTriggers  [dbref] [Just x]
-    t <- unsafeIOToSTM timeInteger
-
-    writeTVar tv $! Exist $! Elem x t t
-    return()
-
-
-instance  Show (DBRef a) where
-  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 ('D':'B':'R':'e':'f':' ':'\"':str1)=
-         let   (key,nstr) =  break (== '\"') str1
-         in  [( getDBRef key :: DBRef a, tail  nstr)]
-       readit  _ = []
-
-instance Eq (DBRef a) where
-  DBRef k _ == DBRef k' _ =  k==k'
-
-instance Ord (DBRef a) where
-  compare (DBRef k _)  (DBRef k' _) = compare k k'
-
--- | Return the key of the object pointed to by the DBRef
-keyObjDBRef ::  DBRef a -> String
-keyObjDBRef (DBRef k _)= k
-
-
--- | Get the reference to the object in the cache. if it does not exist, the reference is created empty.
--- Every execution of 'getDBRef' returns the same unique reference to this key,
--- so it can be safely considered pure. This is a property useful because deserialization
--- of objects with unused embedded DBRef's  do not need to marshall them eagerly.
---  Tbis also avoid unnecesary cache lookups of the pointed objects.
-{-# NOINLINE getDBRef #-}
-getDBRef :: (Typeable a, IResource a) => String -> DBRef a
-getDBRef key=   unsafePerformIO $! getDBRef1 $! key where
- getDBRef1 :: (Typeable a, IResource a) =>  String -> IO (DBRef a)
- getDBRef1 key = do
-  (cache,_) <-  readIORef refcache   -- !> ("getDBRef "++ key)
-  takeMVar getRefFlag
-  r <- H.lookup cache  key
-  case r of
-   Just (CacheElem  mdb w) -> do
-     putMVar getRefFlag ()
-     mr <-  deRefWeak w
-     case mr of
-        Just dbref@(DBRef _ tv) ->
-                case mdb of
-                  Nothing -> return $! castErr dbref     -- !> "just"
-                  Just _  -> do
-                        H.insert cache key (CacheElem Nothing w) --to notify when the DBREf leave its reference
-                        return $! castErr dbref
-        Nothing -> finalize w >>  getDBRef1 key          -- !> "finalize"  -- the weak pointer has not executed his finalizer
-
-   Nothing -> do
-     tv <- newTVarIO NotRead                              -- !> "Nothing"
-     dbref <- evaluate $ DBRef key  tv
-     w <- mkWeakPtr  dbref . Just $ fixToCache dbref
-     H.insert cache key (CacheElem Nothing w)
-     putMVar getRefFlag ()
-     return  dbref
-
-{-# NOINLINE getRefFlag #-}
-getRefFlag= unsafePerformIO $ newMVar ()
-
-{- | Create the object passed as parameter (if it does not exist) and
--- return its reference in the IO monad.
--- If an object with the same key already exists, it is returned as is
--- If not, the reference is created with the new value.
--- If you like to update in any case, use 'getDBRef' and 'writeDBRef' combined
-newDBRefIO :: (IResource a,Typeable a) => a -> IO (DBRef a)
-newDBRefIO x= do
- let key = keyResource x
- mdbref <- mDBRefIO key
- case mdbref of
-   Right dbref -> return dbref
-
-   Left cache -> do
-     tv<- newTVarIO  DoNotExist
-     let dbref= DBRef key  tv
-     w <- mkWeakPtr  dbref . Just $ fixToCache dbref
-     H.insert cache key (CacheElem Nothing w)
-     t <-  timeInteger
-     atomically $ do
-       applyTriggers [dbref] [Just x]      --`debug` ("before "++key)
-       writeTVar tv  . Exist $ Elem x t t
-       return dbref
-
--}
-
-
-----  get a single DBRef if exist
---mDBRefIO
---       :: (IResource a, Typeable a)
---       => String                       -- ^ the list of partial object definitions for which keyResource can be extracted
---       -> IO (Either Ht (DBRef a))     -- ^ ThTCache.hse TVars that contain such objects
---mDBRefIO k= do
---    (cache,_) <-  readIORef refcache
---    r <-   H.lookup cache  k
---    case r of
---     Just (CacheElem _ w) -> do
---        mr <-  deRefWeak w
---        case mr of
---          Just dbref ->  return . Right $! castErr dbref
---          Nothing ->  finalize w >> mDBRefIO k
---     Nothing -> return $ Left cache
-
-
-
--- | Create the object passed as parameter (if it does not exist) and
--- return its reference in the STM monad.
--- If an object with the same key already exists, it is returned as is
--- If not, the reference is created with the new value.
--- If you like to update in any case, use 'getDBRef' and 'writeDBRef' combined
--- if you  need to create the reference and the reference content, use 'newDBRef'
-{-# NOINLINE newDBRef #-}
-newDBRef ::   (IResource a, Typeable a) => a -> STM  (DBRef a)
-newDBRef x = do
-  let ref= getDBRef $! keyResource x
-
-  mr <- readDBRef  ref
-  case mr of
-    Nothing -> writeDBRef ref x >> return ref -- !> " write"
-    Just r -> return ref                      -- !> " non write"
-
---newDBRef ::   (IResource a, Typeable a) => a -> STM  (DBRef a)
---newDBRef x = do
---  let key= keyResource x
---  mdbref <-  unsafeIOToSTM $ mDBRefIO  key
---  case mdbref of
---   Right dbref -> return dbref
---   Left cache -> do
---      t  <- unsafeIOToSTM timeInteger
---      tv <- newTVar DoNotExist
---      let dbref= DBRef key  tv
---      (cache,_) <- unsafeIOToSTM $ readIORef refcache
---      applyTriggers [dbref] [Just x]
---      writeTVar tv   . Exist $ Elem x t t
---      unsafeIOToSTM $ do
---        w <- mkWeakPtr dbref . Just $ fixToCache dbref
---        H.insert cache key ( CacheElem Nothing w)
---      return dbref
-
--- | Delete the content of the DBRef form the cache and from permanent storage
-delDBRef :: (IResource a, Typeable a) => DBRef a -> STM()
-delDBRef dbref@(DBRef k tv)= do
-  mr <- readDBRef dbref
-  case mr of
-   Just x -> do
-     applyTriggers [dbref] [Nothing]
-     writeTVar tv DoNotExist
-
-     safeIOToSTM . criticalSection saving $ delResource x
-
-   Nothing -> return ()
-
-
-
--- | Handles Nothing cases in a simpler way than runMaybeT.
--- it is used in infix notation. for example:
---
--- @result <- readDBRef ref \`onNothing\` error (\"Not found \"++ keyObjDBRef ref)@
---
--- or
---
--- @result <- readDBRef ref \`onNothing\` return someDefaultValue@
-onNothing io onerr= do
-  my <-  io
-  case my of
-   Just y -> return y
-   Nothing -> onerr
-
--- | Deletes the pointed object from the cache, not the database (see 'delDBRef')
--- useful for cache invalidation when the database is modified by other process
-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
- (cache,time) <- unsafeIOToSTM $ readIORef refcache
- elms <- unsafeIOToSTM $ H.toList cache
- mapM_ (del cache) elms
- where
- del cache ( _ , CacheElem _ w)= do
-      mr <- unsafeIOToSTM $ deRefWeak w
-      case mr of
-        Just (DBRef _  tv) ->  writeTVar tv NotRead
-        Nothing -> unsafeIOToSTM (finalize w)
-
-
-
--- | This is the main function for the *Resource(s) calls. All the rest derive from it. The results are kept in the STM monad
--- so it can be part of a larger STM transaction involving other DBRefs.
--- The 'Resources' register  returned by the user-defined function  is interpreted as such:
---
---  * 'toAdd':  the content of this field will be added/updated to the cache
---
---  * 'toDelete': the content of this field will be removed from the cache and from permanent storage
---
---  * 'toReturn': the content of this field will be returned by 'withSTMResources'
---
--- WARNING: To catch evaluations errors at the right place, the values to be written must be fully evaluated.
--- Errors in delayed evaluations at serialization time can cause inconsistencies in the database.
-
-withSTMResources :: (IResource a, Typeable a)=> [a]   -- ^ the list of resources to be retrieved
-                     -> ([Maybe a]-> Resources a x)   -- ^ The function that process the resources found and return a Resources structure
-                     -> STM x                  -- ^ The return value in the STM monad.
-
-withSTMResources rs f=  do
-  (cache,_) <- unsafeIOToSTM $ readIORef refcache
-  mtrs      <- takeDBRefs rs cache AddToHash
-
-  mrs <- mapM mreadDBRef mtrs
-  case f mrs of
-      Retry  -> retry
-      Resources  as ds r  -> do
-          applyTriggers (map (getDBRef . keyResource) ds) (repeat (Nothing  `asTypeOf` (Just(head ds))))
-          delListFromHash cache   ds
-          releaseTPVars as cache
-
-          safeIOToSTM . criticalSection saving $ mapM_ delResource ds
-          return r
-
-  where
-  mreadDBRef :: (IResource a, Typeable a) => Maybe (DBRef a) -> STM (Maybe a)
-  mreadDBRef (Just dbref)= readDBRef dbref
-  mreadDBRef Nothing    =  return Nothing
-
-
--- | 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])
-
-
--- |  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 [] ()
-
--- | 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
-		
-
--- | 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
-
-
-{-# 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
-       Just  (CacheElem _ w) -> do
-          mr <- unsafeIOToSTM $ deRefWeak w
-          case mr of
-            Just dbref -> return . Just $! castErr dbref
-            Nothing -> unsafeIOToSTM (finalize w)  >> takeDBRef cache flags x
-       Nothing   -> do
-           safeIOToSTM $ readToCache flags cache  keyr
-              -- unsafeIOToSTM $ readResourceByKey keyr
-
-   where
-   readToCache flags cache key= do
-       mr <- readResource x
-       case mr of
-            Nothing -> return Nothing
-            Just r2 -> do
-               ti  <-   timeInteger
-               tvr <-   newTVarIO . Exist $ Elem r2 ti (-1)
-               case flags of
-                   NoAddToHash -> return . Just $ DBRef key  tvr
-                   AddToHash   -> do
-                      dbref <- evaluate $ DBRef key  tvr
-                      w <- mkWeakPtr  dbref . Just $ fixToCache dbref
-                      H.insert cache key (CacheElem (Just dbref) w)
-                      return $ Just dbref
-     -- !> ("readToCache "++ key)
-
-
-
-timeInteger= do TOD t _ <- getClockTime
-                return t
-
-
-
-
-
-releaseTPVars :: (IResource a,Typeable a)=> [a] -> Ht  -> STM ()
-releaseTPVars rs cache = mapM_  (releaseTPVar cache)  rs
-
-releaseTPVar :: (IResource a,Typeable a)=>  Ht -> a  -> STM ()
-releaseTPVar cache  r =do
-	c <- unsafeIOToSTM $ H.lookup cache keyr
-	case c of
-	    Just  (CacheElem    _ w) -> do
-	        mr <-  unsafeIOToSTM $ deRefWeak w
-	        case mr of
-	            Nothing -> unsafeIOToSTM (finalize w) >> releaseTPVar cache  r		
-	            Just dbref@(DBRef key  tv) -> do
-	            applyTriggers [dbref] [Just (castErr r)]
-                    t <- unsafeIOToSTM  timeInteger
-                    writeTVar tv . Exist  $ Elem  (castErr r)  t t	
-				
-
-	    Nothing   ->  do
-	        ti  <- unsafeIOToSTM timeInteger
-	        tvr <- newTVar NotRead
-	        dbref <- unsafeIOToSTM . evaluate $ DBRef keyr  tvr
-	        applyTriggers [dbref] [Just r]
-	        writeTVar tvr . Exist $ Elem r ti ti
-	        w <- unsafeIOToSTM . mkWeakPtr dbref $ Just $ fixToCache dbref
-	        unsafeIOToSTM $ H.insert cache keyr (CacheElem (Just dbref) w)-- accesed and modified XXX
-	        return ()				
-				
-						
-	where 	keyr= keyResource r
-
-
-		
-
-delListFromHash :: IResource a => Ht -> [a] -> STM ()
-delListFromHash  cache  xs= mapM_ del xs
- where
- del :: IResource a => a -> STM ()
- del x= do
-   let key= keyResource x
-   mr <- unsafeIOToSTM $ H.lookup cache key
-   case mr of
-     Nothing -> return ()
-     Just (CacheElem _ w) -> do
-      mr <- unsafeIOToSTM $ deRefWeak w
-      case mr of
-        Just dbref@(DBRef _  tv) -> do
-           writeTVar tv DoNotExist
-        Nothing -> do
-          unsafeIOToSTM (finalize w) >> del  x
-
-
-
-updateListToHash hash kv= mapM (update1 hash) kv where
-	update1 h (k,v)= H.insert h k v
-
-
-
--- | 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 ::
-         Int                          -- ^ number of seconds betwen checks. objects not written to disk are written
-      -> (Integer -> Integer-> Integer-> Bool)  -- ^ The user-defined check-for-cleanup-from-cache for each object. 'defaultCheck' is an example
-      -> Int                          -- ^ The max number of objects in the cache, if more, the  cleanup starts
-      -> IO ThreadId           -- ^ Identifier of the thread created
-clearSyncCacheProc  time check sizeObjects= forkIO  clear
- where
- clear = do
-     threadDelay $ time * 1000000
-     handle ( \ (e :: SomeException)-> hPutStr stderr (show e) >> clear ) $ do
-    	clearSyncCache   check sizeObjects                                        -- !>  "CLEAR"
-    	clear
-
-criticalSection mv f= bracket
-  (takeMVar mv)
-  (putMVar mv)
-  $ const $ f
-
--- | Force the atomic write of all cached objects modified since the last save into permanent storage.
--- Cache writes allways save a coherent state. As allways, only the modified objects are written.
-syncCache ::  IO ()
-syncCache  = criticalSection saving $ do
-      (cache,lastSync) <- readIORef refcache  --`debug` "syncCache"
-      t2<- timeInteger
-      elems <- H.toList cache
-      (tosave,_,_) <- atomically $ extract elems lastSync
-      save tosave
-      writeIORef refcache (cache, t2)
-
-
-data SyncMode= Synchronous   -- ^ sync state to permanent storage when `atomicallySync` is invoked
-             | Asyncronous
-                  {frecuency  :: Int                     -- ^ number of seconds between saves when asyncronous
-                  ,check      :: (Integer-> Integer-> Integer-> Bool)  -- ^ The user-defined check-for-cleanup-from-cache for each object. 'defaultCheck' is an example
-                  ,cacheSize  :: Int                     -- ^ size of the cache when async
-                  }
-             | SyncManual               -- ^ use `syncCache` to write the state
-
-
-
-{-# NOINLINE tvSyncWrite #-}
-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
-     when (isJust thread ) $ killThread . fromJust $ thread
-     case mode of
-          Synchronous -> modeWrite
-          SyncManual  -> modeWrite
-          Asyncronous time check maxsize -> do
-               th <- clearSyncCacheProc  time check maxsize >> return()
-               writeIORef tvSyncWrite (mode,Just th)
-     where
-     modeWrite= writeIORef tvSyncWrite (mode, Nothing)
-
-
--- | Perform a synchronization of the cache with permanent storage once executed the STM transaction
--- when 'syncWrite' policy is `Synchronous`
-atomicallySync :: STM a -> IO a
-atomicallySync proc=do
-   r <- atomically  proc
-   sync
-   return r
-
-   where
-   sync= do
-       (savetype,_) <- readIORef tvSyncWrite
-       case  savetype of
-        Synchronous -> do
-            syncCache
-        _ -> return ()
-
-
--- |Saves the unsaved elems of the cache.
--- Cache writes allways save a coherent state.
---  Unlike `syncChace` this call deletes some elems of  the cache when the number of elems > @sizeObjects@.
---  The deletion depends on the check criteria, expressed by the first parameter.
---  'defaultCheck' is the one implemented to be passed by default. Look at it to understand the clearing criteria.
-clearSyncCache ::  (Integer -> Integer-> Integer-> Bool)-> Int -> IO ()
-clearSyncCache check sizeObjects= criticalSection saving $ do
-      (cache,lastSync) <- readIORef refcache
-      t <- timeInteger
-      elems <- H.toList cache
-      (tosave, elems, size) <- atomically $ extract elems lastSync
-      save tosave
-      when (size > sizeObjects) $  forkIO (filtercache t cache lastSync elems) >> performGC
-      writeIORef refcache (cache, t)
-
-
-  where
-
-        -- delete elems from the cache according with the checking criteria
-  filtercache t cache lastSync elems= mapM_ filter elems
-    where	
-    filter (CacheElem Nothing w)= return()  --alive because the dbref is being referenced elsewere
-    filter (CacheElem (Just (DBRef key _)) w) = do
-     mr <-  deRefWeak w
-     case mr of
-       Nothing ->    finalize w
-       Just (DBRef _  tv) -> atomically $ do
-         r <- readTVar tv
-         case r of
-    		Exist (Elem x lastAccess _ ) ->
-            		 if check t lastAccess lastSync
-            		      then do
-                              unsafeIOToSTM . H.insert cache key $ CacheElem Nothing w
-                              writeTVar tv NotRead
-            		      else return ()
-    		_    ->  return()
-
-
-
--- | This is a default cache clearance check. It forces to drop from the cache all the
--- elems not accesed since half the time between now and the last sync
--- if it returns True, the object will be discarded from the cache
--- it is invoked when the cache size exceeds the number of objects configured
--- in 'clearSyncCacheProc' or 'clearSyncCache'
-defaultCheck
-       :: Integer    -- ^ current time in seconds
-       -> Integer    -- ^ last access time for a given object
-       -> Integer    -- ^ last cache syncronization (with the persisten storage)
-       -> Bool       -- ^ return true for all the elems not accesed since half the time between now and the last sync
-defaultCheck  now lastAccess lastSync
-	| lastAccess > halftime = False
-	| otherwise  = True
-
-    where
-    halftime= now- (now-lastSync) `div` 2
-
-{-# NOINLINE refConditions #-}
-refConditions= unsafePerformIO $ newIORef (return(), return())
-
-setConditions :: IO() -> IO() -> IO()
--- ^ stablishes the procedures to call before and after saving with 'syncCache', 'clearSyncCache' or 'clearSyncCacheProc'. The postcondition of
--- database persistence should be a commit.
-setConditions pre post= writeIORef refConditions (pre, post)
-
-{-# NOINLINE saving #-}
-saving= unsafePerformIO $ newMVar False
-
-save  tosave = do
-     (pre, post) <-  readIORef refConditions
-     pre    -- !> (concatMap (\(Filtered x) -> keyResource x)tosave)
-     mapM (\(Filtered x) -> writeResource x) tosave
-     post
-
-
-data Filtered= forall a.(IResource a)=> Filtered a
-
-
-extract elems lastSave= filter1 [] [] (0:: Int)  elems
- where
-  filter1 sav val n []= return (sav, val, n)
-  filter1 sav val n ((_, ch@(CacheElem mybe w)):rest)= do
-      mr <- unsafeIOToSTM $ deRefWeak w
-      case mr of
-        Nothing -> unsafeIOToSTM (finalize w) >> filter1 sav val n rest
-        Just (DBRef key  tvr)  ->
-         let  tofilter = case mybe of
-                    Just _ -> ch:val
-                    Nothing -> val
-         in do
-          r <- readTVar tvr
-          case r of
-            Exist (Elem r _ modTime) ->
-        	  if (modTime >= lastSave)
-        	    then filter1 (Filtered r:sav) tofilter (n+1) rest
-        	    else filter1 sav tofilter (n+1) rest -- !> ("rejected->" ++ keyResource r)
-
-            _ -> filter1 sav tofilter (n+1) rest
-
-
--- | 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
--- 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)
-          `Control.Exception.catch`
-          (\(e :: SomeException) -> putMVar tv $ Left e )
-  r <- takeMVar tv
-  case r of
-   Right x -> return x
-   Left e -> throw e
-
-
-
+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE ScopedTypeVariables, ExistentialQuantification,+  FlexibleInstances, UndecidableInstances #-}++{- | TCache is a transactional cache with configurable persistence that permits+STM transactions with objects that synchronize synchronously or asynchronously with+their user defined storages. Persistence in files is provided by default.++ TCache implements 'DBRef's . They are persistent STM references with a typical Haskell interface.+similar to TVars ('newDBRef', 'readDBRef', 'writeDBRef' etc) but with added persistence.+DBRefs are serializable, so they can be stored and retrieved.+Because they are references, they point to other serializable registers.+This permits persistent mutable inter-object relations.++For simple transactions of lists of objects of the same type TCache implements+inversion of control primitives 'withSTMResources' and variants, that call pure user-defined code for registers update. Examples below.++Triggers in "Data.TCache.Triggers" are user-defined hooks that are called on register updates.+They are used internally for indexing.++"Data.TCache.IndexQuery" implements a straightforward pure Haskell, type-safe query language based+ on register field relations. This module must be imported separately.++"Data.TCache.IndexText" add full text search and content search to the query language.++"Data.TCache.DefaultPersistence" has instances for key indexation, serialization+ and default file persistence. The file persistence is more reliable, and the embedded IO reads inside STM transactions are safe.++"Data.Persistent.Collection" implements a persistent, transactional collection with Queue interface as well as indexed access by key.++-}+++++module Data.TCache (+-- * Inherited from 'Control.Concurrent.STM' and variations++ atomically+ ,atomicallySync+ ,STM+ ,unsafeIOToSTM+ ,safeIOToSTM++-- * Operations with cached database references+{-|  'DBRef's are persistent cached database references in the STM monad+with read/write primitives, so the traditional syntax of Haskell STM references+can be used for interfacing with databases. As expected, the DBRefs are transactional,+ because they operate in the STM monad.++A @DBRef@ is associated with its referred object trough its key.+Since DBRefs are serializable, they can be elements of mutable cached objects themselves.+They could point to other mutable objects+and so on, so DBRefs can act as \"hardwired\" relations from mutable objects+to other mutable objects in the database/cache. their referred objects are loaded, saved and flushed+to and from the cache automatically depending on the cache handling policies and the access needs.++@DBRefs@ are univocally identified by its referenced object keys, so they can be compared, ordered, checked for equality, and so on.+The creation of a DBRef, though 'getDBRef' is pure. This permits an efficient lazy access to the+ registers through their DBRefs by lazy marshalling of the register content on demand.++Example: Car registers have references to Person registers.++@+data Person= Person {pname :: String} deriving  (Show, Read, Eq, Typeable)+data Car= Car{owner :: DBRef Person , cname:: String} deriving (Show, Read, Eq, Typeable)+@++Here the Car register point to the Person register through the owner field.++To permit persistence and being referred with DBRefs, define the 'Indexable' instance+for these two register types:++@+instance Indexable Person where key Person{pname= n} = "Person " ++ n+instance Indexable Car where key Car{cname= n} = "Car " ++ n+@++Now we create a DBRef to a Person whose name is \"Bruce\"++>>> let bruce = getDBRef . key $ Person "Bruce" :: DBRef Person++>>> show bruce+>"DBRef \"Person bruce\""++>>> atomically (readDBRef bruce)+>Nothing++'getDBRef' is pure and creates the reference, but not the referred object;+To create both the reference and the DBRef, use 'newDBRef'.+Lets create two Cars and its two Car DBRefs with bruce as owner:++>>> cars <- atomically $ mapM newDBRef [Car bruce "Bat Mobile", Car bruce "Porsche"]++>>> print cars+>[DBRef "Car Bat Mobile",DBRef "Car Porsche"]++>>> carRegs<- atomically $ mapM readDBRef cars+> [Just (Car {owner = DBRef "Person bruce", cname = "Bat Mobile"})+> ,Just (Car {owner = DBRef "Person bruce", cname = "Porsche"})]++try to write with 'writeDBRef':++>>> atomically . writeDBRef bruce $ Person "Other"+>*** Exception: writeDBRef: law of key conservation broken: old , new= Person bruce , Person Other++DBRef's can not be written with objects of different keys:++>>> atomically . writeDBRef bruce $ Person "Bruce"++>>> let Just carReg1= head carRegs++now from the Car register it is possible to recover the owner's register:++>>> atomically $ readDBRef ( owner carReg1)+>Just (Person {pname = "bruce"})++DBRefs, once the referenced, cached object is looked up in the cache and found at creation, do+not perform any further cache lookup afterwards, so reads and writes from/to DBRefs are faster+than *Resource(s) calls, which perform cache lookups every time the object is accessed.++DBRefs and @*Resource(s)@ primitives are completely interoperable. The latter operate implicitly with DBRefs++-}+++,DBRef+,getDBRef+,keyObjDBRef+,newDBRef+--,newDBRefIO+,readDBRef+,readDBRefs+,writeDBRef+,delDBRef++-- * @IResource@ class+{- | Cached objects must be instances of `IResource`.+Such instances can be implicitly derived trough auxiliary classes for file persistence.+-}+,IResource(..)++-- * Operations with cached objects+{- | Implement inversion of control primitives where the user defines the objects to retrieve. The primitives+then call the defined function that determines how to transform the retrieved objects, which are sent+back to the storage and a result is returned.++In this example \"buy\" is a transaction where the user buys an item.+The spent amount is increased and the stock of the product is decreased:++@+data  Data=   User{uname:: String, uid:: String, spent:: Int} |+              Item{iname:: String, iid:: String, price:: Int, stock:: Int}+              deriving (Read, Show)++instance `Indexable` Data where+        `key`   User{uid=id}= id+        `key`   Item{iid=id}= id++user `buy` item= 'withResources'[user,item] buyIt+ where+    buyIt[Just us,Just it]+       | stock it > 0= [us',it']+       | otherwise   = error \"stock is empty for this product\"+      where+       us'= us{spent=spent us + price it}+       it'= it{stock= stock it-1}+    buyIt _ = error \"either the user or the item (or both) does not exist\"+@+-}+,Resources(..)  -- data definition used to communicate object Inserts and Deletes to the cache+,resources      -- empty resources+,withSTMResources+,withResources+,withResource+,getResources+,getResource+,deleteResources+,deleteResource++-- * Trigger operations+{- | Trriggers are called just before an object of the given type is created, modified or deleted.+The DBRef to the object and the new value is passed to the trigger.+The called trigger function has two parameters: the DBRef being accesed+(which still contains the old value), and the new value.+If the content of the DBRef is being deleted, the second parameter is 'Nothing'.+if the DBRef contains Nothing, then the object is being created++Example:++Every time a car is added, or deleted, the owner's list is updated.+This is done by the user defined trigger addCar++@+ addCar pcar (Just(Car powner _ )) = addToOwner powner pcar+ addCar pcar Nothing  = readDBRef pcar >>= \\(Just car)-> deleteOwner (owner car) pcar++ addToOwner powner pcar=do+    Just owner <- readDBRef powner+    writeDBRef powner owner{cars= nub $ pcar : cars owner}++ deleteOwner powner pcar= do+   Just owner <- readDBRef powner+   writeDBRef powner owner{cars= delete  pcar $ cars owner}++ main= do+    'addTrigger' addCar+    putStrLn \"create bruce's register with no cars\"+    bruce \<- 'atomically' 'newDBRef' $ Person \"Bruce\" []+    putStrLn \"add two car register with \\"bruce\\" as owner using the reference to the bruces register\"+    let newcars= [Car bruce \"Bat Mobile\" , Car bruce \"Porsche\"]+    insert newcars+    Just bruceData \<- atomically $ 'readDBRef' bruce+    putStrLn \"the trigger automatically updated the car references of the Bruce register\"+    print . length $ cars bruceData+    print bruceData+@++gives:++> main+> 2+> Person {pname = "Bruce", cars = [DBRef "Car Porsche",DBRef "Car Bat Mobile"]}++-}++,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+,flushAll+,Cache+,setCache+,newCache+--,refcache+,syncCache+,setConditions+,clearSyncCache+,numElems+,statElems+,syncWrite+,SyncMode(..)+,clearSyncCacheProc+,defaultCheck+-- * Other+,onNothing+)+where+++import GHC.Conc+import GHC.MVar(MVar)+import Control.Monad(when, void)+import qualified Data.HashTable.IO as H(BasicHashTable, new, insert, lookup, toList)+import Data.IORef(IORef, newIORef, readIORef, writeIORef)+import System.IO.Unsafe(unsafePerformIO)+import System.IO(hPutStr, stderr)+import Data.Maybe(catMaybes)+import Data.Foldable(forM_)+import Data.Char(isSpace)+import Data.TCache.Defs+import Data.TCache.IResource+import Data.TCache.Triggers+import Data.Typeable(Typeable)+import System.Time(getClockTime, ClockTime(TOD))+import System.Mem(performGC)+import System.Mem.Weak(Weak, deRefWeak, mkWeakPtr, finalize)++import Control.Concurrent.MVar(newMVar, newEmptyMVar, takeMVar, putMVar)+import Control.Exception(catch, handle, throw, evaluate, bracket, SomeException)++--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+-- calls which does not reference dbrefs explicitly+-- The weak reference keeps the dbref alive until is it not referenced elsewere+data CacheElem= forall a.(IResource a,Typeable a) => CacheElem (Maybe (DBRef a)) (Weak(DBRef a))++type Ht = H.BasicHashTable   String  CacheElem++-- contains the hastable, last sync time+type Cache = IORef (Ht , Integer)+data CheckTPVarFlags= AddToHash | NoAddToHash++-- | Set the cache. this is useful for hot loaded modules that will update an existing cache. Experimental+setCache :: Cache -> IO()+setCache ref = readIORef ref >>= \ch -> writeIORef refcache ch++-- | The cache holder. established by default+refcache :: Cache+{-# NOINLINE refcache #-}+refcache =unsafePerformIO $ newCache >>= newIORef++-- |   Creates a new cache. Experimental+newCache  :: IO (Ht , Integer)+newCache =do+        c <- H.new  -- (==) H.hashString+        return (c,0)++-- | Return the  total number of DBRefs in the cache. For debug purposes.+-- This does not count the number of objects in the cache since many of the 'DBRef's+-- may not have the referenced object loaded. It's O(n).+numElems :: IO Int+numElems= do+   (cache, _) <- readIORef refcache+   elems <-   H.toList cache+   return $ length elems+++-- | Retuns some statistical information for the DBRefs in the cache (for debugging)+-- This returns a tuple containing:+-- total : count of the total elements in cache+-- dirty : the elements which need to be written to the persistent storage+-- loaded : the elements which are currently hold in memory+statElems :: IO (Int, Int, Int)+statElems = do+  (cache, lastSync) <- readIORef refcache+  clist <- H.toList cache+  (tosave, elems, size) <- atomically $ extract clist lastSync+  counted <- mapM count elems+  return (size, length tosave, sum counted)+  where+    count (CacheElem _ w) = do+      mr <- deRefWeak w+      case mr of+        Just (DBRef _ tv) -> do+          r <- readTVarIO tv+          case r of+            Exist Elem {} -> return 1+            DoNotExist -> return 0+            NotRead -> return 0+        Nothing -> finalize w >> return 0++-- deRefWeakSTM = unsafeIOToSTM . deRefWeak++--deleteFromCache :: (IResource a, Typeable a) => DBRef a -> IO ()+--deleteFromCache (DBRef k tv)=   do+--    (cache, _) <- readIORef refcache+--    H.delete cache k    -- !> ("delete " ++ k)++fixToCache :: (IResource a, Typeable a) => DBRef a -> IO ()+fixToCache dbref@(DBRef k _)= do+       (cache, _) <- readIORef refcache+       w <- mkWeakPtr dbref  $ Just $ fixToCache dbref+       H.insert cache k (CacheElem (Just dbref) w)+       return()++-- | Return the reference value. If it is not in the cache, it is fetched+-- from the database.+readDBRef :: (IResource a, Typeable a)  => DBRef a -> STM (Maybe a)+readDBRef (DBRef key1  tv)= do+  r <- readTVar tv+  case r of+   Exist (Elem x _ mt) -> do+       t <- unsafeIOToSTM timeInteger+       writeTVar tv  . Exist $ Elem x t mt+       return $ Just x+   DoNotExist -> return Nothing+   NotRead ->  do+       r1 <- safeIOToSTM $ readResourceByKey key1+       case r1 of+         Nothing -> writeTVar tv DoNotExist >> return Nothing+         Just x  -> do+           t <- unsafeIOToSTM timeInteger+           writeTVar tv $ Exist $ Elem  x t (-1)+           return $ Just  x++-- | Read multiple DBRefs in a single request using the new 'readResourcesByKey'+readDBRefs :: (IResource a, Typeable a)  => [DBRef a] -> STM [Maybe a]+readDBRefs dbrefs= do+  let mf (DBRef key1  tv)= do+        r <- readTVar tv+        case r of+          Exist (Elem x _ mt) -> do+            t <- unsafeIOToSTM timeInteger+            writeTVar tv  . Exist $ Elem x t mt+            return $ Right $ Just x+          DoNotExist -> return $ Right Nothing+          NotRead ->  return $ Left key1+  inCache <- mapM mf dbrefs+  let pairs = foldr(\pair@(x,_) xs -> case x of Left _ -> pair:xs; _ -> xs ) [] $ zip inCache dbrefs+  let (toReadKeys, dbrs) = unzip pairs+  let fromLeft (Left k)= k+      fromLeft _ = error "this will never happen"+  rs <- safeIOToSTM . readResourcesByKey $ map fromLeft toReadKeys+  let processTVar (r, DBRef _ tv)=+        case r of+            Nothing -> writeTVar tv DoNotExist+            Just x  -> do+              t <- unsafeIOToSTM timeInteger+              writeTVar tv $ Exist $ Elem  x t (-1)++  mapM_ processTVar $ zip rs dbrs+  let mix (Right x:xs) ys   = x:mix xs ys+      mix (Left _:xs) (y:ys)= y:mix xs ys+      mix [] _ = error "this will never happen(?)"+      mix (Left _:_) [] = error "this will never happen(?)"++  return $ mix inCache rs++-- | Write in the reference a value+-- The new key must be the same than the old key of the previous object stored+-- otherwise, an error "law of key conservation broken" will be raised+--+-- WARNING: the value to be written in the DBRef must be fully evaluated. Delayed evaluations at+-- serialization time can cause inconsistencies in the database.+-- In future releases this will be enforced.+writeDBRef :: (IResource a, Typeable a)  => DBRef a -> a -> STM ()+writeDBRef dbref@(DBRef key1  tv) x= x `seq` do+ let newkey= keyResource x+ if newkey /= key1+   then  error $ "writeDBRef: law of key conservation broken: old , new= " ++ key1 ++ " , "++newkey+   else do+    applyTriggers  [dbref] [Just x]+    t <- unsafeIOToSTM timeInteger++    writeTVar tv $! Exist $! Elem x t t+    return()++instance  (IResource a, Typeable a) => Read (DBRef a) where+    readsPrec _ str1= readit str+       where+       str = dropWhile isSpace str1+       readit ('D':'B':'R':'e':'f':' ':'\"':str2)=+         let   (key1,nstr) =  break (== '\"') str2+         in  [( getDBRef key1 :: DBRef a, tail  nstr)]+       readit  _ = []++-- | Return the key of the object referenced by the DBRef+keyObjDBRef ::  DBRef a -> String+keyObjDBRef (DBRef k _)= k++-- | Get the reference to the object in the cache. If it does not exist, the reference is created empty.+-- Every execution of 'getDBRef' returns the same unique reference to this key,+-- so it can be safely considered pure. This property is useful because deserialization+-- of objects with unused embedded 'DBRef's do not need to marshall them eagerly.+--  This also avoids unnecessary cache lookups of the referenced objects.+{-# NOINLINE getDBRef #-}+getDBRef :: (Typeable a, IResource a) => String -> DBRef a+getDBRef key1 =   unsafePerformIO $! getDBRef1 $! key1 where+ getDBRef1 :: (Typeable a, IResource a) =>  String -> IO (DBRef a)+ getDBRef1 key2 = do+  (cache,_) <-  readIORef refcache   -- !> ("getDBRef "++ key)+  takeMVar getRefFlag+  r <- H.lookup cache  key2+  case r of+   Just (CacheElem  mdb w) -> do+     putMVar getRefFlag ()+     mr <-  deRefWeak w+     case mr of+        Just dbref@(DBRef _ _) ->+                case mdb of+                  Nothing -> return $! castErr dbref     -- !> "just"+                  Just _  -> do+                        H.insert cache key2 (CacheElem Nothing w) --to notify when the DBREf leave its reference+                        return $! castErr dbref+        Nothing -> finalize w >>  getDBRef1 key2          -- !> "finalize"  -- the weak pointer has not executed his finalizer++   Nothing -> do+     tv <- newTVarIO NotRead                              -- !> "Nothing"+     dbref <- evaluate $ DBRef key2  tv+     w <- mkWeakPtr  dbref . Just $ fixToCache dbref+     H.insert cache key2 (CacheElem Nothing w)+     putMVar getRefFlag ()+     return  dbref++getRefFlag :: MVar ()+{-# NOINLINE getRefFlag #-}+getRefFlag= unsafePerformIO $ newMVar ()++{- | Create the object passed as parameter (if it does not exist) and+-- return its reference in the IO monad.+-- If an object with the same key already exists, it is returned as is+-- If not, the reference is created with the new value.+-- If you like to update in any case, use 'getDBRef' and 'writeDBRef' combined+newDBRefIO :: (IResource a,Typeable a) => a -> IO (DBRef a)+newDBRefIO x= do+ let key = keyResource x+ mdbref <- mDBRefIO key+ case mdbref of+   Right dbref -> return dbref++   Left cache -> do+     tv<- newTVarIO  DoNotExist+     let dbref= DBRef key  tv+     w <- mkWeakPtr  dbref . Just $ fixToCache dbref+     H.insert cache key (CacheElem Nothing w)+     t <-  timeInteger+     atomically $ do+       applyTriggers [dbref] [Just x]      --`debug` ("before "++key)+       writeTVar tv  . Exist $ Elem x t t+       return dbref++-}+++----  get a single DBRef if exist+--mDBRefIO+--       :: (IResource a, Typeable a)+--       => String                       -- ^ the list of partial object definitions for which keyResource can be extracted+--       -> IO (Either Ht (DBRef a))     -- ^ ThTCache.hse TVars that contain such objects+--mDBRefIO k= do+--    (cache,_) <-  readIORef refcache+--    r <-   H.lookup cache  k+--    case r of+--     Just (CacheElem _ w) -> do+--        mr <-  deRefWeak w+--        case mr of+--          Just dbref ->  return . Right $! castErr dbref+--          Nothing ->  finalize w >> mDBRefIO k+--     Nothing -> return $ Left cache++++-- | Create the object passed as parameter (if it does not exist) and+-- return its reference in the STM monad.+-- If an object with the same key already exists, it is returned as is+-- If not, the reference is created with the new value.+-- If you like to update in any case, use 'getDBRef' and 'writeDBRef' combined+-- if you  need to create the reference and the reference content, use 'newDBRef'+{-# NOINLINE newDBRef #-}+newDBRef ::   (IResource a, Typeable a) => a -> STM  (DBRef a)+newDBRef x = do+  let ref= getDBRef $! keyResource x++  mr <- readDBRef  ref+  case mr of+    Nothing -> writeDBRef ref x >> return ref -- !> " write"+    Just _ -> return ref                      -- !> " non write"++--newDBRef ::   (IResource a, Typeable a) => a -> STM  (DBRef a)+--newDBRef x = do+--  let key= keyResource x+--  mdbref <-  unsafeIOToSTM $ mDBRefIO  key+--  case mdbref of+--   Right dbref -> return dbref+--   Left cache -> do+--      t  <- unsafeIOToSTM timeInteger+--      tv <- newTVar DoNotExist+--      let dbref= DBRef key  tv+--      (cache,_) <- unsafeIOToSTM $ readIORef refcache+--      applyTriggers [dbref] [Just x]+--      writeTVar tv   . Exist $ Elem x t t+--      unsafeIOToSTM $ do+--        w <- mkWeakPtr dbref . Just $ fixToCache dbref+--        H.insert cache key ( CacheElem Nothing w)+--      return dbref++-- | Delete the content of the DBRef form the cache and from permanent storage+delDBRef :: (IResource a, Typeable a) => DBRef a -> STM()+delDBRef dbref@(DBRef _ tv)= do+  mr <- readDBRef dbref+  case mr of+   Just x -> do+     applyTriggers [dbref] [Nothing]+     writeTVar tv DoNotExist++     safeIOToSTM . criticalSection saving $ delResource x++   Nothing -> return ()++++-- | Handles Nothing cases in a simpler way than runMaybeT.+-- it is used in infix notation. for example:+--+-- @result <- readDBRef ref \`onNothing\` error (\"Not found \"++ keyObjDBRef ref)@+--+-- or+--+-- @result <- readDBRef ref \`onNothing\` return someDefaultValue@+onNothing :: Monad m => m (Maybe b) -> m b -> m b+onNothing io onerr= do+  my <-  io+  case my of+   Just y -> return y+   Nothing -> onerr++-- | Deletes the referenced object from the cache, not the database (see 'delDBRef')+-- useful for cache invalidation when the database is modified by other processes.+flushDBRef ::  (IResource a, Typeable a) =>DBRef a -> STM()+flushDBRef (DBRef _ tv)=   writeTVar  tv  NotRead++-- | flush the element with the given key+flushKey :: String -> STM ()+flushKey key1=  do+   (cache, _) <- unsafeIOToSTM $ readIORef refcache+   c <- unsafeIOToSTM $ H.lookup cache key1+   case c of+       Just  (CacheElem _ w) -> do+          mr <- unsafeIOToSTM $ deRefWeak w+          case mr of+            Just (DBRef _ tv) -> writeTVar  tv  NotRead+            Nothing -> unsafeIOToSTM (finalize w)  >> flushKey key1+       Nothing   -> return ()++-- | label the object as not existent in database+invalidateKey :: String -> STM ()+invalidateKey key1=  do+   (cache, _) <- unsafeIOToSTM $ readIORef refcache+   c <- unsafeIOToSTM $ H.lookup cache key1+   case c of+       Just  (CacheElem _ w) -> do+          mr <- unsafeIOToSTM $ deRefWeak w+          case mr of+            Just (DBRef _ tv) -> writeTVar  tv  DoNotExist+            Nothing -> unsafeIOToSTM (finalize w)  >> flushKey key1+       Nothing   -> return ()+++-- | drops the entire cache.+flushAll :: STM ()+flushAll = do+ (cache, _) <- unsafeIOToSTM $ readIORef refcache+ elms <- unsafeIOToSTM $ H.toList cache+ mapM_ del elms+ where+ del ( _ , CacheElem _ w)= do+      mr <- unsafeIOToSTM $ deRefWeak w+      case mr of+        Just (DBRef _  tv) ->  writeTVar tv NotRead+        Nothing -> unsafeIOToSTM (finalize w)++++-- | This is the main function for the *Resource(s) calls. All the rest derive from it. The results are kept in the STM monad+-- so it can be part of a larger STM transaction involving other DBRefs.+-- The 'Resources' register  returned by the user-defined function  is interpreted as such:+--+--  * 'toAdd':  the content of this field will be added/updated to the cache+--+--  * 'toDelete': the content of this field will be removed from the cache and from permanent storage+--+--  * 'toReturn': the content of this field will be returned by 'withSTMResources'+--+-- WARNING: To catch evaluations errors at the right place, the values to be written must be fully evaluated.+-- Errors in delayed evaluations at serialization time can cause inconsistencies in the database.++withSTMResources :: (IResource a, Typeable a)=> [a]   -- ^ the list of resources to be retrieved+                     -> ([Maybe a]-> Resources a x)   -- ^ The function that process the resources found and return a Resources structure+                     -> STM x                  -- ^ The return value in the STM monad.++withSTMResources rs f = do+  (cache, _) <- unsafeIOToSTM $ readIORef refcache+  mtrs <- takeDBRefs rs cache AddToHash+  mrs <- mapM mreadDBRef mtrs+  case f mrs of+    Retry -> retry+    Resources as ds r -> do+      applyTriggers (map (getDBRef . keyResource) ds) (repeat (Nothing `asTypeOf` Just (head ds)))+      delListFromHash cache ds+      releaseTPVars as cache+      safeIOToSTM . criticalSection saving $ mapM_ delResource ds+      return r+  where+    mreadDBRef :: (IResource a, Typeable a) => Maybe (DBRef a) -> STM (Maybe a)+    mreadDBRef (Just dbref) = readDBRef dbref+    mreadDBRef Nothing = return Nothing+++-- | 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])+++-- |  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 $ void (withSTMResources rs f1)+  where+    f1 mrs =+      let as = f mrs+       in Resources as [] ()++-- | 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 = Resources  [] []+++-- | 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+++{-# 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+       Just  (CacheElem _ w) -> do+          mr <- unsafeIOToSTM $ deRefWeak w+          case mr of+            Just dbref -> return . Just $! castErr dbref+            Nothing -> unsafeIOToSTM (finalize w)  >> takeDBRef cache flags x+       Nothing   ->+           safeIOToSTM $ readToCache flags cache  keyr+              -- unsafeIOToSTM $ readResourceByKey keyr++   where+   readToCache flags1 cache1 key1= do+       mr <- readResource x+       case mr of+            Nothing -> return Nothing+            Just r2 -> do+               ti  <-   timeInteger+               tvr <-   newTVarIO . Exist $ Elem r2 ti (-1)+               case flags1 of+                   NoAddToHash -> return . Just $ DBRef key1  tvr+                   AddToHash   -> do+                      dbref <- evaluate $ DBRef key1  tvr+                      w <- mkWeakPtr  dbref . Just $ fixToCache dbref+                      H.insert cache1 key1 (CacheElem (Just dbref) w)+                      return $ Just dbref+     -- !> ("readToCache "++ key)++++timeInteger :: IO Integer+timeInteger= do TOD t _ <- getClockTime+                return t++++++releaseTPVars :: (IResource a,Typeable a)=> [a] -> Ht  -> STM ()+releaseTPVars rs cache = mapM_  (releaseTPVar cache)  rs++releaseTPVar :: (IResource a,Typeable a)=>  Ht -> a  -> STM ()+releaseTPVar cache  r =do+        c <- unsafeIOToSTM $ H.lookup cache keyr+        case c of+            Just  (CacheElem    _ w) -> do+                mr <-  unsafeIOToSTM $ deRefWeak w+                case mr of+                    Nothing -> unsafeIOToSTM (finalize w) >> releaseTPVar cache  r+                    Just dbref@(DBRef _  tv) -> do+                      applyTriggers [dbref] [Just (castErr r)]+                      t <- unsafeIOToSTM  timeInteger+                      writeTVar tv . Exist  $ Elem  (castErr r)  t t+++            Nothing   ->  do+                ti  <- unsafeIOToSTM timeInteger+                tvr <- newTVar NotRead+                dbref <- unsafeIOToSTM . evaluate $ DBRef keyr  tvr+                applyTriggers [dbref] [Just r]+                writeTVar tvr . Exist $ Elem r ti ti+                w <- unsafeIOToSTM . mkWeakPtr dbref $ Just $ fixToCache dbref+                unsafeIOToSTM $ H.insert cache keyr (CacheElem (Just dbref) w)-- accesed and modified XXX+                return ()+++        where keyr= keyResource r+++++delListFromHash :: IResource a => Ht -> [a] -> STM ()+delListFromHash cache= mapM_ del+ where+ del :: IResource a => a -> STM ()+ del x= do+   let key1= keyResource x+   mr <- unsafeIOToSTM $ H.lookup cache key1+   case mr of+     Nothing -> return ()+     Just (CacheElem _ w) -> do+      mr1 <- unsafeIOToSTM $ deRefWeak w+      case mr1 of+        Just (DBRef _  tv) ->+           writeTVar tv DoNotExist+        Nothing ->+          unsafeIOToSTM (finalize w) >> del  x+++{- never used+updateListToHash hash kv= mapM (update1 hash) kv where+        update1 h (k,v)= H.insert h k v+-}+++-- | Start the thread that periodically call `clearSyncCache` to clean and writes on the persistent storage.+-- it is indirectly 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 ::+         Int                          -- ^ number of seconds betwen checks. objects not written to disk are written+      -> (Integer -> Integer-> Integer-> Bool)  -- ^ The user-defined check-for-cleanup-from-cache for each object. 'defaultCheck' is an example+      -> Int                          -- ^ The max number of objects in the cache, if more, the  cleanup starts+      -> IO ThreadId           -- ^ Identifier of the thread created+clearSyncCacheProc  time check1 sizeObjects= forkIO  clear+ where+ clear = do+     threadDelay $ time * 1000000+     handle ( \ (e :: SomeException)-> hPutStr stderr (show e) >> clear ) $ do+            clearSyncCache   check1 sizeObjects                                        -- !>  "CLEAR"+            clear++criticalSection :: MVar b -> IO c -> IO c+criticalSection mv f= bracket+  (takeMVar mv)+  (putMVar mv)+  $ const f++-- | Force the atomic write of all cached objects modified since the last save into permanent storage.+-- Cache writes allways save a coherent state. As always, only the modified objects are written.+syncCache ::  IO ()+syncCache  = criticalSection saving $ do+      (cache,lastSync) <- readIORef refcache  --`debug` "syncCache"+      t2<- timeInteger+      elems <- H.toList cache+      (tosave,_,_) <- atomically $ extract elems lastSync+      save tosave+      writeIORef refcache (cache, t2)+++data SyncMode= Synchronous   -- ^ sync state to permanent storage when `atomicallySync` is invoked+             | Asynchronous+                  {frequency  :: Int                     -- ^ number of seconds between saves when asynchronous+                  ,check      :: Integer-> Integer-> Integer-> Bool  -- ^ The user-defined check-for-cleanup-from-cache for each object. 'defaultCheck' is an example+                  ,cacheSize  :: Int                     -- ^ size of the cache when async+                  }+             | SyncManual               -- ^ use `syncCache` to write the state+++++{-# NOINLINE tvSyncWrite #-}+tvSyncWrite :: IORef (SyncMode, Maybe a)+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+  forM_ thread killThread+  case mode of+    Synchronous -> modeWrite+    SyncManual -> modeWrite+    Asynchronous time check1 maxsize -> do+      th <- void $ clearSyncCacheProc time check1 maxsize+      writeIORef tvSyncWrite (mode, Just th)+  where+    modeWrite = writeIORef tvSyncWrite (mode, Nothing)+++-- | Perform a synchronization of the cache with permanent storage once executed the STM transaction+-- when 'syncWrite' policy is `Synchronous`+atomicallySync :: STM a -> IO a+atomicallySync proc=do+   r <- atomically  proc+   sync+   return r++   where+   sync= do+       (savetype,_) <- readIORef tvSyncWrite+       case  savetype of+        Synchronous -> syncCache+        _ -> return ()+++-- |Saves the unsaved elems of the cache.+-- Cache writes allways save a coherent state.+--  Unlike `syncCache` this call deletes some elems from the cache when the number of elems > @sizeObjects@.+--  The deletion depends on the check criteria, expressed by the first parameter.+--  'defaultCheck' is the one implemented to be passed by default. Look at it to understand the clearing criteria.+clearSyncCache ::  (Integer -> Integer-> Integer-> Bool)-> Int -> IO ()+clearSyncCache check1 sizeObjects= criticalSection saving $ do+      (cache,lastSync) <- readIORef refcache+      t <- timeInteger+      elems <- H.toList cache+      (tosave, elems1, size) <- atomically $ extract elems lastSync+      save tosave+      when (size > sizeObjects) $  forkIO (filtercache t cache lastSync elems1) >> performGC+      writeIORef refcache (cache, t)+++  where++  -- delete elems from the cache according with the checking criteria+  filtercache t cache lastSync = mapM_ filter1+    where+    filter1 (CacheElem Nothing _)= return()  --alive because the dbref is being referenced elsewere+    filter1 (CacheElem (Just (DBRef key1 _)) w) = do+     mr <-  deRefWeak w+     case mr of+       Nothing ->    finalize w+       Just (DBRef _  tv) -> atomically $ do+         r <- readTVar tv+         case r of+            Exist (Elem _ lastAccess _ ) ->+                when (check1 t lastAccess lastSync) $ do+                    unsafeIOToSTM . H.insert cache key1 $ CacheElem Nothing w+                    writeTVar tv NotRead+            _    ->  return()++++-- | This is a default cache clearance check. It forces to drop from the cache all the+-- elems not accesed since half the time between now and the last sync+-- if it returns True, the object will be discarded from the cache+-- it is invoked when the cache size exceeds the number of objects configured+-- in 'clearSyncCacheProc' or 'clearSyncCache'+defaultCheck+       :: Integer    -- ^ current time in seconds+       -> Integer    -- ^ last access time for a given object+       -> Integer    -- ^ last cache synchronization (with the persisten storage)+       -> Bool       -- ^ return true for all the elems not accesed since half the time between now and the last sync+defaultCheck  now lastAccess lastSync+        | lastAccess > halftime = False+        | otherwise  = True++    where+    halftime= now- (now-lastSync) `div` 2++{-# NOINLINE refConditions #-}+refConditions :: IORef (IO (), IO ())+refConditions= unsafePerformIO $ newIORef (return(), return())++setConditions :: IO() -> IO() -> IO()+-- ^ stablishes the procedures to call before and after saving with 'syncCache', 'clearSyncCache' or 'clearSyncCacheProc'. The postcondition of+-- database persistence should be a commit.+setConditions pre post= writeIORef refConditions (pre, post)++{-# NOINLINE saving #-}+saving :: MVar Bool+saving= unsafePerformIO $ newMVar False++save :: Foldable t => t Filtered -> IO ()+save  tosave = do+     (pre, post) <-  readIORef refConditions+     pre    -- !> (concatMap (\(Filtered x) -> keyResource x)tosave)+     mapM_ (\(Filtered x) -> writeResource x) tosave+     post+++data Filtered= forall a.(IResource a)=> Filtered a+++extract :: [(a, CacheElem)] -> Integer -> STM ([Filtered], [CacheElem], Int)+extract elems lastSave= filter1 [] [] (0:: Int)  elems+ where+  filter1 sav val n []= return (sav, val, n)+  filter1 sav val n ((_, ch@(CacheElem mybe w)):rest)= do+      mr <- unsafeIOToSTM $ deRefWeak w+      case mr of+        Nothing -> unsafeIOToSTM (finalize w) >> filter1 sav val n rest+        Just (DBRef _  tvr)  ->+         let  tofilter = case mybe of+                    Just _ -> ch:val+                    Nothing -> val+         in do+          r <- readTVar tvr+          case r of+            Exist (Elem r1 _ modTime) ->+                  if modTime >= lastSave+                    then filter1 (Filtered r1:sav) tofilter (n+1) rest+                    else filter1 sav tofilter (n+1) rest -- !> ("rejected->" ++ keyResource r)++            _ -> filter1 sav tofilter (n+1) rest+++-- | 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+-- 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)+          `Control.Exception.catch`+          (\(e :: SomeException) -> putMVar tv $ Left e )+  r <- takeMVar tv+  case r of+   Right x -> return x+   Left e -> throw e+

@@ -1,9 +1,7 @@-{-# LANGUAGE   FlexibleInstances, UndecidableInstances-               , MultiParamTypeClasses, FunctionalDependencies--               , ExistentialQuantification-               , ScopedTypeVariables-                #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE FlexibleInstances, UndecidableInstances,+  MultiParamTypeClasses, ExistentialQuantification,+  ScopedTypeVariables #-}  {- | This module decouples the 'IResource" class in two classes  one for key extraction 'Indexable' and other ('Serializable" for serlalization and persistence@@ -20,18 +18,13 @@ ,filePersist ,Persist(..)) where -import System.IO.Unsafe import Data.Typeable-import Data.Maybe(fromJust)
 import Data.TCache.Defs import Data.TCache --- instance  (Typeable a,  Indexable a, Serializable a) => IResource a where   keyResource = key-  writeResource =defWriteResource+  writeResource = defWriteResource   readResourceByKey = defReadResourceByKey   delResource = defDelResource 

@@ -1,4 +1,4 @@-{-# LANGUAGE   TypeSynonymInstances, FlexibleInstances, ScopedTypeVariables, DeriveDataTypeable #-}+{-# LANGUAGE   FlexibleInstances, ScopedTypeVariables, DeriveDataTypeable #-}  {- | some internal definitions. To use default persistence, import @Data.TCache.DefaultPersistence@ instead -}@@ -7,43 +7,47 @@ import Data.Typeable import Control.Concurrent.STM(TVar) -import Data.TCache.IResource- import System.IO.Unsafe import Data.IORef import System.Directory-import Control.Monad(when,replicateM) import System.IO import System.IO.Error import Control.Exception as Exception-import Control.Concurrent import Data.List(elemIndices,isInfixOf)-import Data.Maybe(fromJust)+import Data.Maybe(fromJust, fromMaybe)  import qualified Data.ByteString.Lazy.Char8 as B  --import Debug.Trace --(!>) = flip trace-
-type AccessTime = Integer
-type ModifTime  = Integer
-
 -data Status a= NotRead | DoNotExist | Exist a deriving Typeable+type AccessTime = Integer+type ModifTime  = Integer -data Elem a= Elem !a !AccessTime !ModifTime   deriving Typeable-
-type TPVar a=   TVar (Status(Elem a)) -data DBRef a= DBRef !String  !(TPVar a)  deriving Typeable+data Status a = NotRead | DoNotExist | Exist a deriving Typeable +data Elem a = Elem !a !AccessTime !ModifTime   deriving Typeable -
+type TPVar a =   TVar (Status(Elem a))++data DBRef a = DBRef !String  !(TPVar a)  deriving Typeable++instance  Show (DBRef a) where+  show (DBRef key1 _)= "DBRef \""++ key1 ++ "\""++instance Eq (DBRef a) where+  DBRef k _ == DBRef k' _ =  k == k'++instance Ord (DBRef a) where+  compare (DBRef k _) (DBRef k' _) = compare k k'++castErr :: (Typeable a1, Typeable a2) => a1 -> a2 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 previously stored one for the same key\n"-      Just x  -> x+  r = fromMaybe+      (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 previously stored one for the same key\n")+      (cast a)   {- | Indexable is an utility class used to derive instances of IResource@@ -63,9 +67,9 @@ @ -} class Indexable a where-    key:: a -> String+    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/"
+    -- 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@@ -101,9 +105,9 @@ class Serializable a  where   serialize   :: a -> B.ByteString   deserialize :: B.ByteString -> a-  deserialize= error "No deserialization defined for your data"+  deserialize = error "No deserialization defined for your data"   deserialKey :: String -> B.ByteString -> a-  deserialKey _ v= deserialize v+  deserialKey _ = deserialize   setPersist  :: a -> Maybe Persist              -- ^ `defaultPersist` if Nothing   setPersist =  const Nothing @@ -121,26 +125,33 @@ -- | a persist mechanism has to implement these three primitives -- 'filePersist' is the default file persistence data Persist = Persist{-       readByKey   ::  (Key -> IO(Maybe B.ByteString)) -- ^  read by key. It must be strict-     , write       ::  (Key -> B.ByteString -> IO())   -- ^  write. It must be strict-     , delete      ::  (Key -> IO())}                  -- ^  delete+       readByKey   ::  Key -> IO(Maybe B.ByteString) -- ^  read by key. It must be strict+     , write       ::  Key -> B.ByteString -> IO()   -- ^  write. It must be strict+     , delete      ::  Key -> IO()}                  -- ^  delete  -- | Implements default default-persistence of objects in files with their keys as filenames+filePersist :: Persist filePersist   = Persist     {readByKey= defaultReadByKey     ,write    = defaultWrite     ,delete   = defaultDelete} +defaultPersistIORef :: IORef Persist+{-# NOINLINE defaultPersistIORef #-} defaultPersistIORef = unsafePerformIO $ newIORef  filePersist  -- | Set the default persistence mechanism of all 'serializable' objects that have -- @setPersist= const Nothing@. By default it is 'filePersist' -- -- this statement must be the first one before any other TCache call-setDefaultPersist p= writeIORef defaultPersistIORef p+setDefaultPersist :: Persist -> IO ()+setDefaultPersist = writeIORef defaultPersistIORef +{-# NOINLINE getDefaultPersist #-}+getDefaultPersist :: Persist getDefaultPersist =  unsafePerformIO $ readIORef defaultPersistIORef +getPersist :: (Serializable a, Typeable a) => a -> Persist getPersist x= unsafePerformIO $ case setPersist x of      Nothing -> readIORef defaultPersistIORef      Just p  -> return p@@ -149,85 +160,89 @@                                                          ++ "error was:" ++ show e)  -defaultReadByKey ::   String-> IO (Maybe B.ByteString)
+defaultReadByKey ::   String-> IO (Maybe B.ByteString) defaultReadByKey k= iox   -- !> "defaultReadByKey"      where-     iox = handle handler $ do   
-             s <-  readFileStrict  k 
-             return $ Just   s                                                       -- `debug` ("read "++ filename)
+     iox = handle handler $ do+             s <-  readFileStrict  k+             return $ Just   s                                                       -- `debug` ("read "++ filename) - 
-     handler ::  IOError ->  IO (Maybe B.ByteString)
-     handler  e
-      | isAlreadyInUseError e = defaultReadByKey  k                         
++     handler ::  IOError ->  IO (Maybe B.ByteString)+     handler  e+      | isAlreadyInUseError e = defaultReadByKey  k       | isDoesNotExistError e = return Nothing-      | otherwise= if ("invalid" `isInfixOf` ioeGetErrorString e)+      | otherwise= if "invalid" `isInfixOf` ioeGetErrorString e          then             error $  "defaultReadByKey: " ++ show e ++ " defPath and/or keyResource are not suitable for a file path:\n"++ k++"\""-              
+          else defaultReadByKey  k   defaultWrite :: String-> B.ByteString -> IO()-defaultWrite filename x= safeWrite filename  x+defaultWrite = safeWrite++safeWrite :: FilePath -> B.ByteString -> IO () safeWrite filename str= handle  handler  $ B.writeFile filename str   -- !> ("write "++filename)-     where          
-     handler e-- (e :: IOError)
-       | isDoesNotExistError e=do 
-                  createDirectoryIfMissing True $ take (1+(last $ elemIndices '/' filename)) filename   --maybe the path does not exist
-                  safeWrite filename str               
+     where+     handler e-- (e :: IOError)+       | isDoesNotExistError e=do+                  createDirectoryIfMissing True $ take (1 + last (elemIndices '/' filename)) filename   --maybe the path does not exist+                  safeWrite filename str  -       | otherwise= if ("invalid" `isInfixOf` ioeGetErrorString e)+       | otherwise= if "invalid" `isInfixOf` ioeGetErrorString e              then-                error  $ "defaultWriteResource: " ++ show e ++ " defPath and/or keyResource are not suitable for a file path: "++ filename
+                error  $ "defaultWriteResource: " ++ show e ++ " defPath and/or keyResource are not suitable for a file path: "++ filename              else do                 hPutStrLn stderr $ "defaultWriteResource:  " ++ show e ++  " in file: " ++ filename ++ " retrying"                 safeWrite filename str-              
+ defaultDelete :: String -> IO()-defaultDelete filename =do+defaultDelete filename =      handle (handler filename) $ removeFile filename-
+      where-
-     handler :: String -> IOException -> IO ()
-     handler file e
++     handler :: String -> IOException -> IO ()+     handler _ e        | isDoesNotExistError e= return ()  --`debug` "isDoesNotExistError"        | isAlreadyInUseError e= do             hPutStrLn stderr $ "defaultDelResource: busy"  ++  " in file: " ++ filename ++ " retrying" --            threadDelay 100000   --`debug`"isAlreadyInUseError"-            defaultDelete filename  
+            defaultDelete filename        | otherwise = do-            hPutStrLn stderr $ "defaultDelResource:  " ++ show e ++  " in file: " ++ filename ++ " retrying"
+            hPutStrLn stderr $ "defaultDelResource:  " ++ show e ++  " in file: " ++ filename ++ " retrying" --           threadDelay 100000     --`debug` ("otherwise " ++ show e)             defaultDelete filename -
 ++defReadResourceByKey :: (Indexable a, Serializable a, Typeable a) => String -> IO (Maybe a) defReadResourceByKey k= iox where     iox= do       let Persist f _ _ = getPersist  x       f  file >>=  evaluate . fmap  (deserialKey k)       where       file= defPath x ++ k-      x= undefined `asTypeOf` (fromJust $ unsafePerformIO iox)+      x= undefined `asTypeOf` fromJust (unsafePerformIO iox) +defWriteResource :: (Indexable a, Serializable a, Typeable a) => a -> IO () defWriteResource s= do       let Persist _ f _ = getPersist  s       f (defPath s ++ key s) $ serialize s +defDelResource :: (Indexable a, Serializable a, Typeable a) => a -> IO () defDelResource s= do       let Persist _ _ f = getPersist s       f $ defPath s ++ key s-
-
--- | Strict read from file, needed for default file persistence
+++-- | Strict read from file, needed for default file persistence+readFileStrict :: FilePath -> IO B.ByteString readFileStrict f = openFile f ReadMode >>= \ h -> readIt h `finally` hClose h   where-  readIt h= do
-      s   <- hFileSize h
-      let n= fromIntegral s
-      str <- B.hGet h n
-      return str-+  readIt h= do+      s   <- hFileSize h+      let n= fromIntegral s+      B.hGet h n

@@ -1,38 +1,27 @@  {-# LANGUAGE   ScopedTypeVariables     , UndecidableInstances, FlexibleInstances #-}-module Data.TCache.IResource where
+module Data.TCache.IResource where -import Data.Typeable-import System.IO.Unsafe-import Control.Concurrent.STM-import Control.Concurrent
-import Control.Exception as Exception-import System.IO
-import System.IO.Error-import Data.List(elemIndices)-import Control.Monad(when,replicateM)-import Data.List(isInfixOf)-
-
+ {- | Must be defined for every object to be cached. -}-class IResource a where 
-        {- The `keyResource string must be a unique  since this is used to index it in the hash table. 
-        when accessing a resource, the user must provide a partial object for wich the key can be obtained.
+class IResource a where+        {- The `keyResource string must be a unique  since this is used to index it in the hash table.+        when accessing a resource, the user must provide a partial object for wich the key can be obtained.         for example:-        
-        @data Person= Person{name, surname:: String, account :: Int ....)
-        
-        keyResource Person n s ...= n++s@
-        
++        @data Person= Person{name, surname:: String, account :: Int ....)++        keyResource Person n s ...= n++s@+         the data being accesed must define the fields used by keyResource. For example -         @  readResource Person {name="John", surname= "Adams"}@
-        
+         @  readResource Person {name="John", surname= "Adams"}@+         leaving the rest of the fields undefined -        when using default file persistence, the key is used as file name. so it must contain valid filename characters
-        
+        when using default file persistence, the key is used as file name. so it must contain valid filename characters+         -}         keyResource :: a -> String             -- ^ must be defined @@ -45,7 +34,7 @@         . However, because it is executed by 'safeIOToSTM' it is guaranteed that the execution is not interrupted.         -}         readResourceByKey :: String -> IO(Maybe a)-        readResourceByKey k= return . head =<< readResourcesByKey [k]+        readResourceByKey k= head <$> readResourcesByKey [k]         -- | hopefully optimized read of many objects by key.         readResourcesByKey :: [String] -> IO [Maybe a]         readResourcesByKey = mapM readResourceByKey@@ -55,7 +44,7 @@         readResource :: a -> IO (Maybe a)         readResource x = readResourceByKey $ keyResource x -        -- | To write into persistent storage. It must be strict.  
+        -- | To write into persistent storage. It must be strict.         -- Since STM transactions may retry, @writeResource@ must be idempotent, not only in the result but also in the effect in the database.         -- . However, because it is executed by 'safeIOToSTM' it is guaranteed that the execution is not interrupted.         -- All the new obbects are writeen to the database on synchromization,@@ -63,165 +52,30 @@         -- Commit code must be located in the postcondition. (see  `setConditions`)         -- Since there is no provision for rollback from failure in writing to         -- persistent storage, 'writeResource' must retry until success.-    	writeResource:: a-> IO()-    	writeResource r= writeResources [r]-    	-    	-- | multiple write (hopefully) in a single request. That is up to you and your backend-    	-- . Defined by default as 'mapM_ writeResource'-    	writeResources :: [a] -> IO()-    	writeResources= mapM_ writeResource+        writeResource:: a-> IO()+        writeResource r= writeResources [r] -        -- | Delete the resource. It is called syncronously. So it must commit   
-    	delResource:: a-> IO()-    	delResource x= delResources [x]-    	
-        delResources :: [a] -> IO()
-        delResources= mapM_ delResource
--- | Resources data definition used by 'withSTMResources'    
+        -- | multiple write (hopefully) in a single request. That is up to you and your backend+        -- . Defined by default as 'mapM_ writeResource'+        writeResources :: [a] -> IO()+        writeResources= mapM_ writeResource++        -- | Delete the resource. It is called syncronously. So it must commit+        delResource:: a-> IO()+        delResource x= delResources [x]++        delResources :: [a] -> IO()+        delResources= mapM_ delResource+-- | Resources data definition used by 'withSTMResources' data Resources a b        = Retry             -- ^ forces a retry-       | Resources
+       | Resources           { toAdd :: [a]    -- ^ resources to be inserted back in the cache-          , toDelete :: [a] -- ^ resources to be deleted from the cache and from permanent storage
-          , toReturn :: b   -- ^ result to be returned
+          , toDelete :: [a] -- ^ resources to be deleted from the cache and from permanent storage+          , toReturn :: b   -- ^ result to be returned           }-
 --- | Empty resources: @resources= Resources  [] [] ()@-resources :: Resources a ()
-resources =  Resources  [] [] ()
-
 -{---{- | Indexable is an utility class used to derive instances of IResource--Example:--@data Person= Person{ pname :: String, cars :: [DBRef Car]} deriving (Show, Read, Typeable)-data Car= Car{owner :: DBRef Person , cname:: String} deriving (Show, Read, Eq, Typeable)-@--Since Person and Car are instances of 'Read' ans 'Show', by defining the 'Indexable' instance-will implicitly define the IResource instance for file persistence:--@-instance Indexable Person where  key Person{pname=n} = \"Person \" ++ n-instance Indexable Car where key Car{cname= n} = \"Car \" ++ n-@--}-class Indexable a where-    key:: a -> String-    defPath :: a -> String       -- ^ additional extension for default file paths.-                                -- The default value is "data/".--                                -- 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--{- | Serialize is an abstract serialization ionterface in order to define implicit instances of IResource.-The deserialization must be as lazy as possible if deserialized objects contain DBRefs,-lazy deserialization avoid unnecesary DBRef instantiations when they are not accessed,-since DBRefs instantiations involve extra cache lookups-For this reason serialization/deserialization is to/from ordinary Strings-serialization/deserialization are not performance critical in TCache--}-class Serializable a where-  serialize   :: a -> String-  deserialize :: String -> a----}----{--defaultReadResource :: (Serializable a, Indexable a, Typeable a) =>  a -> IO (Maybe a)-defaultReadResource x= defaultReadResourceByKey $ key x---defaultReadResourceByKey :: (Serializable a, Indexable a) =>  String-> IO (Maybe a)
-defaultReadResourceByKey k= iox-     where-     iox = handle handler $ do   
-             s <-  readFileStrict  filename :: IO String 
-             return $ Just (deserialize s )                                                         -- `debug` ("read "++ filename)
-     
-     filename=  defPathIO iox  ++ k--     defPathIO :: (Serializable a, Indexable a)=> IO (Maybe a) -> String-     defPathIO iox= defPath x-       where-       Just x= unsafePerformIO $ (return $ Just undefined)  `asTypeOf`  iox-- 
-     handler :: (Serializable a, Indexable a) =>   IOError ->  IO (Maybe a)
-     handler  e
-      | isAlreadyInUseError e = defaultReadResourceByKey  k                         
-      | isDoesNotExistError e = return Nothing-      | otherwise= if ("invalid" `isInfixOf` ioeGetErrorString e)-         then-            error $ ( "readResource: " ++ show e) ++ " defPath and/or keyResource are not suitable for a file path"-              
-         else defaultReadResourceByKey  k---defaultWriteResource :: (Serializable a, Indexable a) => a-> IO()-defaultWriteResource x= safeWrite filename (serialize x)   --  `debug` ("write "++filename)
-  where-  filename= defPath x ++ key x--safeWrite filename str= handle  handler  $ writeFile filename str-     where          
-     handler  (e :: IOError)
-       | isDoesNotExistError e=do 
-                  createDirectoryIfMissing True $ take (1+(last $ elemIndices '/' filename)) filename   --maybe the path does not exist
-                  safeWrite filename str               
--       | otherwise =do-                --phPutStrLn stderr $ "defaultWriteResource:  " ++ show e ++  " in file: " ++ filename ++ " retrying"
-                safeWrite filename str-              
-defaultDelResource :: (Indexable a) => a -> IO()-defaultDelResource x=  handle (handler filename) $ removeFile filename  --`debug` ("delete "++filename)
-     where-     filename= defPath x ++ key x
-     handler :: String -> IOError -> IO ()
-     handler file e
-       | isDoesNotExistError e= return ()-       | isAlreadyInUseError e= do-            --hPutStrLn stderr $ "defaultDelResource: busy"  ++  " in file: " ++ filename ++ " retrying"-            threadDelay 1000000-            defaultDelResource x   
-       | otherwise = do-           --hPutStrLn stderr $ "defaultDelResource:  " ++ show e ++  " in file: " ++ filename ++ " retrying"
-           threadDelay 1000000-           defaultDelResource x-
--
-
--- | Strict read from file, needed for default file persistence
-readFileStrict f = openFile f ReadMode >>= \ h -> readIt h `finally` hClose h-  where-  readIt h= do
-      s   <- hFileSize h
-      let n= fromIntegral s
-      str <- replicateM n (hGetChar h) 
-      return str
-    
--newtype Transient a= Transient a---- | Transient wraps any indexable object for living in the cache, but not--- in persistent storage. This is useful for memoization.--- @Transient x@ is neither writeen nor read.-instance Indexable a => IResource (Transient a) where-   keyResource (Transient x)= key x-   readResourceByKey = const $ return Nothing-   writeResource= const $ return ()-   delResource = const $ return ()---}+-- | Empty resources: @resources= Resources  [] [] ()@+resources :: Resources a ()+resources =  Resources  [] [] ()

@@ -69,9 +69,9 @@  -} -{-# LANGUAGE  DeriveDataTypeable, MultiParamTypeClasses-, FunctionalDependencies, FlexibleInstances, UndecidableInstances-, TypeSynonymInstances, IncoherentInstances, OverlappingInstances #-}+{-# LANGUAGE DeriveDataTypeable, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances,+ FlexibleContexts, UndecidableInstances, TypeSynonymInstances, IncoherentInstances, MonoLocalBinds #-}+ module Data.TCache.IndexQuery(   index , (.==.)@@ -91,12 +91,8 @@ import Data.TCache.Defs import Data.List import Data.Typeable-import Control.Concurrent.STM-import Data.Maybe (catMaybes)+import Data.Maybe (catMaybes, fromMaybe) import qualified Data.Map  as M-import Data.IORef-import qualified  Data.Map as M-import System.IO.Unsafe import Data.ByteString.Lazy.Char8(pack, unpack)  @@ -117,8 +113,8 @@   delResource = defDelResource  --data Index reg a= Index (M.Map a [DBRef reg]) deriving ( Show, Typeable)+-- was data before hlint suggested to use a newtype here+newtype Index reg a= Index (M.Map a [DBRef reg]) deriving ( Show, Typeable)  instance (IResource reg, Typeable reg, Ord a, Read a)    => Read (Index reg a) where@@ -129,19 +125,20 @@ instance (Queriable reg a) => Serializable (Index reg a)  where   serialize= pack . show   deserialize= read . unpack-  setPersist index= persistIndex $ getType index+  setPersist index1= persistIndex $ getType index1     where     getType :: Index reg a -> reg     getType= undefined -- type level   +keyIndex :: (Show a1, Show a2) => a1 -> a2 -> String keyIndex treg tv= "index-" ++ show treg ++ show tv  instance (Typeable reg, Typeable a) => Indexable (Index reg a) where-   key map= keyIndex typeofreg typeofa+   key map1= keyIndex typeofreg typeofa        where-       [typeofreg, typeofa]= typeRepArgs $! typeOf map+       [typeofreg, typeofa]= typeRepArgs $! typeOf map1 --   defPath index= defPath $ ofRegister index --       where --       ofRegister :: Index reg a -> reg@@ -165,7 +162,11 @@ getIndexr rindex val= do    mindex <- readDBRef rindex -   let index = case mindex of Just (Index index) ->  index; _ -> M.empty+   let index = case mindex of +        Just (Index index) ->  index+        _ -> do+             let fields= show $ typeOf  rindex+             error $ "the index for "++ fields ++" do not exist. At main, use \"Data.TCache.IdexQuery.index\" to start indexing this field"     let dbrefs= case M.lookup  val index of         Just  dbrefs -> dbrefs@@ -178,9 +179,9 @@       ) =>      (reg -> a) -> DBRef (Index reg a) -> DBRef reg -> Maybe reg -> STM () -selectorIndex selector rindex pobject mobj = do+selectorIndex selector rindex1 pobject mobj1 = do    moldobj <- readDBRef pobject-   choice moldobj mobj+   choice moldobj mobj1    where    choice moldobj mobj=     case (moldobj, mobj) of@@ -194,34 +195,37 @@       (Just oldobj, Nothing) -> do  -- delete the old selector value from the index           let val= selector oldobj-          (rindex,Index index, dbrefs) <-  getIndexr rindex val+          (rindex,Index index2, dbrefs) <-  getIndexr rindex1 val           let dbrefs'=   Data.List.delete pobject  dbrefs-          writeDBRef rindex $ Index (M.insert  val dbrefs' index)+          writeDBRef rindex $ Index (M.insert  val dbrefs' index2)       (Nothing, Just obj) ->  do      -- add the new value to the index           let val= selector obj-          (rindex,Index index, dbrefs) <-  getIndexr rindex val+          (rindex,Index index2, dbrefs) <-  getIndexr rindex1 val           let dbrefs'=   nub $ Data.List.insert pobject  dbrefs-          writeDBRef rindex $ Index (M.insert  val dbrefs' index)+          writeDBRef rindex $ Index (M.insert  val dbrefs' index2)  {- | Register a trigger for indexing the values of the field passed as parameter.  the indexed field can be used to perform relational-like searches -} -index-  :: (Queriable reg a) =>-     (reg -> a) -> IO ()+index :: (Queriable reg a) => (reg -> a) -> IO () index sel= do    let [one, two]= typeRepArgs $! typeOf sel        rindex= getDBRef $! keyIndex one two    addTrigger $ selectorIndex sel rindex    let proto= Index M.empty  `asTypeOf` indexsel sel-   withResources [proto]  $ init proto+   withResources [proto]  $ init1 proto    where-   init proto [Nothing]  =  [proto]-   init _ [Just _] = []+   init1 proto [Nothing]  =  [proto]+   init1 _ [Just _] = []+   init1 _ (Nothing:_:_) = error "this will never happen(?)"+   init1 _ (Just _:_:_) = error "this will never happen(?)"+   init1 _ [] = error "this will never happen(?)"+    indexsel :: (reg-> a)  -> Index reg a    indexsel= undefined+ -- | implement the relational-like operators, operating on record fields class RelationOps field1 field2 res | field1 field2 -> res  where     (.==.) :: field1 -> field2 -> STM  res@@ -251,9 +255,9 @@   return $ mix  idxs  idxs'   where   opv (v, _ )(v', _)= v `op` v'-  mix    xs  ys=-      let zlist= [(x,y) |  x <- xs , y <- ys, x `opv` y]-      in map ( \(( _, xs),(_ ,ys)) ->(xs,ys)) zlist+  mix xs1  ys1 =+      let zlist= [(x,y) |  x <- xs1 , y <- ys1, x `opv` y]+      in map ( \(( _, xs2),(_ ,ys2)) ->(xs2, ys2)) zlist  type JoinData reg reg'=[([DBRef reg],[DBRef reg'])] @@ -277,13 +281,11 @@ instance SetOperations  [DBRef a] [DBRef a] [DBRef a] where     (.&&.) fxs fys= do      xs <- fxs-     ys <- fys-     return $ intersect xs ys+     intersect xs <$> fys      (.||.) fxs fys= do      xs <- fxs-     ys <- fys-     return $ union xs ys+     union xs <$> fys  infixr 4 .&&. infixr 3 .||.@@ -292,12 +294,12 @@     (.&&.) fxs fys= do      xss <- fxs      ys <- fys-     return [(intersect xs ys, zs) | (xs,zs) <- xss]+     return [(xs `intersect` ys, zs) | (xs,zs) <- xss]      (.||.) fxs fys= do      xss <- fxs      ys <- fys-     return [(union xs ys, zs) | (xs,zs) <- xss]+     return [(xs `union` ys, zs) | (xs,zs) <- xss]  instance SetOperations  [DBRef a] (JoinData a a')  (JoinData a a') where     (.&&.) fxs fys=  fys .&&. fxs@@ -307,12 +309,12 @@     (.&&.) fxs fys= do      xss <- fxs      ys <- fys-     return [(zs,intersect xs ys) | (zs,xs) <- xss]+     return [(zs, xs `intersect` ys) | (zs,xs) <- xss]      (.||.) fxs fys= do      xss <- fxs      ys <- fys-     return [(zs, union xs ys) | (zs,xs) <- xss]+     return [(zs, xs `union` ys) | (zs,xs) <- xss]   -- |  return all  the (indexed)  values which this field has and a DBRef pointer to the register@@ -322,23 +324,22 @@    let rindex= getDBRef $! keyIndex one two    mindex <- readDBRef rindex    case mindex of-     Just (Index index) -> return $ M.toList index;+     Just (Index index1) -> return $ M.toList index1;      _ -> do         let fields= show $ typeOf  selector-        error $ "the index for "++ fields ++" do not exist. At main, use \"Data.TCache.IdexQuery.index\" to start indexing this field"+        error $ "the index for "++ fields ++" do not exist. At main, use \"Data.TCache.IndexQuery.index\" to start indexing this field"  retrieve :: Queriable reg a => (reg -> a) -> a -> (a -> a -> Bool) -> STM[DBRef reg] retrieve field value op= do-   index <- indexOf field-   let higuer = map (\(v, vals) -> if op v value then  vals else [])  index+   index1 <- indexOf field+   let higuer = map (\(v, vals) -> if op v value then  vals else [])  index1    return $ concat higuer  -- from a Query result, return the records, rather than the references recordsWith   :: (IResource a, Typeable a) =>      STM [DBRef a] -> STM [ a]-recordsWith dbrefs= dbrefs >>= mapM readDBRef >>= return . catMaybes-+recordsWith dbrefs= catMaybes <$> (dbrefs >>= mapM readDBRef)   class Select  selector a res | selector a -> res  where@@ -353,23 +354,23 @@   instance (Typeable reg, IResource reg) =>  Select (reg -> a) (STM [DBRef reg])  (STM [a]) where-  select sel xs= return . map sel  =<< return . catMaybes =<< mapM readDBRef  =<< xs+  select sel xs= map sel <$> (catMaybes <$> (mapM readDBRef =<< xs))   instance  (Typeable reg, IResource reg,           Select (reg -> a) (STM [DBRef reg])  (STM [a]),           Select (reg -> b) (STM [DBRef reg])  (STM [b]) )-          =>  Select ((reg -> a),(reg -> b)) (STM [DBRef reg])  (STM [(a,b)])+          =>  Select (reg -> a, reg -> b) (STM [DBRef reg])  (STM [(a,b)])           where-    select (sel, sel') xs= mapM (\x -> return (sel x, sel' x)) =<< return . catMaybes =<< mapM readDBRef  =<< xs+    select (sel, sel') xs= mapM (\x -> return (sel x, sel' x)) =<< catMaybes <$> (mapM readDBRef  =<< xs)  instance  (Typeable reg, IResource reg,           Select (reg -> a) (STM [DBRef reg])  (STM [a]),           Select (reg -> b) (STM [DBRef reg])  (STM [b]),           Select (reg -> c) (STM [DBRef reg])  (STM [c]) )-          =>  Select ((reg -> a),(reg -> b),(reg -> c)) (STM [DBRef reg])  (STM [(a,b,c)])+          =>  Select (reg -> a, reg -> b, reg -> c) (STM [DBRef reg])  (STM [(a,b,c)])           where-    select (sel, sel',sel'') xs= mapM (\x -> return (sel x, sel' x, sel'' x)) =<< return . catMaybes =<< mapM readDBRef  =<< xs+    select (sel, sel',sel'') xs= mapM (\x -> return (sel x, sel' x, sel'' x)) =<< catMaybes <$> (mapM readDBRef  =<< xs)   instance  (Typeable reg, IResource reg,@@ -377,9 +378,9 @@           Select (reg -> b) (STM [DBRef reg])  (STM [b]),           Select (reg -> c) (STM [DBRef reg])  (STM [c]),           Select (reg -> d) (STM [DBRef reg])  (STM [d]) )-          =>  Select ((reg -> a),(reg -> b),(reg -> c),(reg -> d)) (STM [DBRef reg])  (STM [(a,b,c,d)])+          =>  Select (reg -> a, reg -> b, reg -> c, reg -> d) (STM [DBRef reg])  (STM [(a,b,c,d)])           where-    select (sel, sel',sel'',sel''') xs= mapM (\x -> return (sel x, sel' x, sel'' x, sel''' x)) =<< return . catMaybes =<< mapM readDBRef  =<< xs+    select (sel, sel',sel'',sel''') xs= mapM (\x -> return (sel x, sel' x, sel'' x, sel''' x)) =<< catMaybes <$> (mapM readDBRef  =<< xs)  -- for join's   (field1 op field2) @@ -387,11 +388,11 @@           Typeable reg', IResource reg',           Select (reg -> a) (STM [DBRef reg])  (STM [a]),           Select (reg' -> b) (STM [DBRef reg'])  (STM [b]) )-          =>  Select ((reg -> a),(reg' -> b)) (STM (JoinData reg reg')) (STM [([a],[b])])+          =>  Select (reg -> a, reg' -> b) (STM (JoinData reg reg')) (STM [([a],[b])])           where     select (sel, sel') xss = xss >>=  mapM select1         where         select1 (xs, ys) = do-         rxs <- return . map sel  =<< return . catMaybes  =<< mapM readDBRef  xs-         rys <- return .  map sel'  =<< return . catMaybes  =<< mapM readDBRef  ys+         rxs <- map sel  <$> (catMaybes  <$> mapM readDBRef  xs)+         rys <- map sel' <$> (catMaybes  <$> mapM readDBRef  ys)          return (rxs,rys)

@@ -1,8 +1,5 @@-{-# LANGUAGE TypeSynonymInstances-             , DeriveDataTypeable-             , FlexibleInstances-             , UndecidableInstances-             , MultiParamTypeClasses #-}+{-# LANGUAGE DeriveDataTypeable, FlexibleInstances,+  UndecidableInstances, MultiParamTypeClasses #-}   {- | Implements full text indexation (`indexText`) and text search(`contains`), as an addition to@@ -71,23 +68,20 @@ import System.Mem.StableName import Data.List((\\)) import GHC.Conc(unsafeIOToSTM)-import Control.Concurrent(forkIO) import Data.Char-import Control.Concurrent(threadDelay) import Data.ByteString.Lazy.Char8(pack, unpack) import Control.Monad-import System.IO.Unsafe  --import Debug.Trace --(!>)= flip trace -data IndexText=  IndexText-        { fieldType :: !String-        , lastDoc :: Int-        , mapDocKeyInt :: M.Map String Int-        , mapIntDocKey :: M.Map Int String-        , mapTextInteger :: M.Map T.Text Integer-         } deriving (Typeable)+data IndexText =  IndexText+  !String -- fieldType+  Int -- lastDoc+  (M.Map String Int) -- mapDocKeyInt+  (M.Map Int String) -- mapIntDocKey+  (M.Map T.Text Integer) -- mapTextInteger+  deriving (Typeable)   instance Show IndexText  where@@ -110,38 +104,57 @@   readResourceByKey = defReadResourceByKey   delResource = defDelResource +{- readInitDBRef v x= do   mv <- readDBRef x   case mv of     Nothing -> writeDBRef x v >> return v     Just v -> return v+-} -add ref t key w = op ref t setBit w key-del ref t key w = op ref t clearBit w key+add :: DBRef IndexText -> String -> String -> [T.Text] -> STM ()+add ref t key1 w = op ref t setBit w key1 -op refIndex t set ws key =  do+del :: DBRef IndexText -> String -> String -> [T.Text] -> STM ()+del ref t key1 w = op ref t clearBit w key1++op :: DBRef IndexText -> String -> (Integer -> Int -> Integer) -> [T.Text] -> String -> STM ()+op refIndex t set ws1 key1 =  do    mindex <- readDBRef refIndex-   let mindex'= process mindex  ws+   let mindex'= process mindex  ws1    writeDBRef refIndex $ fromJust mindex'   where  process mindex []= mindex- process mindex (w:ws)=+ process mindex (w:ws) =    case mindex of-       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',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+       Nothing ->  process (Just $ IndexText t 0 (M.singleton key1 0) (M.singleton  0 key1) (M.singleton w 1)) ws+       Just (IndexText _ n mapSI mapIS map1) -> do+        let (docLocation, n1, mapSI',mapIS')= case M.lookup key1 mapSI  of+               Nothing  -> let n2= n+1 in (n2, n2+                                          , M.insert key1 n2 mapSI+                                          , M.insert n2 key1 mapIS)  -- new Document                Just m -> (m,n, mapSI,mapIS)         -- already indexed document -        case M.lookup w map of+        case M.lookup w map1 of          Nothing ->    --new word-            process (Just $ IndexText t  n' mapSI' mapIS' (M.insert w (set 0 docLocation) map)) ws+            process (Just $ IndexText t  n1 mapSI' mapIS' (M.insert w (set 0 docLocation) map1)) ws          Just integer ->  -- word already indexed-            process (Just $ IndexText t n' mapSI' mapIS' $ M.insert w (set integer docLocation) map) ws+            process (Just $ IndexText t n1 mapSI' mapIS' $ M.insert w (set integer docLocation) map1) ws +addProto :: Typeable a => a -> IO ()+addProto sel =  do+  let [t1,t2]=  typeRepArgs $! typeOf sel+  let t =  show t1 ++ show t2+  let proto = IndexText t 0 M.empty M.empty M.empty+  withResources [proto] $ init' proto+  where+   init' proto [Nothing]  = [proto]+   init' _ [Just _] = []+   init' _ [] = error "this will never happen(?)"+   init' _ (Nothing:_:_) = error "this will never happen(?)"+   init' _ (Just _:_:_) = error "this will never happen(?)"+ -- | start a trigger to index the contents of a register field indexText   :: (IResource a, Typeable a, Typeable b)@@ -150,13 +163,8 @@      -> IO () indexText sel convert= do   addTrigger (indext sel  (words1 . convert))-  let [t1,t2]=  typeRepArgs $! typeOf sel-      t=  show t1 ++ show t2-  let proto = IndexText t 0 M.empty M.empty M.empty-  withResources [proto] $ init proto-  where-  init proto [Nothing]  = [proto]-  init _ [Just _] = []+  addProto sel+ -- | trigger the indexation of list fields with elements convertible to Text indexList   :: (IResource a, Typeable a, Typeable b)@@ -165,80 +173,83 @@      -> IO () indexList sel convert= do   addTrigger (indext sel  convert)-  let [t1,t2]=  typeRepArgs $! typeOf sel-      t=  show t1 ++ show t2-  let proto= IndexText t 0 M.empty M.empty M.empty-  withResources [proto] $ init proto--  where-  init proto [Nothing] = [proto]-  init _ [Just _]= []--+  addProto sel  indext :: (IResource a, Typeable a,Typeable b)        => (a -> b) -> (b -> [T.Text])  -> DBRef a -> Maybe a -> STM()-indext sel  convert dbref  mreg= f1 --  unsafeIOToSTM $! f+indext sel convert dbref mreg = f1 --  unsafeIOToSTM $! f   where-  f=  forkIO (atomically f1) >> return()-  f1=  do-   moldreg <- readDBRef dbref-   case ( moldreg,  mreg) of-      (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-        if st== st'-          then return ()-          else do-            let key= keyResource reg-            let wrds = convert $ sel oldreg-            let wrds'= convert $ sel reg-            let new=  wrds' \\ wrds-            let old= wrds \\ wrds'-            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-   t=  show t1 ++ show t2-   refIndex= getDBRef . key $ IndexText t u u u u where u= undefined+    {-f = void $ forkIO (atomically f1)-}+    f1 = do+      moldreg <- readDBRef dbref+      case (moldreg, mreg) of+        (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+          if st == st'+            then return ()+            else do+              let key1 = keyResource reg+              let wrds = convert $ sel oldreg+              let wrds' = convert $ sel reg+              let new = wrds' \\ wrds+              let old = wrds \\ wrds'+              unless (null old) $ del refIndex t key1 old+              unless (null new) $ add refIndex t key1 new+        (Nothing, Nothing) -> error "this will never happen(?)"+      where+        [t1, t2] = typeRepArgs $! typeOf sel+        t = show t1 ++ show t2+        refIndex = getDBRef . key $ IndexText t u u u u+          where+            u = undefined +-- avoid duplicate code+targs :: Typeable a => a -> STM (Maybe IndexText)+targs sel = do+  let [t1, t2]=  typeRepArgs $! typeOf sel+  let t=  show t1 ++ show t2+  let u= undefined+  withSTMResources [IndexText t u u u u]+     $ \[r] -> resources{toReturn= r}+ -- | return the DBRefs of the registers whose field (first parameter, usually a container) contains the requested value. containsElem :: (IResource a, Typeable a, Typeable b) => (a -> b)  -> String -> STM [DBRef a]-containsElem  sel wstr = do-    let w= T.pack wstr-    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 -> do-        let fields= show $ typeOf  sel-        error $ "the index for "++ fields ++" do not exist. At main, use \"Data.TCache.IdexQuery.index\" to start indexing this field"-      Just (IndexText t n _ mmapIntString map1) ->-       case M.lookup w map1 of-        Nothing ->  return []-        Just integer ->  do-            let mns=map (\n ->case testBit integer n of True -> Just n; _ -> Nothing)  [0..n]-            let wordsr = catMaybes $ map (\n -> M.lookup n mmapIntString) $ catMaybes mns-            return $ map getDBRef wordsr+containsElem sel wstr = do+  let w = T.pack wstr+  mr <- targs sel+  case mr of+    Nothing -> do+      let fields = show $ typeOf sel+      error $+        "the index for " +++        fields ++ " do not exist. At main, use \"Data.TCache.IndexQuery.index\" to start indexing this field"+    Just (IndexText _ n _ mmapIntString map1) ->+      case M.lookup w map1 of+        Nothing -> return []+        Just integer -> do+          let mns =+                map+                  (\i ->+                     if testBit integer i+                       then Just i+                       else Nothing)+                  [0 .. n]+          let wordsr = mapMaybe (`M.lookup` mmapIntString) $ catMaybes mns+          return $ map getDBRef wordsr  -- | return all the values of a given field (if it has been indexed with 'index') 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}+    mr <- targs sel     case mr of       Nothing -> return []-      Just (IndexText t n _ _ map) -> return $ M.keys map+      Just (IndexText _ _ _ _ map') -> return $ M.keys map' -words1= filter filterWordt {-( (<) 2 . T.length)-} . T.split (\c -> isSeparator c || c=='\n' || isPunctuation c )+words1 :: T.Text -> [T.Text]+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@@ -252,7 +263,10 @@      [w] -> containsElem sel w      ws  -> do         let rs = map (containsElem sel) $ filter filterWord ws-        foldl (.&&.) (head rs)  (tail rs)+        foldl1 (.&&.) 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)+filterWordt :: T.Text -> Bool+filterWordt w = T.length w >2 || any (\c -> isUpper c || isDigit c) (T.unpack w)++filterWord :: Foldable t => t Char -> Bool+filterWord w = length w >2 || any (\c -> isUpper c || isDigit c) w

@@ -1,151 +1,155 @@------------------------------------------------------------------------------
---
--- Module      :  Memoization
--- Copyright   :  Alberto GOmez Corona
--- License     :  BSD3
---
--- Maintainer  :  agocorona@gmail.com
--- Stability   :  Experimental
--- Portability :  Non portable (uses stablenames)
---
--- |
---
------------------------------------------------------------------------------
-{-# 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.Mem.StableName
-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
-
-context= unsafePerformIO 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 x= "addr" ++ show hash
- where
- hash = case unsafePerformIO $ addrHash context x of
-   Right x -> x
-   Left x  -> x
-
--- | to execute a monad for the purpose of memoizing its result
-class Executable m where
-  execute:: m a -> a
-
-instance Executable IO where
-  execute m = unsafePerformIO $! f1 m ""
-   where
-   f1 m x= m
-
-instance Executable Identity where
-  execute (Identity x)= x
-
-instance MonadIO Identity where
-  liftIO f=  Identity $!  unsafePerformIO $! f
-
-
-cachedKeyPrefix = "cached"
-
-instance  (Indexable a) => IResource (Cached a  b) where
-  keyResource ch@(Cached a  _ _ _)= cachedKeyPrefix ++ key a   -- ++ unsafePerformIO (addrStr f )
-
-  writeResource _= return ()
-  delResource _= return ()
-  readResourceByKey k= return Nothing -- 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  -- !> "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  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= liftIO . atomically $ cachedSTM time f a
-
-cachedSTM time f a= do
-   let prot= Cached a f undefined undefined
-   let ref= getDBRef $ keyResource prot
-   cho@(Cached _ _ b t) <- readDBRef ref `onNothing` fillIt ref prot
-   case time of
-     0 -> return b
-     _ -> do
-           TOD tnow _ <- unsafeIOToSTM $ getClockTime
-           if tnow - t >= fromIntegral time
-                      then do
-                            Cached _ _ b _ <- fillIt ref prot
-                            return b
-                      else  return b
-   where
-   -- has been invalidated by flushCached
-   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
---
--- 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 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"
-
--- | a pure version of cached
-cachedp :: (Indexable a,Typeable a,Typeable b) => (a ->b) -> a -> b
-cachedp f k = execute $ cached  0 (\x -> Identity $ f x) 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")
-
-
+-----------------------------------------------------------------------------+--+-- 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 = unsafePerformIO 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 x= "addr" ++ show hash+ where+ hash = case unsafePerformIO $ addrHash context x of+   Right x1 -> x1+   Left x1  -> 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 m = unsafePerformIO $! f1 m ""+   where+   f1 m1 _= m1++instance Executable Identity where+  execute (Identity x)= x++instance MonadIO Identity where+  liftIO f=  Identity $!  unsafePerformIO $! f+++cachedKeyPrefix :: String+cachedKeyPrefix = "cached"++instance  (Indexable a) => IResource (Cached a  b) where+  keyResource (Cached a  _ _ _)= cachedKeyPrefix ++ key a   -- ++ unsafePerformIO (addrStr f )++  writeResource _= return ()+  delResource _= return ()+  readResourceByKey _= return Nothing -- 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  -- !> "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  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= liftIO . atomically $ cachedSTM time f a++cachedSTM :: (Typeable a, Typeable b, Executable m, Indexable a, Integral p) => p -> (a -> m b) -> a -> STM b+cachedSTM time f a= do+   let prot= Cached a f undefined undefined+   let ref= getDBRef $ keyResource prot+   (Cached _ _ b t) <- readDBRef ref `onNothing` fillIt ref prot+   case time of+     0 -> return b+     _ -> do+           TOD tnow _ <- unsafeIOToSTM getClockTime+           if tnow - t >= fromIntegral time+                      then do+                            Cached _ _ b1 _ <- fillIt ref prot+                            return b1+                      else  return b+   where+   -- has been invalidated by flushCached+   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+--+-- 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 key1 time  f = cached time (const f) key1++cachedByKeySTM :: (Typeable a, Executable m) => String -> Int ->  m a -> STM a+cachedByKeySTM key1 time  f = cachedSTM  time (const f) key1++-- Flush the cached object indexed by the key+flushCached :: String -> IO ()+flushCached k= atomically $ invalidateKey $ cachedKeyPrefix ++ k           -- !> "flushCached"++-- | a pure version of cached+cachedp :: (Indexable a,Typeable a,Typeable b) => (a ->b) -> a -> b+cachedp f k = execute $ cached 0 (Identity . f) 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")++

@@ -1,6 +1,5 @@-+{-# LANGUAGE ExistentialQuantification, DeriveDataTypeable #-} -{-# LANGUAGE ExistentialQuantification, DeriveDataTypeable, BangPatterns #-} module Data.TCache.Triggers(DBRef(..),Elem(..),Status(..),addTrigger,applyTriggers) where import Data.TCache.IResource import Data.TCache.Defs@@ -9,21 +8,20 @@ import System.IO.Unsafe import Unsafe.Coerce import GHC.Conc (STM, unsafeIOToSTM)-import Data.Maybe(maybeToList,catMaybes)+import Data.Maybe(fromMaybe, fromJust) import Data.List(nubBy)-import Control.Concurrent.STM -import Debug.Trace-import Data.Maybe(fromJust)+--import Debug.Trace  newtype  TriggerType a= TriggerType (DBRef a -> Maybe a -> STM()) deriving Typeable -data CMTrigger= forall a.(IResource a, Typeable a) => CMTrigger  !((DBRef a) -> Maybe a -> STM())+data CMTrigger= forall a.(IResource a, Typeable a) => CMTrigger  !(DBRef a -> Maybe a -> STM())    cmtriggers :: IORef [(TypeRep ,[CMTrigger])]-cmtriggers= unsafePerformIO $ newIORef []+{-# NOINLINE cmtriggers #-}+cmtriggers = unsafePerformIO $ newIORef []   @@ -35,37 +33,38 @@ If the DBRef is being deleted, the second parameter is 'Nothing'. if the DBRef contains Nothing, then the object is being created -}-addTrigger :: (IResource a, Typeable a) => ((DBRef a) -> Maybe a -> STM()) -> IO()-addTrigger   t= do-   map <-  readIORef cmtriggers+addTrigger :: (IResource a, Typeable a) => (DBRef a -> Maybe a -> STM()) -> IO()+addTrigger  tr = do+   map' <-  readIORef cmtriggers    writeIORef cmtriggers $-      let ts = mbToList $ lookup atype map-          in  nubByType $ (atype ,CMTrigger t : ts) : map+      let ts = mbToList $ lookup atype map'+          in  nubByType $ (atype ,CMTrigger tr : ts) : map'   where   nubByType= nubBy (\(t,_)(t',_) -> t==t')-  (_,(atype:_))= splitTyConApp  . typeOf $ TriggerType t+  (_,atype:_)= splitTyConApp  . typeOf $ TriggerType tr   -mbToList mxs= case mxs of Nothing -> []; Just xs -> xs+mbToList :: Maybe [a] -> [a]+mbToList = fromMaybe []  -- | internally called when a DBRef is modified/deleted/created applyTriggers:: (IResource a, Typeable a) => [DBRef a] -> [Maybe a] -> STM() applyTriggers  [] _ = return() applyTriggers  dbrfs mas = do-   map <- unsafeIOToSTM $ readIORef cmtriggers-   let ts = mbToList $ lookup   (typeOf $ fromJust (head mas)) map+   map' <- unsafeIOToSTM $ readIORef cmtriggers+   let ts = mbToList $ lookup   (typeOf $ fromJust (head mas)) map'    mapM_ f  ts     where    f t= mapM2_ (f1 t)  dbrfs  mas     f1 ::(IResource a, Typeable a) =>  CMTrigger -> DBRef a -> Maybe a ->  STM()-   f1 (CMTrigger t) dbref ma =    (unsafeCoerce t)  dbref ma+   f1 (CMTrigger t)= unsafeCoerce t   -mapM2_ _ [] _= return()+mapM2_ :: Monad m => (t1 -> t2 -> m a) -> [t1] -> [t2] -> m ()+mapM2_ _ [] _ = return()+mapM2_ _ _ [] = return() mapM2_ f (x:xs) (y:ys)=  f x y >> mapM2_ f xs ys--

@@ -0,0 +1,25 @@+# TCache++TCache is a transactional cache written in Haskell with configurable persistence. It allows conventional STM transactions for objects that synchronize with a user-defined storage. State is kept synchronized between memory and permanent storage via transactions. Default persistence is via files, and is provided for testing purposes.++0.9.0.4 : Solves a bug in the management of weak pointers that evaporated registers from the cache+0.9.0.3 : Solves a lost registers bug.+0.9.0.1 : Solves a bug when object keys generate invalid filenames, and includes changes in defaultPersistence to further separate serialization from input-output.++0.9: Introduces full text search. Also adjusts serialization so it is achieved through byteStrings.++This version supports backward compatibility and also permits transparent retrieval of and transactions between objects without directly using STM references. It now provides explicit STM persistent references (`DBRef`s) that leverage clean, traditional haskell reference syntax for performing database transactions.++`DBRef`s are essentially persistent `TVar`s indexed in the cache using a traditional `readDBRef`/`writeDBRef` Haskell interface like that of the STM Monad.  Additionally, because `DBRef`s are serializable, they can be embedded in serializable registers. As they are references this means they point to other serializable registers. This enables persistent, mutable and efficient inter-object relations.++Triggers are also included in this release. These are user defined hooks that get called on register updates. They can be used for making the actualization of inter-object relations easier, and also permit higher-level customizable accesses. The query language internally uses triggers for its indexing.++This version also implements a straight-forward, non-intrusive, type-safe pure Haskell query language that is based on register field relations. This module can be imported separately. See `Data.TCache.IndexQuery` for further information.++The file persistence implementation is more reliable as `IO` reads are now in STM transactions.++To ease the implementation of other user-defined persistence, `Data.TCache.DefaultPersistence` needs to be imported explicitly for deriving file persistence instances.++The 0.9 version adds full-text indexing and search, which is incorporated into the experimental query language.++It also changes the default Persistence mechanism. Now `ByteString`s are used for serialization and deserialization. A `Serializable` class and a `Persist` structure decouples serialization from `ByteString` and read/write to files. Both can be redefined separately, so the default persistence could be changed with `setPersist` to write to blobs in a databases, for example. Default persistence now no longer has to be in files.

@@ -1,5 +1,5 @@-#! /usr/bin/runghc
-
-> import Distribution.Simple
->
-> main = defaultMain
+#! /usr/bin/runghc++> import Distribution.Simple+>+> main = defaultMain

@@ -1,85 +1,86 @@-name: TCache
-version: 0.12.1
-cabal-version: >= 1.6
-build-type: Simple
-license: BSD3
-license-file: LICENSE
-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.
-             State in memory and into permanent storage is transactionally coherent.
-             .
-             It has interface defined for Amazon WS and Yesod Persistent backends defined in tcache-<backend>
-             packages.
-             Persistent is a multi-backend interface for SQL and non SQL databases such in Mongo-db
-             .
-             The package implements serializable STM references, access by key and by record field value, triggers,
-             full text and field indexation, default serialization and a query language based on record fields
-             .
-             Since the STM references can be included in data structures and serialized, this is right
-             for graph databases and other NoSQL databases.
-             .
-             0.12.0 space in index data in indexQuery.hs and IndexText.hs triggered errors in the AWS backend.
-             The space has been changed by '-'. So rename the "index *" files in the TCache folder
-             in order to be recognized.
-             .
-             0.11.0.0 added setIndexParsist to define persistence for indexes by type. started the addition of readDBRefs, readResources and so on for simultaneous read, writes and deletes of
-             objects of the same type.
-             .
-             0.10.2.0 Added setDefaultPersist and modified the signature of setPersist in Data.TCache.DefaultPersistence.
-             Fixed issues with ghc 7.6.3
-             .
-             0.10  version add memoization and a persistent and transactional collection/queue.
-             .
-             0.10.0.8 subversion add cachedByKeySTM
-             .
-             0.10.0.9 fixed an error in clearSyncChacheProc and SynWrite Asyncronous that checked the cache continuously
-             .
-             See "Data.TCache" for details
-             .
-             In this release:
-             .
-             Dropped Data.Hashtable (deprecated). Now it uses the package hashtables
-
-
-category: Data, Database
-author: Alberto Gómez Corona
-tested-with: GHC ==7.0.3
-data-dir: ""
-extra-source-files: demos/DBRef.hs
-                    demos/IndexQuery.hs
-                    demos/IndexText.hs
-                    demos/basicSample.hs
-                    demos/caching.hs
-                    demos/triggerRelational.lhs
-                    demos/memoization.hs
-                    demos/DBRef.hs
-
-source-repository head
-    type: git
-    location: https://github.com/agocorona/TCache
-
-library
-    build-depends: base >=4 && <5, bytestring -any,
-                   containers >=0.1.0.1, directory >=1.0, old-time >=1.0,
-                   stm -any, text -any, mtl -any, hashtables,
-                   RefSerialize >= 0.4.0
-
-
-
-    exposed-modules: Data.TCache Data.TCache.DefaultPersistence,
-                     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
-                ScopedTypeVariables DeriveDataTypeable
-    hs-source-dirs: .
-    other-modules:
-
+name:           TCache+version:        0.13.3+cabal-version:  >= 1.10+synopsis:       A Transactional cache with user-defined persistence+description:    Please see the README on GitHub at <https://github.com/agocorona/TCache#readme>+category:       Data, Database+homepage:       https://github.com/agocorona/TCache#readme+bug-reports:    https://github.com/agocorona/TCache/issues+author:         Alberto Gómez Corona+maintainer:     agocorona@gmail.com+copyright:      2019 Alberto Gómez Corona+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    ChangeLog.md+    README.md+    demos/basicSample.hs+    demos/caching.hs+    demos/DBRef.hs+    demos/DynamicSample.hs+    demos/indexQuery.hs+    demos/indexText.hs+    demos/memoization.hs+    demos/pr.hs+    demos/pushpop.hs+    demos/testnewdbref.hs+    demos/triggerRelational.lhs+    demos/weakTest.hs+    Data/Persistent/IDynamic.hs++source-repository head+  type: git+  location: https://github.com/agocorona/TCache++library+  exposed-modules:+      Data.TCache+      Data.TCache.DefaultPersistence+      Data.TCache.Defs+      Data.TCache.IResource+      Data.TCache.IndexQuery+      Data.TCache.IndexText+      Data.TCache.Memoization+      Data.TCache.Triggers+      Data.Persistent.Collection+      Data.Persistent.IDynamic+  other-modules:+      Paths_TCache+  hs-source-dirs:+      ./+  ghc-options: -Wall -Wcompat -Widentities+  build-depends:+      RefSerialize+    , base >=4.7 && <5+    , bytestring+    , containers >=0.1.0.1+    , directory >=1.0+    , hashtables+    , mtl+    , old-time >=1.0+    , stm+    , text+  default-language: Haskell2010++test-suite caching+  type: exitcode-stdio-1.0+  main-is: caching.hs+  other-modules:+      Paths_TCache+  hs-source-dirs:+      demos+  ghc-options: -Wall -Wcompat -Widentities -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      RefSerialize+    , TCache+    , base >=4.7 && <5+    , bytestring+    , containers >=0.1.0.1+    , directory >=1.0+    , hashtables+    , mtl+    , old-time >=1.0+    , stm+    , text+  default-language: Haskell2010

@@ -1,41 +1,55 @@-{-# OPTIONS -XDeriveDataTypeable -XFlexibleInstances  -XUndecidableInstances #-}+{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, UndecidableInstances #-} module Main where import Data.TCache import Data.TCache.DefaultPersistence import Data.ByteString.Lazy.Char8(pack,unpack)-import GHC.Conc import System.IO.Unsafe import Data.Typeable-import Debug.Trace +{-+-- would create orphan instances+instance (Read a, Show a) => Serializable a where+   serialize = pack . show+   deserialize = read . unpack+-} +-- An Employee+data Emp = Emp+  { ename :: String+  , salary :: Float+  } deriving (Read, Show, Typeable) +instance Serializable Emp where+   serialize = pack . show+   deserialize = read . unpack -newtype Other= Other String deriving (Read, Show)+instance Indexable Emp where+  key Emp { ename = name } = name -data  Company = Company {-   cname :: String-   ,personnel :: [DBRef Emp]-   ,other :: Other}-   deriving (Read, Show,Typeable)+-- For illustration+newtype Other = Other String deriving (Read, Show) +-- A Company+data Company = Company+  { cname :: String+  , personnel :: [DBRef Emp]+  , other :: Other+  } deriving (Read, Show, Typeable) -data Emp= Emp{ename :: String, salary :: Float} deriving (Read, Show, Typeable)+instance Serializable Company where+   serialize = pack . show+   deserialize = read . unpack  instance Indexable Company where-  key Company{cname=name}= name--instance (Read a, Show a) => Serializable a where-   serialize= pack . show-   deserialize= read . unpack--instance Indexable Emp where-  key Emp{ename= name}= name-+  key Company{ cname = name } = name -myCompanyName= "mycompany"+myCompanyName :: String+myCompanyName = "mycompany" -myCompanyRef= unsafePerformIO . atomically $  do+-- Creating a Company from scratch+{-# NOINLINE myCompanyRef #-}+myCompanyRef :: DBRef Company+myCompanyRef = unsafePerformIO . atomically $  do       refEmp1 <- newDBRef Emp{ename= "Emp1", salary= 34000}      refEmp2 <- newDBRef Emp{ename= "Emp2", salary= 35000}@@ -48,36 +62,45 @@                ,personnel= [refEmp1, refEmp2, refEmp3, refEmp4]                ,other= Other "blah blah blah"} - -- myCompany= Company myCompanyName [getDBRef "Emp1",getDBRef "Emp2",getDBRef "Emp3"] -+increaseSalaries :: Float -> STM ()+increaseSalaries percent1 = do+  mycompany' <- readDBRef myCompanyRef+  mycompany <- case mycompany' of+    Just x -> pure x+    Nothing -> error "Boom" -increaseSalaries percent= do-  Just mycompany <- readDBRef myCompanyRef-  mapM_  (increase percent ) $ personnel  mycompany+  mapM_  (increase percent1 ) $ personnel mycompany   where   increase percent ref= do-    Just emp <- readDBRef ref+    emp' <- readDBRef ref+    emp <- case emp' of+      Just x -> pure x+      Nothing -> error "Boom"+     writeDBRef ref $ emp{salary= salary emp * factor}     where     factor= 1+ percent/ 100 -printSalaries ref= do-  Just comp <- atomically $ readDBRef ref+printSalaries :: DBRef Company -> IO ()+printSalaries ref1 = do+  Just comp <- atomically $ readDBRef ref1   mapM_ printSalary $ personnel comp   where   printSalary ref= atomically (readDBRef ref) >>=  print +putMsg :: String -> IO () putMsg msg= putStrLn $ ">>" ++ msg -main= do-  putMsg "DBRefs are cached idexable, serializable, unique-by-key references to objects stored in the cache, mutable under STM transactions"+main :: IO ()+main = do+  putMsg "DBRefs are cached indexable, serializable, unique-by-key references to objects stored in the cache, mutable under STM transactions"   putMsg "DBRef's are instances of Show"   print myCompanyRef  -  let myCompanyRef2= read $ show myCompanyRef :: DBRef Company+  let myCompanyRef2 = read $ show myCompanyRef :: DBRef Company   putMsg "DBRefs are identified by the key of the referenced object"   putMsg "DBRef's are alse instances of read" @@ -96,7 +119,7 @@   putMsg "after the increase"   printSalaries myCompanyRef2 -  let emp3ref= getDBRef "Emp3"+  let emp3ref = getDBRef "Emp3"   putMsg "tch tch, this bad boy does not deserve his salary"   Just emp3 <- atomically $ readDBRef emp3ref   print emp3@@ -108,16 +131,13 @@    putStrLn "checking race condition on cache cleaning" -  let emp1=  Emp{ename="Emp1"}-  let key= keyResource emp1-  let remp1 = getDBRef key-  Just emp1 <- atomically $ readDBRef remp1+  let emp1 =  Emp{ename="Emp1", salary= -1}+  let key1 = keyResource emp1+  let remp1 = getDBRef key1+  Just emp1' <- atomically $ readDBRef remp1   atomically $ flushDBRef  remp1-  let remp1'= getDBRef key-  atomically $ writeDBRef remp1' $ emp1{salary=0}+  let remp1' = getDBRef key1+  atomically $ writeDBRef remp1' $ emp1'{salary=0}    putStrLn "must reflect the salary 0 for emp1"   printSalaries myCompanyRef2---

@@ -0,0 +1,73 @@+{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}++module Main where+import Data.TCache+import Data.TCache.DefaultPersistence+import Data.ByteString.Lazy.Char8(pack,unpack)+import Data.Typeable++{------------- tests---------+example of IDynamic usage.++-}++-- Very simple data:+-- Two objects with two different datatypes: MyInt and MyString+-- We use newtypes so we don't need to create orphan instances++newtype MyInt = MyInt { fromMyInt :: Int } deriving ( Eq, Show, Typeable, Read )+newtype MyString = MyString { fromMyString :: String } deriving ( Eq, Show, Typeable, Read )++instance Indexable MyString where+  -- making the key 2 chars wide+  key x =  take 2 $ fromMyString x++instance Indexable MyInt where+  -- just use the string representation as key here+  key =  show++instance Serializable MyString where+  serialize = pack . show+  deserialize = read . unpack++instance Serializable MyInt where+  serialize = pack . show+  deserialize = read . unpack+++main :: IO ()+main= do+  putStrLn "see the code to know the meaning of he results"++  -- NOTE: registerType no longer needed+++  let x = MyInt 1++  -- now *Resources primitives support different datatypes+  -- without the need  of Data.Dynamic+  withResources  [] $ const  [x]+  withResources  [] $ const  [MyString "hola"] --resources creation++  syncCache++  res1 <- getResource  x+  print res1++  res2 <- getResource $ MyString "ho"+  print res2++  -- to use heterogeneous data in the same transaction,+  -- use DBRef's:+  s <- atomically $ do+        let refInt    = getDBRef $ key x    :: DBRef MyInt+            refString = getDBRef $ key (MyString "ho") :: DBRef MyString+        i <- readDBRef refInt+        writeDBRef refString $ MyString $ "hola, the retrieved value of x is " ++ show i+        readDBRef refString++  print s++  -- however, retrieval of data with the incorrect type will generate an exception:++  syncCache

@@ -1,39 +0,0 @@-{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, UndecidableInstances #-}-module Main where-import Data.TCache-import Data.TCache.IndexQuery-import Data.TCache.DefaultPersistence-import Data.ByteString.Lazy.Char8(pack,unpack)-import Debug.Trace--import Data.Typeable---data Person= Person {pname :: String} deriving  (Show, Read, Eq, Typeable)--data Car= Car{owner :: DBRef Person , cname:: String} deriving (Show, Read, Eq, Typeable)--instance Indexable Person where key Person{pname= n} = "Person " ++ n-instance Indexable Car where key Car{cname= n} = "Car " ++ n--instance (Read a, Show a) => Serializable a where-   serialize= pack . show-   deserialize= read . unpack--main =  do--   index owner-   index pname-   index cname--   bruce <- atomically $    newDBRef $ Person "bruce"-   atomically $  mapM_ newDBRef [Car bruce "Bat Mobile", Car bruce "Porsche"]--   r <- atomically $ cname .>=. "Bat Mobile"-   print r--   r <- atomically $ select (cname, owner) $  (owner .==. bruce)  .&&. (cname .==. "Bat Mobile")-   print r---   --syncCache

@@ -1,30 +0,0 @@-{-# LANGUAGE DeriveDataTypeable#-}-module Main where-import Data.TCache-import Data.TCache.DefaultPersistence-import Data.TCache.IndexQuery(select)-import Data.TCache.IndexText-import Data.ByteString.Lazy.Char8(pack,unpack)-import qualified Data.Text.Lazy as T(pack)
-import Data.Typeable--data Doc= Doc{title, body :: String} deriving (Read,Show, Typeable)-instance Indexable Doc where-  key Doc{title=t}= t--instance Serializable Doc  where-  serialize= pack . show-  deserialize= read . unpack--main= do-  indexText  body T.pack-  let doc= Doc{title=  "title", body=  "hola que tal estamos"}-  rdoc <- atomically $ newDBRef doc-  r1 <- atomically $ select title $ body `contains` "hola que tal"-  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"

@@ -6,9 +6,11 @@ import Data.TCache.DefaultPersistence import Data.ByteString.Lazy.Char8(pack,unpack) import Control.Concurrent+import Data.Foldable (for_) import Data.Typeable import Debug.Trace +debug :: a -> String -> a debug a b= trace b a  -- The data elements to be used in the example: A user will repeatedly buy Items.@@ -19,7 +21,14 @@               deriving (Read, Show, Typeable)  --- The mappings between the cache and the phisical storage are defined by the interface IResource+-- defining prototypes to make missing-fields warning useful again+user_ :: Data+user_ = User{uname = undefined, uid = undefined, spent = undefined }++item_ :: Data+item_ = Item{iname = undefined, iid = undefined, price = undefined, stock = undefined }++-- The mappings between the cache and the physical storage are defined by the interface IResource --      to extract the unique key, --      to serializa to string --      to deserialize from string@@ -31,65 +40,66 @@   instance Indexable Data where-        key   User{uid=id}= id-        key   Item{iid=id}= id+  key   User { uid=id' } = id'+  key   Item { iid=id' } = id'  instance Serializable Data where-  serialize= pack . show-  deserialize= read . unpack+  serialize = pack . show+  deserialize = read . unpack    -- buy is the operation to be performed in the example ---withResources gets a partial definition of each resource necessary for extracting the key,---fill all the rest of the data structures (if found ) and return a list of Maybe Data.---BuyIt is part of the domain problem. it receive this list and generates a new list of---data objects that are updated in the cache. buyIt is executed atomically.+-- withResources gets a partial definition of each resource necessary for extracting the key,+-- fill all the rest of the data structures (if found ) and return a list of Maybe Data. +-- buyIt is part of the domain problem. it receive this list and generates a new list of+-- data objects that are updated in the cache. buyIt is executed atomically. -user `buy` item=  withResources[user,item] buyIt++buy :: Data -> Data -> IO ()+user `buy` item =  withResources [user, item] buyIt  where-    buyIt[Just us,Just it]-       | stock it > 0= [us',it']   `debug` "john buy a PC"+    buyIt[Just us, Just it]+       | stock it > 0 = [us',it'] `debug` ("john spent " ++ show (spent us) +++          " so far. Hey tries to buy a PC from the stock of " ++ show (stock it))        | otherwise   = error "stock is empty for this product"        where-       us'= us{spent=spent us + price it}-       it'= it{stock= stock it-1}+       us'= us{ spent = spent us + price it}+       it'= it{ stock = stock it - 1 }      buyIt _ = error "either the user or the item does not exist"  -main= do-        -- create resources (acces no resources and return two new Data objects defined in items)-        withResources[]items--        --11 PCs are charged  to the John´s account in paralel, to show transactionality-        --because there are only 10 PCs in stock, the last thread must return an error--        for 11 $ forkIO $ User{uid="U12345"} `buy` Item{iid="I54321"}+main :: IO ()+main = do+  -- create resources (access no resources and return two new Data objects defined in items)+  withResources [] prepareItems -        --wait 1 seconds-        threadDelay 1000000+  -- 11 PCs are charged to the John´s account in parallel, to show transactionality+  -- because there are only 10 PCs in stock, the last thread must return an error+  for_ [(1::Int)..11] $ const $ forkIO $ user_{ uid = "U12345" } `buy` item_{ iid = "I54321" } -        [us,it] <-  getResources [User{uid="U12345"}, Item{iid="I54321"}]+  -- wait a second (to let the forked io finish)+  threadDelay 1000000 -        putStrLn $  "user data=" ++ show us-        putStrLn $  "item data=" ++ show it+  -- get the contents of the resources by their keys+  [us,it] <-  getResources [user_{ uid = "U12345" }, item_{ iid = "I54321" }] -        -- write the cache content in a persistent store (invoque writeResource for each resource)-        -- in a real application clearSyncCacheProc can be used instead to adjust size and write the cache periodically+  putStrLn $  "user data=" ++ show us+  putStrLn $  "item data=" ++ show it -        syncCache-        threadDelay 1000000+  -- write the cache content in a persistent store (invoke writeResource for each resource)+  -- in a real application clearSyncCacheProc can be used instead to adjust size and write the cache periodically+  syncCache+  threadDelay 1000000 -        -- the files have been created. the files U12345 and I54321 must contain the result of the 11 iterations+  -- the files U12345 and I54321 in .tcachedata must now contain the result of the 11 iterations    where-        items _=-              [User "John" "U12345" 0-              ,Item "PC" "I54321" 6000 10]--        for 0 _ = return ()-        for n f= f >> for (n-1) f+    prepareItems = const+      [ User "John" "U12345" 0+      , Item "PC" "I54321" 6000 10+      ]

@@ -11,6 +11,8 @@ import Control.Concurrent import Debug.Trace import Data.Typeable++debug :: a -> String -> a debug a b= trace b a  -- The data elements to be used in the example@@ -21,39 +23,90 @@  instance Indexable Data where         key         (Data i _)= show i-        defPath _ = "cacheData/"  -- directory where the data is stored.+        defPath _ = ".tcachedata/caching/"  -- directory where the data is stored.  instance Serializable Data where   serialize= pack . show   deserialize= read . unpack  -main=  do--        putStrLn "see the source code of this example"-        putStrLn "This program test the caching and cleaning and re-retrieval and update of the cache"+printStat :: (Show a1, Show a2, Show a3) => (a1, a2, a3) -> IO ()+printStat (total, dirty, loaded) =+  putStrLn $ "total: " ++ show total ++ " dirty: " ++ show dirty ++ " loaded: " ++ show loaded -        putStrLn "asyncronous write every 10 seconds, 100 elems max cache size"-        putStrLn "default policy (defaultCheck) for clearing the cache is to reduce the cache to half of max sixe when size exceeds the max"+main :: IO ()+main =  do+        putStrLn "See the source code of this example!"+        putStrLn ""+        putStrLn "This program tests the caching, cleaning, re-retrieval and updating of the cache."+        putStrLn "It uses the DefaultPersistence (disk) and defaultCheck (cleaning rules)."+        putStrLn "It writes asyncronously every 10 seconds all changed elemements to disk."+        putStrLn "When there is more than the allowed number of elements (100) in the cache it cleans them by the given rule."+        putStrLn "With defaultCheck it drops elements which where not accesed since half the time between now and the last sync."          putStrLn ""-        putStrLn "create resources"-        putStrLn " (acces no resources and return two new Data objects defined in items)"+        putStrLn "Creating 200 resources with content: n 0"         withResources[] $ const[Data i 0 | i <- [1..200]]+        -- get stats about them (total, dirty, loaded)+        statElems >>= printStat +        x1 <- getResources [Data i 0 | i <- [1..200]]+        putStrLn $ "Last element: " ++ show (last x1)+         putStrLn ""-        clearSyncCacheProc  10 defaultCheck 100-        putStrLn $ "every 10 seconds, the modified data in the cache is written in the folder: " ++  defPath ( undefined :: Data)-        putStrLn "wait 10 seconds  to let the next write cycle to enter (every 10 seconds, set by clearSyncCacheProc)"+        putStrLn $ "Starting the async proc with folder: " ++  defPath ( undefined :: Data)+        _ <- clearSyncCacheProc 10 defaultCheck 100+        threadDelay 6000000 +        putStrLn "after 6 seconds"+        statElems >>= printStat+        threadDelay 5000000 -        putStrLn "because 200 exceeds the maximum cache size (100) defaultCheck will discard the 150  older elems  to reduce the cache to a half"-        putStrLn "This is the behaviour defined in defaultCheck."-        threadDelay 20000000-        putStrLn " update every element, included the discarded ones"+        putStrLn "after 11 seconds (should have saved)"+        statElems >>= printStat+        threadDelay 5000000++        putStrLn "after 16 seconds (accessing one element)"+        -- I read (access) all the data here!+        getResource (Data 100 undefined) >>= print++        statElems >>= printStat+        --syncCache+        threadDelay 5000000++        putStrLn "after 21 seconds (should have cleaned)"+        statElems >>= printStat++        putStrLn "Updating every element, included the discarded ones with 'n 1'"         withResources [Data i undefined | i <- [1..200]] $           \ds ->  [ Data i (n+1)  | Just(Data i n) <- ds]+        threadDelay 5000000 -        putStrLn $"wait for the next cycle of file update. The files must contain 1 instead o 0 (Data n 1) in the folder "++ defPath ( undefined :: Data)-        threadDelay 20000000+        putStrLn "after 26 seconds (should be 'full')"+        statElems >>= printStat +        putStrLn "accessing all entries once and print the last"+        -- I read (access) all the data here!+        x2 <- getResources [Data i 1 | i <- [1..200]]+        print $ last x2++        threadDelay 5000000++        putStrLn "after 31 seconds (should have saved)"+        statElems >>= printStat+        threadDelay 5000000++        putStrLn "after 36 seconds"+        statElems >>= printStat+        threadDelay 5000000++        putStrLn "after 41 seconds (should be cleaned again)"+        statElems >>= printStat++        -- reloading all of the data again+        putStrLn "getting the first 50 elements"+        x <- getResources [Data i 1 | i <- [1..50]]+        putStrLn $ "Last element: " ++ show (last x)++        putStrLn "Now we have"+        statElems >>= printStat

@@ -0,0 +1,44 @@+{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, UndecidableInstances #-}+module Main where+import Data.TCache+import Data.TCache.IndexQuery+import Data.TCache.DefaultPersistence+import Data.ByteString.Lazy.Char8(pack,unpack)+import Data.Typeable++data Person= Person {pname :: String, age :: Int} deriving  (Show, Read, Eq, Typeable)++data Car= Car{owner :: DBRef Person , cname:: String} deriving (Show, Read, Eq, Typeable)++instance Indexable Person where key Person{pname= n} = "Person " ++ n+instance Indexable Car where key Car{cname= n} = "Car " ++ n++instance Serializable Person where+   serialize = pack . show+   deserialize = read . unpack++instance Serializable Car where+   serialize = pack . show+   deserialize = read . unpack++main :: IO ()+main =  do++   index owner+   index pname+   index cname+   index age++   bruce <- atomically $ newDBRef $ Person "bruce" 42+   atomically $ mapM_ newDBRef [Car bruce "Bat Mobile", Car bruce "Porsche"]++   r1 <- atomically $ cname .>=. "Bat Mobile"+   print r1++   r2 <- atomically $ select (cname, owner) $  (owner .==. bruce)  .&&. (cname .==. "Bat Mobile")+   print r2++   r3 <- atomically $ age .>=. (20 :: Int)+   print r3++   --syncCache

@@ -0,0 +1,31 @@+{-# LANGUAGE DeriveDataTypeable #-}+module Main where+import Data.TCache+import Data.TCache.DefaultPersistence+import Data.TCache.IndexQuery(select)+import Data.TCache.IndexText+import Data.ByteString.Lazy.Char8(pack,unpack)+import qualified Data.Text.Lazy as T(pack)+import Data.Typeable++data Doc= Doc{title, body :: String} deriving (Read,Show, Typeable)+instance Indexable Doc where+  key Doc{title=t}= t++instance Serializable Doc  where+  serialize= pack . show+  deserialize= read . unpack++main :: IO ()+main = do+  indexText  body T.pack+  let doc= Doc{title=  "title", body=  "hola que tal estamos"}+  rdoc <- atomically $ newDBRef doc+  r1 <- atomically $ select title $ body `contains` "hola que tal"+  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  null r then print "OK" else print "FAIL"

@@ -1,15 +1,18 @@ import Data.TCache.Memoization-import Data.TCache.DefaultPersistence import Control.Concurrent import System.Time -+-- | memoization caches a value for a given amount of time+--   This demo stores the current time for 4 seconds until+--   it generates the next timestamp -main= do-        cachedByKey "key" 4 f >>= print-        threadDelay 1000000-        main+main :: IO b+main = do+    cachedByKey "timequant" 4 f >>= print+    threadDelay 1000000+    main -f= do-  TOD t _ <- getClockTime-  return t+f :: IO Integer+f = do+    TOD t _ <- getClockTime+    return t

@@ -0,0 +1,23 @@+module Main where+import Data.TCache+import Data.Typeable+import Data.TCache.DefaultPersistence+import Data.ByteString.Lazy.Char8++data Ops= Plus | Times deriving (Read, Show, Typeable)++instance Serializable Ops where+  serialize= pack . show+  deserialize= read . unpack++instance Indexable Ops where+ key _ = "ops"++main :: IO ()+main = do+    let ref = getDBRef $ keyResource Times+    atomically $ writeDBRef ref Plus+    syncCache+++    print ref

@@ -0,0 +1,58 @@+import Data.Persistent.Collection+import Control.Concurrent+import Data.TCache++main :: IO ()+main = do+    let q = getQRef "hi"++    -- display if and what we have in the queue+    -- will be empty on first run but afterwards+    -- contains "e"+    pickAll q >>= print++    -- make sure there is no data left+    flush q++    -- pop from empty would deadlock, so don't do that+    -- pop q >>= print++    push q "a" -- push before starting asyncs++    -- async pops (first does not need to wait)+    _ <- forkIO $ pop q >>= print+    _ <- forkIO $ pop q >>= print++    putStrLn "Waiting a bit (should print \"a\")"+    threadDelay 1000000+    putStrLn "By mpt \"a\" should be printed"++    -- push more+    push q "b" -- this will be printed asap++    push q "c"+    push q "d" -- will be sync popped+    push q "e" -- will be left over at the end++    -- let the second fork finish+    threadDelay 1000000+    putStrLn "By now \"b\" should be already printed"++    -- another async fork (printing "c")+    _ <- forkIO $ pop q >>= print++    -- sync current state to file and print it+    -- this usually still has "c" included+    threadDelay 1000000+    syncCache+    readFile ".tcachedata/Queue#hi" >>= putStrLn++    -- sync pop (usually prints "d")+    pop q >>= print++    -- another sync / wait / print+    syncCache+    threadDelay 1000000+    -- here "e" will be left in the queue on Disk+    readFile ".tcachedata/Queue#hi" >>= putStrLn+    -- and stays there for the next run

@@ -0,0 +1,34 @@+{-# LANGUAGE  FlexibleInstances+              ,UndecidableInstances+              ,DeriveDataTypeable+               #-}++import Data.TCache+import Data.TCache.DefaultPersistence+import Data.Typeable+import  Data.ByteString.Lazy.Char8 as B++type UserName=  String++data User= User+            { userName :: UserName+            , upassword :: String+            } deriving (Read, Show, Typeable)++userPrefix :: String+userPrefix= "User#"++instance Indexable User where+   key User{userName=   user}= userPrefix++user++userRegister :: String -> String  -> IO(DBRef User)+userRegister user password  = atomically $ newDBRef $ User user password++instance (Show a, Read a) => Serializable a where+  serialize = pack . show+  deserialize = read . unpack++main :: IO ()+main = do+   userRegister "test" "12345678"+   print "(WIP)"

@@ -0,0 +1,13 @@+import System.Mem.Weak+import Debug.Trace++debug :: c -> String -> c+debug = flip trace++dat :: String+dat = "this is the data"++main :: IO b+main = do+  _ <- mkWeakPtr  dat . Just $ print "deleted" `debug` "deleted"+  main