-----------------------------------------------------------------------------
-- |
-- Module : Data.TMap
-- Copyright : Peter Robinson 2009
-- License : LGPL
--
-- Maintainer : Peter Robinson <thaldyron@gmail.com>
-- Stability : experimental
-- Portability : non-portable (requires STM)
--
-- Provides a thread-safe STM interface for finite map types with optional persistent
-- storage.
--
-----------------------------------------------------------------------------
module Data.TMap( -- * TMap
TMap,
-- * Creating a new TMap
newTMapIO,
-- * Finite Map Interace
lookup,
insert,
delete,
member,
adjust,
-- * Handling the size of the TMap
purgeTMap,
purgeTMapIO,
getMaximumSize,
setMaximumSize,
getCurrentSize,
-- * Flushing the backend
flushBackend,
-- * Exception Type
TMapException(..),
)
where
import Control.Concurrent.AdvSTM
import Control.Concurrent.AdvSTM.TVar
-- import Control.Monad.CatchIO
import Control.Monad( liftM, when )
import Control.Monad.Trans( MonadIO, liftIO )
import qualified Control.Exception as Exc
import Data.Maybe( isJust )
import Prelude hiding (lookup,catch)
import qualified Data.TMap.Backend as B
import qualified Data.CacheStructure as C
import Data.TMap.Exception( TMapException(..) )
import qualified Data.Edison.Assoc as M
--------------------------------------------------------------------------------
data Entry a = Entry a -- ^ Cache hit
| NotInTMap -- ^ Cache miss
| NotInBackend -- ^ Element exists neither in backend nor in cache
deriving (Show,Eq)
instance Functor Entry where
fmap _ NotInBackend = NotInBackend
fmap _ NotInTMap = NotInTMap
fmap f (Entry a) = Entry (f a)
data TMap map k a b c = TMap
{ backend :: B.Backend k a b => b k a
, sizeTVar :: TVar (Maybe Int)
, tmapTVar :: (M.FiniteMapX map k, C.CacheStructure c k)
=> TVar (map (Entry a),c k)
}
--------------------------------------------------------------------------------
-- | Creates a new TMap. You will need to use an apropriate backend and specify
-- the caching policy, e.g.,
--
-- @
-- import Data.TMap.Backend.StdoutBackend( newStdoutBackend )
-- import Data.TMap.CacheStructure.LRU
-- @
--
-- will simply log all backend operations to Stdout and use a \"least recently
-- used\" cache algorithm.
--
-- Now, to create an unbounded map that uses the 'FM Int String' (see package EdisonCore)
-- as the map type, you can write
--
-- @
-- tmap = newTMapIO newStdoutBackend Nothing :: IO (TMap (FM Int) Int String StdoutBackend LRU)
-- @
newTMapIO :: (M.FiniteMapX map k, Ord k, B.Backend k a b,C.CacheStructure c k)
=> b k a -- ^ the backend
-> Maybe Int -- ^ maximum-size: Use 'Nothing' for unbounded size.
-> IO (TMap map k a b c)
newTMapIO b maxsize = do
tvar <- newTVarIO (M.empty,C.empty)
tvarSize <- newTVarIO maxsize
B.initialize b
return $ TMap b tvarSize tvar
{-
- Deactivated --- Can cause a non-terminating retry-loop when used with lookup k:
- When key 'k' is not found lookup retries. (Cond 1)
- But this causes the creation of the tmap to be rolled back too, and so
- (Cond 1) holds forever.
newTMap :: (M.FiniteMapX map k, Ord k, B.Backend k a b, MonadAdvSTM m)
=> b -> m (TMap map k a b)
newTMap b = do
tvar <- newTVar M.empty
return $ TMap b tvar
-}
-- | Looks for a given key in the map and (if necessary) in the persistent storage
-- and updates the map if necessary.
lookup :: (M.FiniteMapX map k, MonadAdvSTM m, Ord k, B.Backend k a b,C.CacheStructure c k)
=> k -> TMap map k a b c -> m (Maybe a)
lookup k tmap = do
(themap,accSeq) <- readTVar (tmapTVar tmap)
case M.lookupWithDefault NotInTMap k themap of
Entry v -> do
writeTVar (tmapTVar tmap) (themap,C.hit k accSeq)
-- onCommit $ print ("OldAccess List: ",C.toList accSeq)
-- onCommit $ print ("NewAccess List: ",C.toList $ C.hit k accSeq)
return $ Just v
NotInBackend -> return Nothing
NotInTMap -> retryWith $ do
-- print $ "Lookup: Didn't find " ++ show k ++ ", retrying lookup..."
result <- B.lookup (backend tmap) k
case result of
Nothing -> do
-- print "Entry not in backend"
atomically $ do
(themap',accSeq') <- readTVar (tmapTVar tmap)
writeTVar (tmapTVar tmap) (M.insert k (NotInBackend) themap', accSeq')
Just v -> do
-- print "Found entry in backend"
atomically $ do
(themap',accSeq') <- readTVar (tmapTVar tmap)
writeTVar (tmapTVar tmap) ( M.insert k (Entry v) themap'
, C.hit k accSeq')
-- onCommit $ print ("Access List: ",C.toList $ C.hit k accSeq')
-- | Checks whether the given key is in the map.
member :: (M.FiniteMapX map k, MonadAdvSTM m, Ord k, B.Backend k a b,C.CacheStructure c k)
=> k -> TMap map k a b c -> m Bool
member k tmap = liftM isJust (lookup k tmap)
-- | Adds a key-value mapping to the map. Can throw a 'DuplicateEntry'
-- exception.
insert :: (M.FiniteMapX map k, MonadAdvSTM m, Ord k, B.Backend k a b, C.CacheStructure c k)
=> k -> a -> TMap map k a b c -> m ()
insert k a tmap = do
res <- lookup k tmap
case res of
Just _ -> Exc.throw $ DuplicateEntry -- (show (k,v))
Nothing -> do
(themap,accSeq) <- readTVar (tmapTVar tmap)
writeTVar (tmapTVar tmap) ( M.insert k (Entry a) themap
, C.hit k accSeq)
onCommit $ B.insert (backend tmap) k a
-- | Applies a function to the element identified by the key. Can throw an 'EntryNotFound' exception.
adjust :: (M.FiniteMapX map k, MonadAdvSTM m, Ord k, B.Backend k a b, C.CacheStructure c k)
=> (a -> a) -> k -> TMap map k a b c -> m ()
adjust f k tmap = do
res <- lookup k tmap
case res of
Nothing -> Exc.throw EntryNotFound
Just _ -> do
(themap,accSeq) <- readTVar (tmapTVar tmap)
writeTVar (tmapTVar tmap) (M.adjust (fmap f) k themap, C.hit k accSeq)
onCommit $ B.adjust (backend tmap) f k
-- | Removes a key from the map. Can throw an 'EntryNotFound' exception.
delete :: (M.FiniteMapX map k, MonadAdvSTM m, Ord k, B.Backend k a b,C.CacheStructure c k)
=> k -> TMap map k a b c -> m ()
delete k tmap = do
res <- lookup k tmap
case res of
Nothing -> Exc.throw EntryNotFound
Just _ -> do
(themap,accSeq) <- readTVar (tmapTVar tmap)
writeTVar (tmapTVar tmap) (M.insert k NotInBackend themap, accSeq)
onCommit $ B.delete (backend tmap) k
--------------------------------------------------------------------------------
-- | Reduces the map to the appropriate size if the maximum size was exceeded.
-- Calls /Data.TMap.Backend.flush/ if the map is purged.
-- Runs in /O(1)/ if the map size is within bounds, otherwise /O(n)/.
purgeTMapIO :: (M.FiniteMapX map k, MonadIO m, Ord k, B.Backend k a b, C.CacheStructure c k)
=> TMap map k a b c -> m ()
purgeTMapIO tmap = liftIO . atomically $ purgeTMap tmap
-- | Reduces the map to the appropriate size if the maximum size was exceeded.
-- Calls /Data.TMap.Backend.flush/ if the map is purged.
-- Runs in /O(1)/ if the map size is within bounds, otherwise /O(n)/.
-- /Warning:/ This function should always be called at the end of a transaction to
-- prevent nonterminating retry-loops!
purgeTMap :: (M.FiniteMapX map k, MonadAdvSTM m, Ord k, B.Backend k a b, C.CacheStructure c k)
=> TMap map k a b c -> m ()
purgeTMap tmap = do
mSize <- readTVar (sizeTVar tmap)
case mSize of
Just maxSize -> do
(themap,accSeq) <- readTVar (tmapTVar tmap)
-- onCommit $ print ("Old List: ",C.toList accSeq)
when (C.size accSeq > maxSize) $ do
let (restSeq,delSeq) = C.popMany (C.size accSeq - maxSize) accSeq
writeTVar (tmapTVar tmap) (foldr M.delete themap delSeq, restSeq)
onCommit $ B.flush (backend tmap)
-- onCommit $ print ("Purged List: ",C.toList restSeq)
Nothing -> return ()
--------------------------------------------------------------------------------
-- | Sets the maximum size of the map. /O(1)/. Note that the size of the TMap needs
-- to be reduced manually to the maximum size by calling /purgeTMap/.
setMaximumSize :: (M.FiniteMapX map k, MonadAdvSTM m, Ord k, B.Backend k a b, C.CacheStructure c k)
=> TMap map k a b c -> Int -> m ()
setMaximumSize tmap maxSize
| maxSize <= 0 = Exc.throw $ TMapDefaultExc "setMaximumSize: Invalid size specified."
| otherwise = writeTVar (sizeTVar tmap) $ Just maxSize
-- | Gets the maximum size of the map. /O(1)/.
getMaximumSize :: (M.FiniteMapX map k, MonadAdvSTM m, Ord k, B.Backend k a b, C.CacheStructure c k)
=> TMap map k a b c
-> m (Maybe Int)
getMaximumSize tmap
| otherwise = readTVar (sizeTVar tmap)
-- | Gets the current size of the map. /O(1)/.
getCurrentSize :: (M.FiniteMapX map k, MonadAdvSTM m, Ord k, B.Backend k a b, C.CacheStructure c k)
=> TMap map k a b c
-> m Int
getCurrentSize tmap = do
(_,accSeq) <- readTVar (tmapTVar tmap)
return $ C.size accSeq
--------------------------------------------------------------------------------
-- | Sends a /B.flush/ request to the backend. Useful for asynchronous backend
-- implementations.
flushBackend :: (M.FiniteMapX map k, MonadIO m, Ord k, B.Backend k a b, C.CacheStructure c k)
=> TMap map k a b c -> m ()
flushBackend tmap = B.flush (backend tmap)