packages feed

stm-containers 1.2 → 1.2.0.1

raw patch · 14 files changed

+624/−590 lines, 14 filesdep +quickcheck-instancesdep +tastydep +tasty-hunitdep −HTFdep −QuickCheckdep −quickcheck-textdep ~hashabledep ~transformerssetup-changed

Dependencies added: quickcheck-instances, tasty, tasty-hunit, tasty-quickcheck

Dependencies removed: HTF, QuickCheck, quickcheck-text

Dependency ranges changed: hashable, transformers

Files

− Setup.hs 
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
library/StmContainers/Bimap.hs view
@@ -1,37 +1,35 @@ module StmContainers.Bimap-(-  Bimap,-  new,-  newIO,-  null,-  size,-  focusLeft,-  focusRight,-  lookupLeft,-  lookupRight,-  insertLeft,-  insertRight,-  deleteLeft,-  deleteRight,-  reset,-  unfoldlM,-  listT,-)+  ( Bimap,+    new,+    newIO,+    null,+    size,+    focusLeft,+    focusRight,+    lookupLeft,+    lookupRight,+    insertLeft,+    insertRight,+    deleteLeft,+    deleteRight,+    reset,+    unfoldlM,+    listT,+  ) where -import StmContainers.Prelude hiding (insert, delete, lookup, alter, foldM, toList, empty, null)-import qualified StmContainers.Map as A 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 +--+-- 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)+data Bimap leftKey rightKey+  = Bimap !(A.Map leftKey rightKey) !(A.Map rightKey leftKey)   deriving (Typeable)  -- |@@ -43,8 +41,8 @@  -- | -- Construct a new bimap in IO.--- --- This is useful for creating it on a top-level using 'unsafePerformIO', +--+-- 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)@@ -67,80 +65,80 @@  -- | -- 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 :: (Eq leftKey, Hashable leftKey, Eq rightKey, Hashable rightKey) => B.Focus rightKey STM result -> leftKey -> Bimap leftKey rightKey -> STM result+focusLeft :: (Hashable leftKey, Hashable rightKey) => B.Focus rightKey STM result -> leftKey -> Bimap leftKey rightKey -> STM result focusLeft rightFocus leftKey (Bimap leftMap rightMap) =-  do +  do     ((output, change), maybeRightKey) <- A.focus (B.extractingInput (B.extractingChange rightFocus)) leftKey leftMap     case change of-      B.Leave -> +      B.Leave ->         return ()-      B.Remove -> -        forM_ maybeRightKey $ \ oldRightKey -> A.delete oldRightKey rightMap+      B.Remove ->+        forM_ maybeRightKey $ \oldRightKey -> A.delete oldRightKey rightMap       B.Set newRightKey ->         do-          forM_ maybeRightKey $ \ rightKey -> A.delete rightKey rightMap+          forM_ maybeRightKey $ \rightKey -> A.delete rightKey rightMap           maybeReplacedLeftKey <- A.focus (B.lookup <* B.insert leftKey) newRightKey rightMap-          forM_ maybeReplacedLeftKey $ \ replacedLeftKey -> A.delete replacedLeftKey leftMap+          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 :: (Eq leftKey, Hashable leftKey, Eq rightKey, Hashable rightKey) => B.Focus leftKey STM result -> rightKey -> Bimap leftKey rightKey -> STM result+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 :: (Eq leftKey, Hashable leftKey, Eq rightKey, Hashable rightKey) => leftKey -> Bimap leftKey rightKey -> STM (Maybe rightKey)+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 :: (Eq leftKey, Hashable leftKey, Eq rightKey, Hashable rightKey) => rightKey -> Bimap leftKey rightKey -> STM (Maybe leftKey)+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 :: (Eq leftKey, Hashable leftKey, Eq rightKey, Hashable rightKey) => rightKey -> leftKey -> Bimap leftKey rightKey -> STM ()+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 :: (Eq leftKey, Hashable leftKey, Eq rightKey, Hashable rightKey) => leftKey -> rightKey -> Bimap leftKey rightKey -> STM ()-insertRight leftKey rightKey (Bimap leftMap rightMap) = +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 :: (Eq leftKey, Hashable leftKey, Eq rightKey, Hashable rightKey) => leftKey -> Bimap leftKey rightKey -> STM ()+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)-  +  A.focus B.lookupAndDelete leftKey leftMap+    >>= mapM_ (\rightKey -> A.delete rightKey rightMap)+ -- | -- Delete the association by the right value. {-# INLINE deleteRight #-}-deleteRight :: (Eq leftKey, Hashable leftKey, Eq rightKey, Hashable rightKey) => rightKey -> Bimap leftKey rightKey -> STM ()+deleteRight :: (Hashable leftKey, Hashable rightKey) => rightKey -> Bimap leftKey rightKey -> STM () deleteRight rightKey (Bimap leftMap rightMap) =   deleteLeft rightKey (Bimap rightMap leftMap) @@ -155,11 +153,11 @@  -- | -- 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 rightMap) =+unfoldlM (Bimap leftMap _) =   A.unfoldlM leftMap  -- |
library/StmContainers/Map.hs view
@@ -1,71 +1,69 @@ module StmContainers.Map-(-  Map,-  new,-  newIO,-  null,-  size,-  focus,-  lookup,-  insert,-  delete,-  reset,-  unfoldlM,-  listT,-)+  ( Map,+    new,+    newIO,+    null,+    size,+    focus,+    lookup,+    insert,+    delete,+    reset,+    unfoldlM,+    listT,+  ) where -import StmContainers.Prelude hiding (insert, delete, lookup, alter, foldM, toList, empty, null)-import qualified StmHamt.Hamt as A-import qualified Focus as B 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))+newtype Map key value+  = Map (A.Hamt (Product2 key value))  -- | -- Construct a new map.-{-# INLINABLE new #-}+{-# 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', +--+-- This is useful for creating it on a top-level using 'unsafePerformIO', -- because using 'atomically' inside 'unsafePerformIO' isn't possible.-{-# INLINABLE newIO #-}+{-# INLINEABLE newIO #-} newIO :: IO (Map key value) newIO =   Map <$> A.newIO  -- | -- Check, whether the map is empty.-{-# INLINABLE null #-}+{-# INLINEABLE null #-} null :: Map key value -> STM Bool null (Map hamt) =   A.null hamt  -- | -- Get the number of elements.-{-# INLINABLE size #-}+{-# INLINEABLE size #-} size :: Map key value -> STM Int size =-  C.foldlM' (\ x _ -> return (succ x)) 0 . unfoldlM+  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 :: (Eq key, Hashable key) => B.Focus value STM result -> key -> Map key value -> STM result+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@@ -74,44 +72,44 @@  -- | -- Look up an item.-{-# INLINABLE lookup #-}-lookup :: (Eq key, Hashable key) => key -> Map key value -> STM (Maybe value)+{-# 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 :: (Eq key, Hashable key) => value -> key -> Map key value -> STM ()+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.-{-# INLINABLE delete #-}-delete :: (Eq key, Hashable key) => key -> Map key value -> STM ()+{-# INLINEABLE delete #-}+delete :: (Hashable key) => key -> Map key value -> STM () delete key =   focus B.delete key  -- | -- Delete all the associations.-{-# INLINABLE reset #-}+{-# 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.-{-# INLINABLE unfoldlM #-}+{-# INLINEABLE unfoldlM #-} unfoldlM :: Map key value -> UnfoldlM STM (key, value) unfoldlM (Map hamt) =-  fmap (\ (Product2 k v) -> (k, v)) (A.unfoldlM 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)+  fmap (\(Product2 k v) -> (k, v)) (A.listT hamt)
library/StmContainers/Multimap.hs view
@@ -1,37 +1,35 @@ module StmContainers.Multimap-(-  Multimap,-  new,-  newIO,-  null,-  focus,-  lookup,-  lookupByKey,-  insert,-  delete,-  deleteByKey,-  reset,-  unfoldlM,-  unfoldlMKeys,-  unfoldlMByKey,-  listT,-  listTKeys,-  listTByKey,-)+  ( Multimap,+    new,+    newIO,+    null,+    focus,+    lookup,+    lookupByKey,+    insert,+    delete,+    deleteByKey,+    reset,+    unfoldlM,+    unfoldlMKeys,+    unfoldlMByKey,+    listT,+    listTKeys,+    listTByKey,+  ) where -import StmContainers.Prelude hiding (insert, delete, lookup, alter, foldM, toList, empty, null)+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-import qualified Focus as C - -- | -- 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))+newtype Multimap key value+  = Multimap (A.Map key (B.Set value))   deriving (Typeable)  -- |@@ -67,68 +65,74 @@ -- 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 :: (Eq key, Hashable key, Eq value, Hashable value) => C.Focus () STM result -> value -> key -> Multimap key value -> STM result-focus unitFocus@(Focus concealUnit revealUnit) 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)+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 :: (Eq key, Hashable key, Eq value, Hashable value) => value -> key -> Multimap key value -> STM Bool+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 :: (Eq key, Hashable key) => key -> Multimap key value -> STM (Maybe (B.Set value))+lookupByKey :: (Hashable key) => key -> Multimap key value -> STM (Maybe (B.Set value)) lookupByKey key (Multimap m) =   A.lookup key m  -- | -- Insert an item.-{-# INLINABLE insert #-}-insert :: (Eq key, Hashable key, Eq value, 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)+{-# 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.-{-# INLINABLE delete #-}-delete :: (Eq key, Hashable key, Eq value, 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)+{-# 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 :: (Eq key, Hashable key) => key -> Multimap key value -> STM ()+deleteByKey :: (Hashable key) => key -> Multimap key value -> STM () deleteByKey key (Multimap map) =   A.delete key map @@ -155,7 +159,7 @@  -- | -- Stream values by a key actively.-unfoldlMByKey :: (Eq key, Hashable key) => key -> Multimap key value -> UnfoldlM STM value+unfoldlMByKey :: (Hashable key) => key -> Multimap key value -> UnfoldlM STM value unfoldlMByKey key (Multimap m) =   lift (A.lookup key m) >>= maybe mempty B.unfoldlM @@ -173,6 +177,6 @@  -- | -- Stream values by a key passively.-listTByKey :: (Eq key, Hashable key) => key -> Multimap key value -> ListT STM value+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
@@ -1,22 +1,20 @@ module StmContainers.Prelude-( -  module Exports,-  modifyTVar',-  Product2(..)-)+  ( module Exports,+    modifyTVar',+    Product2 (..),+  ) where --- base-------------------------- 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 (mapM_, sequence_, forM_, msum, mapM, sequence, forM)-import Control.Monad.IO.Class 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@@ -29,12 +27,13 @@ import Data.Foldable as Exports import Data.Function as Exports hiding (id, (.)) import Data.Functor as Exports-import Data.Int as Exports+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 (sortOn, isSubsequenceOf, uncons, concat, foldr, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, find, maximumBy, minimumBy, mapAccumL, mapAccumR, foldl')+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 (Last(..), First(..))+import Data.Monoid as Exports hiding (First (..), Last (..)) import Data.Ord as Exports import Data.Proxy as Exports import Data.Ratio as Exports@@ -46,16 +45,19 @@ 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 (sizeOf, alignment)-import GHC.Conc as Exports hiding (withMVar, threadWaitWriteSTM, threadWaitWrite, threadWaitReadSTM, threadWaitRead)-import GHC.Exts as Exports (lazy, inline, sortWith, groupWith)+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 Prelude as Exports hiding (concat, foldr, mapM_, sequence_, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, mapM, sequence, id, (.)) import System.Environment as Exports import System.Exit as Exports import System.IO as Exports@@ -64,38 +66,17 @@ import System.Mem as Exports import System.Mem.StableName as Exports import System.Timeout as Exports-import Text.ParserCombinators.ReadP as Exports (ReadP, ReadS, readP_to_S, readS_to_P)-import Text.ParserCombinators.ReadPrec as Exports (ReadPrec, readPrec_to_P, readP_to_Prec, readPrec_to_S, readS_to_Prec)-import Text.Printf as Exports (printf, hPrintf)-import Text.Read as Exports (Read(..), readMaybe, readEither)+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---- transformers---------------------------import Control.Monad.Trans.Class as Exports---- hashable---------------------------import Data.Hashable as Exports (Hashable(..))---- focus---------------------------import Focus as Exports (Focus(..))---- deferred-folds---------------------------import DeferredFolds.Unfoldl as Exports (Unfoldl(..))-import DeferredFolds.UnfoldlM as Exports (UnfoldlM(..))---- list-t---------------------------import ListT as Exports (ListT(..))+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+  x <- readTVar var+  writeTVar var $! f x  data Product2 a b = Product2 !a !b deriving (Eq)
library/StmContainers/Set.hs view
@@ -1,111 +1,109 @@ module StmContainers.Set-(-  Set,-  new,-  newIO,-  null,-  size,-  focus,-  lookup,-  insert,-  delete,-  reset,-  unfoldlM,-  listT,-)+  ( Set,+    new,+    newIO,+    null,+    size,+    focus,+    lookup,+    insert,+    delete,+    reset,+    unfoldlM,+    listT,+  ) where -import StmContainers.Prelude hiding (insert, delete, lookup, alter, foldM, toList, empty, null)-import qualified StmHamt.SizedHamt as A 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)+newtype Set item+  = Set (A.SizedHamt item)   deriving (Typeable)  -- | -- Construct a new set.-{-# INLINABLE new #-}+{-# 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', +--+-- This is useful for creating it on a top-level using 'unsafePerformIO', -- because using 'atomically' inside 'unsafePerformIO' isn't possible.-{-# INLINABLE newIO #-}+{-# INLINEABLE newIO #-} newIO :: IO (Set item) newIO =   Set <$> A.newIO  -- | -- Check, whether the set is empty.-{-# INLINABLE null #-}+{-# INLINEABLE null #-} null :: Set item -> STM Bool null (Set hamt) =   A.null hamt  -- | -- Get the number of elements.-{-# INLINABLE size #-}+{-# 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, +--+-- 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.-{-# INLINABLE focus #-}-focus :: (Eq item, Hashable item) => B.Focus () STM result -> item -> Set item -> STM result+{-# 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 = +    rowFocus =       B.mappingInput (const item) (const ()) unitFocus  -- | -- Lookup an element.-{-# INLINABLE lookup #-}-lookup :: (Eq item, Hashable item) => item -> Set item -> STM Bool+{-# INLINEABLE lookup #-}+lookup :: (Hashable item) => item -> Set item -> STM Bool lookup =   focus (fmap isJust B.lookup)  -- | -- Insert a new element.-{-# INLINABLE insert #-}-insert :: (Eq item, Hashable item) => item -> Set item -> STM ()+{-# INLINEABLE insert #-}+insert :: (Hashable item) => item -> Set item -> STM () insert item (Set hamt) =   A.insert id item hamt  -- | -- Delete an element.-{-# INLINABLE delete #-}-delete :: (Eq item, Hashable item) => item -> Set item -> STM ()+{-# INLINEABLE delete #-}+delete :: (Hashable item) => item -> Set item -> STM () delete item (Set hamt) =   A.focus B.delete id item hamt  -- | -- Delete all the elements.-{-# INLINABLE reset #-}+{-# 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.-{-# INLINABLE unfoldlM #-}+{-# INLINEABLE unfoldlM #-} unfoldlM :: Set item -> UnfoldlM STM item unfoldlM (Set hamt) =   A.unfoldlM hamt
stm-containers.cabal view
@@ -1,6 +1,7 @@-name: stm-containers-version: 1.2-synopsis: Containers for STM+cabal-version: 3.0+name:          stm-containers+version:       1.2.0.1+synopsis:      Containers for STM description:   This library is based on an STM-specialized implementation of   Hash Array Mapped Trie.@@ -11,60 +12,138 @@   .   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-tested-with: GHC ==8.0.2, GHC ==8.2.2, GHC ==8.4.2, GHC ==8.6.* +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+  type:     git   location: git://github.com/nikita-volkov/stm-containers.git  library-  hs-source-dirs: library-  default-extensions: Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, PatternSynonyms, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples-  default-language: Haskell2010+  hs-source-dirs:     library+  default-extensions:+    NoImplicitPrelude+    NoMonomorphismRestriction+    Arrows+    BangPatterns+    ConstraintKinds+    DataKinds+    DefaultSignatures+    DeriveDataTypeable+    DeriveFoldable+    DeriveFunctor+    DeriveGeneric+    DeriveTraversable+    EmptyDataDecls+    FlexibleContexts+    FlexibleInstances+    TypeApplications+    FunctionalDependencies+    GADTs+    GeneralizedNewtypeDeriving+    LambdaCase+    LiberalTypeSynonyms+    MagicHash+    MultiParamTypeClasses+    MultiWayIf+    OverloadedStrings+    ParallelListComp+    PatternGuards+    PatternSynonyms+    QuasiQuotes+    RankNTypes+    RecordWildCards+    ScopedTypeVariables+    StandaloneDeriving+    TemplateHaskell+    TupleSections+    TypeFamilies+    TypeOperators+    UnboxedTuples++  default-language:   Haskell2010   exposed-modules:-    StmContainers.Map-    StmContainers.Set     StmContainers.Bimap+    StmContainers.Map     StmContainers.Multimap-  other-modules:-    StmContainers.Prelude+    StmContainers.Set++  other-modules:      StmContainers.Prelude   build-depends:-    base >=4.9 && <5,-    deferred-folds >=0.9 && <0.10,-    focus >=1.0.1.4 && <1.1,-    hashable <2,-    list-t >=1.0.1 && <1.1,-    stm-hamt >=1.2 && <1.3,-    transformers >=0.5 && <0.6+    , 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 && <1.3+    , transformers >=0.5 && <0.7  test-suite test-  type: exitcode-stdio-1.0-  hs-source-dirs: test-  default-extensions: Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, PatternSynonyms, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples-  default-language: Haskell2010-  main-is: Main.hs+  type:               exitcode-stdio-1.0+  hs-source-dirs:     test+  default-extensions:+    NoImplicitPrelude+    NoMonomorphismRestriction+    Arrows+    BangPatterns+    ConstraintKinds+    DataKinds+    DefaultSignatures+    TypeApplications+    DeriveDataTypeable+    DeriveFoldable+    DeriveFunctor+    DeriveGeneric+    DeriveTraversable+    EmptyDataDecls+    FlexibleContexts+    FlexibleInstances+    FunctionalDependencies+    GADTs+    GeneralizedNewtypeDeriving+    LambdaCase+    LiberalTypeSynonyms+    MagicHash+    MultiParamTypeClasses+    MultiWayIf+    OverloadedStrings+    ParallelListComp+    PatternGuards+    PatternSynonyms+    QuasiQuotes+    RankNTypes+    RecordWildCards+    ScopedTypeVariables+    StandaloneDeriving+    TemplateHaskell+    TupleSections+    TypeFamilies+    TypeOperators+    UnboxedTuples++  default-language:   Haskell2010+  main-is:            Main.hs   other-modules:-    Main.BimapTests-    Main.MapTests-    Main.MapTests.Update+    Suites.Bimap+    Suites.Map+    Suites.Map.Update+   build-depends:-    deferred-folds,-    focus,-    foldl >=1.4 && <2,-    free >=4.6 && <6,-    list-t,-    HTF ==0.13.*,-    QuickCheck >=2.7 && <3,-    quickcheck-text >=0.1.2.1 && <0.2,-    rerebase >=1 && <2,-    stm-containers+    , 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+    , tasty >=0.12 && <2+    , tasty-hunit >=0.10.0.3 && <0.11+    , tasty-quickcheck >=0.10.2 && <0.11
test/Main.hs view
@@ -1,10 +1,11 @@-{-# OPTIONS_GHC -F -pgmF htfpp #-}--import Test.Framework+import qualified Suites.Bimap+import qualified Suites.Map+import Test.Tasty import Prelude -import {-@ HTF_TESTS @-} Main.MapTests-import {-@ HTF_TESTS @-} Main.BimapTests---main = htfMain $ htf_thisModulesTests : htf_importedTests+main :: IO ()+main =+  defaultMain . testGroup "" $+    [ testGroup "Bimap" Suites.Bimap.tests,+      testGroup "Map" Suites.Map.tests+    ]
− test/Main/BimapTests.hs 
@@ -1,69 +0,0 @@-{-# OPTIONS_GHC -F -pgmF htfpp #-}-module Main.BimapTests where--import Prelude-import Test.Framework-import StmContainers.Bimap-import qualified Focus-import qualified ListT--test_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))--test_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))--test_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))--test_replactingConstruction = 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))--test_insertOverwrites = 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)--test_insertOverwrites' = 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/Main/MapTests.hs 
@@ -1,173 +0,0 @@-{-# OPTIONS_GHC -F -pgmF htfpp #-}-module Main.MapTests where--import Prelude hiding (choose)-import Test.Framework-import Control.Monad.Free-import Data.Text.Arbitrary ()-import qualified Main.MapTests.Update as Update-import qualified StmContainers.Map as StmMap-import qualified Focus-import qualified Data.HashMap.Strict as HashMap-import qualified DeferredFolds.UnfoldlM as UnfoldlM-import qualified Control.Foldl as Foldl---interpretStmMapUpdate :: (Hashable k, Eq k) => Update.Update k v -> STM (StmMap.Map k v)-interpretStmMapUpdate update = do-  m <- StmMap.new-  flip iterM update $ \case-    Update.Insert k v c -> StmMap.insert v k m >> c-    Update.Delete k c   -> StmMap.delete k m >> c-    Update.Adjust f k c -> StmMap.focus ((Focus.adjustM . fmap return) f) k m >> c-  return m--interpretHashMapUpdate :: (Hashable k, Eq k) => Update.Update k v -> HashMap.HashMap k v-interpretHashMapUpdate update = -  flip execState HashMap.empty $ flip iterM update $ \case-    Update.Insert k v c -> modify (HashMap.insert k v) >> c-    Update.Delete k c   -> modify (HashMap.delete k) >> c-    Update.Adjust f k c -> modify (adjust f k) >> c-  where-    adjust f k m = -      case HashMap.lookup k m of-        Nothing -> m-        Just a -> HashMap.insert k (f a) m--stmMapToHashMap :: (Hashable k, Eq k) => StmMap.Map k v -> STM (HashMap.HashMap k v)-stmMapToHashMap = UnfoldlM.foldM (Foldl.generalize Foldl.hashMap) . StmMap.unfoldlM--stmMapFromList :: (Hashable k, Eq k) => [(k, v)] -> STM (StmMap.Map k v)-stmMapFromList list = do-  m <- StmMap.new-  forM_ list $ \(k, v) -> StmMap.insert v k m-  return m--stmMapToList :: StmMap.Map k v -> STM [(k, v)]-stmMapToList = UnfoldlM.foldM (Foldl.generalize Foldl.list) . StmMap.unfoldlM--interpretStmMapUpdateAsHashMap :: (Hashable k, Eq k) => Update.Update k v -> HashMap.HashMap k v-interpretStmMapUpdateAsHashMap =-  unsafePerformIO . atomically . (stmMapToHashMap <=< interpretStmMapUpdate)----- * Intentional hash collision simulation----------------------------newtype TestKey = TestKey Word8-  deriving (Eq, 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----------------------------prop_sizeAndList =-  forAll gen prop-  where-    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--prop_fromListToListHashMapIsomorphism =-  withQCArgs (\a -> a {maxSuccess = 10000}) $ \ (list :: [(Text, Int)]) -> let-    hashMapList = HashMap.toList (HashMap.fromList list)-    stmMapList = unsafePerformIO $ atomically $ stmMapFromList list >>= stmMapToList-    in sort hashMapList === sort stmMapList--prop_updatesProduceTheSameEffectAsInHashMap =-  withQCArgs (\a -> a {maxSuccess = 100000}) prop-  where-    prop (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)--test_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--test_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--test_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--test_insert = do-  assertEqual (HashMap.fromList [('a', 1), ('b', 2), ('c', 3)]) =<< do -    atomically $ do-      m <- StmMap.new-      StmMap.insert 1 'a' m-      StmMap.insert 3 'c' m-      StmMap.insert 2 'b' m-      stmMapToHashMap m--test_insert2 = do-  assertEqual (HashMap.fromList [(111 :: Int, ()), (207, ())]) =<< do -    atomically $ do-      m <- StmMap.new-      StmMap.insert () 111 m-      StmMap.insert () 207 m-      stmMapToHashMap m--test_adjust = do-  assertEqual (HashMap.fromList [('a', 1), ('b', 3)]) =<< do -    atomically $ do-      m <- stmMapFromList [('a', 1), ('b', 2)]-      StmMap.focus (Focus.adjustM (const $ return 3)) 'b' m-      stmMapToHashMap m--test_focusReachesTheTarget = do-  assertEqual (Just 2) =<< do -    atomically $ do-      m <- stmMapFromList [('a', 1), ('b', 2)]-      StmMap.focus Focus.lookup 'b' m--test_notNull = do-  assertEqual False =<< do -    atomically $ StmMap.null =<< stmMapFromList [('a', ())]--test_nullAfterDeletingTheLastElement = do-  assertEqual True =<< do -    atomically $ do-      m <- stmMapFromList [('a', ())]-      StmMap.delete 'a' m-      StmMap.null m
− test/Main/MapTests/Update.hs 
@@ -1,54 +0,0 @@-module Main.MapTests.Update where--import Prelude hiding (insert, delete, update)-import Test.Framework-import Control.Monad.Free-import Control.Monad.Free.TH---data UpdateF k v c =-  Insert k v c |-  Delete k c |-  Adjust (v -> v) k c-  deriving (Functor)--instance (Show k, Show v, Show c) => Show (UpdateF k v c) where-  showsPrec i = -    showParen (i > 5) . \case-      Insert k v c -> -        showString "Insert " . -        showsPrecInner k .-        showChar ' ' .-        showsPrecInner v .-        showChar ' ' .-        showsPrecInner c-      Delete k c ->-        showString "Delete " .-        showsPrecInner k .-        showChar ' ' .-        showsPrecInner c-      Adjust f k c ->-        showString "Adjust " .-        showString "<v -> v> " .-        showsPrecInner k .-        showChar ' ' .-        showsPrecInner c-    where-      showsPrecInner = showsPrec (succ 5)--instance 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/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 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)+      ]