module Data.TMap(
TMap,
TFiniteMap,
newTMapIO,
newTFiniteMapIO,
lookup,
insert,
delete,
member,
adjust,
purgeTMapIO,
getMaximumSize,
setMaximumSize,
getCurrentSize,
markAsDirty,
tryMarkAsDirty,
flushBackend,
module Data.TMap.Exception,
)
where
import Control.Concurrent.AdvSTM
import Control.Concurrent.AdvSTM.TVar
import Control.Monad( liftM, when )
import Control.Monad.Trans( MonadIO, liftIO )
import qualified Control.Exception as E
import Data.Maybe( isJust, isNothing )
import Prelude hiding (lookup,catch)
import qualified Data.TMap.Backend as B
import qualified Data.CacheStructure as C
import Data.CacheStructure.LRU(LRU)
import Data.TMap.Exception( TMapException(..) )
import qualified Data.Edison.Assoc as M
import qualified Data.Edison.Assoc.StandardMap as FM
data Entry a = Entry a
| NotInTMap
| NotInBackend
| Exc E.SomeException
deriving (Show)
instance Functor Entry where
fmap _ NotInBackend = NotInBackend
fmap _ NotInTMap = NotInTMap
fmap f (Entry a) = Entry (f a)
fmap _ (Exc e) = Exc e
data TMap map key val backendType cacheType = TMap
{ backend :: backendType key val
, sizeTVar :: TVar (Maybe Int)
, tmapTVar :: TVar (map (Entry val),cacheType key)
}
type TFiniteMap key val backendType = TMap (FM.FM key) key val backendType LRU
newTMapIO :: (M.FiniteMapX map k, Ord k, B.Backend k a b,C.CacheStructure c k)
=> b k a
-> Maybe Int
-> 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
newTFiniteMapIO :: (Ord k, B.Backend k a b)
=> b k a
-> IO (TFiniteMap k a b)
newTFiniteMapIO b = newTMapIO b Nothing
lookup :: (M.FiniteMapX map k, MonadAdvSTM stm, Ord k, B.Backend k a b,C.CacheStructure c k)
=> k -> TMap map k a b c -> stm (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)
return $ Just v
NotInBackend -> return Nothing
Exc e -> E.throw e
NotInTMap -> retryWith $ E.handle onExc $ do
result <- B.lookup (backend tmap) k
case result of
Nothing -> do
atomically $ do
(themap',accSeq') <- readTVar (tmapTVar tmap)
writeTVar (tmapTVar tmap) (M.insert k NotInBackend themap', accSeq')
Just v -> do
atomically $ do
(themap',accSeq') <- readTVar (tmapTVar tmap)
writeTVar (tmapTVar tmap) ( M.insert k (Entry v) themap'
, C.hit k accSeq')
where
onExc (e::E.SomeException) = do
atomically $ do
(themap',accSeq') <- readTVar (tmapTVar tmap)
writeTVar (tmapTVar tmap) (M.insert k (Exc e) themap', accSeq')
member :: (M.FiniteMapX map k, MonadAdvSTM stm, Ord k, B.Backend k a b,C.CacheStructure c k)
=> k -> TMap map k a b c -> stm Bool
member k = liftM isJust . lookup k
insert :: (M.FiniteMapX map k, MonadAdvSTM stm, Ord k, B.Backend k a b, C.CacheStructure c k)
=> k -> a -> TMap map k a b c -> stm ()
insert k a tmap = do
res <- lookup k tmap
when (isJust res) $ E.throw DuplicateEntry
(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
adjust :: (M.FiniteMapX map k, MonadAdvSTM stm, Ord k, B.Backend k a b, C.CacheStructure c k)
=> (a -> a) -> k -> TMap map k a b c -> stm ()
adjust f k tmap = do
res <- lookup k tmap
when (isNothing res) $ E.throw EntryNotFound
(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
delete :: (M.FiniteMapX map k, MonadAdvSTM stm, Ord k, B.Backend k a b,C.CacheStructure c k)
=> k -> TMap map k a b c -> stm ()
delete k tmap = do
res <- lookup k tmap
when (isNothing res) $ E.throw EntryNotFound
(themap,accSeq) <- readTVar (tmapTVar tmap)
writeTVar (tmapTVar tmap) (M.insert k NotInBackend themap, accSeq)
onCommit $ B.delete (backend tmap) k
purgeTMapIO :: (M.FiniteMapX map k, MonadIO io, Ord k, B.Backend k a b, C.CacheStructure c k)
=> TMap map k a b c -> io ()
purgeTMapIO = liftIO . atomically . purgeTMap
purgeTMap :: (M.FiniteMapX map k, MonadAdvSTM stm, Ord k, B.Backend k a b, C.CacheStructure c k)
=> TMap map k a b c -> stm ()
purgeTMap tmap = do
mSize <- readTVar (sizeTVar tmap)
case mSize of
Just maxSize -> do
(themap,accSeq) <- readTVar (tmapTVar tmap)
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)
Nothing -> return ()
setMaximumSize :: (M.FiniteMapX map k, MonadAdvSTM stm, Ord k, B.Backend k a b, C.CacheStructure c k)
=> TMap map k a b c -> Int -> stm ()
setMaximumSize tmap maxSize
| maxSize <= 0 = E.throw $ TMapDefaultExc "setMaximumSize: Invalid size specified."
| otherwise = writeTVar (sizeTVar tmap) $ Just maxSize
getMaximumSize :: (M.FiniteMapX map k, MonadAdvSTM stm, Ord k, B.Backend k a b, C.CacheStructure c k)
=> TMap map k a b c
-> stm (Maybe Int)
getMaximumSize tmap
| otherwise = readTVar (sizeTVar tmap)
getCurrentSize :: (M.FiniteMapX map k, MonadAdvSTM stm, Ord k, B.Backend k a b, C.CacheStructure c k)
=> TMap map k a b c
-> stm Int
getCurrentSize tmap = do
(_,accSeq) <- readTVar (tmapTVar tmap)
return $ C.size accSeq
markAsDirty :: (M.FiniteMapX map k, Ord k, B.Backend k a b, C.CacheStructure c k)
=> k -> TMap map k a b c -> IO ()
markAsDirty k tmap = atomically $ do
res <- lookup k tmap
when (isNothing res) $ E.throw EntryNotFound
(themap,accSeq) <- readTVar (tmapTVar tmap)
writeTVar (tmapTVar tmap) (M.insert k NotInTMap themap, accSeq)
tryMarkAsDirty :: (M.FiniteMapX map k, Ord k, B.Backend k a b, C.CacheStructure c k)
=> k -> TMap map k a b c -> IO ()
tryMarkAsDirty k tmap =
markAsDirty k tmap `E.catch` (\(e::TMapException) ->
if e == EntryNotFound then return ()
else E.throw e)
flushBackend :: (M.FiniteMapX map k, Ord k, B.Backend k a b, C.CacheStructure c k)
=> TMap map k a b c -> IO ()
flushBackend = B.flush . backend