stm-hamt 1.2.0.9 → 1.2.0.10
raw patch · 14 files changed
+634/−630 lines, 14 filesdep −mwc-randomdep ~list-tdep ~transformersPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies removed: mwc-random
Dependency ranges changed: list-t, transformers
API changes (from Hackage documentation)
- StmHamt.Hamt: focus :: (Eq key, Hashable key) => Focus element STM result -> (element -> key) -> key -> Hamt element -> STM result
+ StmHamt.Hamt: focus :: Hashable key => Focus element STM result -> (element -> key) -> key -> Hamt element -> STM result
- StmHamt.Hamt: insert :: (Eq key, Hashable key) => (element -> key) -> element -> Hamt element -> STM Bool
+ StmHamt.Hamt: insert :: Hashable key => (element -> key) -> element -> Hamt element -> STM Bool
- StmHamt.Hamt: lookup :: (Eq key, Hashable key) => (element -> key) -> key -> Hamt element -> STM (Maybe element)
+ StmHamt.Hamt: lookup :: Hashable key => (element -> key) -> key -> Hamt element -> STM (Maybe element)
- StmHamt.SizedHamt: focus :: (Eq key, Hashable key) => Focus element STM result -> (element -> key) -> key -> SizedHamt element -> STM result
+ StmHamt.SizedHamt: focus :: Hashable key => Focus element STM result -> (element -> key) -> key -> SizedHamt element -> STM result
- StmHamt.SizedHamt: insert :: (Eq key, Hashable key) => (element -> key) -> element -> SizedHamt element -> STM ()
+ StmHamt.SizedHamt: insert :: Hashable key => (element -> key) -> element -> SizedHamt element -> STM ()
- StmHamt.SizedHamt: lookup :: (Eq key, Hashable key) => (element -> key) -> key -> SizedHamt element -> STM (Maybe element)
+ StmHamt.SizedHamt: lookup :: Hashable key => (element -> key) -> key -> SizedHamt element -> STM (Maybe element)
Files
- concurrent-insertion-bench/Main.hs +19/−32
- library/StmHamt/Constructors/Branch.hs +10/−12
- library/StmHamt/Focuses.hs +46/−49
- library/StmHamt/Hamt.hs +81/−105
- library/StmHamt/IntOps.hs +1/−3
- library/StmHamt/ListT.hs +4/−5
- library/StmHamt/Prelude.hs +30/−56
- library/StmHamt/SizedHamt.hs +17/−19
- library/StmHamt/Types.hs +7/−8
- library/StmHamt/UnfoldlM.hs +4/−5
- stm-hamt.cabal +170/−54
- test/Main.hs +184/−217
- test/Main/Gens.hs +8/−13
- test/Main/Transaction.hs +53/−52
concurrent-insertion-bench/Main.hs view
@@ -1,19 +1,16 @@ module Main where -import Rebase.Prelude-import Criterion.Main-import Control.Monad.Free-import Control.Monad.Free.TH-import qualified StmHamt.Hamt as A import qualified Control.Concurrent.Async as B-import qualified System.Random.MWC.Monad as C+import Control.Monad.Free+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 --- * Transactions --------------------------+-- * Transactions data TransactionF row n where Insert :: row -> n -> TransactionF row n@@ -21,11 +18,9 @@ type Transaction row = Free (TransactionF row) - -- * Interpreters-------------------------- -type Interpreter container = +type Interpreter container = forall row. (Hashable row, Eq row) => container row -> forall result. Transaction row result -> STM result specializedInterpreter :: Interpreter A.Hamt@@ -38,14 +33,12 @@ iterM $ \case Insert row continue -> A.focus (D.insert row) id row container >> continue - -- * Session and runners-------------------------- -- | A list of transactions per thread. type Session row = [[Transaction row ()]] -type SessionRunner = +type SessionRunner = forall row. (Hashable row, Eq row) => Session row -> IO () sessionRunner :: Interpreter A.Hamt -> SessionRunner@@ -54,9 +47,7 @@ void $ flip B.mapConcurrently threadTransactions $ \actions -> do forM_ actions $ atomically . interpreter m - -- * Generators-------------------------- type Generator a = C.Rand IO a @@ -76,9 +67,7 @@ char = chr <$> C.uniformR (ord 'a', ord 'z') - -- * Utils-------------------------- slices :: Int -> [a] -> [[a]] slices size l =@@ -86,28 +75,26 @@ ([], _) -> [] (a, b) -> a : slices size b - -- * Main-------------------------- +main :: IO () main = do allTransactions <- C.runWithSeed seed $ replicateM actionsNum transactionGenerator defaultMain $! flip map threadsNums $! \threadsNum ->- let- sliceSize = actionsNum `div` threadsNum- threadTransactions = slices sliceSize allTransactions- in - bgroup+ let sliceSize = actionsNum `div` threadsNum+ threadTransactions = slices sliceSize allTransactions+ in bgroup (shows threadsNum . showString "/" . shows sliceSize $ "")- [- bench "Focus-based" $ nfIO $- sessionRunner focusInterpreter threadTransactions,- bench "Specialized" $ nfIO $- sessionRunner specializedInterpreter threadTransactions+ [ bench "Focus-based" $+ nfIO $+ sessionRunner focusInterpreter threadTransactions,+ bench "Specialized" $+ nfIO $+ sessionRunner specializedInterpreter threadTransactions ] where seed =- C.toSeed (F.fromList [1..7])+ C.toSeed (F.fromList [1 .. 7]) actionsNum = 100000 threadsNums =
library/StmHamt/Constructors/Branch.hs view
@@ -1,23 +1,21 @@ module StmHamt.Constructors.Branch where +import qualified PrimitiveExtras.By6Bits as By6Bits+import qualified StmHamt.IntOps as IntOps import StmHamt.Prelude import StmHamt.Types-import qualified StmHamt.IntOps as IntOps-import qualified PrimitiveExtras.By6Bits as By6Bits - singleton :: Int -> a -> Branch a singleton hash a = LeavesBranch hash (pure a) pair :: Int -> Int -> Branch a -> Int -> Branch a -> STM (Branch 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- deeperBranch <- pair (IntOps.nextDepth depth) hash1 branch1 hash2 branch2- var <- newTVar (By6Bits.singleton index1 deeperBranch)- return (BranchesBranch (Hamt var))- else BranchesBranch . Hamt <$> newTVar (By6Bits.pair index1 branch1 index2 branch2)+ let index1 = IntOps.indexAtDepth depth hash1+ index2 = IntOps.indexAtDepth depth hash2+ in if index1 == index2+ then do+ deeperBranch <- pair (IntOps.nextDepth depth) hash1 branch1 hash2 branch2+ var <- newTVar (By6Bits.singleton index1 deeperBranch)+ return (BranchesBranch (Hamt var))+ else BranchesBranch . Hamt <$> newTVar (By6Bits.pair index1 branch1 index2 branch2)
library/StmHamt/Focuses.hs view
@@ -1,60 +1,57 @@-{-|-Utility focuses.--}+-- |+-- Utility focuses. module StmHamt.Focuses where -import StmHamt.Prelude-import StmHamt.Types import Focus-import qualified StmHamt.IntOps as IntOps-import qualified StmHamt.Constructors.Branch as BranchConstructors import qualified PrimitiveExtras.By6Bits as By6Bits import qualified PrimitiveExtras.SmallArray as SmallArray-+import qualified StmHamt.Constructors.Branch as BranchConstructors+import qualified StmHamt.IntOps as IntOps+import StmHamt.Prelude+import StmHamt.Types 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 testElement (const False) elementFocus- branchesVarFocus :: Int -> Focus (TVar (By6Bits (Branch a))) STM b- branchesVarFocus depth = let- !branchIndex = IntOps.indexAtDepth depth hash- in onTVarValue (By6Bits.onElementAtFocus branchIndex (branchFocus ( depth)))- branchFocus :: Int -> Focus (Branch a) STM b- 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 -> 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+ let ~(Focus concealLeaves revealLeaves) = SmallArray.onFoundElementFocus testElement (const False) elementFocus+ branchesVarFocus :: Int -> Focus (TVar (By6Bits (Branch a))) STM b+ branchesVarFocus depth =+ let !branchIndex = IntOps.indexAtDepth depth hash+ in onTVarValue (By6Bits.onElementAtFocus branchIndex (branchFocus (depth)))+ branchFocus :: Int -> Focus (Branch a) STM b+ 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 ->+ 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 -> Int -> (a -> Bool) -> Focus a STM b -> Focus (Hamt a) STM b onHamtElement depth hash test focus =- let- branchIndex = IntOps.indexAtDepth depth hash- Focus concealBranches revealBranches =- By6Bits.onElementAtFocus branchIndex $- onBranchElement depth hash test focus- concealHamt = let- hamtChangeStm = \ case- Leave -> return Leave- Set !branches -> Set . Hamt <$> newTVar branches- Remove -> Set . Hamt <$> newTVar By6Bits.empty- in concealBranches >>= traverse hamtChangeStm- revealHamt (Hamt branchesVar) = do- branches <- readTVar branchesVar- (result, branchesChange) <- revealBranches branches- case branchesChange of- Leave -> return (result, Leave)- Set !newBranches -> writeTVar branchesVar newBranches $> (result, Leave)- Remove -> writeTVar branchesVar By6Bits.empty $> (result, Leave)- in Focus concealHamt revealHamt+ let branchIndex = IntOps.indexAtDepth depth hash+ Focus concealBranches revealBranches =+ By6Bits.onElementAtFocus branchIndex $+ onBranchElement depth hash test focus+ concealHamt =+ let hamtChangeStm = \case+ Leave -> return Leave+ Set !branches -> Set . Hamt <$> newTVar branches+ Remove -> Set . Hamt <$> newTVar By6Bits.empty+ in concealBranches >>= traverse hamtChangeStm+ revealHamt (Hamt branchesVar) = do+ branches <- readTVar branchesVar+ (result, branchesChange) <- revealBranches branches+ case branchesChange of+ Leave -> return (result, Leave)+ Set !newBranches -> writeTVar branchesVar newBranches $> (result, Leave)+ Remove -> writeTVar branchesVar By6Bits.empty $> (result, Leave)+ in Focus concealHamt revealHamt
library/StmHamt/Hamt.hs view
@@ -1,31 +1,28 @@ module StmHamt.Hamt-(- Hamt,- new,- newIO,- null,- focus,- focusExplicitly,- insert,- insertExplicitly,- lookup,- lookupExplicitly,- reset,- unfoldlM,- listT,-)+ ( Hamt,+ new,+ newIO,+ null,+ focus,+ focusExplicitly,+ insert,+ insertExplicitly,+ lookup,+ lookupExplicitly,+ reset,+ unfoldlM,+ listT,+ ) where -import StmHamt.Prelude hiding (empty, insert, update, lookup, delete, null)-import StmHamt.Types-import qualified Focus as Focus+import qualified PrimitiveExtras.By6Bits as By6Bits+import qualified PrimitiveExtras.SmallArray as SmallArray import qualified StmHamt.Focuses as Focus-import qualified StmHamt.UnfoldlM as UnfoldlM-import qualified StmHamt.ListT as ListT import qualified StmHamt.IntOps as IntOps-import qualified PrimitiveExtras.SmallArray as SmallArray-import qualified PrimitiveExtras.By6Bits as By6Bits-+import qualified StmHamt.ListT as ListT+import StmHamt.Prelude hiding (delete, empty, insert, lookup, null)+import StmHamt.Types+import qualified StmHamt.UnfoldlM as UnfoldlM new :: STM (Hamt a) new = Hamt <$> newTVar By6Bits.empty@@ -33,96 +30,91 @@ newIO :: IO (Hamt a) newIO = Hamt <$> newTVarIO By6Bits.empty -focus :: (Eq key, Hashable key) => Focus element STM result -> (element -> key) -> key -> Hamt element -> STM result+focus :: (Hashable key) => Focus element STM result -> (element -> key) -> key -> Hamt element -> STM result focus focus elementToKey key = focusExplicitly focus (hash key) ((==) key . elementToKey) focusExplicitly :: Focus a STM b -> Int -> (a -> Bool) -> Hamt a -> STM b focusExplicitly focus hash test hamt =- {-# SCC "focus" #-} - let- Focus _ reveal = Focus.onHamtElement 0 hash test focus- in fmap fst (reveal hamt)+ {-# SCC "focus" #-}+ let Focus _ reveal = Focus.onHamtElement 0 hash test focus+ in fmap fst (reveal hamt) -{-|-Returns a flag, specifying, whether the size has been affected.--}-insert :: (Eq key, Hashable key) => (element -> key) -> element -> Hamt element -> STM Bool-insert elementToKey element = let- !key = elementToKey element- in insertExplicitly (hash key) ((==) key . elementToKey) element+-- |+-- Returns a flag, specifying, whether the size has been affected.+insert :: (Hashable key) => (element -> key) -> element -> Hamt element -> STM Bool+insert elementToKey element =+ let !key = elementToKey element+ in insertExplicitly (hash key) ((==) key . elementToKey) element -{-|-Returns a flag, specifying, whether the size has been affected.--}+-- |+-- Returns a flag, specifying, whether the size has been affected. insertExplicitly :: Int -> (a -> Bool) -> a -> Hamt a -> STM Bool insertExplicitly hash testKey element = {-# SCC "insertExplicitly" #-}- let- loop depth (Hamt var) = let- !branchIndex = IntOps.indexAtDepth depth hash- in do- branchArray <- readTVar var- case By6Bits.lookup branchIndex branchArray of- Nothing -> do- writeTVar var $! By6Bits.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 = By6Bits.replace branchIndex newBranch branchArray- in do- writeTVar var newBranchArray- return False- Nothing -> let- newLeavesArray = SmallArray.cons element leavesArray- in do- writeTVar var $! By6Bits.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 $! By6Bits.replace branchIndex (BranchesBranch hamt) branchArray- return True- BranchesBranch hamt -> loop (IntOps.nextDepth depth) hamt- in loop 0+ let loop depth (Hamt var) =+ let !branchIndex = IntOps.indexAtDepth depth hash+ in do+ branchArray <- readTVar var+ case By6Bits.lookup branchIndex branchArray of+ Nothing -> do+ writeTVar var $! By6Bits.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 = By6Bits.replace branchIndex newBranch branchArray+ in do+ writeTVar var newBranchArray+ return False+ Nothing ->+ let newLeavesArray = SmallArray.cons element leavesArray+ in do+ writeTVar var $! By6Bits.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 $! By6Bits.replace branchIndex (BranchesBranch hamt) branchArray+ return True+ 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+ 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 (By6Bits.singleton index1 (BranchesBranch deeperHamt)) return (Hamt var) else Hamt <$> newTVar (By6Bits.pair index1 branch1 index2 branch2) -{-|-Returns a flag, specifying, whether the size has been affected.--}-lookup :: (Eq key, Hashable key) => (element -> key) -> key -> Hamt element -> STM (Maybe element)+-- |+-- Returns a flag, specifying, whether the size has been affected.+lookup :: (Hashable key) => (element -> key) -> key -> Hamt element -> STM (Maybe element) lookup elementToKey key = lookupExplicitly (hash key) ((==) key . elementToKey) lookupExplicitly :: Int -> (a -> Bool) -> Hamt a -> STM (Maybe a) lookupExplicitly hash test = {-# SCC "lookupExplicitly" #-}- let- loop depth (Hamt var) = let- !index = IntOps.indexAtDepth depth hash- in do- branchArray <- readTVar var- case By6Bits.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+ let loop depth (Hamt var) =+ let !index = IntOps.indexAtDepth depth hash+ in do+ branchArray <- readTVar var+ case By6Bits.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 By6Bits.empty@@ -137,19 +129,3 @@ null (Hamt branchSsaVar) = do branchSsa <- readTVar branchSsaVar return (By6Bits.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) (By6Bits.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
@@ -1,8 +1,6 @@ module StmHamt.IntOps where -import StmHamt.Prelude hiding (mask, index)-import StmHamt.Types-+import StmHamt.Prelude hiding (index, mask) {-# INLINE atDepth #-} atDepth :: Int -> Int -> Int
library/StmHamt/ListT.hs view
@@ -1,17 +1,16 @@ module StmHamt.ListT where -import StmHamt.Prelude hiding (filter, all)-import StmHamt.Types import ListT-import qualified PrimitiveExtras.SmallArray as SmallArray import qualified PrimitiveExtras.By6Bits as By6Bits-+import qualified PrimitiveExtras.SmallArray as SmallArray+import StmHamt.Prelude hiding (all, filter)+import StmHamt.Types hamtElements :: Hamt a -> ListT STM a hamtElements (Hamt var) = tVarValue var >>= By6Bits.elementsListT >>= branchElements branchElements :: Branch a -> ListT STM a-branchElements = \ case+branchElements = \case LeavesBranch _ array -> SmallArray.elementsListT array BranchesBranch hamt -> hamtElements hamt
library/StmHamt/Prelude.hs view
@@ -1,24 +1,22 @@ module StmHamt.Prelude-( - module Exports,- traversePair,- modifyTVar',- forMInAscendingRange_,- forMInDescendingRange_,-)+ ( module Exports,+ traversePair,+ modifyTVar',+ forMInAscendingRange_,+ forMInDescendingRange_,+ ) where --- base-------------------------- import Control.Applicative as Exports import Control.Arrow as Exports import Control.Category as Exports import Control.Concurrent as Exports import Control.Exception as Exports-import Control.Monad as Exports hiding (mapM_, sequence_, forM_, msum, mapM, sequence, forM)-import Control.Monad.IO.Class as Exports+import Control.Monad as Exports hiding (forM, forM_, mapM, mapM_, msum, sequence, sequence_) import Control.Monad.Fix as Exports hiding (fix)+import Control.Monad.IO.Class as Exports import Control.Monad.ST as Exports+import Control.Monad.Trans.Class as Exports import Data.Bits as Exports import Data.Bool as Exports import Data.Char as Exports@@ -31,13 +29,15 @@ import Data.Foldable as Exports import Data.Function as Exports hiding (id, (.)) import Data.Functor as Exports-import Data.Int as Exports+import Data.Hashable as Exports (Hashable (..)) import Data.IORef as Exports+import Data.Int as Exports import Data.Ix as Exports-import Data.List as Exports hiding (sortOn, isSubsequenceOf, uncons, concat, foldr, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, find, maximumBy, minimumBy, mapAccumL, mapAccumR, foldl')+import Data.List as Exports hiding (all, and, any, concat, concatMap, elem, find, foldl, foldl', foldl1, foldr, foldr1, isSubsequenceOf, mapAccumL, mapAccumR, maximum, maximumBy, minimum, minimumBy, notElem, or, product, sortOn, sum, uncons) import Data.Maybe as Exports-import Data.Monoid as Exports hiding (Last(..), First(..))+import Data.Monoid as Exports hiding (First (..), Last (..)) import Data.Ord as Exports+import Data.Primitive as Exports import Data.Proxy as Exports import Data.Ratio as Exports import Data.STRef as Exports@@ -48,16 +48,20 @@ import Data.Version as Exports import Data.Word as Exports import Debug.Trace as Exports+import DeferredFolds.Unfoldl as Exports (Unfoldl (..))+import DeferredFolds.UnfoldlM as Exports (UnfoldlM (..))+import Focus as Exports (Focus (..)) import Foreign.ForeignPtr as Exports import Foreign.Ptr as Exports import Foreign.StablePtr as Exports-import Foreign.Storable as Exports hiding (sizeOf, alignment)-import GHC.Conc as Exports hiding (withMVar, threadWaitWriteSTM, threadWaitWrite, threadWaitReadSTM, threadWaitRead)-import GHC.Exts as Exports (lazy, inline, sortWith, groupWith)+import Foreign.Storable as Exports hiding (alignment, sizeOf)+import GHC.Conc as Exports hiding (threadWaitRead, threadWaitReadSTM, threadWaitWrite, threadWaitWriteSTM, withMVar)+import GHC.Exts as Exports (groupWith, inline, lazy, sortWith) import GHC.Generics as Exports (Generic) import GHC.IO.Exception as Exports+import ListT as Exports (ListT (..)) import Numeric as Exports-import Prelude as Exports hiding (concat, foldr, mapM_, sequence_, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, mapM, sequence, id, (.))+import PrimitiveExtras.By6Bits as Exports (By6Bits) import System.Environment as Exports import System.Exit as Exports import System.IO as Exports@@ -66,59 +70,29 @@ import System.Mem as Exports import System.Mem.StableName as Exports import System.Timeout as Exports-import Text.ParserCombinators.ReadP as Exports (ReadP, ReadS, readP_to_S, readS_to_P)-import Text.ParserCombinators.ReadPrec as Exports (ReadPrec, readPrec_to_P, readP_to_Prec, readPrec_to_S, readS_to_Prec)-import Text.Printf as Exports (printf, hPrintf)-import Text.Read as Exports (Read(..), readMaybe, readEither)+import Text.Printf as Exports (hPrintf, printf)+import Text.Read as Exports (Read (..), readEither, readMaybe) import Unsafe.Coerce as Exports---- transformers---------------------------import Control.Monad.Trans.Class as Exports---- hashable---------------------------import Data.Hashable as Exports (Hashable(..))---- focus---------------------------import Focus as Exports (Focus(..))---- primitive---------------------------import Data.Primitive as Exports---- primitive-extras---------------------------import PrimitiveExtras.By6Bits as Exports (By6Bits)---- deferred-folds---------------------------import DeferredFolds.Unfoldl as Exports (Unfoldl(..))-import DeferredFolds.UnfoldlM as Exports (UnfoldlM(..))---- list-t---------------------------import ListT as Exports (ListT(..))+import Prelude as Exports hiding (all, and, any, concat, concatMap, elem, foldl, foldl1, foldr, foldr1, id, mapM, mapM_, maximum, minimum, notElem, or, product, sequence, sequence_, sum, (.)) -- | A replacement for the missing 'Traverse' instance of pair in base < 4.7. {-# INLINE traversePair #-}-traversePair :: Functor f => (a -> f b) -> (c, a) -> f (c, b)+traversePair :: (Functor f) => (a -> f b) -> (c, a) -> f (c, b) traversePair f (x, y) = (,) x <$> f y -- | Strict version of 'modifyTVar'. {-# INLINE modifyTVar' #-} modifyTVar' :: TVar a -> (a -> a) -> STM () modifyTVar' var f = do- x <- readTVar var- writeTVar var $! f x+ x <- readTVar var+ writeTVar var $! f x {-# INLINE forMInAscendingRange_ #-}-forMInAscendingRange_ :: Applicative m => Int -> Int -> (Int -> m a) -> m ()+forMInAscendingRange_ :: (Applicative m) => Int -> Int -> (Int -> m a) -> m () forMInAscendingRange_ !startN !endN f = ($ startN) $ fix $ \loop !n -> if n < endN then f n *> loop (succ n) else pure () {-# INLINE forMInDescendingRange_ #-}-forMInDescendingRange_ :: Applicative m => Int -> Int -> (Int -> m a) -> m ()+forMInDescendingRange_ :: (Applicative m) => Int -> Int -> (Int -> m a) -> m () forMInDescendingRange_ !startN !endN f = ($ pred startN) $ fix $ \loop !n -> if n >= endN then f n *> loop (pred n) else pure ()
library/StmHamt/SizedHamt.hs view
@@ -3,26 +3,24 @@ -- optimized for a fast 'size' operation. -- That however comes at the cost of a small overhead in the other operations. module StmHamt.SizedHamt-(- SizedHamt,- new,- newIO,- null,- size,- focus,- insert,- lookup,- reset,- unfoldlM,- listT,-)+ ( SizedHamt,+ new,+ newIO,+ null,+ size,+ focus,+ insert,+ lookup,+ reset,+ unfoldlM,+ listT,+ ) where -import StmHamt.Prelude hiding (insert, lookup, delete, fold, null)-import StmHamt.Types import qualified Focus as Focus import qualified StmHamt.Hamt as Hamt-+import StmHamt.Prelude hiding (delete, fold, insert, lookup, null)+import StmHamt.Types {-# INLINE new #-} new :: STM (SizedHamt element)@@ -52,7 +50,7 @@ writeTVar sizeVar 0 {-# INLINE focus #-}-focus :: (Eq key, Hashable key) => Focus element STM result -> (element -> key) -> key -> SizedHamt element -> STM result+focus :: (Hashable key) => Focus element STM result -> (element -> key) -> key -> SizedHamt element -> STM result focus focus elementToKey key (SizedHamt sizeVar hamt) = do (result, sizeModifier) <- Hamt.focus newFocus elementToKey key hamt@@ -62,14 +60,14 @@ newFocus = Focus.testingSizeChange (Just pred) Nothing (Just succ) focus {-# INLINE insert #-}-insert :: (Eq key, Hashable key) => (element -> key) -> element -> SizedHamt element -> STM ()+insert :: (Hashable key) => (element -> key) -> element -> SizedHamt element -> STM () insert elementToKey element (SizedHamt sizeVar hamt) = do inserted <- Hamt.insert elementToKey element hamt when inserted (modifyTVar' sizeVar succ) {-# INLINE lookup #-}-lookup :: (Eq key, Hashable key) => (element -> key) -> key -> SizedHamt element -> STM (Maybe element)+lookup :: (Hashable key) => (element -> key) -> key -> SizedHamt element -> STM (Maybe element) lookup elementToKey key (SizedHamt _ hamt) = Hamt.lookup elementToKey key hamt {-# INLINE unfoldlM #-}
library/StmHamt/Types.hs view
@@ -1,18 +1,17 @@ {-# OPTIONS_GHC -funbox-strict-fields #-}+ module StmHamt.Types where import StmHamt.Prelude -{-|-STM-specialized Hash Array Mapped Trie,-extended with its size-tracking functionality,-allowing for a fast 'size' operation.--}+-- |+-- STM-specialized Hash Array Mapped Trie,+-- extended with its size-tracking functionality,+-- allowing for a fast 'size' operation. data SizedHamt element = SizedHamt !(TVar Int) !(Hamt element) -{-|-STM-specialized Hash Array Mapped Trie.--}+-- |+-- STM-specialized Hash Array Mapped Trie. newtype Hamt element = Hamt (TVar (By6Bits (Branch element))) data Branch element = BranchesBranch !(Hamt element) | LeavesBranch !Int !(SmallArray element)
library/StmHamt/UnfoldlM.hs view
@@ -1,16 +1,15 @@ module StmHamt.UnfoldlM where -import StmHamt.Prelude hiding (filter, all)-import StmHamt.Types import DeferredFolds.UnfoldlM-import qualified PrimitiveExtras.SmallArray as SmallArray import qualified PrimitiveExtras.By6Bits as By6Bits-+import qualified PrimitiveExtras.SmallArray as SmallArray+import StmHamt.Prelude hiding (all, filter)+import StmHamt.Types hamtElements :: Hamt a -> UnfoldlM STM a hamtElements (Hamt var) = tVarValue var >>= By6Bits.elementsUnfoldlM >>= branchElements branchElements :: Branch a -> UnfoldlM STM a-branchElements = \ case+branchElements = \case LeavesBranch _ array -> SmallArray.elementsUnfoldlM array BranchesBranch hamt -> hamtElements hamt
stm-hamt.cabal view
@@ -1,82 +1,198 @@-name: stm-hamt-version: 1.2.0.9-synopsis: STM-specialised Hash Array Mapped Trie+name: stm-hamt+version: 1.2.0.10+synopsis: STM-specialised Hash Array Mapped Trie description: A low-level data-structure, which can be used to implement higher-level interfaces like hash-map and hash-set. Such implementations are presented by <http://hackage.haskell.org/package/stm-containers the "stm-containers" library>.-category: Data Structures, STM, Concurrency-homepage: https://github.com/nikita-volkov/stm-hamt-bug-reports: https://github.com/nikita-volkov/stm-hamt/issues-author: Nikita Volkov <nikita.y.volkov@mail.ru>-maintainer: Nikita Volkov <nikita.y.volkov@mail.ru>-copyright: (c) 2016, Nikita Volkov-license: MIT-license-file: LICENSE-build-type: Simple++category: Data Structures, STM, Concurrency+homepage: https://github.com/nikita-volkov/stm-hamt+bug-reports: https://github.com/nikita-volkov/stm-hamt/issues+author: Nikita Volkov <nikita.y.volkov@mail.ru>+maintainer: Nikita Volkov <nikita.y.volkov@mail.ru>+copyright: (c) 2016, Nikita Volkov+license: MIT+license-file: LICENSE+build-type: Simple cabal-version: >=1.10 library- hs-source-dirs: library- default-extensions: Arrows, BangPatterns, BinaryLiterals, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples- default-language: Haskell2010+ hs-source-dirs: library+ 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 exposed-modules: StmHamt.Hamt StmHamt.SizedHamt+ other-modules:- StmHamt.IntOps StmHamt.Constructors.Branch StmHamt.Focuses+ StmHamt.IntOps+ StmHamt.ListT StmHamt.Prelude StmHamt.Types StmHamt.UnfoldlM- StmHamt.ListT+ build-depends:- base >=4.9 && <5,- deferred-folds >=0.9 && <0.10,- focus >=1 && <1.1,- hashable <2,- list-t >=1.0.1 && <1.1,- primitive >=0.7 && <0.9,- primitive-extras >=0.10 && <0.11,- transformers >=0.5 && <0.6+ base >=4.9 && <5+ , deferred-folds >=0.9 && <0.10+ , focus >=1 && <1.1+ , hashable <2+ , list-t >=1.0.1 && <1.1+ , primitive >=0.7 && <0.9+ , primitive-extras >=0.10 && <0.11+ , transformers >=0.5 && <0.7 test-suite test- type: exitcode-stdio-1.0- hs-source-dirs: test- default-extensions: Arrows, BangPatterns, BinaryLiterals, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples- default-language: Haskell2010- main-is: Main.hs+ 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 other-modules: Main.Gens Main.Transaction+ build-depends:- deferred-folds,- focus,- QuickCheck >=2.8.1 && <3,- quickcheck-instances >=0.3.11 && <0.4,- rerebase <2,- stm-hamt,- tasty >=0.12 && <2,- tasty-hunit >=0.9 && <0.11,- tasty-quickcheck >=0.9 && <0.11+ deferred-folds+ , focus+ , QuickCheck >=2.8.1 && <3+ , quickcheck-instances >=0.3.11 && <0.4+ , rerebase <2+ , stm-hamt+ , tasty >=0.12 && <2+ , tasty-hunit >=0.9 && <0.11+ , tasty-quickcheck >=0.9 && <0.11 benchmark concurrent-insertion-bench- type: exitcode-stdio-1.0- hs-source-dirs: concurrent-insertion-bench- default-extensions: Arrows, BangPatterns, BinaryLiterals, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples- default-language: Haskell2010- ghc-options: -O2 -threaded "-with-rtsopts=-N"- main-is: Main.hs+ 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 build-depends:- async >=2.0 && <3,- criterion >=1.5 && <1.7,- focus,- free >=4.5 && <6,- list-t,- mwc-random >=0.13 && <0.16,- mwc-random-monad ==0.7.*,- rebase <2,- stm-hamt+ async >=2.0 && <3+ , criterion >=1.5 && <1.7+ , focus+ , free >=4.5 && <6+ , mwc-random-monad >=0.7 && <0.8+ , rebase <2+ , stm-hamt
test/Main.hs view
@@ -1,229 +1,196 @@ module Main where -import Prelude-import Test.Tasty-import Test.Tasty.Runners-import Test.Tasty.HUnit-import Test.Tasty.QuickCheck hiding ((.&.))-import Test.QuickCheck.Instances-import Test.QuickCheck hiding ((.&.))-import Test.QuickCheck.Property hiding (testCase, (.&.))-import StmHamt.Hamt (Hamt)+import qualified Data.HashMap.Strict as HashMap+import qualified DeferredFolds.UnfoldlM as UnfoldlM+import qualified Focus+import qualified Main.Gens as Gens import Main.Transaction (Transaction) import qualified Main.Transaction as Transaction-import qualified Main.Gens as Gens+import StmHamt.Hamt (Hamt) import qualified StmHamt.Hamt as Hamt-import qualified Data.HashMap.Strict as HashMap-import qualified Focus-import qualified DeferredFolds.UnfoldlM as UnfoldlM-+import Test.QuickCheck hiding ((.&.))+import Test.QuickCheck.Instances ()+import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck hiding ((.&.))+import Prelude +main :: IO () main = defaultMain $- testGroup "All" $- [- testGroup "Hamt" $ let-- 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) => [(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)+ 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 - listToListThruHamtInIo :: (Eq key, Hashable key, Eq value) => [(key, value)] -> IO [(key, value)]- listToListThruHamtInIo = hamtFromListUsingInsertInIo >=> hamtToListInIo+ 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 - 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+ hamtToListInIo :: Hamt a -> IO [a]+ hamtToListInIo hamt =+ fmap reverse $+ atomically $+ UnfoldlM.foldlM' (\state element -> return (element : state)) [] (Hamt.unfoldlM hamt) - 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+ ] ]- ]- ]+ ]
test/Main/Gens.hs view
@@ -1,14 +1,11 @@ module Main.Gens where -import Prelude hiding (choose)-import Test.QuickCheck.Gen-import StmHamt.Hamt (Hamt)-import Focus (Focus(..)) import Main.Transaction (Transaction)-import qualified StmHamt.Hamt as StmHamt-import qualified Data.HashMap.Strict as HashMap import qualified Main.Transaction as Transaction-+import StmHamt.Hamt (Hamt)+import qualified StmHamt.Hamt as StmHamt+import Test.QuickCheck.Gen+import Prelude hiding (choose) key :: Gen Text key = do@@ -29,9 +26,8 @@ insertWithHashTransaction hash = do keyValue <- key valueValue <- value- let- !hashValue = hash keyValue- in return (Transaction.insertWithHash hashValue keyValue valueValue)+ let !hashValue = hash keyValue+ in return (Transaction.insertWithHash hashValue keyValue valueValue) insertUsingFocusTransaction :: Gen Transaction insertUsingFocusTransaction = Transaction.insertUsingFocus <$> key <*> value@@ -48,8 +44,7 @@ transaction :: Gen Transaction transaction = frequency- [- (9, lookupTransaction),+ [ (9, lookupTransaction), (2, insertTransaction), (2, insertUsingFocusTransaction), (9, deleteUsingFocusTransaction),@@ -61,7 +56,7 @@ list <- keyValueList return $ do hamt <- StmHamt.new- forM_ list $ \ pair -> StmHamt.insert fst pair hamt+ forM_ list $ \pair -> StmHamt.insert fst pair hamt return hamt keyValueList :: Gen [(Text, Int)]
test/Main/Transaction.hs view
@@ -1,73 +1,74 @@ module Main.Transaction where -import Prelude-import StmHamt.Hamt (Hamt)-import Focus (Focus(..))-import qualified StmHamt.Hamt as StmHamt import qualified Data.HashMap.Strict as HashMap-import qualified Focus import qualified Data.Text as Text-+import Focus (Focus (..))+import qualified Focus+import StmHamt.Hamt (Hamt)+import qualified StmHamt.Hamt as StmHamt+import Prelude -data Transaction = forall result. (Show result, Eq result) => Transaction {- name :: Text,- applyToHashMap :: HashMap Text Int -> (result, HashMap Text Int),- applyToStmHamt :: Hamt (Text, Int) -> STM result-}+data Transaction = forall result.+ (Show result, Eq result) =>+ Transaction+ { name :: Text,+ applyToHashMap :: HashMap Text Int -> (result, HashMap Text Int),+ applyToStmHamt :: Hamt (Text, Int) -> STM result+ } instance Show Transaction where show = Text.unpack . name lookup :: Text -> Transaction-lookup key = let- name = fromString ("lookup " <> show key)- applyToHashMap hashMap = (HashMap.lookup key hashMap, hashMap)- applyToStmHamt hamt = (fmap . fmap) snd (StmHamt.lookup fst key hamt)- in Transaction name applyToHashMap applyToStmHamt+lookup key =+ let name = fromString ("lookup " <> show key)+ applyToHashMap hashMap = (HashMap.lookup key hashMap, hashMap)+ applyToStmHamt hamt = (fmap . fmap) snd (StmHamt.lookup fst key hamt)+ in Transaction name applyToHashMap applyToStmHamt insert :: Text -> Int -> Transaction-insert key value = let- name = fromString ("insert " <> show key <> " " <> show value)- applyToHashMap = ((),) . HashMap.insert key value- applyToStmHamt hamt = StmHamt.insert fst (key, value) hamt $> ()- in Transaction name applyToHashMap applyToStmHamt+insert key value =+ let name = fromString ("insert " <> show key <> " " <> show value)+ applyToHashMap = ((),) . HashMap.insert key value+ applyToStmHamt hamt = StmHamt.insert fst (key, value) hamt $> ()+ in Transaction name applyToHashMap applyToStmHamt -{-| A transaction which can be used to manipulate hash collision -}+-- | A transaction which can be used to manipulate hash collision insertWithHash :: Int -> Text -> Int -> Transaction-insertWithHash hash key value = let- name = fromString ("insert " <> show key <> " " <> show value)- applyToHashMap = ((),) . HashMap.insert key value- applyToStmHamt hamt = StmHamt.insertExplicitly hash ((==) key . fst) (key, value) hamt $> ()- in Transaction name applyToHashMap applyToStmHamt+insertWithHash hash key value =+ let name = fromString ("insert " <> show key <> " " <> show value)+ applyToHashMap = ((),) . HashMap.insert key value+ applyToStmHamt hamt = StmHamt.insertExplicitly hash ((==) key . fst) (key, value) hamt $> ()+ in Transaction name applyToHashMap applyToStmHamt -focus :: (forall m. Monad m => Focus Int m ()) -> Text -> Transaction-focus focus@(Focus conceal reveal) key = let- name = "focus"- applyToHashMap hashMap = let- Identity (result, change) = case HashMap.lookup key hashMap of- Just existingValue -> reveal existingValue- Nothing -> conceal- newHashMap = case change of- Focus.Leave -> hashMap- Focus.Set newValue -> HashMap.insert key newValue hashMap- Focus.Remove -> HashMap.delete key hashMap- in (result, newHashMap)- applyToStmHamt = let- stmHamtFocus = Focus.mappingInput (key,) snd focus- in StmHamt.focus stmHamtFocus fst key- in Transaction name applyToHashMap applyToStmHamt+focus :: (forall m. (Monad m) => Focus Int m ()) -> Text -> Transaction+focus focus@(Focus conceal reveal) key =+ let name = "focus"+ applyToHashMap hashMap =+ let Identity (result, change) = case HashMap.lookup key hashMap of+ Just existingValue -> reveal existingValue+ Nothing -> conceal+ newHashMap = case change of+ Focus.Leave -> hashMap+ Focus.Set newValue -> HashMap.insert key newValue hashMap+ Focus.Remove -> HashMap.delete key hashMap+ in (result, newHashMap)+ applyToStmHamt =+ let stmHamtFocus = Focus.mappingInput (key,) snd focus+ in StmHamt.focus stmHamtFocus fst key+ in Transaction name applyToHashMap applyToStmHamt insertUsingFocus :: Text -> Int -> Transaction-insertUsingFocus key value = let- name = fromString ("insertUsingFocus " <> show key <> " " <> show value)- in (focus (Focus.insert value) key) { name = name }+insertUsingFocus key value =+ let name = fromString ("insertUsingFocus " <> show key <> " " <> show value)+ in (focus (Focus.insert value) key) {name = name} deleteUsingFocus :: Text -> Transaction-deleteUsingFocus key = let- name = fromString ("deleteUsingFocus " <> show key)- in (focus Focus.delete key) { name = name }+deleteUsingFocus key =+ let name = fromString ("deleteUsingFocus " <> show key)+ in (focus Focus.delete key) {name = name} incrementUsingAdjustFocus :: Text -> Transaction-incrementUsingAdjustFocus key = let- name = fromString ("incrementUsingAdjustFocus " <> show key)- in (focus (Focus.adjust succ) key) { name = name }+incrementUsingAdjustFocus key =+ let name = fromString ("incrementUsingAdjustFocus " <> show key)+ in (focus (Focus.adjust succ) key) {name = name}