packages feed

tmapmvar 0.0.2 → 0.0.3

raw patch · 4 files changed

+149/−35 lines, 4 filesdep +QuickCheckdep +asyncdep +quickcheck-instancesdep ~base

Dependencies added: QuickCheck, async, quickcheck-instances, tasty, tasty-quickcheck, tmapmvar

Dependency ranges changed: base

Files

src/Control/Concurrent/STM/TMapMVar.hs view
@@ -4,7 +4,7 @@ import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Control.Monad (void)-import Control.Concurrent.STM (STM)+import Control.Concurrent.STM (STM, atomically) import Control.Concurrent.STM.TVar (TVar, newTVar, modifyTVar', readTVar) import Control.Concurrent.STM.TMVar (TMVar, readTMVar, tryReadTMVar, newEmptyTMVar, takeTMVar, tryTakeTMVar, swapTMVar, putTMVar) @@ -36,41 +36,41 @@   -- | Blocks if it's full-insert :: (Ord k) => TMapMVar k a -> k -> a -> STM ()+insert :: (Ord k) => TMapMVar k a -> k -> a -> IO () insert t k a = do   x <- getTMVar t k-  putTMVar x a+  atomically $ putTMVar x a  -- | Doesn't Block-insertForce :: (Ord k) => TMapMVar k a -> k -> a -> STM ()+insertForce :: (Ord k) => TMapMVar k a -> k -> a -> IO () insertForce t k a = do   x <- getTMVar t k-  putForceTMVar x a+  atomically $ putForceTMVar x a   -- | Blocks, and deletes upon looking it up-lookup :: (Ord k) => TMapMVar k a -> k -> STM a+lookup :: (Ord k) => TMapMVar k a -> k -> IO a lookup t k = do   x <- getTMVar t k-  takeTMVar x+  atomically $ takeTMVar x -tryLookup :: (Ord k) => TMapMVar k a -> k -> STM (Maybe a)+tryLookup :: (Ord k) => TMapMVar k a -> k -> IO (Maybe a) tryLookup t k = do   x <- getTMVar t k-  tryTakeTMVar x+  atomically $ tryTakeTMVar x  -- | Blocks, but doesn't delete when looking it up-observe :: (Ord k) => TMapMVar k a -> k -> STM a+observe :: (Ord k) => TMapMVar k a -> k -> IO a observe t k = do   x <- getTMVar t k-  readTMVar x+  atomically $ readTMVar x -tryObserve :: (Ord k) => TMapMVar k a -> k -> STM (Maybe a)+tryObserve :: (Ord k) => TMapMVar k a -> k -> IO (Maybe a) tryObserve t k = do   x <- getTMVar t k-  tryReadTMVar x+  atomically $ tryReadTMVar x -delete :: (Ord k) => TMapMVar k a -> k -> STM ()+delete :: (Ord k) => TMapMVar k a -> k -> IO () delete t k =   void $ tryLookup t k @@ -78,8 +78,8 @@  -- * Utils -getTMVar :: (Ord k) => TMapMVar k a -> k -> STM (TMVar a)-getTMVar (TMapMVar m) k = do+getTMVar :: (Ord k) => TMapMVar k a -> k -> IO (TMVar a)+getTMVar (TMapMVar m) k = atomically $ do   m' <- readTVar m   case Map.lookup k m' of     Nothing -> do
src/Control/Concurrent/STM/TMapMVar/Hash.hs view
@@ -5,12 +5,19 @@ import Data.Hashable (Hashable) import qualified Data.HashMap.Strict as HashMap import Control.Monad (void)-import Control.Concurrent.STM (STM)+import Control.Concurrent.STM (STM, atomically) import Control.Concurrent.STM.TVar (TVar, newTVar, modifyTVar', readTVar) import Control.Concurrent.STM.TMVar (TMVar, readTMVar, tryReadTMVar, newEmptyTMVar, takeTMVar, tryTakeTMVar, swapTMVar, putTMVar)  +putForceTMVar :: TMVar a -> a -> STM ()+putForceTMVar t x = do+  q <- tryReadTMVar t+  case q of+    Nothing -> putTMVar t x+    Just _  -> () <$ swapTMVar t x + newtype TMapMVar k a = TMapMVar   { getTMapMVar :: TVar (HashMap k (TMVar a))   }@@ -23,57 +30,57 @@ keys (TMapMVar m) = HashMap.keys <$> readTVar m  peekElems :: TMapMVar k a -> STM [a]-peekElems t@(TMapMVar m) = do+peekElems (TMapMVar m) = do   m' <- readTVar m   let ts = HashMap.elems m'   catMaybes <$> traverse tryReadTMVar ts   -- | Blocks if it's full-insert :: (Eq k, Hashable k) => TMapMVar k a -> k -> a -> STM ()+insert :: (Eq k, Hashable k) => TMapMVar k a -> k -> a -> IO () insert t k a = do   x <- getTMVar t k-  putTMVar x a+  atomically $ putTMVar x a  -- | Doesn't Block-insertForce :: (Eq k, Hashable k) => TMapMVar k a -> k -> a -> STM ()+insertForce :: (Eq k, Hashable k) => TMapMVar k a -> k -> a -> IO () insertForce t k a = do   x <- getTMVar t k-  void $ swapTMVar x a+  atomically $ putForceTMVar x a   -- | Blocks, and deletes upon looking it up-lookup :: (Eq k, Hashable k) => TMapMVar k a -> k -> STM a+lookup :: (Eq k, Hashable k) => TMapMVar k a -> k -> IO a lookup t k = do   x <- getTMVar t k-  takeTMVar x+  atomically $ takeTMVar x -tryLookup :: (Eq k, Hashable k) => TMapMVar k a -> k -> STM (Maybe a)+tryLookup :: (Eq k, Hashable k) => TMapMVar k a -> k -> IO (Maybe a) tryLookup t k = do   x <- getTMVar t k-  tryTakeTMVar x+  atomically $ tryTakeTMVar x  -- | Blocks, but doesn't delete when looking it up-observe :: (Eq k, Hashable k) => TMapMVar k a -> k -> STM a+observe :: (Eq k, Hashable k) => TMapMVar k a -> k -> IO a observe t k = do   x <- getTMVar t k-  readTMVar x+  atomically $ readTMVar x -tryObserve :: (Eq k, Hashable k) => TMapMVar k a -> k -> STM (Maybe a)+tryObserve :: (Eq k, Hashable k) => TMapMVar k a -> k -> IO (Maybe a) tryObserve t k = do   x <- getTMVar t k-  tryReadTMVar x+  atomically $ tryReadTMVar x -delete :: (Eq k, Hashable k) => TMapMVar k a -> k -> STM ()-delete t k = do+delete :: (Eq k, Hashable k) => TMapMVar k a -> k -> IO ()+delete t k =   void $ tryLookup t k    -- * Utils -getTMVar :: (Eq k, Hashable k) => TMapMVar k a -> k -> STM (TMVar a)-getTMVar (TMapMVar m) k = do+getTMVar :: (Eq k, Hashable k) => TMapMVar k a -> k -> IO (TMVar a)+getTMVar (TMapMVar m) k = atomically $ do   m' <- readTVar m   case HashMap.lookup k m' of     Nothing -> do
+ test/Spec.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE+    ScopedTypeVariables+  , RankNTypes+  #-}++module Main where++import Data.Map.Strict as Map+import Control.Monad (forM_)+import Control.Concurrent (threadDelay)+import Control.Concurrent.Async (async)+import Control.Concurrent.STM.TMapMVar as TMapMVar+import Control.Concurrent.STM.TVar (readTVar, newTVarIO, writeTVar, modifyTVar')+import Control.Concurrent.STM.TMVar (tryReadTMVar)+import Control.Concurrent.STM (atomically, STM)+import Test.Tasty (defaultMain, testGroup)+import Test.Tasty.QuickCheck (testProperty)+import Test.QuickCheck (Arbitrary (..), Property, ioProperty)+import System.IO.Unsafe (unsafePerformIO)++++main :: IO ()+main =+  defaultMain $ testGroup "Control.Concurrent.STM.TMapMVar"+    [ testProperty "Insert in Empty" insertInEmpty+    , testProperty "Insert in Full" insertInFull+    , testProperty "Insert Force doesn't Block" insertForceDoesntBlock+    , testProperty "Empty after Lookup" emptyAfterLookup+    , testProperty "Observe doesn't Mutate" nonMutativeObserve+    , testProperty "Lookup before Insert" lookupThenInsert+    ]+++insertInEmpty :: Int -> Int -> Property+insertInEmpty k v = ioProperty $ do+  var <- atomically newTMapMVar+  TMapMVar.insert var k v+  v' <- TMapMVar.observe var k+  pure (v == v')+++insertInFull :: Int -> Int -> Property+insertInFull k v = ioProperty $ do+  var <- do+    m <- atomically newTMapMVar+    TMapMVar.insert m k (v-1)+    pure m+  async $ do+    threadDelay 10+    TMapMVar.delete var k+  TMapMVar.insert var k v+  v' <- TMapMVar.lookup var k+  pure (v == v')+++insertForceDoesntBlock :: Int -> Int -> Int -> Property+insertForceDoesntBlock k v1 v2 = ioProperty $ do+  var <- atomically newTMapMVar+  TMapMVar.insert var k v1+  TMapMVar.insertForce var k v2+  v' <- TMapMVar.lookup var k+  pure (v' == v2)+++emptyAfterLookup :: Int -> Int -> Property+emptyAfterLookup k v = ioProperty $ do+  var <- atomically newTMapMVar+  TMapMVar.insert var k v+  _ <- TMapMVar.lookup var k+  mV' <- TMapMVar.tryObserve var k+  pure (mV' == Nothing)+++nonMutativeObserve :: Int -> Int -> Property+nonMutativeObserve k v = ioProperty $ do+  var <- atomically newTMapMVar+  TMapMVar.insert var k v+  v1 <- TMapMVar.observe var k+  v2 <- TMapMVar.observe var k+  pure (v1 == v2 && v2 == v)+++lookupThenInsert :: Int -> Int -> Property+lookupThenInsert k v = ioProperty $ do+  var <- atomically newTMapMVar+  async $ do+    threadDelay 10+    TMapMVar.insert var k v+  v' <- TMapMVar.lookup var k+  pure (v' == v)
tmapmvar.cabal view
@@ -1,5 +1,5 @@ name:                tmapmvar-version:             0.0.2+version:             0.0.3 synopsis:            A single-entity stateful Map in STM, similar to tmapchan -- description: homepage:            https://github.com/athanclark/tmapmvar#readme@@ -22,6 +22,22 @@                      , hashable                      , stm                      , unordered-containers+  default-language:    Haskell2010++test-suite tmapmvar-test+  type:                exitcode-stdio-1.0+  hs-source-dirs:      test+  main-is:             Spec.hs+  build-depends:       base+                     , tmapmvar+                     , async+                     , containers+                     , QuickCheck+                     , quickcheck-instances+                     , stm+                     , tasty+                     , tasty-quickcheck+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N   default-language:    Haskell2010  source-repository head