packages feed

stm-hamt (empty) → 1

raw patch · 16 files changed

+962/−0 lines, 16 filesdep +QuickCheckdep +asyncdep +basesetup-changed

Dependencies added: QuickCheck, async, base, criterion, deferred-folds, focus, free, hashable, list-t, mwc-random, mwc-random-monad, primitive, primitive-extras, quickcheck-instances, rebase, rerebase, stm-hamt, tasty, tasty-hunit, tasty-quickcheck

Files

+ LICENSE view
@@ -0,0 +1,22 @@+Copyright (c) 2016, Nikita Volkov++Permission is hereby granted, free of charge, to any person+obtaining a copy of this software and associated documentation+files (the "Software"), to deal in the Software without+restriction, including without limitation the rights to use,+copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the+Software is furnished to do so, subject to the following+conditions:++The above copyright notice and this permission notice shall be+included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES+OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT+HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,+WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING+FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR+OTHER DEALINGS IN THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ concurrent-insertion-bench/Main.hs view
@@ -0,0 +1,114 @@+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 qualified Focus as D+import qualified Rebase.Data.Text as E+import qualified Rebase.Data.Vector as F+++-- * Transactions +-------------------------++data TransactionF row n where+  Insert :: row -> n -> TransactionF row n+  deriving (Functor)++type Transaction row = Free (TransactionF row)+++-- * Interpreters+-------------------------++type Interpreter container = +  forall row. (Hashable row, Eq row) => container row -> forall result. Transaction row result -> STM result++specializedInterpreter :: Interpreter A.Hamt+specializedInterpreter container =+  iterM $ \case+    Insert row continue -> A.insert id row container >> continue++focusInterpreter :: Interpreter A.Hamt+focusInterpreter container =+  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 = +  forall row. (Hashable row, Eq row) => Session row -> IO ()++sessionRunner :: Interpreter A.Hamt -> SessionRunner+sessionRunner interpreter threadTransactions = do+  m <- atomically $ A.new+  void $ flip B.mapConcurrently threadTransactions $ \actions -> do+    forM_ actions $ atomically . interpreter m+++-- * Generators+-------------------------++type Generator a = C.Rand IO a++transactionGenerator :: Generator (Transaction Text ())+transactionGenerator = do+  text <- textGenerator+  return $ Free $ Insert text (Pure ())++textGenerator :: Generator Text+textGenerator = do+  l <- length+  s <- replicateM l char+  return $! E.pack s+  where+    length =+      C.uniformR (7, 20)+    char =+      chr <$> C.uniformR (ord 'a', ord 'z')+++-- * Utils+-------------------------++slices :: Int -> [a] -> [[a]]+slices size l =+  case splitAt size l of+    ([], _) -> []+    (a, b) -> a : slices size b+++-- * Main+-------------------------++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+          (shows threadsNum . showString "/" . shows sliceSize $ "")+          [+            bench "Focus-based" $ nfIO $+              sessionRunner focusInterpreter threadTransactions,+            bench "Specialized" $ nfIO $+              sessionRunner specializedInterpreter threadTransactions+          ]+  where+    seed =+      C.toSeed (F.fromList [1..7])+    actionsNum =+      100000+    threadsNums =+      [1, 2, 4, 6, 8, 12, 16, 32, 40, 52, 64, 80, 128]
+ library/StmHamt/Accessors/Hash.hs view
@@ -0,0 +1,17 @@+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
@@ -0,0 +1,21 @@+module StmHamt.Constructors.Branch where++import StmHamt.Prelude+import StmHamt.Types+import qualified StmHamt.Accessors.Hash as HashAccessors+import qualified StmHamt.Constructors.Hash as HashConstructors+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 =+  {-# 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 BranchesBranch . Hamt <$> newTVar (SparseSmallArray.pair index1 branch1 index2 branch2)
+ library/StmHamt/Constructors/Hash.hs view
@@ -0,0 +1,10 @@+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
@@ -0,0 +1,60 @@+{-|+Utility focuses.+-}+module StmHamt.Focuses where++import StmHamt.Prelude+import StmHamt.Types+import Focus+import qualified StmHamt.Accessors.Hash as HashAccessors+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) =+  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))+    branchFocus :: Int -> Focus (Branch a) STM b+    branchFocus hash = Focus concealBranch revealBranch where+      Focus concealBranchesVar revealBranchesVar = branchesFocus (HashConstructors.succLevel hash)+      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++onHamtElement :: Int -> (a -> Bool) -> Focus a STM b -> Focus (Hamt a) STM b+onHamtElement hash test focus =+  let+    !branchIndex = HashAccessors.index hash+    Focus concealBranches revealBranches =+      SparseSmallArray.onElementAtFocus branchIndex $+      onBranchElement hash test focus+    concealHamt = concealBranches >>= traverse hamtChangeStm where+      hamtChangeStm = \ case+        Leave -> return Leave+        Set !branches -> Set . Hamt <$> newTVar branches+        Remove -> Set . Hamt <$> newTVar SparseSmallArray.empty+    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 SparseSmallArray.empty $> (result, Leave)+    in Focus concealHamt revealHamt
+ library/StmHamt/Hamt.hs view
@@ -0,0 +1,125 @@+module StmHamt.Hamt+(+  Hamt,+  new,+  newIO,+  null,+  focus,+  focusExplicitly,+  insert,+  insertExplicitly,+  lookup,+  lookupExplicitly,+  reset,+  unfoldM,+)+where++import StmHamt.Prelude hiding (empty, insert, update, lookup, delete)+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.UnfoldMs as UnfoldMs+import qualified PrimitiveExtras.SmallArray as SmallArray+import qualified PrimitiveExtras.SparseSmallArray as SparseSmallArray+++new :: STM (Hamt a)+new = Hamt <$> newTVar SparseSmallArray.empty++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)++focusExplicitly :: Focus a STM b -> Int -> (a -> Bool) -> Hamt a -> STM b+focusExplicitly focus hash test hamt =+  {-# SCC "focus" #-} +  let+    Focus conceal reveal = Focuses.onHamtElement 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.+-}+insertExplicitly :: Int -> (a -> Bool) -> a -> Hamt a -> STM Bool+insertExplicitly hash testKey element (Hamt var) =+  {-# 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+                  !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)+                writeTVar var $! SparseSmallArray.replace branchIndex (BranchesBranch hamt) branchArray+                return True+          BranchesBranch hamt -> insertExplicitly (HashConstructors.succLevel hash) testKey element hamt++{-|+Returns a flag, specifying, whether the size has been affected.+-}+lookup :: (Eq key, 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 (Hamt var) =+  {-# 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++reset :: Hamt a -> STM ()+reset (Hamt branchSsaVar) = writeTVar branchSsaVar SparseSmallArray.empty++unfoldM :: Hamt a -> UnfoldM STM a+unfoldM = UnfoldMs.hamtElements
+ library/StmHamt/Prelude.hs view
@@ -0,0 +1,116 @@+module StmHamt.Prelude+( +  module Exports,+  traversePair,+  modifyTVar',+  forMInPositiveRange_,+  forMInNegativeRange_,+)+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.Fix as Exports hiding (fix)+import Control.Monad.ST as Exports+import Data.Bits as Exports+import Data.Bool as Exports+import Data.Char as Exports+import Data.Coerce as Exports+import Data.Complex as Exports+import Data.Data as Exports+import Data.Dynamic as Exports+import Data.Either as Exports+import Data.Fixed as Exports+import Data.Foldable as Exports+import Data.Function as Exports hiding (id, (.))+import Data.Functor as Exports+import Data.Int as Exports+import Data.IORef 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.Maybe as Exports+import Data.Monoid as Exports hiding (Last(..), First(..))+import Data.Ord as Exports+import Data.Proxy as Exports+import Data.Ratio as Exports+import Data.STRef as Exports+import Data.String as Exports+import Data.Traversable as Exports+import Data.Tuple as Exports+import Data.Unique as Exports+import Data.Version as Exports+import Data.Word as Exports+import Debug.Trace as Exports+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 GHC.Generics as Exports (Generic)+import GHC.IO.Exception as Exports+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 System.Environment as Exports+import System.Exit as Exports+import System.IO as Exports+import System.IO.Error as Exports+import System.IO.Unsafe as Exports+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 Unsafe.Coerce 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.SparseSmallArray as Exports (SparseSmallArray)++-- deferred-folds+-------------------------+import DeferredFolds.Unfold as Exports (Unfold(..))+import DeferredFolds.UnfoldM as Exports (UnfoldM(..))++-- | 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 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++{-# INLINE forMInPositiveRange_ #-}+forMInPositiveRange_ :: Applicative m => Int -> Int -> (Int -> m a) -> m ()+forMInPositiveRange_ !startN !endN f =+  ($ startN) $ fix $ \loop !n -> if n < endN then f n *> loop (succ n) else pure ()++{-# INLINE forMInNegativeRange_ #-}+forMInNegativeRange_ :: Applicative m => Int -> Int -> (Int -> m a) -> m ()+forMInNegativeRange_ !startN !endN f =+  ($ pred startN) $ fix $ \loop !n -> if n >= endN then f n *> loop (pred n) else pure ()
+ library/StmHamt/SizedHamt.hs view
@@ -0,0 +1,76 @@+-- |+-- HAMT API,+-- 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,+  unfoldM,+)+where++import StmHamt.Prelude hiding (insert, lookup, delete, fold, null)+import StmHamt.Types+import qualified Focus as Focus+import qualified StmHamt.Hamt as Hamt+++{-# INLINE new #-}+new :: STM (SizedHamt element)+new = SizedHamt <$> Hamt.new <*> newTVar 0++{-# INLINE newIO #-}+newIO :: IO (SizedHamt element)+newIO = SizedHamt <$> Hamt.newIO <*> newTVarIO 0++-- |+-- /O(1)/.+{-# INLINE null #-}+null :: SizedHamt element -> STM Bool+null (SizedHamt _ sizeVar) = (== 0) <$> readTVar sizeVar++-- |+-- /O(1)/.+{-# INLINE size #-}+size :: SizedHamt element -> STM Int+size (SizedHamt _ sizeVar) = readTVar sizeVar++{-# INLINE reset #-}+reset :: SizedHamt element -> STM ()+reset (SizedHamt hamt sizeVar) =+  do+    Hamt.reset hamt+    writeTVar sizeVar 0++{-# INLINE focus #-}+focus :: (Eq key, Hashable key) => Focus element STM result -> (element -> key) -> key -> SizedHamt element -> STM result+focus focus elementToKey key (SizedHamt hamt sizeVar) =+  do+    (result, sizeModifier) <- Hamt.focus newFocus elementToKey key hamt+    forM_ sizeModifier (modifyTVar' sizeVar)+    return result+  where+    newFocus = Focus.testingSizeChange (Just pred) Nothing (Just succ) focus++{-# INLINE insert #-}+insert :: (Eq key, Hashable key) => (element -> key) -> element -> SizedHamt element -> STM ()+insert elementToKey element (SizedHamt hamt sizeVar) =+  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 elementToKey key (SizedHamt hamt _) = Hamt.lookup elementToKey key hamt++{-# INLINE unfoldM #-}+unfoldM :: SizedHamt a -> UnfoldM STM a+unfoldM (SizedHamt hamt _) = Hamt.unfoldM hamt
+ library/StmHamt/Types.hs view
@@ -0,0 +1,18 @@+{-# 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.+-}+data SizedHamt element = SizedHamt !(Hamt element) !(TVar Int)++{-|+STM-specialized Hash Array Mapped Trie.+-}+newtype Hamt element = Hamt (TVar (SparseSmallArray (Branch element)))++data Branch element = BranchesBranch !(Hamt element) | LeavesBranch !Int !(SmallArray element)
+ library/StmHamt/UnfoldMs.hs view
@@ -0,0 +1,16 @@+module StmHamt.UnfoldMs where++import StmHamt.Prelude hiding (filter, all)+import StmHamt.Types+import DeferredFolds.UnfoldM+import qualified PrimitiveExtras.SmallArray as SmallArray+import qualified PrimitiveExtras.SparseSmallArray as SparseSmallArray+++hamtElements :: Hamt a -> UnfoldM STM a+hamtElements (Hamt var) = tVarValue var >>= SparseSmallArray.elementsUnfoldM >>= branchElements++branchElements :: Branch a -> UnfoldM STM a+branchElements = \ case+  LeavesBranch _ array -> SmallArray.elementsUnfoldM array+  BranchesBranch hamt -> hamtElements hamt
+ stm-hamt.cabal view
@@ -0,0 +1,115 @@+name:+  stm-hamt+version:+  1+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+cabal-version:+  >=1.10++source-repository head+  type:+    git+  location:+    git://github.com/nikita-volkov/stm-hamt.git++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+  exposed-modules:+    StmHamt.Hamt+    StmHamt.SizedHamt+  other-modules:+    StmHamt.Accessors.Hash+    StmHamt.Constructors.Branch+    StmHamt.Constructors.Hash+    StmHamt.Focuses+    StmHamt.Prelude+    StmHamt.Types+    StmHamt.UnfoldMs+  build-depends:+    base >=4.6 && <5,+    deferred-folds >=0.6.5 && <0.7,+    focus >=1 && <1.1,+    hashable <2,+    primitive >=0.6.4 && <0.7,+    primitive-extras >=0.5 && <0.6++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+  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++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+  build-depends:+    criterion ==1.5.*,+    mwc-random >=0.13 && <0.15,+    mwc-random-monad ==0.7.*,+    -- data:+    list-t,+    focus,+    stm-hamt,+    -- general:+    free >=4.5 && <6,+    async >=2.0 && <3,+    rebase <2
+ test/Main.hs view
@@ -0,0 +1,107 @@+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 Main.Transaction (Transaction)+import qualified Main.Transaction as Transaction+import qualified Main.Gens as Gens+import qualified StmHamt.Hamt as Hamt+import qualified Data.HashMap.Strict as HashMap+import qualified Focus+import qualified DeferredFolds.UnfoldM as UnfoldM+++main =+  defaultMain $+  testGroup "All" $+  [+    testGroup "Hamt" $ let++      hamtFromListUsingInsertWithHashInIo :: (Eq key, Eq value, Show (key, 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 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 $+        UnfoldM.foldlM' (\ state element -> return (element : state)) [] (Hamt.unfoldM hamt)++      listToListThruHamtInIo :: [(Char, Int)] -> IO [(Char, Int)]+      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+            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+          ,+          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
@@ -0,0 +1,70 @@+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+++key :: Gen Text+key = do+  length <- frequency [(1, pure 0), (20, pure 1), (2, pure 2), (1, pure 3)]+  chars <- vectorOf length (choose ('a', 'b'))+  return (fromString chars)++value :: Gen Int+value = choose (0, 9)++lookupTransaction :: Gen Transaction+lookupTransaction = Transaction.lookup <$> key++insertTransaction :: Gen Transaction+insertTransaction = Transaction.insert <$> key <*> value++insertWithHashTransaction :: (Text -> Int) -> Gen Transaction+insertWithHashTransaction hash = do+  keyValue <- key+  valueValue <- value+  let+    !hashValue = hash keyValue+    in return (Transaction.insertWithHash hashValue keyValue valueValue)++insertUsingFocusTransaction :: Gen Transaction+insertUsingFocusTransaction = Transaction.insertUsingFocus <$> key <*> value++deleteUsingFocusTransaction :: Gen Transaction+deleteUsingFocusTransaction = Transaction.deleteUsingFocus <$> key++incrementUsingAdjustFocusTransaction :: Gen Transaction+incrementUsingAdjustFocusTransaction = Transaction.incrementUsingAdjustFocus <$> key++seriesOfModificationsTransaction :: Gen Transaction+seriesOfModificationsTransaction = undefined++transaction :: Gen Transaction+transaction =+  frequency+    [+      (9, lookupTransaction),+      (2, insertTransaction),+      (2, insertUsingFocusTransaction),+      (9, deleteUsingFocusTransaction),+      (9, incrementUsingAdjustFocusTransaction)+    ]++hamt :: Gen (STM (Hamt (Text, Int)))+hamt = do+  list <- keyValueList+  return $ do+    hamt <- StmHamt.new+    forM_ list $ \ pair -> StmHamt.insert fst pair hamt+    return hamt++keyValueList :: Gen [(Text, Int)]+keyValueList = do+  size <- choose (0, 9)+  replicateM size ((,) <$> key <*> value)
+ test/Main/Transaction.hs view
@@ -0,0 +1,73 @@+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+++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++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++{-| 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++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 }++deleteUsingFocus :: Text -> Transaction+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 }