├── .github └── workflows │ ├── check.yaml │ ├── format.yaml │ ├── on-push-to-master-or-pr.yaml │ └── on-push-to-release.yaml ├── LICENSE ├── cabal.project ├── library └── StmContainers │ ├── Bimap.hs │ ├── Map.hs │ ├── Multimap.hs │ ├── Prelude.hs │ └── Set.hs ├── stm-containers.cabal └── test ├── Main.hs └── Suites ├── Bimap.hs ├── Map.hs └── Map └── Update.hs /.github/workflows/check.yaml: -------------------------------------------------------------------------------- 1 | name: Compile, test and check the docs 2 | 3 | on: 4 | workflow_call: 5 | 6 | jobs: 7 | 8 | check: 9 | 10 | strategy: 11 | fail-fast: false 12 | matrix: 13 | include: 14 | - ghc: 8.8.1 15 | ghc-options: "" 16 | ignore-haddock: true 17 | ignore-cabal-check: true 18 | - ghc: latest 19 | ignore-cabal-check: true 20 | 21 | runs-on: ubuntu-latest 22 | 23 | steps: 24 | 25 | - uses: nikita-volkov/build-and-test-cabal-package.github-action@v1 26 | with: 27 | ghc: ${{matrix.ghc}} 28 | ghc-options: ${{matrix.ghc-options}} 29 | ignore-haddock: ${{matrix.ignore-haddock}} 30 | ignore-cabal-check: ${{matrix.ignore-cabal-check}} 31 | -------------------------------------------------------------------------------- /.github/workflows/format.yaml: -------------------------------------------------------------------------------- 1 | name: Format 2 | 3 | on: 4 | workflow_call: 5 | 6 | jobs: 7 | format: 8 | uses: nikita-volkov/haskell-hackage-lib-github-actions-workflows/.github/workflows/format.yaml@v3 9 | secrets: inherit 10 | -------------------------------------------------------------------------------- /.github/workflows/on-push-to-master-or-pr.yaml: -------------------------------------------------------------------------------- 1 | name: Compile, test and check the docs 2 | 3 | on: 4 | push: 5 | branches: 6 | - master 7 | pull_request: 8 | 9 | jobs: 10 | 11 | format: 12 | uses: ./.github/workflows/format.yaml 13 | secrets: inherit 14 | 15 | check: 16 | uses: ./.github/workflows/check.yaml 17 | secrets: inherit 18 | -------------------------------------------------------------------------------- /.github/workflows/on-push-to-release.yaml: -------------------------------------------------------------------------------- 1 | name: Release the lib to Hackage 2 | 3 | on: 4 | push: 5 | branches: 6 | - supermajor 7 | - major 8 | - minor 9 | - patch 10 | 11 | concurrency: 12 | group: release 13 | cancel-in-progress: false 14 | 15 | jobs: 16 | 17 | format: 18 | uses: ./.github/workflows/format.yaml 19 | secrets: inherit 20 | 21 | check: 22 | uses: ./.github/workflows/check.yaml 23 | secrets: inherit 24 | 25 | release: 26 | needs: 27 | - format 28 | - check 29 | uses: nikita-volkov/haskell-hackage-lib-github-actions-workflows/.github/workflows/release.yaml@v3 30 | secrets: inherit 31 | with: 32 | prefix-tag-with-v: false 33 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014, Nikita Volkov 2 | 3 | Permission is hereby granted, free of charge, to any person 4 | obtaining a copy of this software and associated documentation 5 | files (the "Software"), to deal in the Software without 6 | restriction, including without limitation the rights to use, 7 | copy, modify, merge, publish, distribute, sublicense, and/or sell 8 | copies of the Software, and to permit persons to whom the 9 | Software is furnished to do so, subject to the following 10 | conditions: 11 | 12 | The above copyright notice and this permission notice shall be 13 | included in all copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 16 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES 17 | OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 18 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 19 | HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 20 | WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 21 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 22 | OTHER DEALINGS IN THE SOFTWARE. 23 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | allow-newer: 3 | , foldl:text 4 | -------------------------------------------------------------------------------- /library/StmContainers/Bimap.hs: -------------------------------------------------------------------------------- 1 | module StmContainers.Bimap 2 | ( Bimap, 3 | new, 4 | newIO, 5 | null, 6 | size, 7 | focusLeft, 8 | focusRight, 9 | lookupLeft, 10 | lookupRight, 11 | insertLeft, 12 | insertRight, 13 | deleteLeft, 14 | deleteRight, 15 | reset, 16 | unfoldlM, 17 | listT, 18 | ) 19 | where 20 | 21 | import qualified Focus as B 22 | import qualified StmContainers.Map as A 23 | import StmContainers.Prelude hiding (delete, empty, foldM, insert, lookup, null, toList) 24 | 25 | -- | 26 | -- Bidirectional map. 27 | -- Essentially, a bijection between subsets of its two argument types. 28 | -- 29 | -- For one value of the left-hand type this map contains one value 30 | -- of the right-hand type and vice versa. 31 | data Bimap leftKey rightKey 32 | = Bimap !(A.Map leftKey rightKey) !(A.Map rightKey leftKey) 33 | deriving (Typeable) 34 | 35 | -- | 36 | -- Construct a new bimap. 37 | {-# INLINE new #-} 38 | new :: STM (Bimap leftKey rightKey) 39 | new = 40 | Bimap <$> A.new <*> A.new 41 | 42 | -- | 43 | -- Construct a new bimap in IO. 44 | -- 45 | -- This is useful for creating it on a top-level using 'unsafePerformIO', 46 | -- because using 'atomically' inside 'unsafePerformIO' isn't possible. 47 | {-# INLINE newIO #-} 48 | newIO :: IO (Bimap leftKey rightKey) 49 | newIO = 50 | Bimap <$> A.newIO <*> A.newIO 51 | 52 | -- | 53 | -- Check on being empty. 54 | {-# INLINE null #-} 55 | null :: Bimap leftKey rightKey -> STM Bool 56 | null (Bimap leftMap _) = 57 | A.null leftMap 58 | 59 | -- | 60 | -- Get the number of elements. 61 | {-# INLINE size #-} 62 | size :: Bimap leftKey rightKey -> STM Int 63 | size (Bimap leftMap _) = 64 | A.size leftMap 65 | 66 | -- | 67 | -- Focus on a right value by the left value. 68 | -- 69 | -- This function allows to perform composite operations in a single access 70 | -- to a map item. 71 | -- E.g., you can look up an item and delete it at the same time, 72 | -- or update it and return the new value. 73 | {-# INLINE focusLeft #-} 74 | focusLeft :: (Hashable leftKey, Hashable rightKey) => B.Focus rightKey STM result -> leftKey -> Bimap leftKey rightKey -> STM result 75 | focusLeft rightFocus leftKey (Bimap leftMap rightMap) = 76 | do 77 | ((output, change), maybeRightKey) <- A.focus (B.extractingInput (B.extractingChange rightFocus)) leftKey leftMap 78 | case change of 79 | B.Leave -> 80 | return () 81 | B.Remove -> 82 | forM_ maybeRightKey $ \oldRightKey -> A.delete oldRightKey rightMap 83 | B.Set newRightKey -> 84 | do 85 | forM_ maybeRightKey $ \rightKey -> A.delete rightKey rightMap 86 | maybeReplacedLeftKey <- A.focus (B.lookup <* B.insert leftKey) newRightKey rightMap 87 | forM_ maybeReplacedLeftKey $ \replacedLeftKey -> A.delete replacedLeftKey leftMap 88 | return output 89 | 90 | -- | 91 | -- Focus on a left value by the right value. 92 | -- 93 | -- This function allows to perform composite operations in a single access 94 | -- to a map item. 95 | -- E.g., you can look up an item and delete it at the same time, 96 | -- or update it and return the new value. 97 | {-# INLINE focusRight #-} 98 | focusRight :: (Hashable leftKey, Hashable rightKey) => B.Focus leftKey STM result -> rightKey -> Bimap leftKey rightKey -> STM result 99 | focusRight valueFocus2 rightKey (Bimap leftMap rightMap) = 100 | focusLeft valueFocus2 rightKey (Bimap rightMap leftMap) 101 | 102 | -- | 103 | -- Look up a right value by the left value. 104 | {-# INLINE lookupLeft #-} 105 | lookupLeft :: (Hashable leftKey) => leftKey -> Bimap leftKey rightKey -> STM (Maybe rightKey) 106 | lookupLeft leftKey (Bimap leftMap _) = 107 | A.lookup leftKey leftMap 108 | 109 | -- | 110 | -- Look up a left value by the right value. 111 | {-# INLINE lookupRight #-} 112 | lookupRight :: (Hashable rightKey) => rightKey -> Bimap leftKey rightKey -> STM (Maybe leftKey) 113 | lookupRight rightKey (Bimap _ rightMap) = 114 | A.lookup rightKey rightMap 115 | 116 | -- | 117 | -- Insert the association by the left value. 118 | {-# INLINE insertLeft #-} 119 | insertLeft :: (Hashable leftKey, Hashable rightKey) => rightKey -> leftKey -> Bimap leftKey rightKey -> STM () 120 | insertLeft rightKey = 121 | focusLeft (B.insert rightKey) 122 | 123 | -- | 124 | -- Insert the association by the right value. 125 | {-# INLINE insertRight #-} 126 | insertRight :: (Hashable leftKey, Hashable rightKey) => leftKey -> rightKey -> Bimap leftKey rightKey -> STM () 127 | insertRight leftKey rightKey (Bimap leftMap rightMap) = 128 | insertLeft leftKey rightKey (Bimap rightMap leftMap) 129 | 130 | -- | 131 | -- Delete the association by the left value. 132 | {-# INLINE deleteLeft #-} 133 | deleteLeft :: (Hashable leftKey, Hashable rightKey) => leftKey -> Bimap leftKey rightKey -> STM () 134 | deleteLeft leftKey (Bimap leftMap rightMap) = 135 | A.focus B.lookupAndDelete leftKey leftMap 136 | >>= mapM_ (\rightKey -> A.delete rightKey rightMap) 137 | 138 | -- | 139 | -- Delete the association by the right value. 140 | {-# INLINE deleteRight #-} 141 | deleteRight :: (Hashable leftKey, Hashable rightKey) => rightKey -> Bimap leftKey rightKey -> STM () 142 | deleteRight rightKey (Bimap leftMap rightMap) = 143 | deleteLeft rightKey (Bimap rightMap leftMap) 144 | 145 | -- | 146 | -- Delete all the associations. 147 | {-# INLINE reset #-} 148 | reset :: Bimap leftKey rightKey -> STM () 149 | reset (Bimap leftMap rightMap) = 150 | do 151 | A.reset leftMap 152 | A.reset rightMap 153 | 154 | -- | 155 | -- Stream associations actively. 156 | -- 157 | -- Amongst other features this function provides an interface to folding. 158 | {-# INLINE unfoldlM #-} 159 | unfoldlM :: Bimap leftKey rightKey -> UnfoldlM STM (leftKey, rightKey) 160 | unfoldlM (Bimap leftMap _) = 161 | A.unfoldlM leftMap 162 | 163 | -- | 164 | -- Stream the associations passively. 165 | {-# INLINE listT #-} 166 | listT :: Bimap key value -> ListT STM (key, value) 167 | listT (Bimap leftMap _) = 168 | A.listT leftMap 169 | -------------------------------------------------------------------------------- /library/StmContainers/Map.hs: -------------------------------------------------------------------------------- 1 | module StmContainers.Map 2 | ( Map, 3 | new, 4 | newIO, 5 | null, 6 | size, 7 | focus, 8 | lookup, 9 | insert, 10 | delete, 11 | reset, 12 | unfoldlM, 13 | listT, 14 | listTNonAtomic, 15 | ) 16 | where 17 | 18 | import qualified DeferredFolds.UnfoldlM as C 19 | import qualified Focus as B 20 | import StmContainers.Prelude hiding (delete, empty, foldM, insert, lookup, null, toList) 21 | import qualified StmHamt.Hamt as A 22 | 23 | -- | 24 | -- Hash-table, based on STM-specialized Hash Array Mapped Trie. 25 | newtype Map key value 26 | = Map (A.Hamt (Product2 key value)) 27 | 28 | -- | 29 | -- Construct a new map. 30 | {-# INLINEABLE new #-} 31 | new :: STM (Map key value) 32 | new = 33 | Map <$> A.new 34 | 35 | -- | 36 | -- Construct a new map in IO. 37 | -- 38 | -- This is useful for creating it on a top-level using 'unsafePerformIO', 39 | -- because using 'atomically' inside 'unsafePerformIO' isn't possible. 40 | {-# INLINEABLE newIO #-} 41 | newIO :: IO (Map key value) 42 | newIO = 43 | Map <$> A.newIO 44 | 45 | -- | 46 | -- Check, whether the map is empty. 47 | {-# INLINEABLE null #-} 48 | null :: Map key value -> STM Bool 49 | null (Map hamt) = 50 | A.null hamt 51 | 52 | -- | 53 | -- Get the number of elements. 54 | {-# INLINEABLE size #-} 55 | size :: Map key value -> STM Int 56 | size = 57 | C.foldlM' (\x _ -> return (succ x)) 0 . unfoldlM 58 | 59 | -- | 60 | -- Focus on a value by the key. 61 | -- 62 | -- This function allows to perform composite operations in a single access 63 | -- to the map's row. 64 | -- E.g., you can look up a value and delete it at the same time, 65 | -- or update it and return the new value. 66 | {-# INLINE focus #-} 67 | focus :: (Hashable key) => B.Focus value STM result -> key -> Map key value -> STM result 68 | focus valueFocus key (Map hamt) = 69 | A.focus rowFocus (\(Product2 key _) -> key) key hamt 70 | where 71 | rowFocus = 72 | B.mappingInput (\value -> Product2 key value) (\(Product2 _ value) -> value) valueFocus 73 | 74 | -- | 75 | -- Look up an item. 76 | {-# INLINEABLE lookup #-} 77 | lookup :: (Hashable key) => key -> Map key value -> STM (Maybe value) 78 | lookup key = 79 | focus B.lookup key 80 | 81 | -- | 82 | -- Insert a value at a key. 83 | {-# INLINE insert #-} 84 | insert :: (Hashable key) => value -> key -> Map key value -> STM () 85 | insert value key (Map hamt) = 86 | void (A.insert (\(Product2 key _) -> key) (Product2 key value) hamt) 87 | 88 | -- | 89 | -- Delete an item by a key. 90 | {-# INLINEABLE delete #-} 91 | delete :: (Hashable key) => key -> Map key value -> STM () 92 | delete key = 93 | focus B.delete key 94 | 95 | -- | 96 | -- Delete all the associations. 97 | {-# INLINEABLE reset #-} 98 | reset :: Map key value -> STM () 99 | reset (Map hamt) = 100 | A.reset hamt 101 | 102 | -- | 103 | -- Stream the associations actively. 104 | -- 105 | -- Amongst other features this function provides an interface to folding. 106 | {-# INLINEABLE unfoldlM #-} 107 | unfoldlM :: Map key value -> UnfoldlM STM (key, value) 108 | unfoldlM (Map hamt) = 109 | fmap (\(Product2 k v) -> (k, v)) (A.unfoldlM hamt) 110 | 111 | -- | 112 | -- Stream the associations passively. 113 | {-# INLINE listT #-} 114 | listT :: Map key value -> ListT STM (key, value) 115 | listT (Map hamt) = fmap (\(Product2 k v) -> (k, v)) (A.listT hamt) 116 | 117 | -- | 118 | -- Stream the associations passively. 119 | -- Data may be inconsistent/out of date. 120 | {-# INLINE listTNonAtomic #-} 121 | listTNonAtomic :: Map key value -> ListT IO (key, value) 122 | listTNonAtomic (Map hamt) = fmap (\(Product2 k v) -> (k, v)) (A.listTNonAtomic hamt) 123 | -------------------------------------------------------------------------------- /library/StmContainers/Multimap.hs: -------------------------------------------------------------------------------- 1 | module StmContainers.Multimap 2 | ( Multimap, 3 | new, 4 | newIO, 5 | null, 6 | focus, 7 | lookup, 8 | lookupByKey, 9 | insert, 10 | delete, 11 | deleteByKey, 12 | reset, 13 | unfoldlM, 14 | unfoldlMKeys, 15 | unfoldlMByKey, 16 | listT, 17 | listTKeys, 18 | listTByKey, 19 | ) 20 | where 21 | 22 | import qualified Focus as C 23 | import qualified StmContainers.Map as A 24 | import StmContainers.Prelude hiding (delete, empty, foldM, insert, lookup, null, toList) 25 | import qualified StmContainers.Set as B 26 | 27 | -- | 28 | -- A multimap, based on an STM-specialized hash array mapped trie. 29 | -- 30 | -- Basically it's just a wrapper API around @'A.Map' key ('B.Set' value)@. 31 | newtype Multimap key value 32 | = Multimap (A.Map key (B.Set value)) 33 | deriving (Typeable) 34 | 35 | -- | 36 | -- Construct a new multimap. 37 | {-# INLINE new #-} 38 | new :: STM (Multimap key value) 39 | new = 40 | Multimap <$> A.new 41 | 42 | -- | 43 | -- Construct a new multimap in IO. 44 | -- 45 | -- This is useful for creating it on a top-level using 'unsafePerformIO', 46 | -- because using 'atomically' inside 'unsafePerformIO' isn't possible. 47 | {-# INLINE newIO #-} 48 | newIO :: IO (Multimap key value) 49 | newIO = 50 | Multimap <$> A.newIO 51 | 52 | -- | 53 | -- Check on being empty. 54 | {-# INLINE null #-} 55 | null :: Multimap key value -> STM Bool 56 | null (Multimap map) = 57 | A.null map 58 | 59 | -- | 60 | -- Focus on an item by the value and the key. 61 | -- 62 | -- This function allows to perform simultaneous lookup and modification. 63 | -- 64 | -- The focus is over a unit since we already know, 65 | -- which value we're focusing on and it doesn't make sense to replace it, 66 | -- however we still can decide wether to keep or remove it. 67 | {-# INLINE focus #-} 68 | focus :: (Hashable key, Hashable value) => C.Focus () STM result -> value -> key -> Multimap key value -> STM result 69 | focus unitFocus@(Focus concealUnit _) value key (Multimap map) = A.focus setFocus key map 70 | where 71 | setFocus = C.Focus conceal reveal 72 | where 73 | conceal = do 74 | (output, change) <- concealUnit 75 | case change of 76 | C.Set () -> 77 | do 78 | set <- B.new 79 | B.insert value set 80 | return (output, C.Set set) 81 | _ -> 82 | return (output, C.Leave) 83 | reveal set = do 84 | output <- B.focus unitFocus value set 85 | change <- bool C.Leave C.Remove <$> B.null set 86 | return (output, change) 87 | 88 | -- | 89 | -- Look up an item by a value and a key. 90 | {-# INLINE lookup #-} 91 | lookup :: (Hashable key, Hashable value) => value -> key -> Multimap key value -> STM Bool 92 | lookup value key (Multimap m) = 93 | maybe (return False) (B.lookup value) =<< A.lookup key m 94 | 95 | -- | 96 | -- Look up all values by key. 97 | {-# INLINE lookupByKey #-} 98 | lookupByKey :: (Hashable key) => key -> Multimap key value -> STM (Maybe (B.Set value)) 99 | lookupByKey key (Multimap m) = 100 | A.lookup key m 101 | 102 | -- | 103 | -- Insert an item. 104 | {-# INLINEABLE insert #-} 105 | insert :: (Hashable key, Hashable value) => value -> key -> Multimap key value -> STM () 106 | insert value key (Multimap map) = A.focus setFocus key map 107 | where 108 | setFocus = Focus conceal reveal 109 | where 110 | conceal = do 111 | set <- B.new 112 | B.insert value set 113 | return ((), C.Set set) 114 | reveal set = do 115 | B.insert value set 116 | return ((), C.Leave) 117 | 118 | -- | 119 | -- Delete an item by a value and a key. 120 | {-# INLINEABLE delete #-} 121 | delete :: (Hashable key, Hashable value) => value -> key -> Multimap key value -> STM () 122 | delete value key (Multimap map) = A.focus setFocus key map 123 | where 124 | setFocus = Focus conceal reveal 125 | where 126 | conceal = returnChange C.Leave 127 | reveal set = do 128 | B.delete value set 129 | B.null set >>= returnChange . bool C.Leave C.Remove 130 | returnChange c = return ((), c) 131 | 132 | -- | 133 | -- Delete all values associated with the key. 134 | {-# INLINEABLE deleteByKey #-} 135 | deleteByKey :: (Hashable key) => key -> Multimap key value -> STM () 136 | deleteByKey key (Multimap map) = 137 | A.delete key map 138 | 139 | -- | 140 | -- Delete all the associations. 141 | {-# INLINE reset #-} 142 | reset :: Multimap key value -> STM () 143 | reset (Multimap map) = 144 | A.reset map 145 | 146 | -- | 147 | -- Stream associations actively. 148 | -- 149 | -- Amongst other features this function provides an interface to folding. 150 | unfoldlM :: Multimap key value -> UnfoldlM STM (key, value) 151 | unfoldlM (Multimap m) = 152 | A.unfoldlM m >>= \(key, s) -> (key,) <$> B.unfoldlM s 153 | 154 | -- | 155 | -- Stream keys actively. 156 | unfoldlMKeys :: Multimap key value -> UnfoldlM STM key 157 | unfoldlMKeys (Multimap m) = 158 | fmap fst (A.unfoldlM m) 159 | 160 | -- | 161 | -- Stream values by a key actively. 162 | unfoldlMByKey :: (Hashable key) => key -> Multimap key value -> UnfoldlM STM value 163 | unfoldlMByKey key (Multimap m) = 164 | lift (A.lookup key m) >>= maybe mempty B.unfoldlM 165 | 166 | -- | 167 | -- Stream associations passively. 168 | listT :: Multimap key value -> ListT STM (key, value) 169 | listT (Multimap m) = 170 | A.listT m >>= \(key, s) -> (key,) <$> B.listT s 171 | 172 | -- | 173 | -- Stream keys passively. 174 | listTKeys :: Multimap key value -> ListT STM key 175 | listTKeys (Multimap m) = 176 | fmap fst (A.listT m) 177 | 178 | -- | 179 | -- Stream values by a key passively. 180 | listTByKey :: (Hashable key) => key -> Multimap key value -> ListT STM value 181 | listTByKey key (Multimap m) = 182 | lift (A.lookup key m) >>= maybe mempty B.listT 183 | -------------------------------------------------------------------------------- /library/StmContainers/Prelude.hs: -------------------------------------------------------------------------------- 1 | module StmContainers.Prelude 2 | ( module Exports, 3 | modifyTVar', 4 | Product2 (..), 5 | ) 6 | where 7 | 8 | import Control.Applicative as Exports 9 | import Control.Arrow as Exports 10 | import Control.Category as Exports 11 | import Control.Concurrent as Exports 12 | import Control.Exception as Exports 13 | import Control.Monad as Exports hiding (forM, forM_, mapM, mapM_, msum, sequence, sequence_) 14 | import Control.Monad.Fix as Exports hiding (fix) 15 | import Control.Monad.IO.Class as Exports 16 | import Control.Monad.ST as Exports 17 | import Control.Monad.Trans.Class as Exports 18 | import Data.Bits as Exports 19 | import Data.Bool as Exports 20 | import Data.Char as Exports 21 | import Data.Coerce as Exports 22 | import Data.Complex as Exports 23 | import Data.Data as Exports 24 | import Data.Dynamic as Exports 25 | import Data.Either as Exports 26 | import Data.Fixed as Exports 27 | import Data.Foldable as Exports 28 | import Data.Function as Exports hiding (id, (.)) 29 | import Data.Functor as Exports hiding (unzip) 30 | import Data.Hashable as Exports (Hashable (..)) 31 | import Data.IORef as Exports 32 | import Data.Int as Exports 33 | import Data.Ix as Exports 34 | 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) 35 | import Data.Maybe as Exports 36 | import Data.Monoid as Exports hiding (First (..), Last (..)) 37 | import Data.Ord as Exports 38 | import Data.Proxy as Exports 39 | import Data.Ratio as Exports 40 | import Data.STRef as Exports 41 | import Data.String as Exports 42 | import Data.Traversable as Exports 43 | import Data.Tuple as Exports 44 | import Data.Unique as Exports 45 | import Data.Version as Exports 46 | import Data.Word as Exports 47 | import Debug.Trace as Exports 48 | import DeferredFolds.Unfoldl as Exports (Unfoldl (..)) 49 | import DeferredFolds.UnfoldlM as Exports (UnfoldlM (..)) 50 | import Focus as Exports (Focus (..)) 51 | import Foreign.ForeignPtr as Exports 52 | import Foreign.Ptr as Exports 53 | import Foreign.StablePtr as Exports 54 | import Foreign.Storable as Exports hiding (alignment, sizeOf) 55 | import GHC.Conc as Exports hiding (threadWaitRead, threadWaitReadSTM, threadWaitWrite, threadWaitWriteSTM, withMVar) 56 | import GHC.Exts as Exports (groupWith, inline, lazy, sortWith) 57 | import GHC.Generics as Exports (Generic) 58 | import GHC.IO.Exception as Exports 59 | import ListT as Exports (ListT (..)) 60 | import Numeric as Exports 61 | import System.Environment as Exports 62 | import System.Exit as Exports 63 | import System.IO as Exports 64 | import System.IO.Error as Exports 65 | import System.IO.Unsafe as Exports 66 | import System.Mem as Exports 67 | import System.Mem.StableName as Exports 68 | import System.Timeout as Exports 69 | import Text.ParserCombinators.ReadPrec as Exports (ReadPrec, readP_to_Prec, readPrec_to_P, readPrec_to_S, readS_to_Prec) 70 | import Text.Printf as Exports (hPrintf, printf) 71 | import Text.Read as Exports (Read (..), readEither, readMaybe) 72 | import Unsafe.Coerce as Exports 73 | 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, (.)) 74 | 75 | -- | Strict version of 'modifyTVar'. 76 | {-# INLINE modifyTVar' #-} 77 | modifyTVar' :: TVar a -> (a -> a) -> STM () 78 | modifyTVar' var f = do 79 | x <- readTVar var 80 | writeTVar var $! f x 81 | 82 | data Product2 a b = Product2 !a !b deriving (Eq) 83 | -------------------------------------------------------------------------------- /library/StmContainers/Set.hs: -------------------------------------------------------------------------------- 1 | module StmContainers.Set 2 | ( Set, 3 | new, 4 | newIO, 5 | null, 6 | size, 7 | focus, 8 | lookup, 9 | insert, 10 | delete, 11 | reset, 12 | unfoldlM, 13 | listT, 14 | ) 15 | where 16 | 17 | import qualified Focus as B 18 | import StmContainers.Prelude hiding (delete, empty, foldM, insert, lookup, null, toList) 19 | import qualified StmHamt.SizedHamt as A 20 | 21 | -- | 22 | -- A hash set, based on an STM-specialized hash array mapped trie. 23 | newtype Set item 24 | = Set (A.SizedHamt item) 25 | deriving (Typeable) 26 | 27 | -- | 28 | -- Construct a new set. 29 | {-# INLINEABLE new #-} 30 | new :: STM (Set item) 31 | new = 32 | Set <$> A.new 33 | 34 | -- | 35 | -- Construct a new set in IO. 36 | -- 37 | -- This is useful for creating it on a top-level using 'unsafePerformIO', 38 | -- because using 'atomically' inside 'unsafePerformIO' isn't possible. 39 | {-# INLINEABLE newIO #-} 40 | newIO :: IO (Set item) 41 | newIO = 42 | Set <$> A.newIO 43 | 44 | -- | 45 | -- Check, whether the set is empty. 46 | {-# INLINEABLE null #-} 47 | null :: Set item -> STM Bool 48 | null (Set hamt) = 49 | A.null hamt 50 | 51 | -- | 52 | -- Get the number of elements. 53 | {-# INLINEABLE size #-} 54 | size :: Set item -> STM Int 55 | size (Set hamt) = 56 | A.size hamt 57 | 58 | -- | 59 | -- Focus on an element with a strategy. 60 | -- 61 | -- This function allows to perform simultaneous lookup and modification. 62 | -- 63 | -- The strategy is over a unit since we already know, 64 | -- which element we're focusing on and it doesn't make sense to replace it, 65 | -- however we still can decide wether to keep or remove it. 66 | {-# INLINEABLE focus #-} 67 | focus :: (Hashable item) => B.Focus () STM result -> item -> Set item -> STM result 68 | focus unitFocus item (Set hamt) = 69 | A.focus rowFocus id item hamt 70 | where 71 | rowFocus = 72 | B.mappingInput (const item) (const ()) unitFocus 73 | 74 | -- | 75 | -- Lookup an element. 76 | {-# INLINEABLE lookup #-} 77 | lookup :: (Hashable item) => item -> Set item -> STM Bool 78 | lookup = 79 | focus (fmap isJust B.lookup) 80 | 81 | -- | 82 | -- Insert a new element. 83 | {-# INLINEABLE insert #-} 84 | insert :: (Hashable item) => item -> Set item -> STM () 85 | insert item (Set hamt) = 86 | A.insert id item hamt 87 | 88 | -- | 89 | -- Delete an element. 90 | {-# INLINEABLE delete #-} 91 | delete :: (Hashable item) => item -> Set item -> STM () 92 | delete item (Set hamt) = 93 | A.focus B.delete id item hamt 94 | 95 | -- | 96 | -- Delete all the elements. 97 | {-# INLINEABLE reset #-} 98 | reset :: Set item -> STM () 99 | reset (Set hamt) = 100 | A.reset hamt 101 | 102 | -- | 103 | -- Stream the elements actively. 104 | -- 105 | -- Amongst other features this function provides an interface to folding. 106 | {-# INLINEABLE unfoldlM #-} 107 | unfoldlM :: Set item -> UnfoldlM STM item 108 | unfoldlM (Set hamt) = 109 | A.unfoldlM hamt 110 | 111 | -- | 112 | -- Stream the elements passively. 113 | {-# INLINE listT #-} 114 | listT :: Set item -> ListT STM item 115 | listT (Set hamt) = 116 | A.listT hamt 117 | -------------------------------------------------------------------------------- /stm-containers.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 3.0 2 | name: stm-containers 3 | version: 1.2.1.1 4 | synopsis: Containers for STM 5 | description: 6 | This library is based on an STM-specialized implementation of 7 | Hash Array Mapped Trie. 8 | It provides efficient implementations of @Map@, @Set@ 9 | and other data structures, 10 | which starting from version @1@ perform even better than their counterparts from \"unordered-containers\", 11 | but also scale well on concurrent access patterns. 12 | . 13 | For details on performance of the library, which are a bit outdated, see 14 | . 15 | 16 | category: Data Structures, STM, Concurrency 17 | homepage: https://github.com/nikita-volkov/stm-containers 18 | bug-reports: https://github.com/nikita-volkov/stm-containers/issues 19 | author: Nikita Volkov 20 | maintainer: Nikita Volkov 21 | copyright: (c) 2014, Nikita Volkov 22 | license: MIT 23 | license-file: LICENSE 24 | 25 | source-repository head 26 | type: git 27 | location: git://github.com/nikita-volkov/stm-containers.git 28 | 29 | library 30 | hs-source-dirs: library 31 | default-extensions: 32 | Arrows 33 | BangPatterns 34 | ConstraintKinds 35 | DataKinds 36 | DefaultSignatures 37 | DeriveDataTypeable 38 | DeriveFoldable 39 | DeriveFunctor 40 | DeriveGeneric 41 | DeriveTraversable 42 | EmptyDataDecls 43 | FlexibleContexts 44 | FlexibleInstances 45 | FunctionalDependencies 46 | GADTs 47 | GeneralizedNewtypeDeriving 48 | LambdaCase 49 | LiberalTypeSynonyms 50 | MagicHash 51 | MultiParamTypeClasses 52 | MultiWayIf 53 | NoImplicitPrelude 54 | NoMonomorphismRestriction 55 | OverloadedStrings 56 | ParallelListComp 57 | PatternGuards 58 | PatternSynonyms 59 | QuasiQuotes 60 | RankNTypes 61 | RecordWildCards 62 | ScopedTypeVariables 63 | StandaloneDeriving 64 | TemplateHaskell 65 | TupleSections 66 | TypeApplications 67 | TypeFamilies 68 | TypeOperators 69 | UnboxedTuples 70 | 71 | default-language: Haskell2010 72 | exposed-modules: 73 | StmContainers.Bimap 74 | StmContainers.Map 75 | StmContainers.Multimap 76 | StmContainers.Set 77 | 78 | other-modules: StmContainers.Prelude 79 | build-depends: 80 | base >=4.9 && <5, 81 | deferred-folds >=0.9 && <0.10, 82 | focus >=1.0.1.4 && <1.1, 83 | hashable >=1.4 && <2, 84 | list-t >=1.0.1 && <1.1, 85 | stm-hamt >=1.2.1 && <1.3, 86 | transformers >=0.5 && <0.7, 87 | 88 | test-suite test 89 | type: exitcode-stdio-1.0 90 | hs-source-dirs: test 91 | default-extensions: 92 | Arrows 93 | BangPatterns 94 | ConstraintKinds 95 | DataKinds 96 | DefaultSignatures 97 | DeriveDataTypeable 98 | DeriveFoldable 99 | DeriveFunctor 100 | DeriveGeneric 101 | DeriveTraversable 102 | EmptyDataDecls 103 | FlexibleContexts 104 | FlexibleInstances 105 | FunctionalDependencies 106 | GADTs 107 | GeneralizedNewtypeDeriving 108 | LambdaCase 109 | LiberalTypeSynonyms 110 | MagicHash 111 | MultiParamTypeClasses 112 | MultiWayIf 113 | NoImplicitPrelude 114 | NoMonomorphismRestriction 115 | OverloadedStrings 116 | ParallelListComp 117 | PatternGuards 118 | PatternSynonyms 119 | QuasiQuotes 120 | RankNTypes 121 | RecordWildCards 122 | ScopedTypeVariables 123 | StandaloneDeriving 124 | TemplateHaskell 125 | TupleSections 126 | TypeApplications 127 | TypeFamilies 128 | TypeOperators 129 | UnboxedTuples 130 | 131 | default-language: Haskell2010 132 | main-is: Main.hs 133 | other-modules: 134 | Suites.Bimap 135 | Suites.Map 136 | Suites.Map.Update 137 | 138 | build-depends: 139 | deferred-folds, 140 | focus, 141 | foldl >=1.4 && <2, 142 | free >=4.6 && <6, 143 | list-t, 144 | quickcheck-instances >=0.3.29.1 && <0.4, 145 | rerebase >=1 && <2, 146 | stm-containers, 147 | tasty >=0.12 && <2, 148 | tasty-hunit >=0.10.0.3 && <0.11, 149 | tasty-quickcheck >=0.10.2 && <0.12, 150 | -------------------------------------------------------------------------------- /test/Main.hs: -------------------------------------------------------------------------------- 1 | import qualified Suites.Bimap 2 | import qualified Suites.Map 3 | import Test.Tasty 4 | import Prelude 5 | 6 | main :: IO () 7 | main = 8 | defaultMain 9 | . testGroup "" 10 | $ [ testGroup "Bimap" Suites.Bimap.tests, 11 | testGroup "Map" Suites.Map.tests 12 | ] 13 | -------------------------------------------------------------------------------- /test/Suites/Bimap.hs: -------------------------------------------------------------------------------- 1 | module Suites.Bimap (tests) where 2 | 3 | import qualified Focus 4 | import qualified ListT 5 | import StmContainers.Bimap 6 | import Test.Tasty 7 | import Test.Tasty.HUnit 8 | import Prelude 9 | 10 | tests :: [TestTree] 11 | tests = 12 | [ testCase "construction" $ do 13 | m <- newIO :: IO (Bimap Int Int) 14 | atomically $ insertRight 3 1 m 15 | atomically $ insertRight 4 2 m 16 | assertEqual "" [(3, 1), (4, 2)] =<< atomically (ListT.toList (listT m)), 17 | testCase "deleteLeft" $ do 18 | m <- newIO :: IO (Bimap Int Int) 19 | atomically $ insertRight 3 1 m 20 | atomically $ insertRight 4 2 m 21 | atomically $ deleteLeft 4 m 22 | assertEqual "" [(3, 1)] =<< atomically (ListT.toList (listT m)), 23 | testCase "deleteRight" $ do 24 | m <- newIO :: IO (Bimap Int Int) 25 | atomically $ insertRight 3 1 m 26 | atomically $ insertRight 4 2 m 27 | atomically $ deleteRight 2 m 28 | assertEqual "" [(3, 1)] =<< atomically (ListT.toList (listT m)), 29 | testCase "replacing construction" $ do 30 | m <- newIO :: IO (Bimap Int Int) 31 | atomically $ insertRight 3 1 m 32 | atomically $ insertRight 4 2 m 33 | atomically $ insertRight 3 2 m 34 | assertEqual "" [(3, 2)] =<< atomically (ListT.toList (listT m)), 35 | testCase "insert overwrites" $ do 36 | m <- newIO :: IO (Bimap Int Int) 37 | atomically $ insertRight 3 1 m 38 | assertEqual "" 1 =<< atomically (size m) 39 | atomically $ insertRight 3 2 m 40 | assertEqual "" 1 =<< atomically (size m) 41 | assertEqual "" Nothing =<< atomically (lookupRight 1 m) 42 | assertEqual "" (Just 3) =<< atomically (lookupRight 2 m) 43 | assertEqual "" (Just 2) =<< atomically (lookupLeft 3 m) 44 | assertEqual "" Nothing =<< atomically (focusRight Focus.lookup 1 m) 45 | assertEqual "" (Just 3) =<< atomically (focusRight Focus.lookup 2 m) 46 | atomically $ focusRight (Focus.insert 3) 4 m 47 | assertEqual "" 1 =<< atomically (size m) 48 | assertEqual "" Nothing =<< atomically (lookupRight 1 m) 49 | assertEqual "" Nothing =<< atomically (lookupRight 2 m) 50 | assertEqual "" (Just 3) =<< atomically (lookupRight 4 m), 51 | testCase "insert overwrites 2" $ do 52 | m <- newIO :: IO (Bimap Int Char) 53 | atomically $ insertLeft 'a' 1 m 54 | assertEqual "" 1 =<< atomically (size m) 55 | atomically $ insertLeft 'a' 2 m 56 | assertEqual "" 1 =<< atomically (size m) 57 | assertEqual "" Nothing =<< atomically (lookupLeft 1 m) 58 | assertEqual "" (Just 'a') =<< atomically (lookupLeft 2 m) 59 | assertEqual "" Nothing =<< atomically (focusLeft Focus.lookup 1 m) 60 | assertEqual "" (Just 'a') =<< atomically (focusLeft Focus.lookup 2 m) 61 | atomically $ focusLeft (Focus.insert 'a') 3 m 62 | assertEqual "" 1 =<< atomically (size m) 63 | assertEqual "" Nothing =<< atomically (lookupLeft 1 m) 64 | assertEqual "" Nothing =<< atomically (lookupLeft 2 m) 65 | assertEqual "" (Just 'a') =<< atomically (lookupLeft 3 m) 66 | ] 67 | -------------------------------------------------------------------------------- /test/Suites/Map.hs: -------------------------------------------------------------------------------- 1 | module Suites.Map (tests) where 2 | 3 | import qualified Control.Foldl as Foldl 4 | import Control.Monad.Free 5 | import qualified Data.HashMap.Strict as HashMap 6 | import qualified DeferredFolds.UnfoldlM as UnfoldlM 7 | import qualified Focus 8 | import qualified StmContainers.Map as StmMap 9 | import qualified Suites.Map.Update as Update 10 | import Test.QuickCheck.Instances () 11 | import Test.Tasty 12 | import Test.Tasty.HUnit 13 | import Test.Tasty.QuickCheck 14 | import Prelude hiding (choose) 15 | 16 | interpretStmMapUpdate :: (Hashable k) => Update.Update k v -> STM (StmMap.Map k v) 17 | interpretStmMapUpdate update = do 18 | m <- StmMap.new 19 | flip iterM update $ \case 20 | Update.Insert k v c -> StmMap.insert v k m >> c 21 | Update.Delete k c -> StmMap.delete k m >> c 22 | Update.Adjust f k c -> StmMap.focus ((Focus.adjustM . fmap return) f) k m >> c 23 | return m 24 | 25 | interpretHashMapUpdate :: (Hashable k) => Update.Update k v -> HashMap.HashMap k v 26 | interpretHashMapUpdate update = 27 | flip execState HashMap.empty $ flip iterM update $ \case 28 | Update.Insert k v c -> modify (HashMap.insert k v) >> c 29 | Update.Delete k c -> modify (HashMap.delete k) >> c 30 | Update.Adjust f k c -> modify (adjust f k) >> c 31 | where 32 | adjust f k m = 33 | case HashMap.lookup k m of 34 | Nothing -> m 35 | Just a -> HashMap.insert k (f a) m 36 | 37 | stmMapToHashMap :: (Hashable k) => StmMap.Map k v -> STM (HashMap.HashMap k v) 38 | stmMapToHashMap = UnfoldlM.foldM (Foldl.generalize Foldl.hashMap) . StmMap.unfoldlM 39 | 40 | stmMapFromList :: (Hashable k) => [(k, v)] -> STM (StmMap.Map k v) 41 | stmMapFromList list = do 42 | m <- StmMap.new 43 | forM_ list $ \(k, v) -> StmMap.insert v k m 44 | return m 45 | 46 | stmMapToList :: StmMap.Map k v -> STM [(k, v)] 47 | stmMapToList = UnfoldlM.foldM (Foldl.generalize Foldl.list) . StmMap.unfoldlM 48 | 49 | -- * Intentional hash collision simulation 50 | 51 | ------------------------- 52 | 53 | newtype TestKey = TestKey Word8 54 | deriving (Eq, Ord, Show) 55 | 56 | instance Arbitrary TestKey where 57 | arbitrary = TestKey <$> choose (0, 63) 58 | 59 | instance Hashable TestKey where 60 | hashWithSalt salt (TestKey w) = 61 | if odd w 62 | then hashWithSalt salt (pred w) 63 | else hashWithSalt salt w 64 | 65 | -- * Tests 66 | 67 | ------------------------- 68 | 69 | tests :: [TestTree] 70 | tests = 71 | [ testProperty "sizeAndList" 72 | $ let gen = do 73 | keys <- nub <$> listOf (choose ('a', 'z')) 74 | mapM (liftA2 (flip (,)) (choose (0, 99 :: Int)) . pure) keys 75 | prop list = 76 | length list == stmMapLength 77 | where 78 | stmMapLength = 79 | unsafePerformIO $ atomically $ do 80 | x <- stmMapFromList list 81 | StmMap.size x 82 | in forAll gen prop, 83 | testProperty "fromListToListHashMapIsomorphism" $ \(list :: [(Text, Int)]) -> 84 | let hashMapList = HashMap.toList (HashMap.fromList list) 85 | stmMapList = unsafePerformIO $ atomically $ stmMapFromList list >>= stmMapToList 86 | in sort hashMapList === sort stmMapList, 87 | testProperty "updatesProduceTheSameEffectAsInHashMap" $ \(updates :: [Update.Update TestKey ()]) -> 88 | let update = sequence_ updates 89 | hashMap = interpretHashMapUpdate update 90 | hashMapSize = HashMap.size hashMap 91 | hashMapList = sort (HashMap.toList hashMap) 92 | (stmMapList, stmMapSize) = unsafePerformIO $ atomically $ do 93 | stmMap <- interpretStmMapUpdate update 94 | size <- StmMap.size stmMap 95 | stmMapList <- stmMapToList stmMap 96 | return (sort stmMapList, size) 97 | in (hashMapSize, hashMapList) === (stmMapSize, stmMapList), 98 | testCase "focusInsert" $ do 99 | assertEqual "" (HashMap.fromList [('a', 1), ('b', 2)]) =<< do 100 | atomically $ do 101 | m <- StmMap.new 102 | StmMap.focus (Focus.insert 1) 'a' m 103 | StmMap.focus (Focus.insert 2) 'b' m 104 | stmMapToHashMap m, 105 | testCase "focusInsertAndDelete" $ do 106 | assertEqual "" (HashMap.fromList [('b', 2)]) =<< do 107 | atomically $ do 108 | m <- StmMap.new 109 | StmMap.focus (Focus.insert 1) 'a' m 110 | StmMap.focus (Focus.insert 2) 'b' m 111 | StmMap.focus (Focus.delete) 'a' m 112 | stmMapToHashMap m, 113 | testCase "focusInsertAndDeleteWithCollision" $ do 114 | assertEqual "" (HashMap.fromList [(TestKey 32, 2)]) =<< do 115 | atomically $ do 116 | m <- StmMap.new 117 | StmMap.focus (Focus.insert 2) (TestKey 32) m 118 | StmMap.focus (Focus.delete) (TestKey 1) m 119 | stmMapToHashMap m, 120 | testCase "insert" $ do 121 | assertEqual "" (HashMap.fromList [('a', 1), ('b', 2), ('c', 3)]) =<< do 122 | atomically $ do 123 | m <- StmMap.new 124 | StmMap.insert 1 'a' m 125 | StmMap.insert 3 'c' m 126 | StmMap.insert 2 'b' m 127 | stmMapToHashMap m, 128 | testCase "insert2" $ do 129 | assertEqual "" (HashMap.fromList [(111 :: Int, ()), (207, ())]) =<< do 130 | atomically $ do 131 | m <- StmMap.new 132 | StmMap.insert () 111 m 133 | StmMap.insert () 207 m 134 | stmMapToHashMap m, 135 | testCase "adjust" $ do 136 | assertEqual "" (HashMap.fromList [('a', 1), ('b', 3)]) =<< do 137 | atomically $ do 138 | m <- stmMapFromList [('a', 1), ('b', 2)] 139 | StmMap.focus (Focus.adjustM (const $ return 3)) 'b' m 140 | stmMapToHashMap m, 141 | testCase "focusReachesTheTarget" $ do 142 | assertEqual "" (Just 2) =<< do 143 | atomically $ do 144 | m <- stmMapFromList [('a', 1), ('b', 2)] 145 | StmMap.focus Focus.lookup 'b' m, 146 | testCase "notNull" $ do 147 | assertEqual "" False =<< do 148 | atomically $ StmMap.null =<< stmMapFromList [('a', ())], 149 | testCase "nullAfterDeletingTheLastElement" $ do 150 | assertEqual "" True =<< do 151 | atomically $ do 152 | m <- stmMapFromList [('a', ())] 153 | StmMap.delete 'a' m 154 | StmMap.null m 155 | ] 156 | -------------------------------------------------------------------------------- /test/Suites/Map/Update.hs: -------------------------------------------------------------------------------- 1 | module Suites.Map.Update where 2 | 3 | import Control.Monad.Free 4 | import Control.Monad.Free.TH 5 | import Test.QuickCheck.Instances () 6 | import Test.Tasty.QuickCheck 7 | import Prelude hiding (delete, insert) 8 | 9 | data UpdateF k v c 10 | = Insert k v c 11 | | Delete k c 12 | | Adjust (v -> v) k c 13 | deriving (Functor) 14 | 15 | instance (Show k, Show v, Show c) => Show (UpdateF k v c) where 16 | showsPrec i = 17 | showParen (i > 5) . \case 18 | Insert k v c -> 19 | showString "Insert " 20 | . showsPrecInner k 21 | . showChar ' ' 22 | . showsPrecInner v 23 | . showChar ' ' 24 | . showsPrecInner c 25 | Delete k c -> 26 | showString "Delete " 27 | . showsPrecInner k 28 | . showChar ' ' 29 | . showsPrecInner c 30 | Adjust _ k c -> 31 | showString "Adjust " 32 | . showString " v> " 33 | . showsPrecInner k 34 | . showChar ' ' 35 | . showsPrecInner c 36 | where 37 | showsPrecInner = showsPrec (succ 5) 38 | 39 | instance (Show k, Show v) => Show1 (UpdateF k v) where 40 | liftShowsPrec = undefined 41 | 42 | makeFree ''UpdateF 43 | 44 | type Update k v = Free (UpdateF k v) () 45 | 46 | instance (Arbitrary k, Arbitrary v) => Arbitrary (Update k v) where 47 | arbitrary = 48 | frequency 49 | [ (1, delete <$> arbitrary), 50 | (10, insert <$> arbitrary <*> arbitrary), 51 | (3, adjust <$> (const <$> arbitrary) <*> arbitrary) 52 | ] 53 | --------------------------------------------------------------------------------