module Data.TMap(
TMap,
newTMapIO,
lookup,
insert,
delete,
member,
adjust,
purgeTMap,
purgeTMapIO,
getMaximumSize,
setMaximumSize,
getCurrentSize,
flushBackend,
TMapException(..),
)
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 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
| NotInTMap
| NotInBackend
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)
}
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
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)
return $ Just v
NotInBackend -> return Nothing
NotInTMap -> retryWith $ 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')
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)
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
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
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
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
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
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)
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 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
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)
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
flushBackend :: (M.FiniteMapX map k, Ord k, B.Backend k a b, C.CacheStructure c k)
=> TMap map k a b c -> IO ()
flushBackend tmap = B.flush (backend tmap)