packages feed

stm-containers 0.2.1 → 0.2.2

raw patch · 5 files changed

+287/−1 lines, 5 files

Files

+ executables/APITests/MapTests.hs view
@@ -0,0 +1,134 @@+{-# OPTIONS_GHC -F -pgmF htfpp #-}+module APITests.MapTests where++import Test.Framework+import BasePrelude+import Data.Hashable+import STMContainers.Transformers+import Control.Monad.Free+import qualified APITests.MapTests.Update as Update+import qualified STMContainers.Map as STMMap+import qualified Focus+import qualified Data.HashMap.Strict as HashMap+import qualified ListT+++interpretSTMMapUpdate :: (Hashable k, Eq k) => Update.Update k v -> STM (STMMap.Map k v)+interpretSTMMapUpdate update = do+  m <- STMMap.new+  flip iterM update $ \case+    Update.Insert k v c -> STMMap.insert v k m >> c+    Update.Delete k c   -> STMMap.delete k m >> c+    Update.Adjust f k c -> STMMap.focus ((Focus.adjustM . fmap return) f) k m >> c+  return m++interpretHashMapUpdate :: (Hashable k, Eq k) => Update.Update k v -> HashMap.HashMap k v+interpretHashMapUpdate update = +  flip execState HashMap.empty $ flip iterM update $ \case+    Update.Insert k v c -> modify (HashMap.insert k v) >> c+    Update.Delete k c   -> modify (HashMap.delete k) >> c+    Update.Adjust f k c -> modify (adjust f k) >> c+  where+    adjust f k m = +      case HashMap.lookup k m of+        Nothing -> m+        Just a -> HashMap.insert k (f a) m++stmMapToHashMap :: (Hashable k, Eq k) => STMMap.Map k v -> STM (HashMap.HashMap k v)+stmMapToHashMap = ListT.fold f HashMap.empty . STMMap.stream+  where+    f m (k, v) = return (HashMap.insert k v m)++stmMapFromList :: (Hashable k, Eq k) => [(k, v)] -> STM (STMMap.Map k v)+stmMapFromList list = do+  m <- STMMap.new+  forM_ list $ \(k, v) -> STMMap.insert v k m+  return m++stmMapToList :: STMMap.Map k v -> STM [(k, v)]+stmMapToList = ListT.fold (\l -> return . (:l)) [] . STMMap.stream++interpretSTMMapUpdateAsHashMap :: (Hashable k, Eq k) => Update.Update k v -> HashMap.HashMap k v+interpretSTMMapUpdateAsHashMap =+  unsafePerformIO . atomically . (stmMapToHashMap <=< interpretSTMMapUpdate)+++-- * Intentional hash collision simulation+-------------------------++newtype TestKey = TestKey Word8+  deriving (Eq, Show)++instance Arbitrary TestKey where+  arbitrary = TestKey <$> choose (0, 63)++instance Hashable TestKey where+  hashWithSalt salt (TestKey w) =+    if odd w+      then hashWithSalt salt (pred w)+      else hashWithSalt salt w+++-- * Tests+-------------------------++prop_fromListToListIsomorphism =+  forAll gen prop+  where+    gen = do+      keys <- nub <$> listOf (arbitrary :: Gen Char)+      mapM (liftA2 (flip (,)) (arbitrary :: Gen Int) . pure) keys+    prop list =+      list \\ list' === []+      where+        list' = unsafePerformIO $ atomically $ stmMapFromList list >>= stmMapToList++prop_updatesProduceTheSameEffectAsInHashMap =+  withQCArgs (\a -> a {maxSuccess = 1000}) prop+  where+    prop (updates :: [Update.Update TestKey ()]) =+      interpretHashMapUpdate update === interpretSTMMapUpdateAsHashMap update+      where+        update = sequence_ updates++test_insert = do+  assertEqual (HashMap.fromList [('a', 1), ('b', 2), ('c', 3)]) =<< do +    atomically $ do+      m <- STMMap.new+      STMMap.insert 1 'a' m+      STMMap.insert 3 'c' m+      STMMap.insert 2 'b' m+      stmMapToHashMap m++test_insert2 = do+  assertEqual (HashMap.fromList [(111 :: Int, ()), (207, ())]) =<< do +    atomically $ do+      m <- STMMap.new+      STMMap.insert () 111 m+      STMMap.insert () 207 m+      stmMapToHashMap m++test_adjust = do+  assertEqual (HashMap.fromList [('a', 1), ('b', 3)]) =<< do +    atomically $ do+      m <- stmMapFromList [('a', 1), ('b', 2)]+      STMMap.focus (Focus.adjustM (const $ return 3)) 'b' m+      stmMapToHashMap m++test_focusReachesTheTarget = do+  assertEqual (Just 2) =<< do +    atomically $ do+      m <- stmMapFromList [('a', 1), ('b', 2)]+      STMMap.focus Focus.lookupM 'b' m++test_notNull = do+  assertEqual False =<< do +    atomically $ STMMap.null =<< stmMapFromList [('a', ())]++test_nullAfterDeletingTheLastElement = do+  assertEqual True =<< do +    atomically $ do+      m <- stmMapFromList [('a', ())]+      STMMap.delete 'a' m+      STMMap.null m+
+ executables/APITests/MapTests/Update.hs view
@@ -0,0 +1,52 @@+module APITests.MapTests.Update where++import Test.Framework+import BasePrelude hiding (insert, delete, update)+import STMContainers.Transformers+import Control.Monad.Free+import Control.Monad.Free.TH+++data UpdateF k v c =+  Insert k v c |+  Delete k c |+  Adjust (v -> v) k c+  deriving (Functor)++instance (Show k, Show v, Show c) => Show (UpdateF k v c) where+  showsPrec i = +    showParen (i > 5) . \case+      Insert k v c -> +        showString "Insert " . +        showsPrecInner k .+        showChar ' ' .+        showsPrecInner v .+        showChar ' ' .+        showsPrecInner c+      Delete k c ->+        showString "Delete " .+        showsPrecInner k .+        showChar ' ' .+        showsPrecInner c+      Adjust f k c ->+        showString "Adjust " .+        showString "<v -> v> " .+        showsPrecInner k .+        showChar ' ' .+        showsPrecInner c+    where+      showsPrecInner = showsPrec (succ 5)++makeFree ''UpdateF++type Update k v = Free (UpdateF k v) ()++instance (Arbitrary k, Arbitrary v) => Arbitrary (Update k v) where+  arbitrary = +    frequency+      [+        (1 , delete <$> arbitrary),+        (10, insert <$> arbitrary <*> arbitrary),+        (3 , adjust <$> (const <$> arbitrary) <*> arbitrary)+      ]+
+ executables/STMContainers/Transformers.hs view
@@ -0,0 +1,11 @@+module STMContainers.Transformers (module Exports) where++-- mtl+-------------------------+import Control.Monad.Identity as Exports hiding (mapM_, sequence_, forM_, msum, mapM, sequence, forM)+import Control.Monad.State.Strict as Exports hiding (mapM_, sequence_, forM_, msum, mapM, sequence, forM)+import Control.Monad.Reader as Exports hiding (mapM_, sequence_, forM_, msum, mapM, sequence, forM)+import Control.Monad.Writer.Strict as Exports hiding (mapM_, sequence_, forM_, msum, mapM, sequence, forM, Any)+import Control.Monad.RWS.Strict as Exports hiding (mapM_, sequence_, forM_, msum, mapM, sequence, forM, Any)+import Control.Monad.Error as Exports hiding (mapM_, sequence_, forM_, msum, mapM, sequence, forM)+import Control.Monad.Trans as Exports
+ executables/WordArrayTests/Update.hs view
@@ -0,0 +1,76 @@+module WordArrayTests.Update where++import Test.Framework+import STMContainers.Prelude+import STMContainers.Transformers+import Control.Monad.Free+import Control.Monad.Free.TH+import qualified STMContainers.WordArray as WordArray+++data UpdateF e f =+  Singleton Int e f |+  Set Int e f |+  Unset Int f+  deriving (Functor)++makeFree ''UpdateF++newtype Update e r = Update (Free (UpdateF e) r)++instance Show (Update e r) where+  show = const "<Update>"++instance Arbitrary (Update Char ()) where+  arbitrary = do+    i <- bit+    v <- char+    fmap Update $ build $ singleton i v+    where+      build = execStateT $ do+        amount <- lift $ choose (0, 200)+        replicateM_ amount $ do+          lift (choose (0 :: Int, 1)) >>= \case+            0 -> do+              i <- lift $ bit+              v <- lift $ char+              modify (>> set i v)+            1 -> do+              i <- lift $ bit+              modify (>> unset i)+      char = fmap chr $ choose (ord 'a', ord 'z')+      bit = choose (0, pred wordSize)++interpretWordArray :: Update e () -> Maybe (WordArray.WordArray e)+interpretWordArray (Update u) = +  flip execState Nothing $ flip iterM u $ \case+    Singleton i e f -> do+      put $ Just $ WordArray.singleton i e+      f+    Set i e f -> get >>= put . fmap (WordArray.set i e) >> f+    Unset i f -> get >>= put . fmap (WordArray.unset i) >> f++interpretMaybeList :: Update e () -> Maybe [Maybe e]+interpretMaybeList (Update u) = +  flip execState Nothing $ flip iterM u $ \case+    Singleton i e f -> do+      put $ Just $ map (\i' -> if i == i' then Just e else Nothing) [0 .. pred wordSize]+      f+    Set i e f -> do+      lm <- get+      lm' <- forM lm $ \l -> +        return $ do+          (i', e') <- zip [0..] l+          return $ if i == i' then Just e else e'+      put lm'+      f+    Unset i f -> do+      lm <- get+      put $ flip fmap lm $ \l -> do+        (i', e') <- zip [0..] l+        return $ if i == i' then Nothing else e'+      f++wordSize :: Int+wordSize = bitSize (undefined :: Word)+
stm-containers.cabal view
@@ -1,7 +1,7 @@ name:   stm-containers version:-  0.2.1+  0.2.2 synopsis:   Containers for STM description:@@ -86,6 +86,9 @@     library   main-is:     WordArrayTests.hs+  other-modules:+    WordArrayTests.Update+    STMContainers.Transformers   build-depends:     -- testing:     free >= 4.6 && < 4.10,@@ -117,6 +120,10 @@     executables   main-is:     APITests.hs+  other-modules:+    APITests.MapTests+    APITests.MapTests.Update+    STMContainers.Transformers   build-depends:     QuickCheck == 2.7.*,     HTF == 0.12.*,@@ -146,6 +153,8 @@     executables   main-is:     InsertionBench.hs+  other-modules:+    STMContainers.Transformers   ghc-options:     -O2 -threaded "-with-rtsopts=-N"   default-extensions:@@ -179,6 +188,8 @@     executables   main-is:     ConcurrentInsertionBench.hs+  other-modules:+    STMContainers.Transformers   ghc-options:     -O2 -threaded "-with-rtsopts=-N"   default-extensions:@@ -212,6 +223,8 @@     executables   main-is:     ConcurrentTransactionsBench.hs+  other-modules:+    STMContainers.Transformers   ghc-options:     -O2 -threaded "-with-rtsopts=-N"   default-extensions: