stm-hamt 1.2.0.13 → 1.2.0.14
raw patch · 5 files changed
+202/−281 lines, 5 filesdep +randomdep −mwc-random-monad
Dependencies added: random
Dependencies removed: mwc-random-monad
Files
- concurrent-insertion-bench/Main.hs +5/−8
- library/StmHamt/Focuses.hs +2/−2
- library/StmHamt/Prelude.hs +1/−1
- stm-hamt.cabal +20/−97
- test/Main.hs +174/−173
concurrent-insertion-bench/Main.hs view
@@ -5,10 +5,9 @@ import Criterion.Main import qualified Focus as D import qualified Rebase.Data.Text as E-import qualified Rebase.Data.Vector as F import Rebase.Prelude import qualified StmHamt.Hamt as A-import qualified System.Random.MWC.Monad as C+import qualified System.Random as G -- * Transactions @@ -49,7 +48,7 @@ -- * Generators -type Generator a = C.Rand IO a+type Generator a = State G.StdGen a transactionGenerator :: Generator (Transaction Text ()) transactionGenerator = do@@ -63,9 +62,9 @@ return $! E.pack s where length =- C.uniformR (7, 20)+ state $ G.uniformR (7, 20) char =- chr <$> C.uniformR (ord 'a', ord 'z')+ chr <$> state (G.uniformR (ord 'a', ord 'z')) -- * Utils @@ -79,7 +78,7 @@ main :: IO () main = do- allTransactions <- C.runWithSeed seed $ replicateM actionsNum transactionGenerator+ allTransactions <- G.getStdRandom $ runState $ replicateM actionsNum transactionGenerator defaultMain $! flip map threadsNums $! \threadsNum -> let sliceSize = actionsNum `div` threadsNum threadTransactions = slices sliceSize allTransactions@@ -93,8 +92,6 @@ sessionRunner specializedInterpreter threadTransactions ] where- seed =- C.toSeed (F.fromList [1 .. 7]) actionsNum = 100000 threadsNums =
library/StmHamt/Focuses.hs view
@@ -39,8 +39,8 @@ onHamtElement depth hash test focus = let branchIndex = IntOps.indexAtDepth depth hash Focus concealBranches revealBranches =- By6Bits.onElementAtFocus branchIndex $- onBranchElement depth hash test focus+ By6Bits.onElementAtFocus branchIndex+ $ onBranchElement depth hash test focus concealHamt = let hamtChangeStm = \case Leave -> return Leave
library/StmHamt/Prelude.hs view
@@ -28,7 +28,7 @@ import Data.Fixed as Exports import Data.Foldable as Exports import Data.Function as Exports hiding (id, (.))-import Data.Functor as Exports+import Data.Functor as Exports hiding (unzip) import Data.Hashable as Exports (Hashable (..)) import Data.IORef as Exports import Data.Int as Exports
stm-hamt.cabal view
@@ -1,5 +1,6 @@+cabal-version: 3.0 name: stm-hamt-version: 1.2.0.13+version: 1.2.0.14 synopsis: STM-specialised Hash Array Mapped Trie description: A low-level data-structure,@@ -16,11 +17,9 @@ copyright: (c) 2016, Nikita Volkov license: MIT license-file: LICENSE-build-type: Simple-cabal-version: >=1.10 -library- hs-source-dirs: library+common base+ default-language: Haskell2010 default-extensions: NoImplicitPrelude NoMonomorphismRestriction@@ -60,7 +59,9 @@ TypeOperators UnboxedTuples - default-language: Haskell2010+library+ import: base+ hs-source-dirs: library exposed-modules: StmHamt.Hamt StmHamt.SizedHamt@@ -75,7 +76,7 @@ StmHamt.UnfoldlM build-depends:- base >=4.9 && <5+ , base >=4.9 && <5 , deferred-folds >=0.9 && <0.10 , focus >=1 && <1.1 , hashable >=1.4.0.0 && <2@@ -85,55 +86,16 @@ , transformers >=0.5 && <0.7 test-suite test- type: exitcode-stdio-1.0- hs-source-dirs: test- default-extensions:- NoImplicitPrelude- NoMonomorphismRestriction- Arrows- BangPatterns- BinaryLiterals- ConstraintKinds- DataKinds- DefaultSignatures- DeriveDataTypeable- DeriveFoldable- DeriveFunctor- DeriveGeneric- DeriveTraversable- EmptyDataDecls- FlexibleContexts- FlexibleInstances- FunctionalDependencies- GADTs- GeneralizedNewtypeDeriving- LambdaCase- LiberalTypeSynonyms- MagicHash- MultiParamTypeClasses- MultiWayIf- OverloadedStrings- ParallelListComp- PatternGuards- QuasiQuotes- RankNTypes- RecordWildCards- ScopedTypeVariables- StandaloneDeriving- TemplateHaskell- TupleSections- TypeFamilies- TypeOperators- UnboxedTuples-- default-language: Haskell2010- main-is: Main.hs+ import: base+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Main.hs other-modules: Main.Gens Main.Transaction build-depends:- deferred-folds+ , deferred-folds , focus , QuickCheck >=2.8.1 && <3 , quickcheck-instances >=0.3.11 && <0.4@@ -144,55 +106,16 @@ , tasty-quickcheck >=0.9 && <0.11 benchmark concurrent-insertion-bench- type: exitcode-stdio-1.0- hs-source-dirs: concurrent-insertion-bench- default-extensions:- NoImplicitPrelude- NoMonomorphismRestriction- Arrows- BangPatterns- BinaryLiterals- ConstraintKinds- DataKinds- DefaultSignatures- DeriveDataTypeable- DeriveFoldable- DeriveFunctor- DeriveGeneric- DeriveTraversable- EmptyDataDecls- FlexibleContexts- FlexibleInstances- FunctionalDependencies- GADTs- GeneralizedNewtypeDeriving- LambdaCase- LiberalTypeSynonyms- MagicHash- MultiParamTypeClasses- MultiWayIf- OverloadedStrings- ParallelListComp- PatternGuards- QuasiQuotes- RankNTypes- RecordWildCards- ScopedTypeVariables- StandaloneDeriving- TemplateHaskell- TupleSections- TypeFamilies- TypeOperators- UnboxedTuples-- default-language: Haskell2010- ghc-options: -O2 -threaded -with-rtsopts=-N- main-is: Main.hs+ import: base+ type: exitcode-stdio-1.0+ hs-source-dirs: concurrent-insertion-bench+ ghc-options: -O2 -threaded -with-rtsopts=-N+ main-is: Main.hs build-depends:- async >=2.0 && <3+ , async >=2.0 && <3 , criterion >=1.5 && <1.7 , focus , free >=4.5 && <6- , mwc-random-monad >=0.7 && <0.8+ , random >=1.2 && <2 , rebase <2 , stm-hamt
test/Main.hs view
@@ -17,180 +17,181 @@ main :: IO () main =- defaultMain $- testGroup "All" $- [ testGroup "Hamt" $- let hamtFromListUsingInsertWithHashInIo :: (Eq key) => (key -> Int) -> [(key, value)] -> IO (Hamt (key, value))- hamtFromListUsingInsertWithHashInIo hash list = do- hamt <- Hamt.newIO- atomically $ forM_ list $ \(key, value) -> Hamt.insertExplicitly (hash key) ((==) key . fst) (key, value) hamt- return hamt+ defaultMain+ $ testGroup "All"+ $ [ testGroup "Hamt"+ $ let hamtFromListUsingInsertWithHashInIo :: (Eq key) => (key -> Int) -> [(key, value)] -> IO (Hamt (key, value))+ hamtFromListUsingInsertWithHashInIo hash list = do+ hamt <- Hamt.newIO+ atomically $ forM_ list $ \(key, value) -> Hamt.insertExplicitly (hash key) ((==) key . fst) (key, value) hamt+ return hamt - hamtFromListUsingInsertInIo :: (Hashable key) => [(key, value)] -> IO (Hamt (key, value))- hamtFromListUsingInsertInIo list = do- hamt <- Hamt.newIO- atomically $ forM_ list $ \pair -> Hamt.insert fst pair hamt- return hamt+ hamtFromListUsingInsertInIo :: (Hashable key) => [(key, value)] -> IO (Hamt (key, value))+ hamtFromListUsingInsertInIo list = do+ hamt <- Hamt.newIO+ atomically $ forM_ list $ \pair -> Hamt.insert fst pair hamt+ return hamt - hamtToListInIo :: Hamt a -> IO [a]- hamtToListInIo hamt =- fmap reverse $- atomically $- UnfoldlM.foldlM' (\state element -> return (element : state)) [] (Hamt.unfoldlM hamt)+ hamtToListInIo :: Hamt a -> IO [a]+ hamtToListInIo hamt =+ fmap reverse+ $ atomically+ $ UnfoldlM.foldlM' (\state element -> return (element : state)) [] (Hamt.unfoldlM hamt) - listToListThruHamtInIo :: (Hashable key) => [(key, value)] -> IO [(key, value)]- listToListThruHamtInIo = hamtFromListUsingInsertInIo >=> hamtToListInIo- in [ testCase "insert" $- let list =- [ ('a', 1),- ('b', 2),- ('c', 3),- ('d', 4)- ]- in do- hamtList <- listToListThruHamtInIo list- assertEqual (show hamtList) list hamtList,- testCase "insert with dup" $- let list =- [ ('a', 1),- ('b', 1),- ('b', 2),- ('c', 3),- ('d', 4)- ]- in do- hamtList <- listToListThruHamtInIo list- assertEqual (show hamtList) (delete ('b', 1) list) hamtList,- testCase "insert text with dups" $- let list :: [(Text, Int)]- list = [("\44825\v8<\178sV\37709\59477\EM\n\SYN\34862\45730\57533\1643\1958i8\65022F]B\54233\9429A\RS\1797\54979\580@\2006\3400\ETX\ACK\63557\50825C\3741 \238\54817P\3258\54517\1081F5\16070\NAKR\1539\1193S\33229\1726&\778\20733\250\857\712C)\SYN1\17881\DC2\702\1446\61050S\5170s\ENQ\826\1379[7\53746\46137\55010\&0\1518:\2827R\54715\n\DEL\33260\1966\664\58929\64301\839\2980", 0), ("", 0), ("", 0)]- hashMapList = sort (HashMap.toList (HashMap.fromList list))- hamtList = sort $ unsafePerformIO $ do- hamt <- Hamt.newIO- atomically $ forM_ list $ \pair -> Hamt.insert fst pair hamt- hamtToListInIo hamt- in assertEqual (show hamtList) hashMapList hamtList,- testCase "insert text with dups using focus" $- let list :: [(Text, Int)]- list = [("\44825\v8<\178sV\37709\59477\EM\n\SYN\34862\45730\57533\1643\1958i8\65022F]B\54233\9429A\RS\1797\54979\580@\2006\3400\ETX\ACK\63557\50825C\3741 \238\54817P\3258\54517\1081F5\16070\NAKR\1539\1193S\33229\1726&\778\20733\250\857\712C)\SYN1\17881\DC2\702\1446\61050S\5170s\ENQ\826\1379[7\53746\46137\55010\&0\1518:\2827R\54715\n\DEL\33260\1966\664\58929\64301\839\2980", 0), ("", 0), ("", 0)]- hashMapList = sort (HashMap.toList (HashMap.fromList list))- hamtList = sort $ unsafePerformIO $ do- hamt <- Hamt.newIO- atomically $ forM_ list $ \pair -> Hamt.focus (Focus.insert pair) fst (fst pair) hamt- hamtToListInIo hamt- in assertEqual (show hamtList) hashMapList hamtList,- testCase "insert text with dups using focus 2" $- let list :: [(Text, Int)]- list = [("", 0), ("\877925R\vGw{f}\1112191+", 0), ("", 0)]- hashMapList = sort (HashMap.toList (HashMap.fromList list))- hamtList = sort $ unsafePerformIO $ do- hamt <- Hamt.newIO- atomically $ forM_ list $ \pair -> Hamt.focus (Focus.insert pair) fst (fst pair) hamt- hamtToListInIo hamt- in assertEqual (show hamtList) hashMapList hamtList,- testCase "insert text with dups using focus 3" $- let list :: [(Text, Int)]- list = [("", 0), ("\DC3\STXI\671038$Nq\892882\1099487\&0\DLEJ$!\DC4\741033\556944P\380108~g?J\ENQcXoQ\817654\n", 0)]- hashMapList = sort (HashMap.toList (HashMap.fromList list))- hamtList = sort $ unsafePerformIO $ do- hamt <- Hamt.newIO- atomically $ forM_ list $ \pair -> Hamt.focus (Focus.insert pair) fst (fst pair) hamt- hamtToListInIo hamt- in assertEqual (show hamtList) hashMapList hamtList,- testCase "insert text with dups using focus 4" $- let list :: [(Text, Int)]- list = [("b", 1), ("a", 9), ("b", 8), ("b", 6), ("b", 8), ("b", 9), ("abb", 5), ("b", 8), ("a", 0), ("a", 7)]- hashMapList = sort (HashMap.toList (HashMap.fromList list))- hamtList = sort $ unsafePerformIO $ do- hamt <- Hamt.newIO- atomically $ forM_ list $ \pair -> Hamt.focus (Focus.insert pair) fst (fst pair) hamt- hamtToListInIo hamt- in assertEqual (show hamtList) hashMapList hamtList,- testCase "insert text with dups using focus 5" $- let list :: [(Text, Int)]- list = [("a", 8), ("b", 5), ("b", 9), ("a", 4), ("abb", 2), ("a", 0), ("a", 1), ("a", 0), ("a", 1)]- hashMapList = sort (HashMap.toList (HashMap.fromList list))- hamtList = sort $ unsafePerformIO $ do- hamt <- Hamt.newIO- atomically $ forM_ list $ \pair -> Hamt.focus (Focus.insert pair) fst (fst pair) hamt- atomically $ Hamt.focus (Focus.insert ("a", 1)) fst ("a") hamt- hamtToListInIo hamt- in assertEqual (show hamtList) hashMapList hamtList,- testCase "insert text with dups using focus 6" $- let list :: [(Text, Int)]- list = [("", 0), ("8\DC2=s\b\122991\SOH\ETXi\t\97248\640988\121154S*w8\845163F*xyDW_MB5\371198]0", 0), ("", 0)]- hashMapList = sort (HashMap.toList (HashMap.fromList list))- hamtList = sort $ unsafePerformIO $ do- hamt <- Hamt.newIO- atomically $ forM_ list $ \pair -> do- Hamt.focus (Focus.insert pair) fst (fst pair) hamt- hamtToListInIo hamt- in assertEqual (show hamtList) hashMapList hamtList,- testCase "insert text with dups using focus on map created using insert" $- let list :: [(Text, Int)]- list = [("", 1), ("abb", 9), ("a", 3), ("b", 2), ("a", 0), ("a", 0), ("aa", 1)]- hashMapList = sort (HashMap.toList (HashMap.insert "a" 7 (HashMap.fromList list)))- hamtList = sort $ unsafePerformIO $ do- hamt <- Hamt.newIO- atomically $ forM_ list $ \pair -> do- -- traceM ("Inserting: " <> show pair)- Hamt.insert fst pair hamt- -- traceM =<< atomically (Hamt.introspect hamt)- -- traceM ("Inserting with focus: " <> show ("a", 7))- atomically $ Hamt.focus (Focus.insert ("a", 7)) fst "a" hamt- -- traceM =<< atomically (Hamt.introspect hamt)- hamtToListInIo hamt- in assertEqual (show hamtList) hashMapList hamtList,- testCase "delete using focus" $- let list :: [(Text, Int)]- list = [("abb", 5), ("a", 5), ("a", 5), ("ab", 0), ("a", 3), ("a", 7)]- hashMapList = sort (HashMap.toList (HashMap.delete "a" (HashMap.fromList list)))- hamtList = sort $ unsafePerformIO $ do- hamt <- Hamt.newIO- atomically $ forM_ list $ \pair -> do- Hamt.focus (Focus.insert pair) fst (fst pair) hamt- atomically $ Hamt.focus (Focus.delete) fst "a" hamt- hamtToListInIo hamt- in assertEqual (show hamtList) hashMapList hamtList,- testProperty "hashmap insertion isomorphism" $ \(list :: [(Text, Int)]) ->- let expectedList = sort (HashMap.toList (HashMap.fromList list))- hamtList = sort $ unsafePerformIO $ do- hamt <- Hamt.newIO- atomically $ forM_ list $ \pair -> Hamt.insert fst pair hamt- hamtToListInIo hamt- in expectedList === hamtList,- testProperty "hashmap insertion isomorphism using focus" $ \(list :: [(Text, Int)]) ->- let expectedList = sort (HashMap.toList (HashMap.fromList list))- hamtList = sort $ unsafePerformIO $ do- hamt <- Hamt.newIO- atomically $ forM_ list $ \pair -> Hamt.focus (Focus.insert pair) fst (fst pair) hamt- hamtToListInIo hamt- in expectedList === hamtList,- testGroup "Transaction properties" $- let testTransactionProperty :: String -> (Text -> Int) -> Gen Transaction -> TestTree- testTransactionProperty name hash transactionGen =- let gen = (,) <$> transactionGen <*> Gens.keyValueList- in testProperty ("Transaction: " <> name) $- forAll gen $ \(Transaction.Transaction name applyToHashMap applyToStmHamt, list) ->- let (result1, hashMapList) = fmap (sort . HashMap.toList) (applyToHashMap (HashMap.fromList list))- (result2, hamtList) = unsafePerformIO $ do- hamt <- hamtFromListUsingInsertWithHashInIo hash list- -- traceM =<< atomically (Hamt.introspect hamt)- result2 <- atomically $ applyToStmHamt hamt- -- traceM =<< atomically (Hamt.introspect hamt)- list <- atomically $ UnfoldlM.foldlM' (\state element -> return (element : state)) [] (Hamt.unfoldlM hamt)- return (result2, sort list)- in -- trace ("-----") $- counterexample- ("hashMapList: " <> show hashMapList <> "\nhamtList: " <> show hamtList <> "\nresult1: " <> show result1 <> "\nresult2: " <> show result2)- (hashMapList == hamtList && result1 == result2)- in [ testTransactionProperty "insert" hash Gens.insertTransaction,- let newHash key = hash key .&. 0b111- in testTransactionProperty "Hash collision" newHash (Gens.insertWithHashTransaction newHash),- testTransactionProperty "insertUsingFocus" hash Gens.insertUsingFocusTransaction,- testTransactionProperty "deleteUsingFocus" hash Gens.deleteUsingFocusTransaction,- testTransactionProperty "incrementUsingAdjustFocus" hash Gens.incrementUsingAdjustFocusTransaction,- testTransactionProperty "lookup" hash Gens.lookupTransaction- ]- ]+ listToListThruHamtInIo :: (Hashable key) => [(key, value)] -> IO [(key, value)]+ listToListThruHamtInIo = hamtFromListUsingInsertInIo >=> hamtToListInIo+ in [ testCase "insert"+ $ let list =+ [ ('a', 1),+ ('b', 2),+ ('c', 3),+ ('d', 4)+ ]+ in do+ hamtList <- listToListThruHamtInIo list+ assertEqual (show hamtList) list hamtList,+ testCase "insert with dup"+ $ let list =+ [ ('a', 1),+ ('b', 1),+ ('b', 2),+ ('c', 3),+ ('d', 4)+ ]+ in do+ hamtList <- listToListThruHamtInIo list+ assertEqual (show hamtList) (delete ('b', 1) list) hamtList,+ testCase "insert text with dups"+ $ let list :: [(Text, Int)]+ list = [("\44825\v8<\178sV\37709\59477\EM\n\SYN\34862\45730\57533\1643\1958i8\65022F]B\54233\9429A\RS\1797\54979\580@\2006\3400\ETX\ACK\63557\50825C\3741 \238\54817P\3258\54517\1081F5\16070\NAKR\1539\1193S\33229\1726&\778\20733\250\857\712C)\SYN1\17881\DC2\702\1446\61050S\5170s\ENQ\826\1379[7\53746\46137\55010\&0\1518:\2827R\54715\n\DEL\33260\1966\664\58929\64301\839\2980", 0), ("", 0), ("", 0)]+ hashMapList = sort (HashMap.toList (HashMap.fromList list))+ hamtList = sort $ unsafePerformIO $ do+ hamt <- Hamt.newIO+ atomically $ forM_ list $ \pair -> Hamt.insert fst pair hamt+ hamtToListInIo hamt+ in assertEqual (show hamtList) hashMapList hamtList,+ testCase "insert text with dups using focus"+ $ let list :: [(Text, Int)]+ list = [("\44825\v8<\178sV\37709\59477\EM\n\SYN\34862\45730\57533\1643\1958i8\65022F]B\54233\9429A\RS\1797\54979\580@\2006\3400\ETX\ACK\63557\50825C\3741 \238\54817P\3258\54517\1081F5\16070\NAKR\1539\1193S\33229\1726&\778\20733\250\857\712C)\SYN1\17881\DC2\702\1446\61050S\5170s\ENQ\826\1379[7\53746\46137\55010\&0\1518:\2827R\54715\n\DEL\33260\1966\664\58929\64301\839\2980", 0), ("", 0), ("", 0)]+ hashMapList = sort (HashMap.toList (HashMap.fromList list))+ hamtList = sort $ unsafePerformIO $ do+ hamt <- Hamt.newIO+ atomically $ forM_ list $ \pair -> Hamt.focus (Focus.insert pair) fst (fst pair) hamt+ hamtToListInIo hamt+ in assertEqual (show hamtList) hashMapList hamtList,+ testCase "insert text with dups using focus 2"+ $ let list :: [(Text, Int)]+ list = [("", 0), ("\877925R\vGw{f}\1112191+", 0), ("", 0)]+ hashMapList = sort (HashMap.toList (HashMap.fromList list))+ hamtList = sort $ unsafePerformIO $ do+ hamt <- Hamt.newIO+ atomically $ forM_ list $ \pair -> Hamt.focus (Focus.insert pair) fst (fst pair) hamt+ hamtToListInIo hamt+ in assertEqual (show hamtList) hashMapList hamtList,+ testCase "insert text with dups using focus 3"+ $ let list :: [(Text, Int)]+ list = [("", 0), ("\DC3\STXI\671038$Nq\892882\1099487\&0\DLEJ$!\DC4\741033\556944P\380108~g?J\ENQcXoQ\817654\n", 0)]+ hashMapList = sort (HashMap.toList (HashMap.fromList list))+ hamtList = sort $ unsafePerformIO $ do+ hamt <- Hamt.newIO+ atomically $ forM_ list $ \pair -> Hamt.focus (Focus.insert pair) fst (fst pair) hamt+ hamtToListInIo hamt+ in assertEqual (show hamtList) hashMapList hamtList,+ testCase "insert text with dups using focus 4"+ $ let list :: [(Text, Int)]+ list = [("b", 1), ("a", 9), ("b", 8), ("b", 6), ("b", 8), ("b", 9), ("abb", 5), ("b", 8), ("a", 0), ("a", 7)]+ hashMapList = sort (HashMap.toList (HashMap.fromList list))+ hamtList = sort $ unsafePerformIO $ do+ hamt <- Hamt.newIO+ atomically $ forM_ list $ \pair -> Hamt.focus (Focus.insert pair) fst (fst pair) hamt+ hamtToListInIo hamt+ in assertEqual (show hamtList) hashMapList hamtList,+ testCase "insert text with dups using focus 5"+ $ let list :: [(Text, Int)]+ list = [("a", 8), ("b", 5), ("b", 9), ("a", 4), ("abb", 2), ("a", 0), ("a", 1), ("a", 0), ("a", 1)]+ hashMapList = sort (HashMap.toList (HashMap.fromList list))+ hamtList = sort $ unsafePerformIO $ do+ hamt <- Hamt.newIO+ atomically $ forM_ list $ \pair -> Hamt.focus (Focus.insert pair) fst (fst pair) hamt+ atomically $ Hamt.focus (Focus.insert ("a", 1)) fst ("a") hamt+ hamtToListInIo hamt+ in assertEqual (show hamtList) hashMapList hamtList,+ testCase "insert text with dups using focus 6"+ $ let list :: [(Text, Int)]+ list = [("", 0), ("8\DC2=s\b\122991\SOH\ETXi\t\97248\640988\121154S*w8\845163F*xyDW_MB5\371198]0", 0), ("", 0)]+ hashMapList = sort (HashMap.toList (HashMap.fromList list))+ hamtList = sort $ unsafePerformIO $ do+ hamt <- Hamt.newIO+ atomically $ forM_ list $ \pair -> do+ Hamt.focus (Focus.insert pair) fst (fst pair) hamt+ hamtToListInIo hamt+ in assertEqual (show hamtList) hashMapList hamtList,+ testCase "insert text with dups using focus on map created using insert"+ $ let list :: [(Text, Int)]+ list = [("", 1), ("abb", 9), ("a", 3), ("b", 2), ("a", 0), ("a", 0), ("aa", 1)]+ hashMapList = sort (HashMap.toList (HashMap.insert "a" 7 (HashMap.fromList list)))+ hamtList = sort $ unsafePerformIO $ do+ hamt <- Hamt.newIO+ atomically $ forM_ list $ \pair -> do+ -- traceM ("Inserting: " <> show pair)+ Hamt.insert fst pair hamt+ -- traceM =<< atomically (Hamt.introspect hamt)+ -- traceM ("Inserting with focus: " <> show ("a", 7))+ atomically $ Hamt.focus (Focus.insert ("a", 7)) fst "a" hamt+ -- traceM =<< atomically (Hamt.introspect hamt)+ hamtToListInIo hamt+ in assertEqual (show hamtList) hashMapList hamtList,+ testCase "delete using focus"+ $ let list :: [(Text, Int)]+ list = [("abb", 5), ("a", 5), ("a", 5), ("ab", 0), ("a", 3), ("a", 7)]+ hashMapList = sort (HashMap.toList (HashMap.delete "a" (HashMap.fromList list)))+ hamtList = sort $ unsafePerformIO $ do+ hamt <- Hamt.newIO+ atomically $ forM_ list $ \pair -> do+ Hamt.focus (Focus.insert pair) fst (fst pair) hamt+ atomically $ Hamt.focus (Focus.delete) fst "a" hamt+ hamtToListInIo hamt+ in assertEqual (show hamtList) hashMapList hamtList,+ testProperty "hashmap insertion isomorphism" $ \(list :: [(Text, Int)]) ->+ let expectedList = sort (HashMap.toList (HashMap.fromList list))+ hamtList = sort $ unsafePerformIO $ do+ hamt <- Hamt.newIO+ atomically $ forM_ list $ \pair -> Hamt.insert fst pair hamt+ hamtToListInIo hamt+ in expectedList === hamtList,+ testProperty "hashmap insertion isomorphism using focus" $ \(list :: [(Text, Int)]) ->+ let expectedList = sort (HashMap.toList (HashMap.fromList list))+ hamtList = sort $ unsafePerformIO $ do+ hamt <- Hamt.newIO+ atomically $ forM_ list $ \pair -> Hamt.focus (Focus.insert pair) fst (fst pair) hamt+ hamtToListInIo hamt+ in expectedList === hamtList,+ testGroup "Transaction properties"+ $ let testTransactionProperty :: String -> (Text -> Int) -> Gen Transaction -> TestTree+ testTransactionProperty name hash transactionGen =+ let gen = (,) <$> transactionGen <*> Gens.keyValueList+ in testProperty ("Transaction: " <> name)+ $ forAll gen+ $ \(Transaction.Transaction name applyToHashMap applyToStmHamt, list) ->+ let (result1, hashMapList) = fmap (sort . HashMap.toList) (applyToHashMap (HashMap.fromList list))+ (result2, hamtList) = unsafePerformIO $ do+ hamt <- hamtFromListUsingInsertWithHashInIo hash list+ -- traceM =<< atomically (Hamt.introspect hamt)+ result2 <- atomically $ applyToStmHamt hamt+ -- traceM =<< atomically (Hamt.introspect hamt)+ list <- atomically $ UnfoldlM.foldlM' (\state element -> return (element : state)) [] (Hamt.unfoldlM hamt)+ return (result2, sort list)+ in -- trace ("-----") $+ counterexample+ ("hashMapList: " <> show hashMapList <> "\nhamtList: " <> show hamtList <> "\nresult1: " <> show result1 <> "\nresult2: " <> show result2)+ (hashMapList == hamtList && result1 == result2)+ in [ testTransactionProperty "insert" hash Gens.insertTransaction,+ let newHash key = hash key .&. 0b111+ in testTransactionProperty "Hash collision" newHash (Gens.insertWithHashTransaction newHash),+ testTransactionProperty "insertUsingFocus" hash Gens.insertUsingFocusTransaction,+ testTransactionProperty "deleteUsingFocus" hash Gens.deleteUsingFocusTransaction,+ testTransactionProperty "incrementUsingAdjustFocus" hash Gens.incrementUsingAdjustFocusTransaction,+ testTransactionProperty "lookup" hash Gens.lookupTransaction+ ]+ ] ]