stm-hamt 1.1.2 → 1.1.2.1
raw patch · 8 files changed
+288/−143 lines, 8 filesdep ~basedep ~primitive-extrasPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: base, primitive-extras
API changes (from Hackage documentation)
Files
- library/StmHamt/Accessors/Hash.hs +0/−17
- library/StmHamt/Constructors/Branch.hs +9/−7
- library/StmHamt/Constructors/Hash.hs +0/−10
- library/StmHamt/Focuses.hs +27/−27
- library/StmHamt/Hamt.hs +68/−48
- library/StmHamt/IntOps.hs +29/−0
- stm-hamt.cabal +4/−5
- test/Main.hs +151/−29
− library/StmHamt/Accessors/Hash.hs
@@ -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
library/StmHamt/Constructors/Branch.hs view
@@ -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)
− library/StmHamt/Constructors/Hash.hs
@@ -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
library/StmHamt/Focuses.hs view
@@ -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
library/StmHamt/Hamt.hs view
@@ -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)))))
+ library/StmHamt/IntOps.hs view
@@ -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)
stm-hamt.cabal view
@@ -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
test/Main.hs view
@@ -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+ ] ] ]