packages feed

stm-containers 0.1.4 → 1.2.2

raw patch · 28 files changed

Files

− Setup.hs 
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
− executables/APITests.hs 
@@ -1,9 +0,0 @@-{-# OPTIONS_GHC -F -pgmF htfpp #-}--import Test.Framework-import BasePrelude--import {-@ HTF_TESTS @-} APITests.MapTests---main = htfMain $ htf_thisModulesTests : htf_importedTests
− executables/ConcurrentInsertionBench.hs 
@@ -1,131 +0,0 @@--import STMContainers.Prelude-import Criterion.Main-import Control.Monad.Free-import Control.Monad.Free.TH-import qualified Data.HashMap.Strict as UC-import qualified STMContainers.Map as SC-import qualified Control.Concurrent.Async as Async-import qualified System.Random.MWC.Monad as MWC-import qualified Focus-import qualified Data.Char as Char-import qualified Data.Text as Text---type UCMap k v = TVar (UC.HashMap k (TVar v))----- * Transactions ----------------------------data TransactionF k v n where-  Insert :: v -> k -> n -> TransactionF k v n-  deriving (Functor)--type Transaction k v = Free (TransactionF k v)----- * Interpreters----------------------------type Interpreter m = -  forall k v r. (Hashable k, Eq k) => m k v -> Transaction k v r -> STM r--ucInterpreter :: Interpreter UCMap-ucInterpreter m = -  iterM $ \case-    Insert v k n -> do-      mv <- readTVar m-      vt <- newTVar v-      writeTVar m $! UC.insert k vt mv-      n--specializedSCInterpreter :: Interpreter SC.Map-specializedSCInterpreter m =-  iterM $ \case-    Insert v k n -> SC.insert v k m >> n--focusSCInterpreter :: Interpreter SC.Map-focusSCInterpreter m =-  iterM $ \case-    Insert v k n -> SC.focus (Focus.insertM v) k m >> n----- * Session and runners------------------------------ | A list of transactions per thread.-type Session k v = [[Transaction k v ()]]--type SessionRunner = -  forall k v. (Hashable k, Eq k) => Session k v -> IO ()--scSessionRunner :: Interpreter SC.Map -> SessionRunner-scSessionRunner interpreter threadTransactions = do-  m <- atomically $ SC.new-  void $ flip Async.mapConcurrently threadTransactions $ \actions -> do-    forM_ actions $ atomically . interpreter m--ucSessionRunner :: SessionRunner-ucSessionRunner threadTransactions = do-  m <- newTVarIO UC.empty-  void $ flip Async.mapConcurrently threadTransactions $ \actions -> do-    forM_ actions $ atomically . ucInterpreter m----- * Generators----------------------------type Generator a = MWC.Rand IO a--transactionGenerator :: Generator (Transaction Text.Text () ())-transactionGenerator = do-  k <- keyGenerator-  return $ Free $ Insert () k (Pure ())--keyGenerator :: Generator Text.Text-keyGenerator = do-  l <- length-  s <- replicateM l char-  return $! Text.pack s-  where-    length = MWC.uniformR (7, 20)-    char = Char.chr <$> MWC.uniformR (Char.ord 'a', Char.ord 'z')----- * Utils----------------------------slices :: Int -> [a] -> [[a]]-slices size l =-  case splitAt size l of-    ([], _) -> []-    (a, b) -> a : slices size b----- * Main----------------------------main = do-  allTransactions <- MWC.runWithCreate $ replicateM actionsNum transactionGenerator-  defaultMain $! flip map threadsNums $! \threadsNum ->-    let-      sliceSize = actionsNum `div` threadsNum-      threadTransactions = slices sliceSize allTransactions-      in -        bgroup-          (shows threadsNum . showString "/" . shows sliceSize $ "")-          [-            bgroup "STM Containers"-              [-                bench "Focus-based" $ -                  scSessionRunner focusSCInterpreter threadTransactions,-                bench "Specialized" $ -                  scSessionRunner specializedSCInterpreter threadTransactions-              ],-            bench "Unordered Containers" $-              ucSessionRunner threadTransactions-          ]-  where-    actionsNum = 100000-    threadsNums = [1, 2, 4, 6, 8, 12, 16, 32, 40, 52, 64, 80, 128]
− executables/ConcurrentTransactionsBench.hs 
@@ -1,208 +0,0 @@--import STMContainers.Prelude-import STMContainers.Transformers-import Criterion.Main-import Control.Monad.Free-import Control.Monad.Free.TH-import qualified Data.HashMap.Strict as UC-import qualified STMContainers.Map as SC-import qualified Control.Concurrent.Async as Async-import qualified System.Random.MWC.Monad as MWC-import qualified Focus-import qualified Data.Char as Char-import qualified Data.Text as Text-import qualified Data.Set as Set----- * Custom data structures----------------------------type UCMap k v = TVar (UC.HashMap k (TVar v))----- * Transactions ----------------------------data TransactionF k v n where-  Insert :: v -> k -> n -> TransactionF k v n-  Delete :: k -> n -> TransactionF k v n-  Lookup :: k -> n -> TransactionF k v n-  deriving (Functor, Show)--type Transaction k v = Free (TransactionF k v)---- * Interpreters----------------------------type Interpreter m = -  forall k v r. (Hashable k, Eq k) => m k v -> Transaction k v r -> STM r--ucInterpreter :: Interpreter UCMap-ucInterpreter m = -  iterM $ \case-    Insert v k c -> -      do-        mv <- readTVar m-        vt <- newTVar v-        writeTVar m $! UC.insert k vt mv-        c-    Delete k c -> -      readTVar m >>= writeTVar m . UC.delete k >> c-    Lookup k c -> -      readTVar m >>= mapM readTVar . UC.lookup k >> c--specializedSCInterpreter :: Interpreter SC.Map-specializedSCInterpreter m =-  iterM $ \case-    Insert v k c -> SC.insert v k m >> c-    Delete k c   -> SC.delete k m >> c-    Lookup k c   -> SC.lookup k m >> c--focusSCInterpreter :: Interpreter SC.Map-focusSCInterpreter m =-  iterM $ \case-    Insert v k c -> SC.focus (Focus.insertM v) k m >> c-    Delete k c   -> SC.focus Focus.deleteM k m >> c-    Lookup k c   -> SC.focus Focus.lookupM k m >> c----- * Session and runners------------------------------ | A list of transactions per thread.-type Session k v = [[Transaction k v ()]]--type SessionRunner = -  forall k v. (Hashable k, Eq k) => Session k v -> IO ()--scSessionRunner :: Interpreter SC.Map -> SessionRunner-scSessionRunner interpreter threadTransactions = do-  m <- atomically $ SC.new-  void $ flip Async.mapConcurrently threadTransactions $ \actions -> do-    forM_ actions $ atomically . interpreter m--ucSessionRunner :: SessionRunner-ucSessionRunner threadTransactions = do-  m <- newTVarIO UC.empty-  void $ flip Async.mapConcurrently threadTransactions $ \actions -> do-    forM_ actions $ atomically . ucInterpreter m----- * Generators----------------------------type Generator a = MWC.Rand IO a---- |--- Generate a list of transactions with a context of shared keys.-transactionsGroupGenerator :: Int -> Generator [Transaction Text.Text () ()]-transactionsGroupGenerator n =-  (flip evalStateT) Set.empty $ replicateM n transaction-  where-    transaction = do-      s <- size-      fmap sequence_ $ replicateM s action-      where-        size = -          lift $ join $ weightedElementGenerator $-          [-            (1  , MWC.uniformR (8, 14)),-            (5  , MWC.uniformR (2, 7)),-            (10 , return 1)-          ]-        action =-          join $ lift $ weightedElementGenerator $-          [-            (1, delete),-            (5, insert),-            (20, lookup)-          ]-          where-            insert = do-              k <- key 10 1-              modify $ Set.insert k-              return $ liftF (Insert () k ())-            delete = do-              k <- key 1 10-              modify $ Set.delete k-              return $ liftF (Delete k ())-            lookup = do-              k <- key 1 5-              return $ liftF (Lookup k ())-            key unknownWeight knownWeight =-              join $ lift $ weightedElementGenerator $ -              [-                (unknownWeight, unknown), -                (knownWeight, known)-              ]-              where-                unknown = lift $ keyGenerator-                known = do-                  allKeys <- get-                  maybe unknown return =<< lift (setElementGenerator allKeys)-              -keyGenerator :: Generator Text.Text-keyGenerator = do-  l <- length-  s <- replicateM l char-  return $! Text.pack s-  where-    length = MWC.uniformR (7, 20)-    char = Char.chr <$> MWC.uniformR (Char.ord 'a', Char.ord 'z')--setElementGenerator :: Set.Set a -> Generator (Maybe a)-setElementGenerator set = do-  case Set.size set of-    0 -> return Nothing-    size -> Just . (flip Set.elemAt) set <$> MWC.uniformR (0, pred size)--elementGenerator :: [a] -> Generator a-elementGenerator = \case-  [] -> $bug "Empty list"-  l -> (!!) l <$> MWC.uniformR (0, (pred . length) l)--weightedElementGenerator :: [(Int, a)] -> Generator a-weightedElementGenerator = \case-  [] -> -    $bug "Empty list"-  l -> -    (flip pick) l <$> MWC.uniformR (1, total)-    where-      total = (sum . map fst) l-      pick n = \case-        (n', e) : t ->-          if n' >= n-            then e -            else pick (n - n') t---- * Utils----------------------------slices :: Int -> [a] -> [[a]]-slices size l =-  case splitAt size l of-    ([], _) -> []-    (a, b) -> a : slices size b----- * Main----------------------------main = do-  -- Pregenerate the transactions:-  transactionsGroups <- -    MWC.runWithCreate $ replicateM (maximum threadsNums) $-    transactionsGroupGenerator (transactionsNum `div` (maximum threadsNums))--  -- Run the benchmark:-  defaultMain $! flip map threadsNums $ \threadsNum -> -    let-      session = -        map concat $! -        slices (length transactionsGroups `div` threadsNum) transactionsGroups-      in-        bench (shows threadsNum . showString "/" . shows (transactionsNum `div` threadsNum) $ "") $-          scSessionRunner specializedSCInterpreter session-  where-    threadsNums = [1, 2, 4, 6, 8, 12, 16, 32, 40, 52, 64, 80, 128]-    transactionsNum = 400000
− executables/InsertionBench.hs 
@@ -1,52 +0,0 @@--import STMContainers.Prelude-import Criterion.Main-import qualified Data.HashTable.IO as Hashtables-import qualified Data.HashMap.Strict as UnorderedContainers-import qualified Data.Map as Containers-import qualified STMContainers.Map as STMContainers-import qualified Focus-import qualified System.Random.MWC.Monad as MWC-import qualified Data.Char as Char-import qualified Data.Text as Text--main = do-  keys <- MWC.runWithCreate $ replicateM rows keyGenerator-  defaultMain-    [-      bgroup "STM Containers"-      [-        bench "focus-based" $ -          do-            t <- atomically $ STMContainers.new :: IO (STMContainers.Map Text.Text ())-            forM_ keys $ \k -> atomically $ STMContainers.focus (Focus.insertM ()) k t-        ,-        bench "specialized" $-          do-            t <- atomically $ STMContainers.new :: IO (STMContainers.Map Text.Text ())-            forM_ keys $ \k -> atomically $ STMContainers.insert () k t-      ]-      ,-      bench "Unordered Containers" $-        nf (foldr (\k -> UnorderedContainers.insert k ()) UnorderedContainers.empty) keys-      ,-      bench "Containers" $-        nf (foldr (\k -> Containers.insert k ()) Containers.empty) keys-      ,-      bench "Hashtables" $ -        do-          t <- Hashtables.new :: IO (Hashtables.BasicHashTable Text.Text ())-          forM_ keys $ \k -> Hashtables.insert t k ()-    ]--rows :: Int = 100000--keyGenerator :: MWC.Rand IO Text.Text-keyGenerator = do-  l <- length-  s <- replicateM l char-  return $! Text.pack s-  where-    length = MWC.uniformR (7, 20)-    char = Char.chr <$> MWC.uniformR (Char.ord 'a', Char.ord 'z')-
− executables/WordArrayTests.hs 
@@ -1,40 +0,0 @@-{-# OPTIONS_GHC -F -pgmF htfpp #-}--import Test.Framework-import STMContainers.Prelude-import STMContainers.Transformers-import qualified STMContainers.WordArray as WordArray-import qualified Focus-import qualified WordArrayTests.Update as Update---main = htfMain $ htf_thisModulesTests--prop_differentInterpretersProduceSameResults (update :: Update.Update Char ()) =-  Update.interpretMaybeList update ==-  fmap WordArray.toMaybeList (Update.interpretWordArray update)--prop_fromListIsIsomorphicToToList =-  forAll gen prop-  where-    gen = do-      indices <- (nub . sort) <$> listOf index-      mapM (liftA2 (flip (,)) char . pure) indices-      where-        index = choose (0, pred (WordArray.maxSize)) :: Gen Int-        char = arbitrary :: Gen Char-    prop list = -      list === (WordArray.toList . WordArray.fromList) list--test_focusMLookup = do-  assertEqual (Just 'a') . fst =<< WordArray.focusM Focus.lookupM 3 w-  assertEqual (Just 'b') . fst =<< WordArray.focusM Focus.lookupM 7 w-  assertEqual Nothing . fst =<< WordArray.focusM Focus.lookupM 1 w-  assertEqual Nothing . fst =<< WordArray.focusM Focus.lookupM 11 w-  where-    w = WordArray.fromList [(3, 'a'), (7, 'b'), (14, 'c')]--test_foldable = do-  assertEqual "abdc" $ toList w-  where-    w = WordArray.fromList [(3, 'a'), (7, 'b'), (8, 'd'), (14, 'c')]
− library/STMContainers/Bimap.hs 
@@ -1,143 +0,0 @@-module STMContainers.Bimap-(-  Bimap,-  Association,-  new,-  newIO,-  insert1,-  insert2,-  delete1,-  delete2,-  lookup1,-  lookup2,-  focus1,-  focus2,-  foldM,-  null,-)-where--import STMContainers.Prelude hiding (insert, delete, lookup, alter, foldM, toList, empty, null)-import qualified Focus-import qualified STMContainers.Map as Map----- |--- A bidirectional map.--- Essentially a bijection between subsets of its two argument types.--- --- For one value of a left-hand type this map contains one value --- of the right-hand type and vice versa.-data Bimap a b = -  Bimap {m1 :: !(Map.Map a b), m2 :: !(Map.Map b a)}---- |--- A standard constraint for associations.-type Association a b = (Map.Key a, Map.Key b)---- |--- Construct a new bimap.-{-# INLINABLE new #-}-new :: STM (Bimap a b)-new = Bimap <$> Map.new <*> Map.new---- |--- Construct a new bimap in IO.--- --- This is useful for creating it on a top-level using 'unsafePerformIO', --- because using 'atomically' inside 'unsafePerformIO' isn't possible.-{-# INLINABLE newIO #-}-newIO :: IO (Bimap a b)-newIO = Bimap <$> Map.newIO <*> Map.newIO---- |--- Check on being empty.-{-# INLINABLE null #-}-null :: Bimap a b -> STM Bool-null = Map.null . m1---- |--- Look up a right value by a left value.-{-# INLINABLE lookup1 #-}-lookup1 :: (Association a b) => a -> Bimap a b -> STM (Maybe b)-lookup1 k = Map.lookup k . m1---- |--- Look up a left value by a right value.-{-# INLINABLE lookup2 #-}-lookup2 :: (Association a b) => b -> Bimap a b -> STM (Maybe a)-lookup2 k = Map.lookup k . m2---- |--- Insert an association by a left value.-{-# INLINABLE insert1 #-}-insert1 :: (Association a b) => b -> a -> Bimap a b -> STM ()-insert1 b a (Bimap m1 m2) = -  do-    Map.insert b a m1-    Map.insert a b m2---- |--- Insert an association by a right value.-{-# INLINABLE insert2 #-}-insert2 :: (Association a b) => a -> b -> Bimap a b -> STM ()-insert2 b a (Bimap m1 m2) = (inline insert1) b a (Bimap m2 m1)---- |--- Delete an association by a left value.-{-# INLINABLE delete1 #-}-delete1 :: (Association a b) => a -> Bimap a b -> STM ()-delete1 k (Bimap m1 m2) =-  Map.focus lookupAndDeleteStrategy k m1 >>= -    mapM_ (\k' -> Map.delete k' m2)-  where-    lookupAndDeleteStrategy r =-      return (r, Focus.Remove)---- |--- Delete an association by a right value.-{-# INLINABLE delete2 #-}-delete2 :: (Association a b) => b -> Bimap a b -> STM ()-delete2 k (Bimap m1 m2) = (inline delete1) k (Bimap m2 m1)---- |--- Focus on a right value by a left value with a strategy.--- --- This function allows to perform composite operations in a single access--- to a map item.--- E.g., you can look up an item and delete it at the same time,--- or update it and return the new value.-{-# INLINABLE focus1 #-}-focus1 :: (Association a b) => Focus.StrategyM STM b r -> a -> Bimap a b -> STM r-focus1 s a (Bimap m1 m2) =-  do -    (r, d, mb) <- Map.focus s' a m1-    case d of-      Focus.Keep -> -        return ()-      Focus.Remove -> -        forM_ mb $ \b -> Map.delete b m2-      Focus.Replace b' ->-        do-          forM_ mb $ \b -> Map.delete b m2-          Map.insert a b' m2-    return r-  where-    s' = \k -> s k >>= \(r, d) -> return ((r, d, k), d)---- |--- Focus on a left value by a right value with a strategy.--- --- This function allows to perform composite operations in a single access--- to a map item.--- E.g., you can look up an item and delete it at the same time,--- or update it and return the new value.-{-# INLINABLE focus2 #-}-focus2 :: (Association a b) => Focus.StrategyM STM a r -> b -> Bimap a b -> STM r-focus2 s b (Bimap m1 m2) = (inline focus1) s b (Bimap m2 m1)---- |--- Fold all the associations.-{-# INLINABLE foldM #-}-foldM :: (r -> (a, b) -> STM r) -> r -> Bimap a b -> STM r-foldM s r = Map.foldM s r . m1
− library/STMContainers/HAMT.hs 
@@ -1,34 +0,0 @@-module STMContainers.HAMT where--import STMContainers.Prelude hiding (insert, lookup, delete, foldM)-import qualified STMContainers.HAMT.Nodes as Nodes-import qualified Focus---type HAMT e = Nodes.Nodes e--type Element e = (Nodes.Element e, Hashable (Nodes.ElementKey e))--{-# INLINE insert #-}-insert :: (Element e) => e -> HAMT e -> STM ()-insert e = Nodes.insert e (hash (Nodes.elementKey e)) (Nodes.elementKey e) 0--{-# INLINE focus #-}-focus :: (Element e) => Focus.StrategyM STM e r -> Nodes.ElementKey e -> HAMT e -> STM r-focus s k = Nodes.focus s (hash k) k 0--{-# INLINE foldM #-}-foldM :: (a -> e -> STM a) -> a -> HAMT e -> STM a-foldM step acc = Nodes.foldM step acc 0--{-# INLINE new #-}-new :: STM (HAMT e)-new = Nodes.new--{-# INLINE newIO #-}-newIO :: IO (HAMT e)-newIO = Nodes.newIO--{-# INLINE null #-}-null :: HAMT e -> STM Bool-null = Nodes.null
− library/STMContainers/HAMT/Level.hs 
@@ -1,29 +0,0 @@-module STMContainers.HAMT.Level where--import STMContainers.Prelude hiding (mask)----- |--- A depth level of a node.--- Must be a multiple of the 'step' value.-type Level = Int--{-# INLINE hashIndex #-}-hashIndex :: Level -> (Int -> Int)-hashIndex l i = mask .&. unsafeShiftR i l--{-# INLINE mask #-}-mask :: Int-mask = bit step - 1--{-# INLINE step #-}-step :: Int-step = 5--{-# INLINE limit #-}-limit :: Int-limit = bitSize (undefined :: Int)--{-# INLINE succ #-}-succ :: Level -> Level-succ = (+ step)
− library/STMContainers/HAMT/Nodes.hs 
@@ -1,153 +0,0 @@-module STMContainers.HAMT.Nodes where--import STMContainers.Prelude hiding (insert, lookup, delete, foldM, null)-import qualified STMContainers.Prelude as Prelude-import qualified STMContainers.WordArray as WordArray-import qualified STMContainers.SizedArray as SizedArray-import qualified STMContainers.HAMT.Level as Level-import qualified Focus---type Nodes e = TVar (WordArray.WordArray (Node e))--data Node e = -  Nodes {-# UNPACK #-} !(Nodes e) |-  Leaf {-# UNPACK #-} !Hash !e |-  Leaves {-# UNPACK #-} !Hash {-# UNPACK #-} !(SizedArray.SizedArray e)--type Hash = Int--class (Eq (ElementKey e)) => Element e where-  type ElementKey e-  elementKey :: e -> ElementKey e--{-# INLINE new #-}-new :: STM (Nodes e)-new = newTVar WordArray.empty--{-# INLINE newIO #-}-newIO :: IO (Nodes e)-newIO = newTVarIO WordArray.empty--insert :: (Element e) => e -> Hash -> ElementKey e -> Level.Level -> Nodes e -> STM ()-insert e h k l ns = do-  a <- readTVar ns-  let write n = writeTVar ns $ WordArray.set i n a-  case WordArray.lookup i a of-    Nothing -> write (Leaf h e)-    Just n -> case n of-      Nodes ns' -> insert e h k (Level.succ l) ns'-      Leaf h' e' ->-        if h' == h-          then if elementKey e' == k-            then write (Leaf h e)-            else write (Leaves h (SizedArray.pair e e'))-          else do-            nodes <- pair h (Leaf h e) h' (Leaf h' e') (Level.succ l)-            write (Nodes nodes)-      Leaves h' la ->-        if h' == h-          then case SizedArray.find ((== k) . elementKey) la of-            Just (lai, _) ->-              write (Leaves h' (SizedArray.insert lai e la))-            Nothing ->-              write (Leaves h' (SizedArray.append e la))-          else-            write . Nodes =<< pair h (Leaf h e) h' (Leaves h' la) (Level.succ l)-  where-    i = Level.hashIndex l h--pair :: Hash -> Node e -> Hash -> Node e -> Level.Level -> STM (Nodes e)-pair h1 n1 h2 n2 l =-  if i1 == i2-    then newTVar . WordArray.singleton i1 . Nodes =<< pair h1 n1 h2 n2 (Level.succ l)-    else newTVar $ WordArray.pair i1 n1 i2 n2-  where-    hashIndex = Level.hashIndex l-    i1 = hashIndex h1-    i2 = hashIndex h2--focus :: (Element e) => Focus.StrategyM STM e r -> Hash -> ElementKey e -> Level.Level -> Nodes e -> STM r-focus s h k l ns = do-  a <- readTVar ns-  (r, a'm) <- WordArray.focusM s' ai a-  maybe (return ()) (writeTVar ns) a'm-  return r-  where-    ai = Level.hashIndex l h-    s' = \case-      Nothing -> traversePair (return . fmap (Leaf h)) =<< s Nothing-      Just n -> case n of-        Nodes ns' -> do-          r <- focus s h k (Level.succ l) ns'-          null ns' >>= \case-            True -> return (r, Focus.Remove)-            False -> return (r, Focus.Keep)-        Leaf h' e' ->-          case h' == h of-            True -> -              case elementKey e' == k of-                True  -> -                  traversePair (return . fmap (Leaf h)) =<< s (Just e')-                False -> -                  traversePair processDecision =<< s Nothing-                  where-                    processDecision = \case-                      Focus.Replace e -> -                        return (Focus.Replace (Leaves h (SizedArray.pair e e')))-                      _ -> -                        return Focus.Keep-            False -> -              traversePair processDecision =<< s Nothing-              where-                processDecision = \case-                  Focus.Replace e -> do-                    ns' <- pair h (Leaf h e) h' (Leaf h' e') (Level.succ l)-                    return (Focus.Replace (Nodes ns'))-                  _ -> return Focus.Keep-        Leaves h' a' ->-          case h' == h of-            True ->-              case SizedArray.find ((== k) . elementKey) a' of-                Just (i', e') -> -                  s (Just e') >>= traversePair processDecision-                  where-                    processDecision = \case-                      Focus.Keep -> -                        return Focus.Keep-                      Focus.Remove -> -                        case SizedArray.delete i' a' of-                          a'' -> case SizedArray.null a'' of-                            False -> return (Focus.Replace (Leaves h' a''))-                            True -> return Focus.Remove-                      Focus.Replace e ->-                        return (Focus.Replace (Leaves h' (SizedArray.insert i' e a')))-                Nothing -> -                  s Nothing >>= traversePair processDecision-                  where-                    processDecision = \case-                      Focus.Replace e ->-                        return (Focus.Replace (Leaves h' (SizedArray.append e a')))-                      _ ->-                        return Focus.Keep-            False ->-              s Nothing >>= traversePair processDecision-              where-                processDecision = \case-                  Focus.Replace e -> do-                    ns' <- pair h (Leaf h e) h' (Leaves h' a') (Level.succ l)-                    return (Focus.Replace (Nodes ns'))-                  _ ->-                    return Focus.Keep--null :: Nodes e -> STM Bool-null = fmap WordArray.null . readTVar--foldM :: (a -> e -> STM a) -> a -> Level.Level -> Nodes e -> STM a-foldM step acc level = -  readTVar >=> foldlM step' acc-  where-    step' acc' = \case-      Nodes ns -> foldM step acc' (Level.succ level) ns-      Leaf _ e -> step acc' e-      Leaves _ a -> SizedArray.foldM step acc' a
− library/STMContainers/Map.hs 
@@ -1,98 +0,0 @@-module STMContainers.Map-(-  Map,-  Key,-  new,-  newIO,-  insert,-  delete,-  lookup,-  focus,-  foldM,-  null,-)-where--import STMContainers.Prelude hiding (insert, delete, lookup, alter, foldM, toList, empty, null)-import qualified STMContainers.HAMT as HAMT-import qualified STMContainers.HAMT.Nodes as HAMTNodes-import qualified Focus----- |--- A hash table, based on an STM-specialized hash array mapped trie.-newtype Map k v = Map (HAMT.HAMT (Association k v))---- |--- A standard constraint for keys.-type Key a = (Eq a, Hashable a)---- |--- A key-value association.-type Association k v = (k, v)--instance (Eq k) => HAMTNodes.Element (Association k v) where-  type ElementKey (Association k v) = k-  elementKey (k, v) = k--{-# INLINE associationValue #-}-associationValue :: Association k v -> v-associationValue (_, v) = v---- |--- Look up an item.-{-# INLINE lookup #-}-lookup :: (Key k) => k -> Map k v -> STM (Maybe v)-lookup k = focus Focus.lookupM k---- |--- Insert a value at a key.-{-# INLINE insert #-}-insert :: (Key k) => v -> k -> Map k v -> STM ()-insert !v !k (Map h) = HAMT.insert (k, v) h---- |--- Delete an item by a key.-{-# INLINE delete #-}-delete :: (Key k) => k -> Map k v -> STM ()-delete k (Map h) = HAMT.focus Focus.deleteM k h---- |--- Focus on an item by a key with a strategy.--- --- This function allows to perform composite operations in a single access--- to a map item.--- E.g., you can look up an item and delete it at the same time,--- or update it and return the new value.-{-# INLINE focus #-}-focus :: (Key k) => Focus.StrategyM STM v r -> k -> Map k v -> STM r-focus f k (Map h) = HAMT.focus f' k h-  where-    f' = (fmap . fmap . fmap) (\v -> k `seq` v `seq` (k, v)) . f . fmap associationValue---- |--- Fold all the items of a map.-{-# INLINE foldM #-}-foldM :: (a -> (k, v) -> STM a) -> a -> Map k v -> STM a-foldM s a (Map h) = HAMT.foldM s a h---- |--- Construct a new map.-{-# INLINE new #-}-new :: STM (Map k v)-new = Map <$> HAMT.new---- |--- Construct a new map in IO.--- --- This is useful for creating it on a top-level using 'unsafePerformIO', --- because using 'atomically' inside 'unsafePerformIO' isn't possible.-{-# INLINE newIO #-}-newIO :: IO (Map k v)-newIO = Map <$> HAMT.newIO---- |--- Check, whether the map is empty.-{-# INLINE null #-}-null :: Map k v -> STM Bool-null (Map h) = HAMT.null h
− library/STMContainers/Multimap.hs 
@@ -1,141 +0,0 @@-module STMContainers.Multimap-(-  Multimap,-  Association,-  new,-  newIO,-  insert,-  delete,-  lookup,-  focus,-  foldM,-  null,-)-where--import STMContainers.Prelude hiding (insert, delete, lookup, alter, foldM, toList, empty, null)-import qualified Focus-import qualified STMContainers.Map as Map-import qualified STMContainers.Set as Set----- |--- A multimap, based on an STM-specialized hash array mapped trie.--- --- Basically it's just a wrapper API around @'Map.Map' k ('Set.Set' v)@.-newtype Multimap k v = Multimap (Map.Map k (Set.Set v))---- |--- A standard constraint for items.-type Association k v = (Eq k, Hashable k, Eq v, Hashable v)---- |--- Look up an item by a value and a key.-{-# INLINE lookup #-}-lookup :: (Association k v) => v -> k -> Multimap k v -> STM Bool-lookup v k (Multimap m) = -  maybe (return False) (Set.lookup v) =<< Map.lookup k m---- |--- Insert an item.-{-# INLINABLE insert #-}-insert :: (Association k v) => v -> k -> Multimap k v -> STM ()-insert v k (Multimap m) =-  Map.focus ms k m-  where-    ms = -      \case -        Just s -> -          do-            Set.insert v s-            return ((), Focus.Keep)-        Nothing ->-          do-            s <- Set.new-            Set.insert v s-            return ((), Focus.Replace s)---- |--- Delete an item by a value and a key.-{-# INLINABLE delete #-}-delete :: (Association k v) => v -> k -> Multimap k v -> STM ()-delete v k (Multimap m) =-  Map.focus ms k m-  where-    ms = -      \case -        Just s -> -          do-            Set.delete v s-            Set.null s >>= returnDecision . bool Focus.Keep Focus.Remove-        Nothing ->-          returnDecision Focus.Keep-      where-        returnDecision c = return ((), c)---- |--- Focus on an item with a strategy by a value and a key.--- --- This function allows to perform simultaneous lookup and modification.--- --- The strategy is over a unit since we already know,--- which value we're focusing on and it doesn't make sense to replace it,--- however we still can decide wether to keep or remove it.-{-# INLINE focus #-}-focus :: (Association k v) => Focus.StrategyM STM () r -> v -> k -> Multimap k v -> STM r-focus = -  \s v k (Multimap m) -> Map.focus (liftSetItemStrategy v s) k m-  where-    liftSetItemStrategy :: -      (Set.Element e) => e -> Focus.StrategyM STM () r -> Focus.StrategyM STM (Set.Set e) r-    liftSetItemStrategy e s =-      \case-        Nothing ->-          traversePair liftDecision =<< s Nothing-          where-            liftDecision =-              \case-                Focus.Replace b ->-                  do-                    s <- Set.new-                    Set.insert e s-                    return (Focus.Replace s)-                _ ->-                  return Focus.Keep-        Just set -> -          do-            r <- Set.focus s e set-            (r,) . bool Focus.Keep Focus.Remove <$> Set.null set---- |--- Fold all the items.-{-# INLINE foldM #-}-foldM :: (a -> (k, v) -> STM a) -> a -> Multimap k v -> STM a-foldM f a (Multimap m) = -  Map.foldM f' a m-  where-    f' a' (k, set) = -      Set.foldM f'' a' set-      where-        f'' a'' v = f a'' (k, v)---- |--- Construct a new multimap.-{-# INLINE new #-}-new :: STM (Multimap k v)-new = Multimap <$> Map.new---- |--- Construct a new multimap in IO.--- --- This is useful for creating it on a top-level using 'unsafePerformIO', --- because using 'atomically' inside 'unsafePerformIO' isn't possible.-{-# INLINE newIO #-}-newIO :: IO (Multimap k v)-newIO = Multimap <$> Map.newIO---- |--- Check on being empty.-{-# INLINE null #-}-null :: Multimap k v -> STM Bool-null (Multimap m) = Map.null m
− library/STMContainers/Prelude.hs 
@@ -1,34 +0,0 @@-module STMContainers.Prelude-( -  module Exports,-  bug,-  bottom,-  traversePair,-)-where---- base---------------------------import BasePrelude as Exports---- placeholders---------------------------import Development.Placeholders as Exports---- hashable---------------------------import Data.Hashable as Exports (Hashable(..))---- custom---------------------------import qualified Debug.Trace.LocationTH--bug = [e| $(Debug.Trace.LocationTH.failure) . (msg <>) |]-  where-    msg = "A \"stm-containers\" package bug: " :: String--bottom = [e| $bug "Bottom evaluated" |]---- | A replacement for the missing 'Traverse' instance of pair in base < 4.7.-traversePair :: Functor f => (a -> f b) -> (c, a) -> f (c, b)-traversePair f (x, y) = (,) x <$> f y
− library/STMContainers/Set.hs 
@@ -1,98 +0,0 @@-module STMContainers.Set-(-  Set,-  Element,-  new,-  newIO,-  insert,-  delete,-  lookup,-  focus,-  foldM,-  null,-)-where--import STMContainers.Prelude hiding (insert, delete, lookup, alter, foldM, toList, empty, null)-import qualified STMContainers.HAMT as HAMT-import qualified STMContainers.HAMT.Nodes as HAMTNodes-import qualified Focus----- |--- A hash set, based on an STM-specialized hash array mapped trie.-newtype Set e = Set {hamt :: HAMT.HAMT (HAMTElement e)}---- |--- A standard constraint for elements.-type Element a = (Eq a, Hashable a)--newtype HAMTElement e = HAMTElement e--instance (Eq e) => HAMTNodes.Element (HAMTElement e) where-  type ElementKey (HAMTElement e) = e-  elementKey (HAMTElement e) = e--{-# INLINE elementValue #-}-elementValue :: HAMTElement e -> e-elementValue (HAMTElement e) = e---- |--- Insert a new element.-{-# INLINE insert #-}-insert :: (Element e) => e -> Set e -> STM ()-insert e = HAMT.insert (HAMTElement e) . hamt---- |--- Delete an element.-{-# INLINE delete #-}-delete :: (Element e) => e -> Set e -> STM ()-delete e = HAMT.focus Focus.deleteM e . hamt---- |--- Lookup an element.-{-# INLINE lookup #-}-lookup :: (Element e) => e -> Set e -> STM Bool-lookup e = fmap (maybe False (const True)) . HAMT.focus Focus.lookupM e . hamt---- |--- Focus on an element with a strategy.--- --- This function allows to perform simultaneous lookup and modification.--- --- The strategy is over a unit since we already know, --- which element we're focusing on and it doesn't make sense to replace it,--- however we still can decide wether to keep or remove it.-{-# INLINE focus #-}-focus :: (Element e) => Focus.StrategyM STM () r -> e -> Set e -> STM r-focus s e = HAMT.focus elementStrategy e . hamt-  where-    elementStrategy = -      (fmap . fmap . fmap) (const (HAMTElement e)) . s . fmap (const ())---- |--- Fold all the elements.-{-# INLINE foldM #-}-foldM :: (a -> e -> STM a) -> a -> Set e -> STM a-foldM f a = HAMT.foldM (\a -> f a . elementValue) a . hamt---- |--- Construct a new set.-{-# INLINE new #-}-new :: STM (Set e)-new = Set <$> HAMT.new---- |--- Construct a new set in IO.--- --- This is useful for creating it on a top-level using 'unsafePerformIO', --- because using 'atomically' inside 'unsafePerformIO' isn't possible.-{-# INLINE newIO #-}-newIO :: IO (Set e)-newIO = Set <$> HAMT.newIO---- |--- Check, whether the set is empty.-{-# INLINE null #-}-null :: Set e -> STM Bool-null = HAMT.null . hamt
− library/STMContainers/SizedArray.hs 
@@ -1,87 +0,0 @@-module STMContainers.SizedArray where--import STMContainers.Prelude hiding (lookup, toList, foldM)-import Data.Primitive.Array-import qualified STMContainers.Prelude as Prelude-import qualified Focus---- |--- An array, --- which sacrifices the performance for space-efficiency and thread-safety.-data SizedArray a =-  SizedArray {-# UNPACK #-} !Int {-# UNPACK #-} !(Array a)--instance Foldable SizedArray where-  {-# INLINE foldr #-}-  foldr step r (SizedArray size array) =-    foldr step r $ map (indexArray array) [0 .. pred size]---- |--- An index of an element.-type Index = Int--{-# INLINE pair #-}-pair :: a -> a -> SizedArray a-pair e e' =-  runST $ do-    a <- newArray 2 e-    writeArray a 1 e'-    SizedArray 2 <$> unsafeFreezeArray a---- |--- Get the amount of elements.-{-# INLINE size #-}-size :: SizedArray a -> Int-size (SizedArray b _) = b---- |--- Get the amount of elements.-{-# INLINE null #-}-null :: SizedArray a -> Bool-null = (== 0) . size--{-# INLINE find #-}-find :: (a -> Bool) -> SizedArray a -> Maybe (Index, a)-find p (SizedArray s a) = loop 0-  where-    loop i = if i < s-      then let e = indexArray a i in if p e-        then Just (i, e)-        else loop (succ i)-      else Nothing---- |--- Unsafe. Doesn't check the index overflow.-{-# INLINE insert #-}-insert :: Index -> a -> SizedArray a -> SizedArray a-insert i e (SizedArray s a) = -  runST $ do-    m' <- newArray s undefined-    forM_ [0 .. pred s] $ \i' -> indexArrayM a i' >>= writeArray m' i'-    writeArray m' i e-    SizedArray s <$> unsafeFreezeArray m'--{-# INLINE delete #-}-delete :: Index -> SizedArray a -> SizedArray a-delete i (SizedArray s a) = -  runST $ do-    m' <- newArray (pred s) undefined-    forM_ [0 .. pred i] $ \i' -> indexArrayM a i' >>= writeArray m' i'-    forM_ [succ i .. pred s] $ \i' -> indexArrayM a i' >>= writeArray m' (pred i')-    SizedArray (pred s) <$> unsafeFreezeArray m'--{-# INLINE append #-}-append :: a -> SizedArray a -> SizedArray a-append e (SizedArray s a) =-  runST $ do-    m' <- newArray (succ s) undefined-    forM_ [0 .. pred s] $ \i -> indexArrayM a i >>= writeArray m' i-    writeArray m' s e-    SizedArray (succ s) <$> unsafeFreezeArray m'--{-# INLINE foldM #-}-foldM :: (Monad m) => (a -> b -> m a) -> a -> SizedArray b -> m a-foldM step acc (SizedArray size array) =-  Prelude.foldM step' acc [0 .. pred size]-  where-    step' acc' i = indexArrayM array i >>= step acc'
− library/STMContainers/WordArray.hs 
@@ -1,198 +0,0 @@-module STMContainers.WordArray where--import STMContainers.Prelude hiding (lookup, toList, traverse_)-import Data.Primitive.Array-import qualified STMContainers.Prelude as Prelude-import qualified STMContainers.WordArray.Indices as Indices-import qualified Focus----- |--- An immutable space-efficient sparse array, --- which can store only as many elements as there are bits in the machine word.-data WordArray e =-  WordArray {-# UNPACK #-} !Indices {-# UNPACK #-} !(Array e)--instance Foldable WordArray where-  {-# INLINE foldr #-}-  foldr step r (WordArray indices array) =-    foldr (step . indexArray array) r $ Indices.positions indices---- | --- A bitmap of set elements.-type Indices = Indices.Indices---- |--- An index of an element.-type Index = Int--{-# INLINE indices #-}-indices :: WordArray e -> Indices-indices (WordArray b _) = b--{-# INLINE maxSize #-}-maxSize :: Int-maxSize = Indices.maxSize--{-# INLINE empty #-}-empty :: WordArray e-empty = WordArray 0 a-  where-    a = runST $ newArray 0 undefined >>= unsafeFreezeArray---- |--- An array with a single element at the specified index.-{-# INLINE singleton #-}-singleton :: Index -> e -> WordArray e-singleton i e = -  let b = Indices.insert i 0-      a = runST $ newArray 1 e >>= unsafeFreezeArray-      in WordArray b a--{-# INLINE pair #-}-pair :: Index -> e -> Index -> e -> WordArray e-pair i e i' e' =-  WordArray is a-  where -    is = Indices.fromList [i, i']-    a = -      runST $ if -        | i < i' -> do-          a <- newArray 2 e-          writeArray a 1 e'-          unsafeFreezeArray a-        | i > i' -> do-          a <- newArray 2 e-          writeArray a 0 e'-          unsafeFreezeArray a-        | i == i' -> do-          a <- newArray 1 e'-          unsafeFreezeArray a---- |--- Unsafe.--- Assumes that the list is sorted and contains no duplicate indexes.-{-# INLINE fromList #-}-fromList :: [(Index, e)] -> WordArray e-fromList l = -  runST $ do-    indices <- newSTRef 0-    array <- newArray (length l) undefined-    forM_ (zip l [0..]) $ \((i, e), ai) -> do-      modifySTRef indices $ Indices.insert i-      writeArray array ai e-    WordArray <$> readSTRef indices <*> unsafeFreezeArray array-  -{-# INLINE toList #-}-toList :: WordArray e -> [(Index, e)]-toList (WordArray is a) = do-  i <- Indices.toList is-  e <- indexArrayM a (Indices.position i is)-  return (i, e)---- |--- Convert into a list representation.-{-# INLINE toMaybeList #-}-toMaybeList :: WordArray e -> [Maybe e]-toMaybeList w = do-  i <- [0 .. pred Indices.maxSize] -  return $ lookup i w--{-# INLINE elements #-}-elements :: WordArray e -> [e]-elements (WordArray indices array) =-  map (\i -> indexArray array (Indices.position i indices)) .-  Indices.toList $-  indices---- |--- Set an element value at the index.-{-# INLINE set #-}-set :: Index -> e -> WordArray e -> WordArray e-set i e (WordArray b a) = -  let -    sparseIndex = Indices.position i b-    size = Indices.size b-    in if Indices.elem i b-      then -        let a' = runST $ do-              ma' <- newArray size undefined-              forM_ [0 .. (size - 1)] $ \i -> indexArrayM a i >>= writeArray ma' i-              writeArray ma' sparseIndex e-              unsafeFreezeArray ma'-            in WordArray b a'-      else-        let a' = runST $ do-              ma' <- newArray (size + 1) undefined-              forM_ [0 .. (sparseIndex - 1)] $ \i -> indexArrayM a i >>= writeArray ma' i-              writeArray ma' sparseIndex e-              forM_ [sparseIndex .. (size - 1)] $ \i -> indexArrayM a i >>= writeArray ma' (i + 1)-              unsafeFreezeArray ma'-            b' = Indices.insert i b-            in WordArray b' a'---- |--- Remove an element.-{-# INLINE unset #-}-unset :: Index -> WordArray e -> WordArray e-unset i (WordArray b a) =-  if Indices.elem i b-    then-      let -        b' = Indices.invert i b-        a' = runST $ do-          ma' <- newArray (pred size) undefined-          forM_ [0 .. pred sparseIndex] $ \i -> indexArrayM a i >>= writeArray ma' i-          forM_ [succ sparseIndex .. pred size] $ \i -> indexArrayM a i >>= writeArray ma' (pred i)-          unsafeFreezeArray ma'-        sparseIndex = Indices.position i b-        size = Indices.size b-        in WordArray b' a'-    else WordArray b a---- |--- Lookup an item at the index.-{-# INLINE lookup #-}-lookup :: Index -> WordArray e -> Maybe e-lookup i (WordArray b a) =-  if Indices.elem i b-    then Just (indexArray a (Indices.position i b))-    else Nothing---- |--- Lookup strictly, using 'indexArrayM'.-{-# INLINE lookupM #-}-lookupM :: Monad m => Index -> WordArray e -> m (Maybe e)-lookupM i (WordArray b a) =-  if Indices.elem i b-    then liftM Just (indexArrayM a (Indices.position i b))-    else return Nothing---- |--- Check, whether there is an element at the index.-{-# INLINE isSet #-}-isSet :: Index -> WordArray e -> Bool-isSet i = Indices.elem i . indices---- |--- Get the amount of elements.-{-# INLINE size #-}-size :: WordArray e -> Int-size = Indices.size . indices--{-# INLINE null #-}-null :: WordArray e -> Bool-null = Indices.null . indices--{-# INLINE focusM #-}-focusM :: Monad m => Focus.StrategyM m a r -> Index -> WordArray a -> m (r, Maybe (WordArray a))-focusM f i w = do-  let em = lookup i w-  (r, c) <- f em-  let w' = case c of-        Focus.Keep -> Nothing-        Focus.Remove -> case em of-          Nothing -> Nothing-          Just _ -> Just $ unset i w-        Focus.Replace e' -> Just $ set i e' w-  return (r, w')
− library/STMContainers/WordArray/Indices.hs 
@@ -1,68 +0,0 @@-module STMContainers.WordArray.Indices where--import STMContainers.Prelude hiding (toList, traverse_)-import qualified STMContainers.Prelude as Prelude----- |--- A compact set of indices.-type Indices = Int--type Index = Int--type Position = Int---- |--- A number of indexes, preceding this one.-{-# INLINE position #-}-position :: Index -> Indices -> Position-position i b = popCount (b .&. (bit i - 1))--{-# INLINE singleton #-}-singleton :: Index -> Indices-singleton = bit--{-# INLINE insert #-}-insert :: Index -> Indices -> Indices-insert i = (bit i .|.)--{-# INLINE invert #-}-invert :: Index -> Indices -> Indices-invert i = (bit i `xor`)--{-# INLINE elem #-}-elem :: Index -> Indices -> Bool-elem = flip testBit--{-# INLINE size #-}-size :: Indices -> Int-size = popCount--{-# INLINE null #-}-null :: Indices -> Bool-null = (== 0)--{-# INLINE maxSize #-}-maxSize :: Int-maxSize = bitSize (undefined :: Indices)--{-# INLINE fromList #-}-fromList :: [Index] -> Indices-fromList = Prelude.foldr (.|.) 0 . map bit--{-# INLINE toList #-}-toList :: Indices -> [Index]-toList w = filter (testBit w) allIndices--{-# INLINE positions #-}-positions :: Indices -> [Position]-positions = enumFromTo 0 . pred . size--{-# NOINLINE allIndices #-}-allIndices :: [Index]-allIndices = [0 .. pred maxSize]--{-# INLINE foldr #-}-foldr :: (Index -> r -> r) -> r -> Indices -> r-foldr s r ix = -  Prelude.foldr (\i r' -> if testBit ix i then s i r' else r') r allIndices
+ library/StmContainers/Bimap.hs view
@@ -0,0 +1,167 @@+module StmContainers.Bimap+  ( Bimap,+    new,+    newIO,+    null,+    size,+    focusLeft,+    focusRight,+    lookupLeft,+    lookupRight,+    insertLeft,+    insertRight,+    deleteLeft,+    deleteRight,+    reset,+    unfoldlM,+    listT,+  )+where++import qualified Focus as B+import qualified StmContainers.Map as A+import StmContainers.Prelude hiding (delete, empty, foldM, insert, lookup, null, toList)++-- |+-- Bidirectional map.+-- Essentially, a bijection between subsets of its two argument types.+--+-- For one value of the left-hand type this map contains one value+-- of the right-hand type and vice versa.+data Bimap leftKey rightKey+  = Bimap !(A.Map leftKey rightKey) !(A.Map rightKey leftKey)++-- |+-- Construct a new bimap.+{-# INLINE new #-}+new :: STM (Bimap leftKey rightKey)+new =+  Bimap <$> A.new <*> A.new++-- |+-- Construct a new bimap in IO.+--+-- This is useful for creating it on a top-level using 'unsafePerformIO',+-- because using 'atomically' inside 'unsafePerformIO' isn't possible.+{-# INLINE newIO #-}+newIO :: IO (Bimap leftKey rightKey)+newIO =+  Bimap <$> A.newIO <*> A.newIO++-- |+-- Check on being empty.+{-# INLINE null #-}+null :: Bimap leftKey rightKey -> STM Bool+null (Bimap leftMap _) =+  A.null leftMap++-- |+-- Get the number of elements.+{-# INLINE size #-}+size :: Bimap leftKey rightKey -> STM Int+size (Bimap leftMap _) =+  A.size leftMap++-- |+-- Focus on a right value by the left value.+--+-- This function allows to perform composite operations in a single access+-- to a map item.+-- E.g., you can look up an item and delete it at the same time,+-- or update it and return the new value.+{-# INLINE focusLeft #-}+focusLeft :: (Hashable leftKey, Hashable rightKey) => B.Focus rightKey STM result -> leftKey -> Bimap leftKey rightKey -> STM result+focusLeft rightFocus leftKey (Bimap leftMap rightMap) =+  do+    ((output, change), maybeRightKey) <- A.focus (B.extractingInput (B.extractingChange rightFocus)) leftKey leftMap+    case change of+      B.Leave ->+        return ()+      B.Remove ->+        forM_ maybeRightKey $ \oldRightKey -> A.delete oldRightKey rightMap+      B.Set newRightKey ->+        do+          forM_ maybeRightKey $ \rightKey -> A.delete rightKey rightMap+          maybeReplacedLeftKey <- A.focus (B.lookup <* B.insert leftKey) newRightKey rightMap+          forM_ maybeReplacedLeftKey $ \replacedLeftKey -> A.delete replacedLeftKey leftMap+    return output++-- |+-- Focus on a left value by the right value.+--+-- This function allows to perform composite operations in a single access+-- to a map item.+-- E.g., you can look up an item and delete it at the same time,+-- or update it and return the new value.+{-# INLINE focusRight #-}+focusRight :: (Hashable leftKey, Hashable rightKey) => B.Focus leftKey STM result -> rightKey -> Bimap leftKey rightKey -> STM result+focusRight valueFocus2 rightKey (Bimap leftMap rightMap) =+  focusLeft valueFocus2 rightKey (Bimap rightMap leftMap)++-- |+-- Look up a right value by the left value.+{-# INLINE lookupLeft #-}+lookupLeft :: (Hashable leftKey) => leftKey -> Bimap leftKey rightKey -> STM (Maybe rightKey)+lookupLeft leftKey (Bimap leftMap _) =+  A.lookup leftKey leftMap++-- |+-- Look up a left value by the right value.+{-# INLINE lookupRight #-}+lookupRight :: (Hashable rightKey) => rightKey -> Bimap leftKey rightKey -> STM (Maybe leftKey)+lookupRight rightKey (Bimap _ rightMap) =+  A.lookup rightKey rightMap++-- |+-- Insert the association by the left value.+{-# INLINE insertLeft #-}+insertLeft :: (Hashable leftKey, Hashable rightKey) => rightKey -> leftKey -> Bimap leftKey rightKey -> STM ()+insertLeft rightKey =+  focusLeft (B.insert rightKey)++-- |+-- Insert the association by the right value.+{-# INLINE insertRight #-}+insertRight :: (Hashable leftKey, Hashable rightKey) => leftKey -> rightKey -> Bimap leftKey rightKey -> STM ()+insertRight leftKey rightKey (Bimap leftMap rightMap) =+  insertLeft leftKey rightKey (Bimap rightMap leftMap)++-- |+-- Delete the association by the left value.+{-# INLINE deleteLeft #-}+deleteLeft :: (Hashable leftKey, Hashable rightKey) => leftKey -> Bimap leftKey rightKey -> STM ()+deleteLeft leftKey (Bimap leftMap rightMap) =+  A.focus B.lookupAndDelete leftKey leftMap+    >>= mapM_ (\rightKey -> A.delete rightKey rightMap)++-- |+-- Delete the association by the right value.+{-# INLINE deleteRight #-}+deleteRight :: (Hashable leftKey, Hashable rightKey) => rightKey -> Bimap leftKey rightKey -> STM ()+deleteRight rightKey (Bimap leftMap rightMap) =+  deleteLeft rightKey (Bimap rightMap leftMap)++-- |+-- Delete all the associations.+{-# INLINE reset #-}+reset :: Bimap leftKey rightKey -> STM ()+reset (Bimap leftMap rightMap) =+  do+    A.reset leftMap+    A.reset rightMap++-- |+-- Stream associations actively.+--+-- Amongst other features this function provides an interface to folding.+{-# INLINE unfoldlM #-}+unfoldlM :: Bimap leftKey rightKey -> UnfoldlM STM (leftKey, rightKey)+unfoldlM (Bimap leftMap _) =+  A.unfoldlM leftMap++-- |+-- Stream the associations passively.+{-# INLINE listT #-}+listT :: Bimap key value -> ListT STM (key, value)+listT (Bimap leftMap _) =+  A.listT leftMap
+ library/StmContainers/Map.hs view
@@ -0,0 +1,122 @@+module StmContainers.Map+  ( Map,+    new,+    newIO,+    null,+    size,+    focus,+    lookup,+    insert,+    delete,+    reset,+    unfoldlM,+    listT,+    listTNonAtomic,+  )+where++import qualified DeferredFolds.UnfoldlM as C+import qualified Focus as B+import StmContainers.Prelude hiding (delete, empty, foldM, insert, lookup, null, toList)+import qualified StmHamt.Hamt as A++-- |+-- Hash-table, based on STM-specialized Hash Array Mapped Trie.+newtype Map key value+  = Map (A.Hamt (Product2 key value))++-- |+-- Construct a new map.+{-# INLINEABLE new #-}+new :: STM (Map key value)+new =+  Map <$> A.new++-- |+-- Construct a new map in IO.+--+-- This is useful for creating it on a top-level using 'unsafePerformIO',+-- because using 'atomically' inside 'unsafePerformIO' isn't possible.+{-# INLINEABLE newIO #-}+newIO :: IO (Map key value)+newIO =+  Map <$> A.newIO++-- |+-- Check, whether the map is empty.+{-# INLINEABLE null #-}+null :: Map key value -> STM Bool+null (Map hamt) =+  A.null hamt++-- |+-- Get the number of elements.+{-# INLINEABLE size #-}+size :: Map key value -> STM Int+size =+  C.foldlM' (\x _ -> return (succ x)) 0 . unfoldlM++-- |+-- Focus on a value by the key.+--+-- This function allows to perform composite operations in a single access+-- to the map's row.+-- E.g., you can look up a value and delete it at the same time,+-- or update it and return the new value.+{-# INLINE focus #-}+focus :: (Hashable key) => B.Focus value STM result -> key -> Map key value -> STM result+focus valueFocus key (Map hamt) =+  A.focus rowFocus (\(Product2 key _) -> key) key hamt+  where+    rowFocus =+      B.mappingInput (\value -> Product2 key value) (\(Product2 _ value) -> value) valueFocus++-- |+-- Look up an item.+{-# INLINEABLE lookup #-}+lookup :: (Hashable key) => key -> Map key value -> STM (Maybe value)+lookup key =+  focus B.lookup key++-- |+-- Insert a value at a key.+{-# INLINE insert #-}+insert :: (Hashable key) => value -> key -> Map key value -> STM ()+insert value key (Map hamt) =+  void (A.insert (\(Product2 key _) -> key) (Product2 key value) hamt)++-- |+-- Delete an item by a key.+{-# INLINEABLE delete #-}+delete :: (Hashable key) => key -> Map key value -> STM ()+delete key =+  focus B.delete key++-- |+-- Delete all the associations.+{-# INLINEABLE reset #-}+reset :: Map key value -> STM ()+reset (Map hamt) =+  A.reset hamt++-- |+-- Stream the associations actively.+--+-- Amongst other features this function provides an interface to folding.+{-# INLINEABLE unfoldlM #-}+unfoldlM :: Map key value -> UnfoldlM STM (key, value)+unfoldlM (Map hamt) =+  fmap (\(Product2 k v) -> (k, v)) (A.unfoldlM hamt)++-- |+-- Stream the associations passively.+{-# INLINE listT #-}+listT :: Map key value -> ListT STM (key, value)+listT (Map hamt) = fmap (\(Product2 k v) -> (k, v)) (A.listT hamt)++-- |+-- Stream the associations passively.+-- Data may be inconsistent/out of date.+{-# INLINE listTNonAtomic #-}+listTNonAtomic :: Map key value -> ListT IO (key, value)+listTNonAtomic (Map hamt) = fmap (\(Product2 k v) -> (k, v)) (A.listTNonAtomic hamt)
+ library/StmContainers/Multimap.hs view
@@ -0,0 +1,181 @@+module StmContainers.Multimap+  ( Multimap,+    new,+    newIO,+    null,+    focus,+    lookup,+    lookupByKey,+    insert,+    delete,+    deleteByKey,+    reset,+    unfoldlM,+    unfoldlMKeys,+    unfoldlMByKey,+    listT,+    listTKeys,+    listTByKey,+  )+where++import qualified Focus as C+import qualified StmContainers.Map as A+import StmContainers.Prelude hiding (delete, empty, foldM, insert, lookup, null, toList)+import qualified StmContainers.Set as B++-- |+-- A multimap, based on an STM-specialized hash array mapped trie.+--+-- 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))++-- |+-- Construct a new multimap.+{-# INLINE new #-}+new :: STM (Multimap key value)+new =+  Multimap <$> A.new++-- |+-- Construct a new multimap in IO.+--+-- This is useful for creating it on a top-level using 'unsafePerformIO',+-- because using 'atomically' inside 'unsafePerformIO' isn't possible.+{-# INLINE newIO #-}+newIO :: IO (Multimap key value)+newIO =+  Multimap <$> A.newIO++-- |+-- Check on being empty.+{-# INLINE null #-}+null :: Multimap key value -> STM Bool+null (Multimap map) =+  A.null map++-- |+-- Focus on an item by the value and the key.+--+-- This function allows to perform simultaneous lookup and modification.+--+-- The focus is over a unit since we already know,+-- which value we're focusing on and it doesn't make sense to replace it,+-- however we still can decide wether to keep or remove it.+{-# INLINE focus #-}+focus :: (Hashable key, Hashable value) => C.Focus () STM result -> value -> key -> Multimap key value -> STM result+focus unitFocus@(Focus concealUnit _) value key (Multimap map) = A.focus setFocus key map+  where+    setFocus = C.Focus conceal reveal+      where+        conceal = do+          (output, change) <- concealUnit+          case change of+            C.Set () ->+              do+                set <- B.new+                B.insert value set+                return (output, C.Set set)+            _ ->+              return (output, C.Leave)+    reveal set = do+      output <- B.focus unitFocus value set+      change <- bool C.Leave C.Remove <$> B.null set+      return (output, change)++-- |+-- Look up an item by a value and a key.+{-# INLINE lookup #-}+lookup :: (Hashable key, Hashable value) => value -> key -> Multimap key value -> STM Bool+lookup value key (Multimap m) =+  maybe (return False) (B.lookup value) =<< A.lookup key m++-- |+-- Look up all values by key.+{-# INLINE lookupByKey #-}+lookupByKey :: (Hashable key) => key -> Multimap key value -> STM (Maybe (B.Set value))+lookupByKey key (Multimap m) =+  A.lookup key m++-- |+-- Insert an item.+{-# INLINEABLE insert #-}+insert :: (Hashable key, Hashable value) => value -> key -> Multimap key value -> STM ()+insert value key (Multimap map) = A.focus setFocus key map+  where+    setFocus = Focus conceal reveal+      where+        conceal = do+          set <- B.new+          B.insert value set+          return ((), C.Set set)+        reveal set = do+          B.insert value set+          return ((), C.Leave)++-- |+-- Delete an item by a value and a key.+{-# INLINEABLE delete #-}+delete :: (Hashable key, Hashable value) => value -> key -> Multimap key value -> STM ()+delete value key (Multimap map) = A.focus setFocus key map+  where+    setFocus = Focus conceal reveal+      where+        conceal = returnChange C.Leave+        reveal set = do+          B.delete value set+          B.null set >>= returnChange . bool C.Leave C.Remove+        returnChange c = return ((), c)++-- |+-- Delete all values associated with the key.+{-# INLINEABLE deleteByKey #-}+deleteByKey :: (Hashable key) => key -> Multimap key value -> STM ()+deleteByKey key (Multimap map) =+  A.delete key map++-- |+-- Delete all the associations.+{-# INLINE reset #-}+reset :: Multimap key value -> STM ()+reset (Multimap map) =+  A.reset map++-- |+-- Stream associations actively.+--+-- Amongst other features this function provides an interface to folding.+unfoldlM :: Multimap key value -> UnfoldlM STM (key, value)+unfoldlM (Multimap m) =+  A.unfoldlM m >>= \(key, s) -> (key,) <$> B.unfoldlM s++-- |+-- Stream keys actively.+unfoldlMKeys :: Multimap key value -> UnfoldlM STM key+unfoldlMKeys (Multimap m) =+  fmap fst (A.unfoldlM m)++-- |+-- Stream values by a key actively.+unfoldlMByKey :: (Hashable key) => key -> Multimap key value -> UnfoldlM STM value+unfoldlMByKey key (Multimap m) =+  lift (A.lookup key m) >>= maybe mempty B.unfoldlM++-- |+-- Stream associations passively.+listT :: Multimap key value -> ListT STM (key, value)+listT (Multimap m) =+  A.listT m >>= \(key, s) -> (key,) <$> B.listT s++-- |+-- Stream keys passively.+listTKeys :: Multimap key value -> ListT STM key+listTKeys (Multimap m) =+  fmap fst (A.listT m)++-- |+-- Stream values by a key passively.+listTByKey :: (Hashable key) => key -> Multimap key value -> ListT STM value+listTByKey key (Multimap m) =+  lift (A.lookup key m) >>= maybe mempty B.listT
+ library/StmContainers/Prelude.hs view
@@ -0,0 +1,82 @@+module StmContainers.Prelude+  ( module Exports,+    modifyTVar',+    Product2 (..),+  )+where++import Control.Applicative as Exports+import Control.Arrow as Exports+import Control.Category as Exports+import Control.Concurrent as Exports+import Control.Exception as Exports+import Control.Monad as Exports hiding (forM, forM_, mapM, mapM_, msum, sequence, sequence_)+import Control.Monad.Fix as Exports hiding (fix)+import Control.Monad.IO.Class as Exports+import Control.Monad.ST as Exports+import Control.Monad.Trans.Class as Exports+import Data.Bits as Exports+import Data.Bool as Exports+import Data.Char as Exports+import Data.Coerce as Exports+import Data.Complex as Exports+import Data.Data as Exports+import Data.Dynamic as Exports+import Data.Either as Exports+import Data.Fixed as Exports+import Data.Foldable as Exports+import Data.Function as Exports hiding (id, (.))+import Data.Functor as Exports hiding (unzip)+import Data.Hashable as Exports (Hashable (..))+import Data.IORef as Exports+import Data.Int as Exports+import Data.Ix as Exports+import Data.List as Exports hiding (all, and, any, concat, concatMap, elem, find, foldl, foldl', foldl1, foldr, foldr1, isSubsequenceOf, mapAccumL, mapAccumR, maximum, maximumBy, minimum, minimumBy, notElem, or, product, sortOn, sum, uncons)+import Data.Maybe as Exports+import Data.Monoid as Exports hiding (First (..), Last (..))+import Data.Ord as Exports+import Data.Proxy as Exports+import Data.Ratio as Exports+import Data.STRef as Exports+import Data.String as Exports+import Data.Traversable as Exports+import Data.Tuple as Exports+import Data.Unique as Exports+import Data.Version as Exports+import Data.Word as Exports+import Debug.Trace as Exports+import DeferredFolds.Unfoldl as Exports (Unfoldl (..))+import DeferredFolds.UnfoldlM as Exports (UnfoldlM (..))+import Focus as Exports (Focus (..))+import Foreign.ForeignPtr as Exports+import Foreign.Ptr as Exports+import Foreign.StablePtr as Exports+import Foreign.Storable as Exports hiding (alignment, sizeOf)+import GHC.Conc as Exports hiding (threadWaitRead, threadWaitReadSTM, threadWaitWrite, threadWaitWriteSTM, withMVar)+import GHC.Exts as Exports (groupWith, inline, lazy, sortWith)+import GHC.Generics as Exports (Generic)+import GHC.IO.Exception as Exports+import ListT as Exports (ListT (..))+import Numeric as Exports+import System.Environment as Exports+import System.Exit as Exports+import System.IO as Exports+import System.IO.Error as Exports+import System.IO.Unsafe as Exports+import System.Mem as Exports+import System.Mem.StableName as Exports+import System.Timeout as Exports+import Text.ParserCombinators.ReadPrec as Exports (ReadPrec, readP_to_Prec, readPrec_to_P, readPrec_to_S, readS_to_Prec)+import Text.Printf as Exports (hPrintf, printf)+import Text.Read as Exports (Read (..), readEither, readMaybe)+import Unsafe.Coerce as Exports+import Prelude as Exports hiding (all, and, any, concat, concatMap, elem, foldl, foldl1, foldr, foldr1, id, mapM, mapM_, maximum, minimum, notElem, or, product, sequence, sequence_, sum, (.))++-- | Strict version of 'modifyTVar'.+{-# INLINE modifyTVar' #-}+modifyTVar' :: TVar a -> (a -> a) -> STM ()+modifyTVar' var f = do+  x <- readTVar var+  writeTVar var $! f x++data Product2 a b = Product2 !a !b deriving (Eq)
+ library/StmContainers/Set.hs view
@@ -0,0 +1,123 @@+module StmContainers.Set+  ( Set,+    new,+    newIO,+    null,+    size,+    focus,+    lookup,+    insert,+    delete,+    reset,+    unfoldlM,+    listT,+    listTNonAtomic,+  )+where++import qualified Focus as B+import StmContainers.Prelude hiding (delete, empty, foldM, insert, lookup, null, toList)+import qualified StmHamt.SizedHamt as A++-- |+-- A hash set, based on an STM-specialized hash array mapped trie.+newtype Set item+  = Set (A.SizedHamt item)++-- |+-- Construct a new set.+{-# INLINEABLE new #-}+new :: STM (Set item)+new =+  Set <$> A.new++-- |+-- Construct a new set in IO.+--+-- This is useful for creating it on a top-level using 'unsafePerformIO',+-- because using 'atomically' inside 'unsafePerformIO' isn't possible.+{-# INLINEABLE newIO #-}+newIO :: IO (Set item)+newIO =+  Set <$> A.newIO++-- |+-- Check, whether the set is empty.+{-# INLINEABLE null #-}+null :: Set item -> STM Bool+null (Set hamt) =+  A.null hamt++-- |+-- Get the number of elements.+{-# INLINEABLE size #-}+size :: Set item -> STM Int+size (Set hamt) =+  A.size hamt++-- |+-- Focus on an element with a strategy.+--+-- This function allows to perform simultaneous lookup and modification.+--+-- The strategy is over a unit since we already know,+-- which element we're focusing on and it doesn't make sense to replace it,+-- however we still can decide wether to keep or remove it.+{-# INLINEABLE focus #-}+focus :: (Hashable item) => B.Focus () STM result -> item -> Set item -> STM result+focus unitFocus item (Set hamt) =+  A.focus rowFocus id item hamt+  where+    rowFocus =+      B.mappingInput (const item) (const ()) unitFocus++-- |+-- Lookup an element.+{-# INLINEABLE lookup #-}+lookup :: (Hashable item) => item -> Set item -> STM Bool+lookup =+  focus (fmap isJust B.lookup)++-- |+-- Insert a new element.+{-# INLINEABLE insert #-}+insert :: (Hashable item) => item -> Set item -> STM ()+insert item (Set hamt) =+  A.insert id item hamt++-- |+-- Delete an element.+{-# INLINEABLE delete #-}+delete :: (Hashable item) => item -> Set item -> STM ()+delete item (Set hamt) =+  A.focus B.delete id item hamt++-- |+-- Delete all the elements.+{-# INLINEABLE reset #-}+reset :: Set item -> STM ()+reset (Set hamt) =+  A.reset hamt++-- |+-- Stream the elements actively.+--+-- Amongst other features this function provides an interface to folding.+{-# INLINEABLE unfoldlM #-}+unfoldlM :: Set item -> UnfoldlM STM item+unfoldlM (Set hamt) =+  A.unfoldlM hamt++-- |+-- Stream the elements passively.+{-# INLINE listT #-}+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
stm-containers.cabal view
@@ -1,232 +1,150 @@-name:-  stm-containers-version:-  0.1.4-synopsis:-  Containers for STM+cabal-version: 3.0+name: stm-containers+version: 1.2.2+synopsis: Containers for STM description:-  This library is based on an STM-specialized implementation of a+  This library is based on an STM-specialized implementation of   Hash Array Mapped Trie.-  It provides efficient implementations of @Map@, @Set@ +  It provides efficient implementations of @Map@, @Set@   and other data structures,-  which are slightly slower than their counterparts from \"unordered-containers\",-  but scale very well on concurrent access patterns.+  which starting from version @1@ perform even better than their counterparts from \"unordered-containers\",+  but also scale well on concurrent access patterns.   .-  For details on performance of the library see+  For details on performance of the library, which are a bit outdated, see   <http://nikita-volkov.github.io/stm-containers/ this blog post>.-category:-  Data Structures, STM, Concurrency-homepage:-  https://github.com/nikita-volkov/stm-containers -bug-reports:-  https://github.com/nikita-volkov/stm-containers/issues -author:-  Nikita Volkov <nikita.y.volkov@mail.ru>-maintainer:-  Nikita Volkov <nikita.y.volkov@mail.ru>-copyright:-  (c) 2014, Nikita Volkov-license:-  MIT-license-file:-  LICENSE-build-type:-  Simple-cabal-version:-  >=1.10 +category: Data Structures, STM, Concurrency+homepage: https://github.com/nikita-volkov/stm-containers+bug-reports: https://github.com/nikita-volkov/stm-containers/issues+author: Nikita Volkov <nikita.y.volkov@mail.ru>+maintainer: Nikita Volkov <nikita.y.volkov@mail.ru>+copyright: (c) 2014, Nikita Volkov+license: MIT+license-file: LICENSE  source-repository head-  type:-    git-  location:-    git://github.com/nikita-volkov/stm-containers.git-+  type: git+  location: https://github.com/nikita-volkov/stm-containers  library-  hs-source-dirs:-    library-  other-modules:-    STMContainers.Prelude-    STMContainers.WordArray.Indices-    STMContainers.WordArray-    STMContainers.SizedArray-    STMContainers.HAMT.Level-    STMContainers.HAMT.Nodes-    STMContainers.HAMT-  exposed-modules:-    STMContainers.Bimap-    STMContainers.Multimap-    STMContainers.Map-    STMContainers.Set-  build-depends:-    -- data:-    hashable < 1.3,-    -- control:-    focus > 0.1.0 && < 0.2,-    -- debugging:-    loch-th == 0.2.*,-    placeholders == 0.1.*,-    -- general:-    primitive == 0.5.*,-    base-prelude == 0.1.*+  hs-source-dirs: library   default-extensions:-    Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, ImpredicativeTypes, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples-  default-language:-    Haskell2010+    Arrows+    BangPatterns+    ConstraintKinds+    DataKinds+    DefaultSignatures+    DeriveDataTypeable+    DeriveFoldable+    DeriveFunctor+    DeriveGeneric+    DeriveTraversable+    EmptyDataDecls+    FlexibleContexts+    FlexibleInstances+    FunctionalDependencies+    GADTs+    GeneralizedNewtypeDeriving+    LambdaCase+    LiberalTypeSynonyms+    MagicHash+    MultiParamTypeClasses+    MultiWayIf+    NoImplicitPrelude+    NoMonomorphismRestriction+    OverloadedStrings+    ParallelListComp+    PatternGuards+    PatternSynonyms+    QuasiQuotes+    RankNTypes+    RecordWildCards+    ScopedTypeVariables+    StandaloneDeriving+    TemplateHaskell+    TupleSections+    TypeApplications+    TypeFamilies+    TypeOperators+    UnboxedTuples +  default-language: Haskell2010+  exposed-modules:+    StmContainers.Bimap+    StmContainers.Map+    StmContainers.Multimap+    StmContainers.Set -test-suite word-array-tests-  type:-    exitcode-stdio-1.0-  hs-source-dirs:-    executables-    library-  main-is:-    WordArrayTests.hs+  other-modules: StmContainers.Prelude   build-depends:-    -- testing:-    free >= 4.6 && < 4.10,-    mtl == 2.*,-    QuickCheck == 2.7.*,-    HTF == 0.11.*,-    -- data:-    hashable < 1.3,-    -- control:-    focus > 0.1.0 && < 0.2,-    -- debugging:-    loch-th == 0.2.*,-    placeholders == 0.1.*,-    -- general:-    primitive == 0.5.*,-    base-prelude == 0.1.*-  default-extensions:-    Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, ImpredicativeTypes, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples-  default-language:-    Haskell2010-+    base >=4.9 && <5,+    deferred-folds >=0.9 && <0.10,+    focus >=1.0.1.4 && <1.1,+    hashable >=1.4 && <2,+    list-t >=1.0.1 && <1.1,+    stm-hamt >=1.2.2 && <1.3,+    transformers >=0.5 && <0.7, -test-suite api-tests-  type:-    exitcode-stdio-1.0-  hs-source-dirs:-    executables-  main-is:-    APITests.hs-  build-depends:-    QuickCheck == 2.7.*,-    HTF == 0.11.*,-    stm-containers,-    -- debugging:-    loch-th == 0.2.*,-    placeholders == 0.1.*,-    -- general:-    base-prelude == 0.1.*,-    focus > 0.1.0 && < 0.2,-    unordered-containers == 0.2.*,-    free >= 4.6 && < 4.10,-    mtl == 2.*,-    hashable < 1.3,-    base >= 4.5 && < 4.8+test-suite test+  type: exitcode-stdio-1.0+  hs-source-dirs: test   default-extensions:-    Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, ImpredicativeTypes, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples-  default-language:-    Haskell2010+    Arrows+    BangPatterns+    ConstraintKinds+    DataKinds+    DefaultSignatures+    DeriveDataTypeable+    DeriveFoldable+    DeriveFunctor+    DeriveGeneric+    DeriveTraversable+    EmptyDataDecls+    FlexibleContexts+    FlexibleInstances+    FunctionalDependencies+    GADTs+    GeneralizedNewtypeDeriving+    LambdaCase+    LiberalTypeSynonyms+    MagicHash+    MultiParamTypeClasses+    MultiWayIf+    NoImplicitPrelude+    NoMonomorphismRestriction+    OverloadedStrings+    ParallelListComp+    PatternGuards+    PatternSynonyms+    QuasiQuotes+    RankNTypes+    RecordWildCards+    ScopedTypeVariables+    StandaloneDeriving+    TemplateHaskell+    TupleSections+    TypeApplications+    TypeFamilies+    TypeOperators+    UnboxedTuples +  default-language: Haskell2010+  main-is: Main.hs+  other-modules:+    Suites.Bimap+    Suites.Map+    Suites.Map.Update+    Suites.Set -benchmark insertion-bench-  type: -    exitcode-stdio-1.0-  hs-source-dirs:-    executables-  main-is:-    InsertionBench.hs-  ghc-options:-    -O2 -threaded "-with-rtsopts=-N"-  default-extensions:-    Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, ImpredicativeTypes, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples-  default-language:-    Haskell2010   build-depends:-    mwc-random == 0.13.*,-    mwc-random-monad == 0.7.*,-    criterion == 0.8.*,-    -- data:-    text < 1.2,-    focus > 0.1.0 && < 0.2,-    hashable < 1.3,-    hashtables == 1.1.*,-    containers == 0.5.*,-    unordered-containers == 0.2.*,-    stm-containers,-    -- debugging:-    loch-th == 0.2.*,-    placeholders == 0.1.*,-    -- general:-    base >= 4.5 && < 4.8---benchmark concurrent-insertion-bench-  type: -    exitcode-stdio-1.0-  hs-source-dirs:-    executables-  main-is:-    ConcurrentInsertionBench.hs-  ghc-options:-    -O2 -threaded "-with-rtsopts=-N"-  default-extensions:-    Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, ImpredicativeTypes, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples-  default-language:-    Haskell2010-  build-depends:-    criterion == 0.8.*,-    mwc-random == 0.13.*,-    mwc-random-monad == 0.7.*,-    -- data:-    text < 1.2,-    focus > 0.1.0 && < 0.2,-    unordered-containers == 0.2.*,-    hashable < 1.3,-    stm-containers,-    -- debugging:-    loch-th == 0.2.*,-    placeholders == 0.1.*,-    -- general:-    free >= 4.5 && < 4.10,-    async == 2.0.*,-    base >= 4.5 && < 4.8---benchmark concurrent-transactions-bench-  type: -    exitcode-stdio-1.0-  hs-source-dirs:-    executables-  main-is:-    ConcurrentTransactionsBench.hs-  ghc-options:-    -O2 -threaded "-with-rtsopts=-N"-  default-extensions:-    Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, ImpredicativeTypes, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples-  default-language:-    Haskell2010-  build-depends:-    criterion == 0.8.*,-    mwc-random == 0.13.*,-    mwc-random-monad == 0.7.*,-    -- data:-    containers >= 0.5.2 && < 0.6,-    text < 1.2,-    focus > 0.1.0 && < 0.2,-    unordered-containers == 0.2.*,-    hashable < 1.3,+    deferred-folds,+    focus,+    foldl >=1.4 && <2,+    free >=4.6 && <6,+    list-t,+    quickcheck-instances >=0.3.29.1 && <0.4,+    rerebase >=1 && <2,     stm-containers,-    -- debugging:-    loch-th == 0.2.*,-    placeholders == 0.1.*,-    -- general:-    mtl == 2.*,-    free >= 4.5 && < 4.10,-    async == 2.0.*,-    base >= 4.5 && < 4.8+    tasty >=0.12 && <2,+    tasty-hunit >=0.10.0.3 && <0.11,+    tasty-quickcheck >=0.10.2 && <0.12,
+ test/Main.hs view
@@ -0,0 +1,14 @@+import qualified Suites.Bimap+import qualified Suites.Map+import qualified Suites.Set+import Test.Tasty+import Prelude++main :: IO ()+main =+  defaultMain+    . testGroup ""+    $ [ testGroup "Bimap" Suites.Bimap.tests,+        testGroup "Map" Suites.Map.tests,+        testGroup "Set" Suites.Set.tests+      ]
+ test/Suites/Bimap.hs view
@@ -0,0 +1,66 @@+module Suites.Bimap (tests) where++import qualified Focus+import qualified ListT+import StmContainers.Bimap+import Test.Tasty+import Test.Tasty.HUnit+import Prelude++tests :: [TestTree]+tests =+  [ testCase "construction" $ do+      m <- newIO :: IO (Bimap Int Int)+      atomically $ insertRight 3 1 m+      atomically $ insertRight 4 2 m+      assertEqual "" [(3, 1), (4, 2)] =<< atomically (ListT.toList (listT m)),+    testCase "deleteLeft" $ do+      m <- newIO :: IO (Bimap Int Int)+      atomically $ insertRight 3 1 m+      atomically $ insertRight 4 2 m+      atomically $ deleteLeft 4 m+      assertEqual "" [(3, 1)] =<< atomically (ListT.toList (listT m)),+    testCase "deleteRight" $ do+      m <- newIO :: IO (Bimap Int Int)+      atomically $ insertRight 3 1 m+      atomically $ insertRight 4 2 m+      atomically $ deleteRight 2 m+      assertEqual "" [(3, 1)] =<< atomically (ListT.toList (listT m)),+    testCase "replacing construction" $ do+      m <- newIO :: IO (Bimap Int Int)+      atomically $ insertRight 3 1 m+      atomically $ insertRight 4 2 m+      atomically $ insertRight 3 2 m+      assertEqual "" [(3, 2)] =<< atomically (ListT.toList (listT m)),+    testCase "insert overwrites" $ do+      m <- newIO :: IO (Bimap Int Int)+      atomically $ insertRight 3 1 m+      assertEqual "" 1 =<< atomically (size m)+      atomically $ insertRight 3 2 m+      assertEqual "" 1 =<< atomically (size m)+      assertEqual "" Nothing =<< atomically (lookupRight 1 m)+      assertEqual "" (Just 3) =<< atomically (lookupRight 2 m)+      assertEqual "" (Just 2) =<< atomically (lookupLeft 3 m)+      assertEqual "" Nothing =<< atomically (focusRight Focus.lookup 1 m)+      assertEqual "" (Just 3) =<< atomically (focusRight Focus.lookup 2 m)+      atomically $ focusRight (Focus.insert 3) 4 m+      assertEqual "" 1 =<< atomically (size m)+      assertEqual "" Nothing =<< atomically (lookupRight 1 m)+      assertEqual "" Nothing =<< atomically (lookupRight 2 m)+      assertEqual "" (Just 3) =<< atomically (lookupRight 4 m),+    testCase "insert overwrites 2" $ do+      m <- newIO :: IO (Bimap Int Char)+      atomically $ insertLeft 'a' 1 m+      assertEqual "" 1 =<< atomically (size m)+      atomically $ insertLeft 'a' 2 m+      assertEqual "" 1 =<< atomically (size m)+      assertEqual "" Nothing =<< atomically (lookupLeft 1 m)+      assertEqual "" (Just 'a') =<< atomically (lookupLeft 2 m)+      assertEqual "" Nothing =<< atomically (focusLeft Focus.lookup 1 m)+      assertEqual "" (Just 'a') =<< atomically (focusLeft Focus.lookup 2 m)+      atomically $ focusLeft (Focus.insert 'a') 3 m+      assertEqual "" 1 =<< atomically (size m)+      assertEqual "" Nothing =<< atomically (lookupLeft 1 m)+      assertEqual "" Nothing =<< atomically (lookupLeft 2 m)+      assertEqual "" (Just 'a') =<< atomically (lookupLeft 3 m)+  ]
+ test/Suites/Map.hs view
@@ -0,0 +1,155 @@+module Suites.Map (tests) where++import qualified Control.Foldl as Foldl+import Control.Monad.Free+import qualified Data.HashMap.Strict as HashMap+import qualified DeferredFolds.UnfoldlM as UnfoldlM+import qualified Focus+import qualified StmContainers.Map as StmMap+import qualified Suites.Map.Update as Update+import Test.QuickCheck.Instances ()+import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck+import Prelude hiding (choose)++interpretStmMapUpdate :: (Hashable 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) => 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) => StmMap.Map k v -> STM (HashMap.HashMap k v)+stmMapToHashMap = UnfoldlM.foldM (Foldl.generalize Foldl.hashMap) . StmMap.unfoldlM++stmMapFromList :: (Hashable 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 = UnfoldlM.foldM (Foldl.generalize Foldl.list) . StmMap.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 = do+              keys <- nub <$> listOf (choose ('a', 'z'))+              mapM (liftA2 (flip (,)) (choose (0, 99 :: Int)) . pure) keys+            prop list =+              length list == stmMapLength+              where+                stmMapLength =+                  unsafePerformIO $ atomically $ do+                    x <- stmMapFromList list+                    StmMap.size x+         in forAll gen prop,+    testProperty "fromListToListHashMapIsomorphism" $ \(list :: [(Text, Int)]) ->+      let hashMapList = HashMap.toList (HashMap.fromList list)+          stmMapList = unsafePerformIO $ atomically $ stmMapFromList list >>= stmMapToList+       in sort hashMapList === sort stmMapList,+    testProperty "updatesProduceTheSameEffectAsInHashMap" $ \(updates :: [Update.Update TestKey ()]) ->+      let update = sequence_ updates+          hashMap = interpretHashMapUpdate update+          hashMapSize = HashMap.size hashMap+          hashMapList = sort (HashMap.toList hashMap)+          (stmMapList, stmMapSize) = unsafePerformIO $ atomically $ do+            stmMap <- interpretStmMapUpdate update+            size <- StmMap.size stmMap+            stmMapList <- stmMapToList stmMap+            return (sort stmMapList, size)+       in (hashMapSize, hashMapList) === (stmMapSize, stmMapList),+    testCase "focusInsert" $ do+      assertEqual "" (HashMap.fromList [('a', 1), ('b', 2)]) =<< do+        atomically $ do+          m <- StmMap.new+          StmMap.focus (Focus.insert 1) 'a' m+          StmMap.focus (Focus.insert 2) 'b' m+          stmMapToHashMap m,+    testCase "focusInsertAndDelete" $ do+      assertEqual "" (HashMap.fromList [('b', 2)]) =<< do+        atomically $ do+          m <- StmMap.new+          StmMap.focus (Focus.insert 1) 'a' m+          StmMap.focus (Focus.insert 2) 'b' m+          StmMap.focus (Focus.delete) 'a' m+          stmMapToHashMap m,+    testCase "focusInsertAndDeleteWithCollision" $ do+      assertEqual "" (HashMap.fromList [(TestKey 32, 2)]) =<< do+        atomically $ do+          m <- StmMap.new+          StmMap.focus (Focus.insert 2) (TestKey 32) m+          StmMap.focus (Focus.delete) (TestKey 1) m+          stmMapToHashMap m,+    testCase "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,+    testCase "insert2" $ do+      assertEqual "" (HashMap.fromList [(111 :: Int, ()), (207, ())]) =<< do+        atomically $ do+          m <- StmMap.new+          StmMap.insert () 111 m+          StmMap.insert () 207 m+          stmMapToHashMap m,+    testCase "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,+    testCase "focusReachesTheTarget" $ do+      assertEqual "" (Just 2) =<< do+        atomically $ do+          m <- stmMapFromList [('a', 1), ('b', 2)]+          StmMap.focus Focus.lookup 'b' m,+    testCase "notNull" $ do+      assertEqual "" False =<< do+        atomically $ StmMap.null =<< stmMapFromList [('a', ())],+    testCase "nullAfterDeletingTheLastElement" $ do+      assertEqual "" True =<< do+        atomically $ do+          m <- stmMapFromList [('a', ())]+          StmMap.delete 'a' m+          StmMap.null m+  ]
+ test/Suites/Map/Update.hs view
@@ -0,0 +1,52 @@+module Suites.Map.Update where++import Control.Monad.Free+import Control.Monad.Free.TH+import Test.QuickCheck.Instances ()+import Test.Tasty.QuickCheck+import Prelude hiding (delete, insert)++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 _ k c ->+        showString "Adjust "+          . showString "<v -> v> "+          . showsPrecInner k+          . showChar ' '+          . showsPrecInner c+    where+      showsPrecInner = showsPrec (succ 5)++instance (Show k, Show v) => Show1 (UpdateF k v) where+  liftShowsPrec = undefined++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)+      ]
+ test/Suites/Set.hs view
@@ -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+  ]