diff --git a/concurrent-insertion-bench/Main.hs b/concurrent-insertion-bench/Main.hs --- a/concurrent-insertion-bench/Main.hs +++ b/concurrent-insertion-bench/Main.hs @@ -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 = diff --git a/library/StmHamt/Focuses.hs b/library/StmHamt/Focuses.hs --- a/library/StmHamt/Focuses.hs +++ b/library/StmHamt/Focuses.hs @@ -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 diff --git a/library/StmHamt/Prelude.hs b/library/StmHamt/Prelude.hs --- a/library/StmHamt/Prelude.hs +++ b/library/StmHamt/Prelude.hs @@ -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 diff --git a/stm-hamt.cabal b/stm-hamt.cabal --- a/stm-hamt.cabal +++ b/stm-hamt.cabal @@ -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 diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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 + ] + ] ]