stm-supply (empty) → 0.1.0.0

raw patch · 5 files changed

+182/−0 lines, 5 filesdep +QuickCheckdep +Uniquedep +asyncsetup-changed

Dependencies added: QuickCheck, Unique, async, base, concurrent-supply, random, stm-supply

Files

• LICENSE +30/−0
• Setup.hs +2/−0
• src/Control/Concurrent/STMSupply.hs +33/−0
• stm-supply.cabal +38/−0
• test/Spec.hs +79/−0

@@ -0,0 +1,30 @@+Copyright Joe Canero (c) 2016++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Joe Canero nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,33 @@+module Control.Concurrent.STMSupply+(+  STMSupply+, newSTMSupplyIO+, freshId+, splitSupply+) where++import qualified Control.Concurrent.Supply as S+import GHC.Conc++-- | newtype wrapper around a TVar Supply.+newtype STMSupply = Supply {+    unSupply :: TVar S.Supply+  }++-- | Construct a new @STMSupply@ in the IO Monad.+newSTMSupplyIO :: IO STMSupply+newSTMSupplyIO = Supply <$> (newTVarIO =<< S.newSupply)++-- | Using an @STMSupply@, atomically get a fresh ID.+freshId :: STMSupply -> STM Int+freshId Supply{unSupply = s} = do+  (i, s') <- S.freshId <$> readTVar s+  writeTVar s s' >> return i++-- | Using an @STMSupply@, atomically split the underlying @Supply@ into two.+--  Stores one of the new supplies in the STMSupply that was the first+--  argument, and returns the second Supply.+splitSupply :: STMSupply -> STM STMSupply+splitSupply Supply{unSupply = s} = do+  (s1, s2) <- S.splitSupply <$> readTVar s+  writeTVar s s1 >> (Supply <$> newTVar s2)

@@ -0,0 +1,38 @@+name:                stm-supply+version:             0.1.0.0+synopsis:            STM wrapper around Control.Concurrent.Supply.+description:         Please see README.md+homepage:            https://github.com/caneroj1/stm-supply#readme+license:             BSD3+license-file:        LICENSE+author:              Joe Canero+maintainer:          jmc41493@gmail.com+copyright:           Copyright: (c) 2016 Joe Canero+category:            Control+build-type:          Simple+-- extra-source-files:+cabal-version:       >=1.10++library+  hs-source-dirs:      src+  exposed-modules:     Control.Concurrent.STMSupply+  build-depends:       base >= 4.7 && < 5+                     , concurrent-supply+  default-language:    Haskell2010++test-suite stm-supply-test+  type:                exitcode-stdio-1.0+  hs-source-dirs:      test+  main-is:             Spec.hs+  build-depends:       base+                     , stm-supply+                     , async+                     , random+                     , QuickCheck+                     , Unique+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N+  default-language:    Haskell2010++source-repository head+  type:     git+  location: https://github.com/caneroj1/stm-supply

@@ -0,0 +1,79 @@+{-# LANGUAGE TemplateHaskell #-}++module Main where++import Control.Concurrent.Async+import Control.Concurrent.STMSupply+import Control.Monad+import Data.List+import Data.List.Unique+import GHC.Conc+import System.Random+import Test.QuickCheck+import Test.QuickCheck.Monadic++-- Each split supply should generate distinct sequences of integers.+prop_idSplitSupply :: Positive Int -> Property+prop_idSplitSupply n = monadicIO $ do+  s   <- run newSTMSupplyIO+  s'  <- run . atomically $ splitSupply s+  ls1 <- run $ testImpl_idSequenceN n s+  ls2 <- run $ testImpl_idSequenceN n s'+  assert (satisfy n ls1 &&+          satisfy n ls2 &&+          ls1 /= ls2)++-- Spawn multiple async actions and have them each get a fresh ID.+-- The sorted IDs should all be distinct and sequential.+prop_idSequenceN :: Positive Int -> Property+prop_idSequenceN n = monadicIO $ do+  supply <- run newSTMSupplyIO+  ls     <- run $ testImpl_idSequenceN n supply+  assert $ satisfy n ls++-- Spawn multiple async actions and have them each get some fresh IDs+-- and split the supply. We want every ID retrieved to be unique.+-- We will spawn N async actions that each split the supply and then+-- take N IDs. We expect NxN unique integers.+prop_idSequenceSplitsN :: Positive Int -> Property+prop_idSequenceSplitsN p@(Positive n) = monadicIO $ do+  s  <- run newSTMSupplyIO+  ls <- run $ sortUniq . concat <$>+        (mapM wait =<< mapM (\_ -> async (asyncAction s)) [0..(n-1)])+  assert (length ls == (n * n))+  where+    asyncAction s = do+      threadDelay <$> randomDelay+      newSupply <- atomically $ splitSupply s+      atomically $ replicateM n (freshId newSupply)++-- testImpl_idSequence accepts an Int N and an STMSupply+-- and creates N async workers that will each atomically get a+-- freshID. We should produce a sorted list of integers L such that+-- L contains N distinct, sequential integers+testImpl_idSequenceN :: Positive Int -> STMSupply -> IO [Int]+testImpl_idSequenceN (Positive n) supply =+  sort <$> (mapM wait =<< mapM (\_ -> async asyncAction) [0..(n-1)])+  where+    asyncAction = do+      threadDelay <$> randomDelay+      atomically $ freshId supply++-- random delay of 350 - 700ms+randomDelay :: IO Int+randomDelay = (fst . randomR (350000, 700000)) <$> newStdGen++-- a list of integers satisfies the test condition if there+-- are N distinct integers and they are sequential.+satisfy :: Positive Int -> [Int] -> Bool+satisfy (Positive n) ls = length ls == n && isSequence ls+  where+    isSequence []       = True+    isSequence [x]      = True+    isSequence l@(x:xs) = all (==1) $ zipWith (-) xs l++return []+runTests = $quickCheckAll++main :: IO ()+main = void runTests