diff --git a/library/StmHamt/Accessors/Hash.hs b/library/StmHamt/Accessors/Hash.hs deleted file mode 100644 --- a/library/StmHamt/Accessors/Hash.hs +++ /dev/null @@ -1,17 +0,0 @@ -module StmHamt.Accessors.Hash where - -import StmHamt.Prelude hiding (mask) -import StmHamt.Types - - -{-# INLINE index #-} -index :: Int -> Int -index hash = mask .&. hash - -{-# INLINE step #-} -step :: Int -step = 5 - -{-# NOINLINE mask #-} -mask :: Int -mask = bit step - 1 diff --git a/library/StmHamt/Constructors/Branch.hs b/library/StmHamt/Constructors/Branch.hs --- a/library/StmHamt/Constructors/Branch.hs +++ b/library/StmHamt/Constructors/Branch.hs @@ -2,20 +2,22 @@ import StmHamt.Prelude import StmHamt.Types -import qualified StmHamt.Accessors.Hash as HashAccessors -import qualified StmHamt.Constructors.Hash as HashConstructors +import qualified StmHamt.IntOps as IntOps import qualified PrimitiveExtras.SparseSmallArray as SparseSmallArray singleton :: Int -> a -> Branch a singleton hash a = LeavesBranch hash (pure a) -pair :: Int -> Branch a -> Int -> Branch a -> STM (Branch a) -pair hash1 branch1 hash2 branch2 = +pair :: Int -> Int -> Branch a -> Int -> Branch a -> STM (Branch a) +pair depth hash1 branch1 hash2 branch2 = {-# SCC "pair" #-} let - index1 = HashAccessors.index hash1 - index2 = HashAccessors.index hash2 + index1 = IntOps.indexAtDepth depth hash1 + index2 = IntOps.indexAtDepth depth hash2 in if index1 == index2 - then pair (HashConstructors.succLevel hash1) branch1 (HashConstructors.succLevel hash2) branch2 + then do + deeperBranch <- pair (IntOps.nextDepth depth) hash1 branch1 hash2 branch2 + var <- newTVar (SparseSmallArray.singleton index1 deeperBranch) + return (BranchesBranch (Hamt var)) else BranchesBranch . Hamt <$> newTVar (SparseSmallArray.pair index1 branch1 index2 branch2) diff --git a/library/StmHamt/Constructors/Hash.hs b/library/StmHamt/Constructors/Hash.hs deleted file mode 100644 --- a/library/StmHamt/Constructors/Hash.hs +++ /dev/null @@ -1,10 +0,0 @@ -module StmHamt.Constructors.Hash where - -import StmHamt.Prelude -import StmHamt.Types -import qualified StmHamt.Accessors.Hash as HashAccessors - - -{-# INLINE succLevel #-} -succLevel :: Int -> Int -succLevel hash = unsafeShiftR hash HashAccessors.step diff --git a/library/StmHamt/Focuses.hs b/library/StmHamt/Focuses.hs --- a/library/StmHamt/Focuses.hs +++ b/library/StmHamt/Focuses.hs @@ -6,50 +6,50 @@ import StmHamt.Prelude import StmHamt.Types import Focus -import qualified StmHamt.Accessors.Hash as HashAccessors +import qualified StmHamt.IntOps as IntOps import qualified StmHamt.Constructors.Branch as BranchConstructors -import qualified StmHamt.Constructors.Hash as HashConstructors import qualified PrimitiveExtras.SparseSmallArray as SparseSmallArray import qualified PrimitiveExtras.SmallArray as SmallArray -onBranchElement :: forall a b. Int -> (a -> Bool) -> Focus a STM b -> Focus (Branch a) STM b -onBranchElement hash testA aFocus@(Focus concealA revealA) = +onBranchElement :: forall a b. Int -> Int -> (a -> Bool) -> Focus a STM b -> Focus (Branch a) STM b +onBranchElement depth hash testElement elementFocus@(Focus concealElement revealElement) = let - Focus concealLeaves revealLeaves = SmallArray.onFoundElementFocus testA (const False) aFocus - branchesFocus :: Int -> Focus (TVar (SparseSmallArray (Branch a))) STM b - branchesFocus hash = let - !branchIndex = HashAccessors.index hash - in onTVarValue (SparseSmallArray.onElementAtFocus branchIndex (branchFocus hash)) + ~(Focus concealLeaves revealLeaves) = SmallArray.onFoundElementFocus testElement (const False) elementFocus + branchesVarFocus :: Int -> Focus (TVar (SparseSmallArray (Branch a))) STM b + branchesVarFocus depth = let + !branchIndex = IntOps.indexAtDepth depth hash + in onTVarValue (SparseSmallArray.onElementAtFocus branchIndex (branchFocus ( depth))) branchFocus :: Int -> Focus (Branch a) STM b - branchFocus hash = Focus concealBranch revealBranch where - Focus concealBranchesVar revealBranchesVar = branchesFocus (HashConstructors.succLevel hash) + branchFocus depth = Focus concealBranch revealBranch where concealBranch = fmap (fmap (fmap (LeavesBranch hash))) concealLeaves revealBranch = \ case - LeavesBranch leavesHash leavesArray -> case leavesHash == hash of - True -> fmap (fmap (fmap (LeavesBranch leavesHash))) (revealLeaves leavesArray) - False -> concealA >>= traverse interpretChange where - interpretChange = \ case - Set newA -> let - newHash = HashConstructors.succLevel hash - newLeavesHash = HashConstructors.succLevel leavesHash - in Set <$> BranchConstructors.pair newHash (BranchConstructors.singleton newHash newA) newLeavesHash (LeavesBranch newLeavesHash leavesArray) - _ -> return Leave - BranchesBranch (Hamt var) -> fmap (fmap (fmap (BranchesBranch . Hamt))) (revealBranchesVar var) - in branchFocus hash + LeavesBranch leavesHash leavesArray -> + case leavesHash == hash of + True -> fmap (fmap (fmap (LeavesBranch leavesHash))) (revealLeaves leavesArray) + False -> let + interpretChange = \ case + Set !newElement -> Set <$> BranchConstructors.pair (IntOps.nextDepth depth) hash (BranchConstructors.singleton hash newElement) leavesHash (LeavesBranch leavesHash leavesArray) + _ -> return Leave + in concealElement >>= traverse interpretChange + BranchesBranch (Hamt var) -> let + Focus _ revealBranchesVar = branchesVarFocus (IntOps.nextDepth depth) + in fmap (fmap (fmap (BranchesBranch . Hamt))) (revealBranchesVar var) + in branchFocus depth -onHamtElement :: Int -> (a -> Bool) -> Focus a STM b -> Focus (Hamt a) STM b -onHamtElement hash test focus = +onHamtElement :: Int -> Int -> (a -> Bool) -> Focus a STM b -> Focus (Hamt a) STM b +onHamtElement depth hash test focus = let - !branchIndex = HashAccessors.index hash + branchIndex = IntOps.indexAtDepth depth hash Focus concealBranches revealBranches = SparseSmallArray.onElementAtFocus branchIndex $ - onBranchElement hash test focus - concealHamt = concealBranches >>= traverse hamtChangeStm where + onBranchElement depth hash test focus + concealHamt = let hamtChangeStm = \ case Leave -> return Leave Set !branches -> Set . Hamt <$> newTVar branches Remove -> Set . Hamt <$> newTVar SparseSmallArray.empty + in concealBranches >>= traverse hamtChangeStm revealHamt (Hamt branchesVar) = do branches <- readTVar branchesVar (result, branchesChange) <- revealBranches branches diff --git a/library/StmHamt/Hamt.hs b/library/StmHamt/Hamt.hs --- a/library/StmHamt/Hamt.hs +++ b/library/StmHamt/Hamt.hs @@ -19,11 +19,10 @@ import StmHamt.Prelude hiding (empty, insert, update, lookup, delete, null) import StmHamt.Types import qualified Focus as Focus -import qualified StmHamt.Focuses as Focuses -import qualified StmHamt.Constructors.Hash as HashConstructors -import qualified StmHamt.Accessors.Hash as HashAccessors +import qualified StmHamt.Focuses as Focus import qualified StmHamt.UnfoldMs as UnfoldMs import qualified StmHamt.ListT as ListT +import qualified StmHamt.IntOps as IntOps import qualified PrimitiveExtras.SmallArray as SmallArray import qualified PrimitiveExtras.SparseSmallArray as SparseSmallArray @@ -34,16 +33,6 @@ newIO :: IO (Hamt a) newIO = Hamt <$> newTVarIO SparseSmallArray.empty -pair :: Int -> Branch a -> Int -> Branch a -> STM (Hamt a) -pair hash1 branch1 hash2 branch2 = - {-# SCC "pair" #-} - let - index1 = HashAccessors.index hash1 - index2 = HashAccessors.index hash2 - in if index1 == index2 - then pair (HashConstructors.succLevel hash1) branch1 (HashConstructors.succLevel hash2) branch2 - else Hamt <$> newTVar (SparseSmallArray.pair index1 branch1 index2 branch2) - focus :: (Eq key, Hashable key) => Focus element STM result -> (element -> key) -> key -> Hamt element -> STM result focus focus elementToKey key = focusExplicitly focus (hash key) ((==) key . elementToKey) @@ -51,7 +40,7 @@ focusExplicitly focus hash test hamt = {-# SCC "focus" #-} let - Focus conceal reveal = Focuses.onHamtElement hash test focus + Focus _ reveal = Focus.onHamtElement 0 hash test focus in fmap fst (reveal hamt) {-| @@ -66,39 +55,52 @@ Returns a flag, specifying, whether the size has been affected. -} insertExplicitly :: Int -> (a -> Bool) -> a -> Hamt a -> STM Bool -insertExplicitly hash testKey element (Hamt var) = - {-# SCC "insertExplicitly" #-} +insertExplicitly hash testKey element = + {-# SCC "insertExplicitly" #-} let - !branchIndex = HashAccessors.index hash - in do - branchArray <- readTVar var - case SparseSmallArray.lookup branchIndex branchArray of - Nothing -> do - writeTVar var $! SparseSmallArray.insert branchIndex (LeavesBranch hash (pure element)) branchArray - return True - Just branch -> case branch of - LeavesBranch leavesHash leavesArray -> if leavesHash == hash - then case SmallArray.findWithIndex testKey leavesArray of - Just (leavesIndex, leavesElement) -> do - let + loop depth (Hamt var) = let + !branchIndex = IntOps.indexAtDepth depth hash + in do + branchArray <- readTVar var + case SparseSmallArray.lookup branchIndex branchArray of + Nothing -> do + writeTVar var $! SparseSmallArray.insert branchIndex (LeavesBranch hash (pure element)) branchArray + return True + Just branch -> case branch of + LeavesBranch leavesHash leavesArray -> if leavesHash == hash + then case SmallArray.findWithIndex testKey leavesArray of + Just (leavesIndex, _) -> let !newLeavesArray = SmallArray.set leavesIndex element leavesArray !newBranch = LeavesBranch hash newLeavesArray !newBranchArray = SparseSmallArray.replace branchIndex newBranch branchArray in do writeTVar var newBranchArray return False - Nothing -> do - writeTVar var $! SparseSmallArray.replace branchIndex (LeavesBranch hash (SmallArray.cons element leavesArray)) branchArray - return True - else let - nextHash = HashConstructors.succLevel hash - nextLeavesHash = HashConstructors.succLevel leavesHash - in do - hamt <- pair nextHash (LeavesBranch nextHash (pure element)) nextLeavesHash (LeavesBranch nextLeavesHash leavesArray) + Nothing -> let + newLeavesArray = SmallArray.cons element leavesArray + in do + writeTVar var $! SparseSmallArray.replace branchIndex (LeavesBranch hash newLeavesArray) branchArray + return True + else do + hamt <- pair (IntOps.nextDepth depth) hash (LeavesBranch hash (pure element)) leavesHash (LeavesBranch leavesHash leavesArray) writeTVar var $! SparseSmallArray.replace branchIndex (BranchesBranch hamt) branchArray return True - BranchesBranch hamt -> insertExplicitly (HashConstructors.succLevel hash) testKey element hamt + BranchesBranch hamt -> loop (IntOps.nextDepth depth) hamt + in loop 0 +pair :: Int -> Int -> Branch a -> Int -> Branch a -> STM (Hamt a) +pair depth hash1 branch1 hash2 branch2 = + {-# SCC "pair" #-} + let + index1 = IntOps.indexAtDepth depth hash1 + index2 = IntOps.indexAtDepth depth hash2 + in if index1 == index2 + then do + deeperHamt <- pair (IntOps.nextDepth depth) hash1 branch1 hash2 branch2 + var <- newTVar (SparseSmallArray.singleton index1 (BranchesBranch deeperHamt)) + return (Hamt var) + else Hamt <$> newTVar (SparseSmallArray.pair index1 branch1 index2 branch2) + {-| Returns a flag, specifying, whether the size has been affected. -} @@ -106,19 +108,21 @@ lookup elementToKey key = lookupExplicitly (hash key) ((==) key . elementToKey) lookupExplicitly :: Int -> (a -> Bool) -> Hamt a -> STM (Maybe a) -lookupExplicitly hash test (Hamt var) = +lookupExplicitly hash test = {-# SCC "lookupExplicitly" #-} let - !index = HashAccessors.index hash - in do - branchArray <- readTVar var - case SparseSmallArray.lookup index branchArray of - Just branch -> case branch of - LeavesBranch leavesHash leavesArray -> if leavesHash == hash - then return (SmallArray.find test leavesArray) - else return Nothing - BranchesBranch hamt -> lookupExplicitly (HashConstructors.succLevel hash) test hamt - Nothing -> return Nothing + loop depth (Hamt var) = let + !index = IntOps.indexAtDepth depth hash + in do + branchArray <- readTVar var + case SparseSmallArray.lookup index branchArray of + Just branch -> case branch of + LeavesBranch leavesHash leavesArray -> if leavesHash == hash + then return (SmallArray.find test leavesArray) + else return Nothing + BranchesBranch hamt -> loop (IntOps.nextDepth depth) hamt + Nothing -> return Nothing + in loop 0 reset :: Hamt a -> STM () reset (Hamt branchSsaVar) = writeTVar branchSsaVar SparseSmallArray.empty @@ -133,3 +137,19 @@ null (Hamt branchSsaVar) = do branchSsa <- readTVar branchSsaVar return (SparseSmallArray.null branchSsa) + +{-| +Render the structure of HAMT. +-} +introspect :: Show a => Hamt a -> STM String +introspect (Hamt branchArrayVar) = do + branchArray <- readTVar branchArrayVar + indexedList <- traverse (traverse introspectBranch) (SparseSmallArray.toIndexedList branchArray) + return $ + "[" <> intercalate ", " (fmap (\ (i, branchString) -> "(" <> show i <> ", " <> branchString <> ")") indexedList) <> "]" + where + introspectBranch = \ case + BranchesBranch deeperHamt -> do + deeperString <- introspect deeperHamt + return (showString "BranchesBranch " deeperString) + LeavesBranch hash array -> return (showString "LeavesBranch " (shows hash (showChar ' ' (show (SmallArray.toList array))))) diff --git a/library/StmHamt/IntOps.hs b/library/StmHamt/IntOps.hs new file mode 100644 --- /dev/null +++ b/library/StmHamt/IntOps.hs @@ -0,0 +1,29 @@ +module StmHamt.IntOps where + +import StmHamt.Prelude hiding (mask, index) +import StmHamt.Types + + +{-# INLINE atDepth #-} +atDepth :: Int -> Int -> Int +atDepth depth hash = unsafeShiftR hash depth + +{-# INLINE indexAtDepth #-} +indexAtDepth :: Int -> Int -> Int +indexAtDepth depth hash = index (atDepth depth hash) + +{-# INLINE index #-} +index :: Int -> Int +index hash = mask .&. hash + +{-# INLINE depthStep #-} +depthStep :: Int +depthStep = 5 + +{-# NOINLINE mask #-} +mask :: Int +mask = bit depthStep - 1 + +{-# INLINE nextDepth #-} +nextDepth :: Int -> Int +nextDepth = (+ depthStep) diff --git a/stm-hamt.cabal b/stm-hamt.cabal --- a/stm-hamt.cabal +++ b/stm-hamt.cabal @@ -1,5 +1,5 @@ name: stm-hamt -version: 1.1.2 +version: 1.1.2.1 synopsis: STM-specialised Hash Array Mapped Trie description: A low-level data-structure, @@ -26,22 +26,21 @@ StmHamt.Hamt StmHamt.SizedHamt other-modules: - StmHamt.Accessors.Hash + StmHamt.IntOps StmHamt.Constructors.Branch - StmHamt.Constructors.Hash StmHamt.Focuses StmHamt.Prelude StmHamt.Types StmHamt.UnfoldMs StmHamt.ListT build-depends: - base >=4.6 && <5, + base >=4.9 && <5, deferred-folds >=0.6.5 && <0.7, focus >=1 && <1.1, hashable <2, list-t >=1.0.1 && <1.1, primitive >=0.6.4 && <0.7, - primitive-extras >=0.6.6 && <0.7, + primitive-extras >=0.6.7 && <0.7, transformers >=0.5 && <0.6 test-suite test diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -24,13 +24,13 @@ [ testGroup "Hamt" $ let - hamtFromListUsingInsertWithHashInIo :: (Eq key, Eq value, Show (key, value)) => (key -> Int) -> [(key, value)] -> IO (Hamt (key, value)) + hamtFromListUsingInsertWithHashInIo :: (Eq key, Eq value) => (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 :: (Eq key, Hashable key, Eq value, Show (key, value)) => [(key, value)] -> IO (Hamt (key, value)) + hamtFromListUsingInsertInIo :: (Eq key, Hashable key, Eq value) => [(key, value)] -> IO (Hamt (key, value)) hamtFromListUsingInsertInIo list = do hamt <- Hamt.newIO atomically $ forM_ list $ \ pair -> Hamt.insert fst pair hamt @@ -42,27 +42,9 @@ atomically $ UnfoldM.foldlM' (\ state element -> return (element : state)) [] (Hamt.unfoldM hamt) - listToListThruHamtInIo :: [(Char, Int)] -> IO [(Char, Int)] + listToListThruHamtInIo :: (Eq key, Hashable key, Eq value) => [(key, value)] -> IO [(key, value)] listToListThruHamtInIo = hamtFromListUsingInsertInIo >=> hamtToListInIo - 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 - result2 <- atomically $ applyToStmHamt hamt - list <- hamtToListInIo hamt - return (result2, sort list) - in - counterexample - ("hashMapList: " <> show hashMapList <> "\nhamtList: " <> show hamtList <> "\nresult1: " <> show result1 <> "\nresult2: " <> show result2) - (hashMapList == hamtList && result1 == result2) - in [ testCase "insert" $ let @@ -90,18 +72,158 @@ hamtList <- listToListThruHamtInIo list assertEqual (show hamtList) (delete ('b', 1) list) hamtList , - testTransactionProperty "insert" hash Gens.insertTransaction + 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 , - let - newHash key = hash key .&. 0b111 - in testTransactionProperty "Hash collision" newHash (Gens.insertWithHashTransaction newHash) + 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 , - testTransactionProperty "insertUsingFocus" hash Gens.insertUsingFocusTransaction + 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 , - testTransactionProperty "deleteUsingFocus" hash Gens.deleteUsingFocusTransaction + 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 , - testTransactionProperty "incrementUsingAdjustFocus" hash Gens.incrementUsingAdjustFocusTransaction + 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 , - testTransactionProperty "lookup" hash Gens.lookupTransaction + 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 $ UnfoldM.foldlM' (\ state element -> return (element : state)) [] (Hamt.unfoldM 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 + ] ] ]