diff --git a/library/StmContainers/Bimap.hs b/library/StmContainers/Bimap.hs --- a/library/StmContainers/Bimap.hs +++ b/library/StmContainers/Bimap.hs @@ -30,7 +30,6 @@ -- of the right-hand type and vice versa. data Bimap leftKey rightKey = Bimap !(A.Map leftKey rightKey) !(A.Map rightKey leftKey) - deriving (Typeable) -- | -- Construct a new bimap. diff --git a/library/StmContainers/Multimap.hs b/library/StmContainers/Multimap.hs --- a/library/StmContainers/Multimap.hs +++ b/library/StmContainers/Multimap.hs @@ -30,7 +30,6 @@ -- Basically it's just a wrapper API around @'A.Map' key ('B.Set' value)@. newtype Multimap key value = Multimap (A.Map key (B.Set value)) - deriving (Typeable) -- | -- Construct a new multimap. diff --git a/library/StmContainers/Set.hs b/library/StmContainers/Set.hs --- a/library/StmContainers/Set.hs +++ b/library/StmContainers/Set.hs @@ -11,6 +11,7 @@ reset, unfoldlM, listT, + listTNonAtomic, ) where @@ -22,7 +23,6 @@ -- A hash set, based on an STM-specialized hash array mapped trie. newtype Set item = Set (A.SizedHamt item) - deriving (Typeable) -- | -- Construct a new set. @@ -114,3 +114,10 @@ listT :: Set item -> ListT STM item listT (Set hamt) = A.listT hamt + +-- | +-- Stream the elements passively. +-- Data may be inconsistent/out of date. +{-# INLINE listTNonAtomic #-} +listTNonAtomic :: Set item -> ListT IO item +listTNonAtomic (Set hamt) = A.listTNonAtomic hamt diff --git a/stm-containers.cabal b/stm-containers.cabal --- a/stm-containers.cabal +++ b/stm-containers.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: stm-containers -version: 1.2.1.1 +version: 1.2.2 synopsis: Containers for STM description: This library is based on an STM-specialized implementation of @@ -24,7 +24,7 @@ source-repository head type: git - location: git://github.com/nikita-volkov/stm-containers.git + location: https://github.com/nikita-volkov/stm-containers library hs-source-dirs: library @@ -82,7 +82,7 @@ focus >=1.0.1.4 && <1.1, hashable >=1.4 && <2, list-t >=1.0.1 && <1.1, - stm-hamt >=1.2.1 && <1.3, + stm-hamt >=1.2.2 && <1.3, transformers >=0.5 && <0.7, test-suite test @@ -134,6 +134,7 @@ Suites.Bimap Suites.Map Suites.Map.Update + Suites.Set build-depends: deferred-folds, diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,5 +1,6 @@ import qualified Suites.Bimap import qualified Suites.Map +import qualified Suites.Set import Test.Tasty import Prelude @@ -8,5 +9,6 @@ defaultMain . testGroup "" $ [ testGroup "Bimap" Suites.Bimap.tests, - testGroup "Map" Suites.Map.tests + testGroup "Map" Suites.Map.tests, + testGroup "Set" Suites.Set.tests ] diff --git a/test/Suites/Set.hs b/test/Suites/Set.hs new file mode 100644 --- /dev/null +++ b/test/Suites/Set.hs @@ -0,0 +1,125 @@ +module Suites.Set (tests) where + +import Control.Concurrent.STM +import qualified Control.Foldl as Foldl +import Control.Monad (forM_) +import Control.Monad.Free +import Data.Hashable +import Data.List (nub, sort, splitAt) +import Data.Word (Word8) +import qualified DeferredFolds.UnfoldlM as UnfoldlM +import qualified Focus +import qualified ListT +import qualified StmContainers.Set as StmSet +import System.IO.Unsafe (unsafePerformIO) +import Test.QuickCheck.Instances () +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck +import Prelude hiding (choose, null) + +-- helpers + +stmSetFromList :: (Hashable a, Eq a) => [a] -> STM (StmSet.Set a) +stmSetFromList xs = do + s <- StmSet.new + forM_ xs $ \x -> StmSet.insert x s + return s + +stmSetToList :: StmSet.Set a -> STM [a] +stmSetToList = UnfoldlM.foldM (Foldl.generalize Foldl.list) . StmSet.unfoldlM + +-- * Intentional hash collision simulation + +newtype TestKey = TestKey Word8 + deriving (Eq, Ord, 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 + +tests :: [TestTree] +tests = + [ testProperty "sizeAndList" + $ let gen = nub <$> listOf (choose ('a', 'z')) + prop xs = + length xs == stmSetSize + where + stmSetSize = + unsafePerformIO $ atomically $ do + s <- stmSetFromList xs + StmSet.size s + in forAll gen prop, + testProperty "fromListToListSetIsomorphism" $ \(xs :: [Int]) -> + let setList = + unsafePerformIO + $ atomically + $ stmSetFromList xs + >>= stmSetToList + in sort (nub xs) === sort setList, + testProperty "listTNonAtomicIsomorphism" $ \(xs :: [Int]) -> + let setList = + unsafePerformIO $ do + set <- atomically (stmSetFromList xs) + ListT.toList (StmSet.listTNonAtomic set) + in sort (nub xs) === sort setList, + testProperty "insertDeleteWithCollisions" $ \(ks :: [TestKey]) -> + let dropped = take (length ks `div` 2) ks + (finalSize, finalList) = + unsafePerformIO $ atomically $ do + s <- StmSet.new + -- insert all + forM_ ks $ \k -> StmSet.insert k s + -- delete ~the first half of them + forM_ dropped $ \k -> StmSet.delete k s + sz <- StmSet.size s + ls <- stmSetToList s + return (sz, sort ls) + expected = + let remaining = nub (filter (`notElem` dropped) ks) + in (length remaining, sort remaining) + in (finalSize, finalList) === expected, + testCase "insert" + $ assertEqual "" (sort ['a', 'b', 'c']) + =<< do + atomically $ do + s <- StmSet.new + StmSet.insert 'a' s + StmSet.insert 'c' s + StmSet.insert 'b' s + sort <$> stmSetToList s, + testCase "focusInsert" + $ assertEqual "" (sort ['a', 'b']) + =<< do + atomically $ do + s <- StmSet.new + StmSet.focus (Focus.insert ()) 'a' s + StmSet.focus (Focus.insert ()) 'b' s + sort <$> stmSetToList s, + testCase "insertAndDelete" + $ assertEqual "" ['b'] + =<< do + atomically $ do + s <- StmSet.new + StmSet.focus (Focus.insert ()) 'a' s + StmSet.focus (Focus.insert ()) 'b' s + StmSet.focus Focus.delete 'a' s + sort <$> stmSetToList s, + testCase "nullAndNotNull" $ do + assertEqual "" True =<< atomically (StmSet.null =<< StmSet.new) + assertEqual "" False =<< atomically (StmSet.null =<< stmSetFromList ['a']), + testCase "nullAfterDeletingTheLastElement" + $ assertEqual "" True + =<< do + atomically $ do + s <- stmSetFromList ['a'] + StmSet.delete 'a' s + StmSet.null s + ]