stm-containers 0.2.16 → 1
raw patch · 28 files changed
+899/−2127 lines, 28 filesdep +deferred-foldsdep +foldldep +rerebasedep −asyncdep −base-preludedep −containersdep ~QuickCheckdep ~basedep ~focus
Dependencies added: deferred-folds, foldl, rerebase, stm-hamt
Dependencies removed: async, base-prelude, containers, criterion, hashtables, list-t, loch-th, mtl, mtl-prelude, mwc-random, mwc-random-monad, placeholders, primitive, text, unordered-containers, vector
Dependency ranges changed: QuickCheck, base, focus, free, hashable, transformers
Files
- executables/APITests.hs +0/−9
- executables/APITests/MapTests.hs +0/−148
- executables/APITests/MapTests/Update.hs +0/−52
- executables/ConcurrentInsertionBench.hs +0/−134
- executables/ConcurrentTransactionsBench.hs +0/−209
- executables/InsertionBench.hs +0/−52
- executables/WordArrayTests.hs +0/−40
- executables/WordArrayTests/Update.hs +0/−76
- library/STMContainers/Bimap.hs +0/−169
- library/STMContainers/HAMT.hs +0/−42
- library/STMContainers/HAMT/Level.hs +0/−29
- library/STMContainers/HAMT/Nodes.hs +0/−179
- library/STMContainers/Map.hs +0/−112
- library/STMContainers/Multimap.hs +0/−187
- library/STMContainers/Prelude.hs +0/−26
- library/STMContainers/Set.hs +0/−116
- library/STMContainers/SizedArray.hs +0/−87
- library/STMContainers/WordArray.hs +0/−198
- library/STMContainers/WordArray/Indices.hs +0/−68
- library/StmContainers/Bimap.hs +165/−0
- library/StmContainers/Map.hs +108/−0
- library/StmContainers/Multimap.hs +157/−0
- library/StmContainers/Prelude.hs +97/−0
- library/StmContainers/Set.hs +110/−0
- stm-containers.cabal +31/−194
- test/Main.hs +9/−0
- test/Main/MapTests.hs +169/−0
- test/Main/MapTests/Update.hs +53/−0
− 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/APITests/MapTests.hs
@@ -1,148 +0,0 @@-{-# OPTIONS_GHC -F -pgmF htfpp #-}-module APITests.MapTests where--import Test.Framework-import BasePrelude-import MTLPrelude-import Data.Hashable-import Control.Monad.Free-import qualified APITests.MapTests.Update as Update-import qualified STMContainers.Map as STMMap-import qualified Focus-import qualified Data.HashMap.Strict as HashMap-import qualified ListT---interpretSTMMapUpdate :: (Hashable k, Eq k) => Update.Update k v -> STM (STMMap.Map k v)-interpretSTMMapUpdate update = do- m <- STMMap.new- flip iterM update $ \case- Update.Insert k v c -> STMMap.insert v k m >> c- Update.Delete k c -> STMMap.delete k m >> c- Update.Adjust f k c -> STMMap.focus ((Focus.adjustM . fmap return) f) k m >> c- return m--interpretHashMapUpdate :: (Hashable k, Eq k) => Update.Update k v -> HashMap.HashMap k v-interpretHashMapUpdate update = - flip execState HashMap.empty $ flip iterM update $ \case- Update.Insert k v c -> modify (HashMap.insert k v) >> c- Update.Delete k c -> modify (HashMap.delete k) >> c- Update.Adjust f k c -> modify (adjust f k) >> c- where- adjust f k m = - case HashMap.lookup k m of- Nothing -> m- Just a -> HashMap.insert k (f a) m--stmMapToHashMap :: (Hashable k, Eq k) => STMMap.Map k v -> STM (HashMap.HashMap k v)-stmMapToHashMap = ListT.fold f HashMap.empty . STMMap.stream- where- f m (k, v) = return (HashMap.insert k v m)--stmMapFromList :: (Hashable k, Eq k) => [(k, v)] -> STM (STMMap.Map k v)-stmMapFromList list = do- m <- STMMap.new- forM_ list $ \(k, v) -> STMMap.insert v k m- return m--stmMapToList :: STMMap.Map k v -> STM [(k, v)]-stmMapToList = ListT.fold (\l -> return . (:l)) [] . STMMap.stream--interpretSTMMapUpdateAsHashMap :: (Hashable k, Eq k) => Update.Update k v -> HashMap.HashMap k v-interpretSTMMapUpdateAsHashMap =- unsafePerformIO . atomically . (stmMapToHashMap <=< interpretSTMMapUpdate)----- * Intentional hash collision simulation----------------------------newtype TestKey = TestKey Word8- deriving (Eq, Show)--instance Arbitrary TestKey where- arbitrary = TestKey <$> choose (0, 63)--instance Hashable TestKey where- hashWithSalt salt (TestKey w) =- if odd w- then hashWithSalt salt (pred w)- else hashWithSalt salt w----- * Tests----------------------------prop_sizeAndList =- forAll gen prop- where- gen = do- keys <- nub <$> listOf (arbitrary :: Gen Char)- mapM (liftA2 (flip (,)) (arbitrary :: Gen Int) . pure) keys- prop list =- length list == stmMapLength- where- stmMapLength =- unsafePerformIO $ atomically $ do- x <- stmMapFromList list- STMMap.size x--prop_fromListToListIsomorphism =- forAll gen prop- where- gen = do- keys <- nub <$> listOf (arbitrary :: Gen Char)- mapM (liftA2 (flip (,)) (arbitrary :: Gen Int) . pure) keys- prop list =- list \\ list' === []- where- list' = unsafePerformIO $ atomically $ stmMapFromList list >>= stmMapToList--prop_updatesProduceTheSameEffectAsInHashMap =- withQCArgs (\a -> a {maxSuccess = 1000}) prop- where- prop (updates :: [Update.Update TestKey ()]) =- interpretHashMapUpdate update === interpretSTMMapUpdateAsHashMap update- where- update = sequence_ updates--test_insert = do- assertEqual (HashMap.fromList [('a', 1), ('b', 2), ('c', 3)]) =<< do - atomically $ do- m <- STMMap.new- STMMap.insert 1 'a' m- STMMap.insert 3 'c' m- STMMap.insert 2 'b' m- stmMapToHashMap m--test_insert2 = do- assertEqual (HashMap.fromList [(111 :: Int, ()), (207, ())]) =<< do - atomically $ do- m <- STMMap.new- STMMap.insert () 111 m- STMMap.insert () 207 m- stmMapToHashMap m--test_adjust = do- assertEqual (HashMap.fromList [('a', 1), ('b', 3)]) =<< do - atomically $ do- m <- stmMapFromList [('a', 1), ('b', 2)]- STMMap.focus (Focus.adjustM (const $ return 3)) 'b' m- stmMapToHashMap m--test_focusReachesTheTarget = do- assertEqual (Just 2) =<< do - atomically $ do- m <- stmMapFromList [('a', 1), ('b', 2)]- STMMap.focus Focus.lookupM 'b' m--test_notNull = do- assertEqual False =<< do - atomically $ STMMap.null =<< stmMapFromList [('a', ())]--test_nullAfterDeletingTheLastElement = do- assertEqual True =<< do - atomically $ do- m <- stmMapFromList [('a', ())]- STMMap.delete 'a' m- STMMap.null m-
− executables/APITests/MapTests/Update.hs
@@ -1,52 +0,0 @@-module APITests.MapTests.Update where--import Test.Framework-import BasePrelude hiding (insert, delete, update)-import MTLPrelude-import Control.Monad.Free-import Control.Monad.Free.TH---data UpdateF k v c =- Insert k v c |- Delete k c |- Adjust (v -> v) k c- deriving (Functor)--instance (Show k, Show v, Show c) => Show (UpdateF k v c) where- showsPrec i = - showParen (i > 5) . \case- Insert k v c -> - showString "Insert " . - showsPrecInner k .- showChar ' ' .- showsPrecInner v .- showChar ' ' .- showsPrecInner c- Delete k c ->- showString "Delete " .- showsPrecInner k .- showChar ' ' .- showsPrecInner c- Adjust f k c ->- showString "Adjust " .- showString "<v -> v> " .- showsPrecInner k .- showChar ' ' .- showsPrecInner c- where- showsPrecInner = showsPrec (succ 5)--makeFree ''UpdateF--type Update k v = Free (UpdateF k v) ()--instance (Arbitrary k, Arbitrary v) => Arbitrary (Update k v) where- arbitrary = - frequency- [- (1 , delete <$> arbitrary),- (10, insert <$> arbitrary <*> arbitrary),- (3 , adjust <$> (const <$> arbitrary) <*> arbitrary)- ]-
− executables/ConcurrentInsertionBench.hs
@@ -1,134 +0,0 @@--import BasePrelude-import Data.Hashable (Hashable)-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.Vector as Vector---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.runWithSeed seed $ 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" $ nfIO $- scSessionRunner focusSCInterpreter threadTransactions,- bench "Specialized" $ nfIO $- scSessionRunner specializedSCInterpreter threadTransactions- ],- bench "Unordered Containers" $ nfIO $- ucSessionRunner threadTransactions- ]- where- seed = MWC.toSeed (Vector.fromList [1,2,3,4,5,6,7])- actionsNum = 100000- threadsNums = [1, 2, 4, 6, 8, 12, 16, 32, 40, 52, 64, 80, 128]
− executables/ConcurrentTransactionsBench.hs
@@ -1,209 +0,0 @@--import BasePrelude-import MTLPrelude-import Data.Hashable (Hashable)-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- [] -> error "Empty list"- l -> (!!) l <$> MWC.uniformR (0, (pred . length) l)--weightedElementGenerator :: [(Int, a)] -> Generator a-weightedElementGenerator = \case- [] -> - error "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) $ "") $ nfIO $- 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 BasePrelude-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" $ nfIO $- do- t <- atomically $ STMContainers.new :: IO (STMContainers.Map Text.Text ())- forM_ keys $ \k -> atomically $ STMContainers.focus (Focus.insertM ()) k t- ,- bench "specialized" $ nfIO $- 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" $ nfIO $- 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 MTLPrelude-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')]
− executables/WordArrayTests/Update.hs
@@ -1,76 +0,0 @@-module WordArrayTests.Update where--import Test.Framework-import STMContainers.Prelude-import MTLPrelude-import Control.Monad.Free-import Control.Monad.Free.TH-import qualified STMContainers.WordArray as WordArray---data UpdateF e f =- Singleton Int e f |- Set Int e f |- Unset Int f- deriving (Functor)--makeFree ''UpdateF--newtype Update e r = Update (Free (UpdateF e) r)--instance Show (Update e r) where- show = const "<Update>"--instance Arbitrary (Update Char ()) where- arbitrary = do- i <- bit- v <- char- fmap Update $ build $ singleton i v- where- build = execStateT $ do- amount <- lift $ choose (0, 200)- replicateM_ amount $ do- lift (choose (0 :: Int, 1)) >>= \case- 0 -> do- i <- lift $ bit- v <- lift $ char- modify (>> set i v)- 1 -> do- i <- lift $ bit- modify (>> unset i)- char = fmap chr $ choose (ord 'a', ord 'z')- bit = choose (0, pred wordSize)--interpretWordArray :: Update e () -> Maybe (WordArray.WordArray e)-interpretWordArray (Update u) = - flip execState Nothing $ flip iterM u $ \case- Singleton i e f -> do- put $ Just $ WordArray.singleton i e- f- Set i e f -> get >>= put . fmap (WordArray.set i e) >> f- Unset i f -> get >>= put . fmap (WordArray.unset i) >> f--interpretMaybeList :: Update e () -> Maybe [Maybe e]-interpretMaybeList (Update u) = - flip execState Nothing $ flip iterM u $ \case- Singleton i e f -> do- put $ Just $ map (\i' -> if i == i' then Just e else Nothing) [0 .. pred wordSize]- f- Set i e f -> do- lm <- get- lm' <- forM lm $ \l -> - return $ do- (i', e') <- zip [0..] l- return $ if i == i' then Just e else e'- put lm'- f- Unset i f -> do- lm <- get- put $ flip fmap lm $ \l -> do- (i', e') <- zip [0..] l- return $ if i == i' then Nothing else e'- f--wordSize :: Int-wordSize = bitSize (undefined :: Word)-
− library/STMContainers/Bimap.hs
@@ -1,169 +0,0 @@-module STMContainers.Bimap-(- Bimap,- Association,- Key,- new,- newIO,- insert1,- insert2,- delete1,- delete2,- deleteAll,- lookup1,- lookup2,- focus1,- focus2,- null,- size,- stream,-)-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)}- deriving (Typeable)---- |--- A constraint for associations.-type Association a b = (Key a, Key b)---- |--- A constraint for keys.-type Key k = Map.Key k---- |--- 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---- |--- Get the number of elements.-{-# INLINE size #-}-size :: Bimap a b -> STM Int-size = Map.size . 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)---- |--- Delete all the associations.-{-# INLINE deleteAll #-}-deleteAll :: Bimap a b -> STM ()-deleteAll (Bimap m1 m2) =- do- Map.deleteAll m1- Map.deleteAll m2---- |--- 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)---- |--- Stream associations.--- --- Amongst other features this function provides an interface to folding --- via the 'ListT.fold' function.-{-# INLINE stream #-}-stream :: Bimap a b -> ListT STM (a, b)-stream = Map.stream . m1
− library/STMContainers/HAMT.hs
@@ -1,42 +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--{-# INLINE stream #-}-stream :: HAMT e -> ListT STM e-stream = Nodes.stream 0--{-# INLINE deleteAll #-}-deleteAll :: HAMT e -> STM ()-deleteAll = Nodes.deleteAll
− 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,179 +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-import qualified ListT---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--stream :: Level.Level -> Nodes e -> ListT.ListT STM e-stream l =- lift . readTVar >=> ListT.fromFoldable >=> \case- Nodes n -> stream (Level.succ l) n- Leaf _ e -> return e- Leaves _ a -> ListT.fromFoldable a--size :: Nodes e -> STM Int-size nodes =- readTVar nodes >>= foldlM step 0- where- step a =- fmap (a+) . nodeSize- where- nodeSize :: Node e -> STM Int- nodeSize =- \case- Nodes nodes -> size nodes- Leaf _ _ -> pure 1- Leaves _ x -> pure (SizedArray.size x)--deleteAll :: Nodes e -> STM ()-deleteAll tvar = - writeTVar tvar WordArray.empty
− library/STMContainers/Map.hs
@@ -1,112 +0,0 @@-module STMContainers.Map-(- Map,- Key,- new,- newIO,- insert,- delete,- deleteAll,- lookup,- focus,- null,- size,- stream,-)-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 (k, v))- deriving (Typeable)---- |--- A constraint for keys.-type Key a = (Eq a, Hashable a)--instance (Eq k) => HAMTNodes.Element (k, v) where- type ElementKey (k, v) = k- elementKey (k, v) = k--{-# INLINE associationValue #-}-associationValue :: (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---- |--- Delete all the associations.-{-# INLINE deleteAll #-}-deleteAll :: Map k v -> STM ()-deleteAll (Map h) = HAMT.deleteAll 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---- |--- 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---- |--- Get the number of elements.-{-# INLINE size #-}-size :: Map k v -> STM Int-size (Map h) = HAMTNodes.size h---- |--- Stream associations.--- --- Amongst other features this function provides an interface to folding --- via the 'ListT.fold' function.-{-# INLINE stream #-}-stream :: Map k v -> ListT STM (k, v)-stream (Map h) = HAMT.stream h
− library/STMContainers/Multimap.hs
@@ -1,187 +0,0 @@-module STMContainers.Multimap-(- Multimap,- Association,- Key,- Value,- new,- newIO,- insert,- delete,- deleteByKey,- deleteAll,- lookup,- lookupByKey,- focus,- null,- stream,- streamKeys,- streamByKey,-)-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))- deriving (Typeable)---- |--- A constraint for associations.-type Association k v = (Key k, Value v)---- |--- A constraint for keys.-type Key k = Map.Key k---- |--- A constraint for values.-type Value v = Set.Element 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---- |--- Look up all values by key.-{-# INLINE lookupByKey #-}-lookupByKey :: Key k => k -> Multimap k v -> STM (Maybe (Set.Set v))-lookupByKey k (Multimap m) = 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)---- |--- Delete all values associated with a key.-{-# INLINEABLE deleteByKey #-}-deleteByKey :: Key k => k -> Multimap k v -> STM ()-deleteByKey k (Multimap m) =- Map.delete k m---- |--- Delete all the associations.-{-# INLINE deleteAll #-}-deleteAll :: Multimap k v -> STM ()-deleteAll (Multimap h) = Map.deleteAll h---- |--- 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---- |--- 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---- |--- Stream associations.------ Amongst other features this function provides an interface to folding--- via the 'ListT.fold' function.-stream :: Multimap k v -> ListT STM (k, v)-stream (Multimap m) =- Map.stream m >>= \(k, s) -> (k,) <$> Set.stream s---- |--- Stream keys.-streamKeys :: Multimap k v -> ListT STM k-streamKeys (Multimap m) =- fmap fst $ Map.stream m---- |--- Stream values by a key.-streamByKey :: Association k v => k -> Multimap k v -> ListT STM v-streamByKey k (Multimap m) =- lift (Map.lookup k m) >>= maybe mempty Set.stream--
− library/STMContainers/Prelude.hs
@@ -1,26 +0,0 @@-module STMContainers.Prelude-( - module Exports,- traversePair,-)-where---- base---------------------------import BasePrelude as Exports---- hashable---------------------------import Data.Hashable as Exports (Hashable(..))---- transformers---------------------------import Control.Monad.Trans.Class as Exports---- list-t---------------------------import ListT as Exports (ListT)---- | 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,116 +0,0 @@-module STMContainers.Set-(- Set,- Element,- new,- newIO,- insert,- delete,- deleteAll,- lookup,- focus,- null,- size,- stream,-)-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)}- deriving (Typeable)---- |--- A 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---- |--- Delete all the associations.-{-# INLINE deleteAll #-}-deleteAll :: Set e -> STM ()-deleteAll = HAMT.deleteAll . 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 ())---- |--- 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---- |--- Get the number of elements.-{-# INLINE size #-}-size :: Set e -> STM Int-size (Set h) = HAMTNodes.size h---- |--- Stream elements.--- --- Amongst other features this function provides an interface to folding --- via the 'ListT.fold' function.-{-# INLINE stream #-}-stream :: Set e -> ListT STM e-stream = fmap elementValue . HAMT.stream . 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,165 @@+module StmContainers.Bimap+(+ Bimap,+ new,+ newIO,+ null,+ size,+ focusLeft,+ focusRight,+ lookupLeft,+ lookupRight,+ insertLeft,+ insertRight,+ deleteLeft,+ deleteRight,+ reset,+ unfoldM,+)+where++import StmContainers.Prelude hiding (insert, delete, lookup, alter, foldM, toList, empty, null)+import qualified StmContainers.Map as A+import qualified Focus as B+++-- |+-- 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)+ deriving (Typeable)++-- |+-- 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 :: (Eq leftKey, Hashable leftKey, Eq rightKey, Hashable rightKey) => B.Focus rightKey STM result -> leftKey -> Bimap leftKey rightKey -> STM result+focusLeft valueFocus1 leftKey (Bimap leftMap rightMap) =+ do + ((output, change), maybeRightKey) <- A.focus (B.extractingInput (B.extractingChange valueFocus1)) leftKey leftMap+ case change of+ B.Leave -> + return ()+ B.Remove -> + forM_ maybeRightKey $ \ rightKey -> A.delete rightKey rightMap+ B.Set newKey2 ->+ do+ forM_ maybeRightKey $ \ rightKey -> A.delete rightKey rightMap+ A.insert leftKey newKey2 rightMap+ 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 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 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 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 rightKey leftKey (Bimap leftMap rightMap) = + do+ A.insert rightKey leftKey leftMap+ A.insert leftKey rightKey rightMap++-- |+-- 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) = + do+ A.insert leftKey rightKey rightMap+ A.insert rightKey leftKey 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 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 :: (Eq leftKey, Hashable leftKey, Eq rightKey, 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.+-- +-- Amongst other features this function provides an interface to folding.+{-# INLINE unfoldM #-}+unfoldM :: Bimap leftKey rightKey -> UnfoldM STM (leftKey, rightKey)+unfoldM (Bimap leftMap rightMap) =+ A.unfoldM leftMap
+ library/StmContainers/Map.hs view
@@ -0,0 +1,108 @@+module StmContainers.Map+(+ Map,+ new,+ newIO,+ null,+ size,+ focus,+ lookup,+ insert,+ delete,+ reset,+ unfoldM,+)+where++import StmContainers.Prelude hiding (insert, delete, lookup, alter, foldM, toList, empty, null)+import qualified StmHamt.SizedHamt as A+import qualified Focus as B+++-- |+-- Hash-table, based on STM-specialized Hash Array Mapped Trie.+newtype Map key value =+ Map (A.SizedHamt (Product2 key value))++-- |+-- Construct a new map.+{-# INLINABLE 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.+{-# INLINABLE newIO #-}+newIO :: IO (Map key value)+newIO =+ Map <$> A.newIO++-- |+-- Check, whether the map is empty.+{-# INLINABLE null #-}+null :: Map key value -> STM Bool+null (Map hamt) =+ A.null hamt++-- |+-- Get the number of elements.+{-# INLINABLE size #-}+size :: Map key value -> STM Int+size (Map hamt) =+ A.size hamt++-- |+-- 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 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.+{-# INLINABLE lookup #-}+lookup :: (Eq key, 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 value key (Map hamt) =+ 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 ()+delete key =+ focus B.delete key++-- |+-- Delete all the associations.+{-# INLINABLE reset #-}+reset :: Map key value -> STM ()+reset (Map hamt) =+ A.reset hamt++-- |+-- Stream the associations.+-- +-- Amongst other features this function provides an interface to folding.+{-# INLINABLE unfoldM #-}+unfoldM :: Map key value -> UnfoldM STM (key, value)+unfoldM (Map hamt) =+ fmap (\(Product2 k v) -> (k, v)) (A.unfoldM hamt)
+ library/StmContainers/Multimap.hs view
@@ -0,0 +1,157 @@+module StmContainers.Multimap+(+ Multimap,+ new,+ newIO,+ null,+ focus,+ lookup,+ lookupByKey,+ insert,+ delete,+ deleteByKey,+ reset,+ unfoldM,+ unfoldMKeys,+ unfoldMByKey,+)+where++import StmContainers.Prelude hiding (insert, delete, lookup, alter, foldM, toList, empty, null)+import qualified StmContainers.Map as A+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))+ deriving (Typeable)++-- |+-- 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 :: (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)++-- |+-- 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 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 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)++-- |+-- 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)++-- |+-- Delete all values associated with the key.+{-# INLINEABLE deleteByKey #-}+deleteByKey :: (Eq key, 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.+--+-- Amongst other features this function provides an interface to folding.+unfoldM :: Multimap key value -> UnfoldM STM (key, value)+unfoldM (Multimap m) =+ A.unfoldM m >>= \(key, s) -> (key,) <$> B.unfoldM s++-- |+-- Stream keys.+unfoldMKeys :: Multimap key value -> UnfoldM STM key+unfoldMKeys (Multimap m) =+ fmap fst (A.unfoldM m)++-- |+-- Stream values by a key.+unfoldMByKey :: (Eq key, Hashable key) => key -> Multimap key value -> UnfoldM STM value+unfoldMByKey key (Multimap m) =+ lift (A.lookup key m) >>= maybe mempty B.unfoldM
+ library/StmContainers/Prelude.hs view
@@ -0,0 +1,97 @@+module StmContainers.Prelude+( + 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.Fix as Exports hiding (fix)+import Control.Monad.ST 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+import Data.Int as Exports+import Data.IORef 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.Maybe as Exports+import Data.Monoid as Exports hiding (Last(..), First(..))+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 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 GHC.Generics as Exports (Generic)+import GHC.IO.Exception as Exports+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+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.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 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.Unfold as Exports (Unfold(..))+import DeferredFolds.UnfoldM as Exports (UnfoldM(..))++-- | 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,110 @@+module StmContainers.Set+(+ Set,+ new,+ newIO,+ null,+ size,+ focus,+ lookup,+ insert,+ delete,+ reset,+ unfoldM,+)+where++import StmContainers.Prelude hiding (insert, delete, lookup, alter, foldM, toList, empty, null)+import qualified StmHamt.SizedHamt as A+import qualified Focus as B+++-- |+-- A hash set, based on an STM-specialized hash array mapped trie.+newtype Set item =+ Set (A.SizedHamt item)+ deriving (Typeable)++-- |+-- Construct a new set.+{-# INLINABLE 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.+{-# INLINABLE newIO #-}+newIO :: IO (Set item)+newIO =+ Set <$> A.newIO++-- |+-- Check, whether the set is empty.+{-# INLINABLE null #-}+null :: Set item -> STM Bool+null (Set hamt) =+ A.null hamt++-- |+-- Get the number of elements.+{-# INLINABLE 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.+{-# INLINABLE focus #-}+focus :: (Eq item, 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.+{-# INLINABLE lookup #-}+lookup :: (Eq item, 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 ()+insert item (Set hamt) =+ A.insert id item hamt++-- |+-- Delete an element.+{-# INLINABLE delete #-}+delete :: (Eq item, Hashable item) => item -> Set item -> STM ()+delete item (Set hamt) =+ A.focus B.delete id item hamt++-- |+-- Delete all the elements.+{-# INLINABLE reset #-}+reset :: Set item -> STM ()+reset (Set hamt) =+ A.reset hamt++-- |+-- Stream elements.+-- +-- Amongst other features this function provides an interface to folding.+{-# INLINABLE unfoldM #-}+unfoldM :: Set item -> UnfoldM STM item+unfoldM (Set hamt) =+ A.unfoldM hamt
stm-containers.cabal view
@@ -1,7 +1,7 @@ name: stm-containers version:- 0.2.16+ 1 synopsis: Containers for STM description:@@ -9,10 +9,10 @@ Hash Array Mapped Trie. It provides efficient implementations of @Map@, @Set@ and other data structures,- which are marginally slower than their counterparts from \"unordered-containers\",- but scale well on concurrent access patterns.+ which starting from version @1@ perform even faster 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@@ -35,217 +35,54 @@ cabal-version: >=1.10 - source-repository head type: git location: git://github.com/nikita-volkov/stm-containers.git - 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 < 2,- -- control:- list-t >= 0.2 && < 2,- focus >= 0.1.2 && < 0.2,- transformers >= 0.3 && < 0.6,- -- general:- primitive >= 0.5 && < 0.7,- base-prelude < 2,- base < 5 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, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples+ 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---test-suite word-array-tests- type:- exitcode-stdio-1.0- hs-source-dirs:- executables- library- main-is:- WordArrayTests.hs+ exposed-modules:+ StmContainers.Map+ StmContainers.Set+ StmContainers.Bimap+ StmContainers.Multimap other-modules:- WordArrayTests.Update+ StmContainers.Prelude build-depends:- -- testing:- free >= 4.6 && < 5,- mtl == 2.*,- QuickCheck >= 2.6 && < 3,- HTF == 0.13.*,- -- data:- hashable,- -- control:- list-t,- focus,- transformers,- -- debugging:- loch-th == 0.2.*,- placeholders == 0.1.*,- -- general:- primitive,- mtl-prelude < 3,- base-prelude,- base- 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, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples- default-language:- Haskell2010-+ base <5,+ deferred-folds >=0.6.6 && <0.7,+ focus >=1 && <1.1,+ hashable <2,+ stm-hamt >=1 && <1.1,+ transformers >=0.5 && <0.6 -test-suite api-tests+test-suite test type: exitcode-stdio-1.0 hs-source-dirs:- executables- main-is:- APITests.hs- other-modules:- APITests.MapTests- APITests.MapTests.Update- build-depends:- QuickCheck >= 2.7 && < 3,- HTF == 0.13.*,- stm-containers,- -- debugging:- loch-th == 0.2.*,- placeholders == 0.1.*,- -- general:- list-t,- focus,- unordered-containers == 0.2.*,- free >= 4.6 && < 5,- mtl == 2.*,- hashable,- mtl-prelude < 3,- base-prelude,- base+ 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, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples+ 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---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, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, 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 == 1.1.*,- -- data:- text < 1.3,- list-t,- focus,- hashable,- hashtables >= 1.1 && < 1.3,- containers == 0.5.*,- unordered-containers == 0.2.*,- stm-containers,- -- debugging:- loch-th == 0.2.*,- placeholders == 0.1.*,- -- general:- base-prelude,- base---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, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, 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 == 1.1.*,- mwc-random == 0.13.*,- mwc-random-monad == 0.7.*,- -- data:- vector,- text < 2,- list-t,- focus,- unordered-containers == 0.2.*,- hashable,- stm-containers,- -- debugging:- loch-th == 0.2.*,- placeholders == 0.1.*,- -- general:- free >= 4.5 && < 5,- async >= 2.0 && < 3,- base-prelude,- base---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, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples- default-language:- Haskell2010+ Main.hs+ other-modules:+ Main.MapTests+ Main.MapTests.Update build-depends:- criterion == 1.1.*,- mwc-random == 0.13.*,- mwc-random-monad == 0.7.*,- -- data:- containers >= 0.5.2 && < 0.6,- text < 2,- list-t,+ deferred-folds, focus,- unordered-containers == 0.2.*,- hashable,- stm-containers,- -- debugging:- loch-th == 0.2.*,- placeholders == 0.1.*,- -- general:- mtl == 2.*,- free >= 4.5 && < 5,- async >= 2.0 && < 3,- mtl-prelude < 3,- base-prelude,- base+ foldl >=1.4 && <2,+ free >=4.6 && <6,+ HTF ==0.13.*,+ QuickCheck >=2.7 && <3,+ rerebase >=1 && <2,+ stm-containers
+ test/Main.hs view
@@ -0,0 +1,9 @@+{-# OPTIONS_GHC -F -pgmF htfpp #-}++import Test.Framework+import Prelude++import {-@ HTF_TESTS @-} Main.MapTests+++main = htfMain $ htf_thisModulesTests : htf_importedTests
+ test/Main/MapTests.hs view
@@ -0,0 +1,169 @@+{-# OPTIONS_GHC -F -pgmF htfpp #-}+module Main.MapTests where++import Prelude hiding (choose)+import Test.Framework+import Control.Monad.Free+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.UnfoldM as UnfoldM+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 = UnfoldM.foldM (Foldl.generalize Foldl.hashMap) . StmMap.unfoldM++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 = UnfoldM.foldM (Foldl.generalize Foldl.list) . StmMap.unfoldM++interpretStmMapUpdateAsHashMap :: (Hashable k, Eq k) => Update.Update k v -> HashMap.HashMap k v+interpretStmMapUpdateAsHashMap =+ unsafePerformIO . atomically . (stmMapToHashMap <=< interpretStmMapUpdate)+++-- * Intentional hash collision simulation+-------------------------++newtype TestKey = TestKey Word8+ deriving (Eq, Show)++instance Arbitrary TestKey where+ arbitrary = TestKey <$> choose (0, 63)++instance Hashable TestKey where+ hashWithSalt salt (TestKey w) =+ if odd w+ then hashWithSalt salt (pred w)+ else hashWithSalt salt w+++-- * Tests+-------------------------++prop_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_fromUnfoldMoListIsomorphism =+ forAll gen prop+ where+ gen = do+ keys <- nub <$> listOf (arbitrary :: Gen Char)+ mapM (liftA2 (flip (,)) (arbitrary :: Gen Int) . pure) keys+ prop list =+ list \\ list' === []+ where+ list' = unsafePerformIO $ atomically $ stmMapFromList list >>= stmMapToList++prop_updatesProduceTheSameEffectAsInHashMap =+ withQCArgs (\a -> a {maxSuccess = 1000}) prop+ where+ prop (updates :: [Update.Update TestKey ()]) =+ interpretHashMapUpdate update === interpretStmMapUpdateAsHashMap update+ where+ update = sequence_ updates++test_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 view
@@ -0,0 +1,53 @@+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)++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)+ ]+