kazura-queue 0.1.0.2 → 0.1.0.3
raw patch · 16 files changed
+658/−632 lines, 16 filesdep ~atomic-primopsdep ~basedep ~doctestPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: atomic-primops, base, doctest
API changes (from Hackage documentation)
Files
- ChangeLog.md +3/−0
- README.md +1/−0
- bench/Main.hs +2/−2
- kazura-queue.cabal +121/−96
- src/Control/Concurrent/KazuraQueue.hs +81/−85
- src/Control/Concurrent/WVar.hs +11/−10
- test/KazuraQueueConcurrentSpec.hs +176/−180
- test/Test/Concurrent.hs +34/−29
- test/Test/Expectations.hs +56/−56
- test/Test/KazuraQueue.hs +15/−15
- test/Test/Util.hs +10/−10
- test/Test/WVar.hs +31/−31
- test/WVarConcurrentSpec.hs +63/−64
- test/WVarSpec.hs +44/−44
- test/doctest.hs +0/−10
- test/kazura-queue-doctest.hs +10/−0
+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for kazura-queue-z++## Unreleased changes
+ README.md view
@@ -0,0 +1,1 @@+# kazura-queue
bench/Main.hs view
@@ -129,7 +129,7 @@ CR.defaultMainWith configSpeed [ CR.bgroup "KazuraQueue" $ testcases $ testSpeed_ testKZRQueue- -- , CR.bgroup "Unagi" $ testcases $ testSpeed_ testUChan+ -- , CR.bgroup "UnagiChan" $ testcases $ testSpeed_ testUChan , CR.bgroup "Chan" $ testcases $ testSpeed_ testChan , CR.bgroup "TQueue" $ testcases $ testSpeed_ testTQueue , CR.bgroup "TChan" $ testcases $ testSpeed_ testTChan@@ -137,7 +137,7 @@ CR.defaultMainWith configCost [ CR.bgroup "KazuraQueue" $ testcases $ testCost_ testKZRQueue- -- , CR.bgroup "Unagi" $ testcases $ testCost_ testUChan+ -- , CR.bgroup "UnagiChan" $ testcases $ testCost_ testUChan , CR.bgroup "Chan" $ testcases $ testCost_ testChan , CR.bgroup "TQueue" $ testcases $ testCost_ testTQueue , CR.bgroup "TChan" $ testcases $ testCost_ testTChan
kazura-queue.cabal view
@@ -1,105 +1,130 @@-name: kazura-queue-version: 0.1.0.2-synopsis: Fast concurrent queues much inspired by unagi-chan-description:- "kazura-queue" provides an implementation of FIFO queue.- It is faster than Chan, TQueue or TChan by the benefit of fetch-and-add- instruction.- .- Main motivation of this package is to solve some difficulty of- "unagi-chan" package.- .- - In "unagi-chan", the item in the queue/chan can be lost when async- exception is throwed to the read thread while waiting for read.- (Although it has handler to recover lost item,- it is difficult to keep FIFO in such case)- .- - In "unagi-chan", garbage items of the queue cannot be collected- immediately.- Since the buffer in the queue has the reference to the items until the- buffer is garbage-collected.- .- "kazura-queue" is slightly slower than "unagi-chan" instead of solving- these issues.- And "kazura-queue" lost broadcast function to improve the second issue.- It means that kazura-queue is not "Chan" but is just "Queue".-homepage: http://github.com/asakamirai/kazura-queue-license: BSD3-license-file: LICENSE-author: Asakamirai-maintainer: asakamirai_hackage@towanowa.net-copyright: 2016 Asakamirai-category: Concurrency-build-type: Simple-cabal-version: >=1.10+-- This file has been generated from package.yaml by hpack version 0.28.2. +--+-- see: https://github.com/sol/hpack+--+-- hash: ce64d904d9dcf6b3df16e486d6230a325fd9480d175e7c84c4a703eee11291b1 +name: kazura-queue+version: 0.1.0.3+synopsis: Fast concurrent queues much inspired by unagi-chan+description: \"kazura-queue\" provides an implementation of FIFO queue.+ It is faster than Chan, TQueue or TChan by the benefit of fetch-and-add+ instruction.+ .+ Main motivation of this package is to solve some difficulty of+ "unagi-chan" package.+ .+ - In "unagi-chan", the item in the queue/chan can be lost when async+ exception is throwed to the read thread while waiting for read.+ (Although it has handler to recover lost item,+ it is difficult to keep FIFO in such case)+ .+ - In "unagi-chan", garbage items of the queue cannot be collected+ immediately.+ Since the buffer in the queue has the reference to the items until the+ buffer is garbage-collected.+ .+ \"kazura-queue\" is slightly slower than "unagi-chan" instead of solving+ these issues.+ .+ \"kazura-queue\" lost broadcast function to improve the second issue.+ It means that kazura-queue is not \"Chan\" but is just \"Queue\".+category: Concurrency+homepage: https://github.com/asakamirai/kazura-queue#readme+bug-reports: https://github.com/asakamirai/kazura-queue/issues+author: Asakamirai+maintainer: asakamirai_hackage@towanowa.net+copyright: 2016-2018 Asakamirai+license: BSD3+license-file: LICENSE+build-type: Simple+cabal-version: >= 1.10+extra-source-files:+ ChangeLog.md+ README.md+ source-repository head- type: git+ type: git location: https://github.com/asakamirai/kazura-queue- branch: master library- hs-source-dirs: src- exposed-modules: Control.Concurrent.WVar- Control.Concurrent.KazuraQueue- build-depends: base >= 4.7 && < 5- , primitive >= 0.5.3- , atomic-primops >= 0.8- , async >= 2.0- , containers >= 0.5- ghc-options: -Wall -O2- default-language: Haskell2010--benchmark kazura-queue-bench- type: exitcode-stdio-1.0- hs-source-dirs: bench- main-is: Main.hs- ghc-options: -Wall -O2 -threaded -rtsopts -with-rtsopts=-N4- build-depends: base- , kazura-queue- , async >= 2.0- , containers >= 0.5- , stm >= 2.4- , criterion >= 1.1- -- , unagi-chan >= 0.4.0.0- default-language: Haskell2010+ exposed-modules:+ Control.Concurrent.KazuraQueue+ Control.Concurrent.WVar+ other-modules:+ Paths_kazura_queue+ hs-source-dirs:+ src+ ghc-options: -Wall -O2+ build-depends:+ atomic-primops >=0.6+ , base >=4.7 && <5.0+ , primitive >=0.5.3+ default-language: Haskell2010 test-suite kazura-queue-doctest- type: exitcode-stdio-1.0- hs-source-dirs: test- main-is: doctest.hs- build-depends: base- , kazura-queue- , doctest >= 0.10- , QuickCheck >= 2.8- ghc-options: -Wall -O2 -threaded -rtsopts -with-rtsopts=-N- default-language: Haskell2010+ type: exitcode-stdio-1.0+ main-is: test/kazura-queue-doctest.hs+ other-modules:+ Paths_kazura_queue+ ghc-options: -Wall -O2 -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ QuickCheck >=2.8+ , atomic-primops >=0.6+ , base >=4.7 && <5.0+ , doctest+ , kazura-queue+ , primitive >=0.5.3+ default-language: Haskell2010 test-suite kazura-queue-test- type: exitcode-stdio-1.0- hs-source-dirs: test- main-is: Spec.hs- other-modules: Test.Concurrent- , Test.Expectations- , Test.KazuraQueue- , Test.Util- , Test.WVar- , WVarSpec- , WVarConcurrentSpec- , KazuraQueueSpec- , KazuraQueueConcurrentSpec- build-depends: base- , kazura-queue- , HUnit >= 1.2- , hspec >= 2.1- , hspec-expectations >= 0.7- , QuickCheck >= 2.8- , deepseq >= 1.4- , containers >= 0.5- , mtl >= 2.2- , transformers >= 0.4- , free >= 4.12- , exceptions >= 0.8- , async >= 2.0- ghc-options: -Wall -O2 -threaded -rtsopts -with-rtsopts=-N- default-language: Haskell2010+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ KazuraQueueConcurrentSpec+ KazuraQueueSpec+ Test.Concurrent+ Test.Expectations+ Test.KazuraQueue+ Test.Util+ Test.WVar+ WVarConcurrentSpec+ WVarSpec+ Paths_kazura_queue+ hs-source-dirs:+ test+ ghc-options: -Wall -O2 -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ HUnit >=1.2+ , QuickCheck >=2.8+ , async >=2.0+ , atomic-primops >=0.6+ , base >=4.7 && <5.0+ , containers >=0.5+ , deepseq >=1.4+ , exceptions >=0.8+ , free >=4.12+ , hspec >=2.1+ , hspec-expectations >=0.7+ , kazura-queue+ , mtl >=2.2+ , primitive >=0.5.3+ , transformers >=0.4+ default-language: Haskell2010++benchmark kazura-queue-bench+ type: exitcode-stdio-1.0+ main-is: Main.hs+ other-modules:+ Paths_kazura_queue+ hs-source-dirs:+ bench+ ghc-options: -Wall -O2 -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ atomic-primops >=0.6+ , base >=4.7 && <5.0+ , criterion >=1.1+ , kazura-queue+ , primitive >=0.5.3+ , stm >=2.4+ default-language: Haskell2010
src/Control/Concurrent/KazuraQueue.hs view
@@ -48,9 +48,9 @@ {-# INLINE divModBufferLength #-} divModBufferLength :: Int -> (Int,Int) divModBufferLength n = d `seq` m `seq` (d,m)- where- d = n `Bits.unsafeShiftR` logBufferLength- m = n .&. (bufferLength - 1)+ where+ d = n `Bits.unsafeShiftR` logBufferLength+ m = n .&. (bufferLength - 1) -------------------------------- -- Queue@@ -126,10 +126,10 @@ , queueReadState = rsvar , queueNoneTicket = noneTicket }- where- -- for test of counter overflow- initialOffset = maxBound - 3- initialIndex = initialOffset - 1+ where+ -- for test of counter overflow+ initialOffset = maxBound - 3+ initialIndex = initialOffset - 1 ---------------------------------------------------------- @@ -176,16 +176,16 @@ readQueueRaw queue rswc0 = do rstr0 <- Ref.readIORef rstrRef strIdx <- Atm.incrCounter 1 rcounter- if rlimit0 - strIdx >= 0+ if rlimit0 `gteIndex` strIdx then readStream rstrRef rstr0 strIdx else do rswt1 <- extendReadStreamWithLock rstr0 rswc0 True True let rswc1 = rswc0 { WVar.cachedTicket = rswt1 } readQueueRaw queue rswc1- where- rstrRef = queueReadStream queue- rswt0 = WVar.cachedTicket rswc0- (ReadState rcounter rlimit0) = WVar.readWTicket rswt0+ where+ rstrRef = queueReadStream queue+ rswt0 = WVar.cachedTicket rswc0+ (ReadState rcounter rlimit0) = WVar.readWTicket rswt0 -- | Try to read an item from the 'Queue'. It never blocks. --@@ -206,27 +206,19 @@ tryReadQueueRaw queue rswc0 = do rstr0 <- Ref.readIORef rstrRef strIdx <- Atm.incrCounter 1 rcounter- if rlimit0 - strIdx >= 0+ if rlimit0 `gteIndex` strIdx then Just <$> readStream rstrRef rstr0 strIdx else do rswt1 <- extendReadStreamWithLock rstr0 rswc0 False False let rswc1 = rswc0 { WVar.cachedTicket = rswt1 } (ReadState _ rlimit1) = WVar.readWTicket rswt1- loop <- if rlimit1 /= rlimit0- then return True- else do- wcount <- Atm.readCounter wcounter- if wcount - strIdx >= 0- then CC.yield >> return True- else return False- if loop+ if rlimit1 /= rlimit0 then tryReadQueueRaw queue rswc1 else return Nothing- where- rstrRef = queueReadStream queue- rswt0 = WVar.cachedTicket rswc0- (ReadState rcounter rlimit0) = WVar.readWTicket rswt0- wcounter = queueWriteCounter queue+ where+ rstrRef = queueReadStream queue+ rswt0 = WVar.cachedTicket rswc0+ (ReadState rcounter rlimit0) = WVar.readWTicket rswt0 {-# INLINE readStream #-} readStream :: IORef (Stream a) -> Stream a -> StreamIndex -> IO a@@ -276,15 +268,15 @@ (rlimitNext2, _) <- searchStreamReadLimit rstr1 rlimitNext1 newRState rlimitNext2 else return rstate0- where- rlimit0 = rsLimit rstate0- rlimitNext0 = rlimit0 + 1- newRState rlimitNext = do- rcounter <- Atm.newCounter rlimit0- return rstate0- { rsCounter = rcounter- , rsLimit = rlimitNext - 1- }+ where+ rlimit0 = rsLimit rstate0+ rlimitNext0 = rlimit0 + 1+ newRState rlimitNext = do+ rcounter <- Atm.newCounter rlimit0+ return rstate0+ { rsCounter = rcounter+ , rsLimit = rlimitNext - 1+ } -- | Write an item to the 'Queue'. -- The item is evaluated (WHNF) before actual queueing.@@ -311,38 +303,38 @@ let (strNum, bufIdx) = divModBufferLength $ strIdx - offset str1 <- getStream strNum bufIdx str0 return (bufIdx, str1)- where- {-# INLINE getStream #-}- getStream 0 _ strA = return strA- getStream n bufIdx strA = do- strB <- waitNextStream strA bufIdx- getStream (n-1) bufIdx strB+ where+ {-# INLINE getStream #-}+ getStream 0 _ strA = return strA+ getStream n bufIdx strA = do+ strB <- waitNextStream strA bufIdx+ getStream (n-1) bufIdx strB {-# NOINLINE waitNextStream #-} waitNextStream :: Stream a -> Int -> IO (Stream a) waitNextStream (Stream _ nextStrRef offset) = go- where- {-# INLINE go #-}- go wait = do- ticket <- Atm.readForCAS nextStrRef- case Atm.peekTicket ticket of- NextStream strNext -> return strNext- nextSrc@(NextSource bufSrc)- | wait > 0 -> do- CC.yield- go (wait - 1)- | otherwise -> do- newBuf <- bufSrc- newNext <- Ref.newIORef nextSrc- let nextStrCand = NextStream Stream- { streamBuffer = newBuf- , streamNext = newNext- , streamOffset = offset + bufferLength- }- (_, next) <- Atm.casIORef nextStrRef ticket nextStrCand- case Atm.peekTicket next of- NextStream nextStr -> return nextStr- NextSource _ -> go 1+ where+ {-# INLINE go #-}+ go wait = do+ ticket <- Atm.readForCAS nextStrRef+ case Atm.peekTicket ticket of+ NextStream strNext -> return strNext+ nextSrc@(NextSource bufSrc)+ | wait > 0 -> do+ CC.yield+ go (wait - 1)+ | otherwise -> do+ newBuf <- bufSrc+ newNext <- Ref.newIORef nextSrc+ let nextStrCand = NextStream Stream+ { streamBuffer = newBuf+ , streamNext = newNext+ , streamOffset = offset + bufferLength+ }+ (_, next) <- Atm.casIORef nextStrRef ticket nextStrCand+ case Atm.peekTicket next of+ NextStream nextStr -> return nextStr+ NextSource _ -> go 1 -- | Search 'Stream' and return 'StreamIndex' and its 'Stream' -- of the oldest unavailable Item.@@ -350,13 +342,13 @@ searchStreamReadLimit :: Stream a -> StreamIndex -> IO (StreamIndex, Stream a) searchStreamReadLimit baseStr strIdx = go (strIdx - streamOffset baseStr) baseStr- where- {-# INLINE go #-}- go bufIdx stream@(Stream buf _ offset) = do- ret <- searchBufferReadLimit buf bufIdx- case ret of- Just retBufIdx -> return (offset + retBufIdx, stream)- Nothing -> waitNextStream stream 0 >>= go 0+ where+ {-# INLINE go #-}+ go bufIdx stream@(Stream buf _ offset) = do+ ret <- searchBufferReadLimit buf bufIdx+ case ret of+ Just retBufIdx -> return (offset + retBufIdx, stream)+ Nothing -> waitNextStream stream 0 >>= go 0 -- | Search 'Buffer' and return 'BufferIndex' -- of the oldest unavailable Item.@@ -364,18 +356,18 @@ {-# INLINE searchBufferReadLimit #-} searchBufferReadLimit :: Buffer a -> BufferIndex -> IO (Maybe BufferIndex) searchBufferReadLimit buf = go- where- {-# INLINE go #-}- go bufIdx- | idxIsOutOfBuf = return Nothing- | otherwise = do- item <- Arr.readArray buf bufIdx- case item of- None -> return $ Just bufIdx- Wait _ -> return $ Just bufIdx- _ -> go $ bufIdx + 1- where- idxIsOutOfBuf = bufIdx >= bufferLength+ where+ {-# INLINE go #-}+ go bufIdx+ | idxIsOutOfBuf = return Nothing+ | otherwise = do+ item <- Arr.readArray buf bufIdx+ case item of+ None -> return $ Just bufIdx+ Wait _ -> return $ Just bufIdx+ _ -> go $ bufIdx + 1+ where+ idxIsOutOfBuf = bufIdx >= bufferLength -- | Get the length of the items in the 'Queue'. --@@ -391,7 +383,11 @@ -- | Non-minus version of 'lengthQueue'. lengthQueue' :: Queue a -> IO Int lengthQueue' queue = f <$> lengthQueue queue- where- f i | i > 0 = i- | otherwise = 0+ where+ f i | i > 0 = i+ | otherwise = 0 +{-# INLINE gteIndex #-}+gteIndex :: Int -> Int -> Bool+gteIndex a b | a - b < 0 = False+ | otherwise = True
src/Control/Concurrent/WVar.hs view
@@ -13,9 +13,9 @@ -- There are two states in the user viewpoint. -- -- [@Fresh@] The 'WVar' is not being updated.--- This state corresponds to to full state of MVar.+-- This state corresponds to full state of 'MVar'. -- [@Updating@] The 'WVar' is being updated by someone.--- This state corresponds to to empty state of MVar.+-- This state corresponds to empty state of 'MVar'. -- However, cached previous value can be read while Updating. module Control.Concurrent.WVar@@ -45,7 +45,7 @@ , readFreshWCached , tryReadFreshWCached )- where+ where import Control.Concurrent.MVar (MVar) import qualified Control.Concurrent.MVar as MVar@@ -55,7 +55,8 @@ import qualified Data.IORef as Ref --------------------------------- WVar+-- $wvar+-- Main functions of 'WVar'. -- | "a" is the type of data in the WVar. newtype WVar a = WVar (IORef (WContent a))@@ -82,12 +83,12 @@ {-# INLINE tryTakeWVar #-} tryTakeWVar :: WVar a -> IO (Bool, a) tryTakeWVar wv = cacheWVar wv >>= go- where- go wc = do- (suc, wt1) <- tryTakeWCached wc- case (suc, wstate (Atm.peekTicket wt1)) of- (False, Fresh) -> go $ WCached wv wt1- _ -> return (suc, readWTicket wt1)+ where+ go wc = do+ (suc, wt1) <- tryTakeWCached wc+ case (suc, wstate (Atm.peekTicket wt1)) of+ (False, Fresh) -> go $ WCached wv wt1+ _ -> return (suc, readWTicket wt1) -- | Put the supplied value into a 'WVar'. -- It performs simple "write" when the 'WVar' is Fresh.
test/KazuraQueueConcurrentSpec.hs view
@@ -9,9 +9,8 @@ import qualified Test.KazuraQueue as T import qualified Test.Util as T -import qualified Test.Hspec as HS-import qualified Test.Hspec.QuickCheck as HS-import qualified Test.QuickCheck as Q+import qualified Test.Hspec as HS+import qualified Test.QuickCheck as Q import qualified Control.Concurrent as CC import qualified Control.Concurrent.Async as AS@@ -30,7 +29,7 @@ writeQueueSpec :: HS.Spec writeQueueSpec = HS.describe "writeQueue" $ do T.whenItemsInQueue (1,10) $ \ prepare -> do- HS.prop "write and read values concurrently" . prepare $ \ (q, pre) -> do+ T.ioprop "write and read values concurrently" . prepare $ \ (q, pre) -> do (val1 :: Int, val2, val3) <- Q.generate Q.arbitrary T.mapConcurrently_ [ KQ.writeQueue q val1 `T.shouldNotBlock` 500000@@ -56,7 +55,7 @@ readQueueSpec :: HS.Spec readQueueSpec = HS.describe "readQueue" $ do T.whenQueueIsEmpty $ \ prepare -> do- HS.prop "values are read in order (thread awakes out of order)" . prepare $ \ q -> do+ T.ioprop "values are read in order (thread awakes out of order)" . prepare $ \ q -> do waits0 <- M.replicateM 3 $ KQ.readQueue q `T.shouldBlock` 500000 q `T.queueLengthShouldBeIn` (-3, 0) (val1 :: Int, val2, val3) <- Q.generate Q.arbitrary@@ -75,137 +74,137 @@ tryReadQueueSpec :: HS.Spec tryReadQueueSpec = HS.describe "tryReadQueue" $ do T.whenItemsInQueue (1,10) $ \ prepare -> do- HS.prop "values are read in order" . prepare $ \ (q, pre :: [Int]) -> do- mrets <- M.replicateM 10 $ KQ.tryReadQueue q `T.shouldNotBlock` 500000+ T.ioprop "values are read in order" . prepare $ \ (q, pre :: [Int]) -> do+ mrets <- M.replicateM 10 $ KQ.tryReadQueue q `T.shouldNotBlock` 1000000 q `T.queueLengthShouldBeIn` (-10, 0) let nothings = L.replicate (10 - length pre) Nothing expected = (Just <$> pre) <> nothings mrets `T.shouldBe` expected T.whenQueueIsEmpty $ \ prepare -> do- HS.prop "read value after writing" . prepare $ \ q -> do+ T.ioprop "read value after writing" . prepare $ \ q -> do (val1 :: Int, val2, val3, val4) <- Q.generate Q.arbitrary- KQ.writeQueue q val1 `T.shouldNotBlock` 500000- mret1 <- KQ.tryReadQueue q `T.shouldNotBlock` 500000+ KQ.writeQueue q val1 `T.shouldNotBlock` 1000000+ mret1 <- KQ.tryReadQueue q `T.shouldNotBlock` 1000000 mret1 `T.shouldBe` Just val1- KQ.writeQueue q val2 `T.shouldNotBlock` 500000- mret2 <- KQ.tryReadQueue q `T.shouldNotBlock` 500000+ KQ.writeQueue q val2 `T.shouldNotBlock` 1000000+ mret2 <- KQ.tryReadQueue q `T.shouldNotBlock` 1000000 mret2 `T.shouldBe` Just val2- KQ.writeQueue q val3 `T.shouldNotBlock` 500000- mret3 <- KQ.tryReadQueue q `T.shouldNotBlock` 500000+ KQ.writeQueue q val3 `T.shouldNotBlock` 1000000+ mret3 <- KQ.tryReadQueue q `T.shouldNotBlock` 1000000 mret3 `T.shouldBe` Just val3- KQ.writeQueue q val4 `T.shouldNotBlock` 500000- mret4 <- KQ.tryReadQueue q `T.shouldNotBlock` 500000+ KQ.writeQueue q val4 `T.shouldNotBlock` 1000000+ mret4 <- KQ.tryReadQueue q `T.shouldNotBlock` 1000000 mret4 `T.shouldBe` Just val4 readWriteQueueSpec :: HS.Spec readWriteQueueSpec = HS.describe "readWriteQueueSpec" $ do T.whenQueueIsEmpty $ \ prepare -> do- HS.prop "read/write = 1/1" . prepare $ \ q -> do+ T.ioprop "read/write = 1/1" . prepare $ \ q -> do test (1,10000) (1,10000) q- HS.prop "read/write = 1/10" . prepare $ \ q -> do+ T.ioprop "read/write = 1/10" . prepare $ \ q -> do test (1,10000) (10,1000) q- HS.prop "read/write = 10/1" . prepare $ \ q -> do+ T.ioprop "read/write = 10/1" . prepare $ \ q -> do test (10,1000) (1,10000) q- HS.prop "read/write = 10/10" . prepare $ \ q -> do+ T.ioprop "read/write = 10/10" . prepare $ \ q -> do test (10,1000) (10,1000) q- where- test :: (Int,Int) -> (Int,Int) -> KQ.Queue (Int,Int) -> IO ()- test readConfig writeConfig q = do- (results, writtens) <-- readConcurrent q readConfig- `T.concurrently` writeConcurrent q writeConfig- case checkEachResult results of- Right _ -> return ()- Left str -> T.assertFailure str- let result = L.concat results- written = L.concat writtens- resultSet = Set.fromList result- writtenSet = Set.fromList written- length result `T.shouldBe` length written- (writtenSet `Set.difference` resultSet) `T.shouldBe` Set.empty- checkEachResult = TF.traverse checkEachItems- checkEachItems = L.foldl' checkItems $ Right Map.empty- checkItems (Right mp) (thnum, num)- | Map.lookup thnum mp < Just num = Right $ Map.insert thnum num mp- | Map.lookup thnum mp > Just num = Left "broken order"- | otherwise = Left "duplicated value"- checkItems err _ = err- readItems q size = M.replicateM size $ KQ.readQueue q- writeItems q items = do- TF.for_ items $ KQ.writeQueue q- return items- readConcurrent q (thsize, itemsize) = do- ass <- M.replicateM thsize . AS.async $ readItems q itemsize- TF.for ass AS.wait- writeConcurrent q (thsize, itemsize) = do- ass <- TF.for [1..thsize] $ \ thnum ->- AS.async . writeItems q $ fmap (thnum,) [1..itemsize]- TF.for ass AS.wait+ where+ test :: (Int,Int) -> (Int,Int) -> KQ.Queue (Int,Int) -> IO ()+ test readConfig writeConfig q = do+ (results, writtens) <-+ readConcurrent q readConfig+ `T.concurrently` writeConcurrent q writeConfig+ case checkEachResult results of+ Right _ -> return ()+ Left str -> T.assertFailure str+ let result = L.concat results+ written = L.concat writtens+ resultSet = Set.fromList result+ writtenSet = Set.fromList written+ length result `T.shouldBe` length written+ (writtenSet `Set.difference` resultSet) `T.shouldBe` Set.empty+ checkEachResult = TF.traverse checkEachItems+ checkEachItems = L.foldl' checkItems $ Right Map.empty+ checkItems (Right mp) (thnum, num)+ | Map.lookup thnum mp < Just num = Right $ Map.insert thnum num mp+ | Map.lookup thnum mp > Just num = Left "broken order"+ | otherwise = Left "duplicated value"+ checkItems err _ = err+ readItems q size = M.replicateM size $ KQ.readQueue q+ writeItems q items = do+ TF.for_ items $ KQ.writeQueue q+ return items+ readConcurrent q (thsize, itemsize) = do+ ass <- M.replicateM thsize . AS.async $ readItems q itemsize+ TF.for ass AS.wait+ writeConcurrent q (thsize, itemsize) = do+ ass <- TF.for [1..thsize] $ \ thnum ->+ AS.async . writeItems q $ fmap (thnum,) [1..itemsize]+ TF.for ass AS.wait tryReadWriteQueueSpec :: HS.Spec tryReadWriteQueueSpec = HS.describe "tryReadWriteQueueSpec" $ do T.whenQueueIsEmpty $ \ prepare -> do- HS.prop "read/write = 1/1" . prepare $ \ q -> do+ T.ioprop "read/write = 1/1" . prepare $ \ q -> do test (1,10000) (1,10000) q- HS.prop "read/write = 1/10" . prepare $ \ q -> do+ T.ioprop "read/write = 1/10" . prepare $ \ q -> do test (1,10000) (10,1000) q- HS.prop "read/write = 10/1" . prepare $ \ q -> do+ T.ioprop "read/write = 10/1" . prepare $ \ q -> do test (10,1000) (1,10000) q- HS.prop "read/write = 10/10" . prepare $ \ q -> do+ T.ioprop "read/write = 10/10" . prepare $ \ q -> do test (10,1000) (10,1000) q- where- test :: (Int,Int) -> (Int,Int) -> KQ.Queue (Int,Int) -> IO ()- test readConfig writeConfig q = do- (results, writtens) <-- readConcurrent q readConfig- `T.concurrently` writeConcurrent q writeConfig- case checkEachResult results of- Right _ -> return ()- Left str -> T.assertFailure str- let result = L.concat results- written = L.concat writtens- resultSet = Set.fromList result- writtenSet = Set.fromList written- length result `T.shouldBe` length written- (writtenSet `Set.difference` resultSet) `T.shouldBe` Set.empty- checkEachResult = TF.traverse checkEachItems- checkEachItems = L.foldl' checkItems $ Right Map.empty- checkItems (Right mp) (thnum, num)- | Map.lookup thnum mp < Just num = Right $ Map.insert thnum num mp- | Map.lookup thnum mp > Just num = Left "broken order"- | otherwise = Left "duplicated value"- checkItems err _ = err- readItem q = do- mret <- KQ.tryReadQueue q- case mret of- Just ret -> return ret- Nothing -> do- CC.yield- readItem q- readItems q size = M.replicateM size $ readItem q- writeItems q items = do- TF.for_ items $ KQ.writeQueue q- return items- readConcurrent q (thsize, itemsize) = do- ass <- M.replicateM thsize . AS.async $ readItems q itemsize- TF.for ass AS.wait- writeConcurrent q (thsize, itemsize) = do- ass <- TF.for [1..thsize] $ \ thnum ->- AS.async . writeItems q $ fmap (thnum,) [1..itemsize]- TF.for ass AS.wait+ where+ test :: (Int,Int) -> (Int,Int) -> KQ.Queue (Int,Int) -> IO ()+ test readConfig writeConfig q = do+ (results, writtens) <-+ readConcurrent q readConfig+ `T.concurrently` writeConcurrent q writeConfig+ case checkEachResult results of+ Right _ -> return ()+ Left str -> T.assertFailure str+ let result = L.concat results+ written = L.concat writtens+ resultSet = Set.fromList result+ writtenSet = Set.fromList written+ length result `T.shouldBe` length written+ (writtenSet `Set.difference` resultSet) `T.shouldBe` Set.empty+ checkEachResult = TF.traverse checkEachItems+ checkEachItems = L.foldl' checkItems $ Right Map.empty+ checkItems (Right mp) (thnum, num)+ | Map.lookup thnum mp < Just num = Right $ Map.insert thnum num mp+ | Map.lookup thnum mp > Just num = Left "broken order"+ | otherwise = Left "duplicated value"+ checkItems err _ = err+ readItem q = do+ mret <- KQ.tryReadQueue q+ case mret of+ Just ret -> return ret+ Nothing -> do+ CC.yield+ readItem q+ readItems q size = M.replicateM size $ readItem q+ writeItems q items = do+ TF.for_ items $ KQ.writeQueue q+ return items+ readConcurrent q (thsize, itemsize) = do+ ass <- M.replicateM thsize . AS.async $ readItems q itemsize+ TF.for ass AS.wait+ writeConcurrent q (thsize, itemsize) = do+ ass <- TF.for [1..thsize] $ \ thnum ->+ AS.async . writeItems q $ fmap (thnum,) [1..itemsize]+ TF.for ass AS.wait readQueueWithExceptionSpec :: HS.Spec readQueueWithExceptionSpec = HS.describe "readQueueWithExceptionSpec" $ do T.whenQueueIsEmpty $ \ prepare -> do- HS.prop "read/write = 1/1" . prepare $ \ q -> do+ T.ioprop "read/write = 1/1" . prepare $ \ q -> do test (1,10000) (1,10000) q- HS.prop "read/write = 1/10" . prepare $ \ q -> do+ T.ioprop "read/write = 1/10" . prepare $ \ q -> do test (1,10000) (10,1000) q- HS.prop "read/write = 10/1" . prepare $ \ q -> do+ T.ioprop "read/write = 10/1" . prepare $ \ q -> do test (10,1000) (1,10000) q- HS.prop "read/write = 10/10" . prepare $ \ q -> do+ T.ioprop "read/write = 10/10" . prepare $ \ q -> do test (10,1000) (10,1000) q- HS.prop "read/write ratio random 100000" . prepare $ \ q -> do+ T.ioprop "read/write ratio random 100000" . prepare $ \ q -> do let genthnum = Q.arbitrary `Q.suchThat` (> 0) `Q.suchThat` ((== 0).(100000 `mod`)) rthnum <- Q.generate $ genthnum@@ -213,84 +212,81 @@ let rnum = 100000 `div` rthnum wnum = 100000 `div` wthnum test (rthnum,rnum) (wthnum,wnum) q- where- test :: (Int,Int) -> (Int,Int) -> KQ.Queue (Int,Int) -> IO ()- test readConfig writeConfig q = do- (results, writtens) <- readConcurrent q readConfig- `T.concurrently` writeConcurrent q writeConfig--- putStrLn "-------------------"--- print results--- putStrLn "-------------------"- case checkEachResult results of- Right _ -> return ()- Left str -> T.assertFailure str- let result = L.concat results- written = L.concat writtens- resultSet = Set.fromList result- writtenSet = Set.fromList written- length result `T.shouldBe` length written- (writtenSet `Set.difference` resultSet) `T.shouldBe` Set.empty- checkEachResult = TF.traverse checkEachItems- checkEachItems = L.foldl' checkItems $ Right Map.empty- checkItems (Right mp) (thnum, num)- | Map.lookup thnum mp < Just num = Right $ Map.insert thnum num mp- | Map.lookup thnum mp > Just num = Left "broken order"- | otherwise = Left "duplicated value"- checkItems err _ = err- readItem refItems refCount q = do- r <- KQ.readQueueWithoutMask q- Ref.modifyIORef refCount (1+)- Ref.modifyIORef refItems (r:)- tryReadItem refItems refCount q = do- mr <- KQ.tryReadQueueWithoutMask q- case mr of- Just r -> do- Ref.modifyIORef refCount (1+)- Ref.modifyIORef refItems (r:)- Nothing -> do- CC.yield- tryReadItem refItems refCount q- readItemOne refItems refCount q = E.mask_ $ do- select <- Q.generate Q.arbitrary- if select- then readItem refItems refCount q- else tryReadItem refItems refCount q- readItems refItems refCount q size restore !c = do- M.void . T.ignoreException . restore $ readItemOne refItems refCount q- count <- Ref.readIORef refCount- M.when (count < size && c < size * 100) $- readItems refItems refCount q size restore $ c + 1- readConcurrent q (thsize, itemsize) = do- ass <- E.mask $ \ restore ->- M.replicateM thsize . AS.async $ do- refItems <- Ref.newIORef []- refCount <- Ref.newIORef 0- readItems refItems refCount q itemsize restore (0 :: Int)- reverse <$> Ref.readIORef refItems- M.void . AS.async $ T.throwExceptionRandomly ass- TF.for ass AS.wait- writeItem refItems q = E.mask_ $ do- items <- Ref.readIORef refItems- case items of- [] -> return Nothing- v:next -> do- KQ.writeQueueWithoutMask q v- Ref.writeIORef refItems next- return $ Just v- writeItems refItems q restore !c = do- mmwritten <- T.ignoreException . restore $ writeItem refItems q- case mmwritten of- Just Nothing -> return ()- _ -> writeItems refItems q restore $ c + 1- writeConcurrent q (thsize, itemsize) = do- ass <- E.mask $ \ restore ->- TF.for [1..thsize] $ \ thnum -> AS.async $ do- let items = fmap (thnum,) [1..itemsize] :: [(Int, Int)]- refItems <- Ref.newIORef items- writeItems refItems q restore (0 :: Int)- return items- M.void . AS.async $ T.throwExceptionRandomly ass- TF.for ass AS.wait+ where+ test :: (Int,Int) -> (Int,Int) -> KQ.Queue (Int,Int) -> IO ()+ test readConfig writeConfig q = do+ (results, writtens) <- readConcurrent q readConfig+ `T.concurrently` writeConcurrent q writeConfig+ case checkEachResult results of+ Right _ -> return ()+ Left str -> T.assertFailure str+ let result = L.concat results+ written = L.concat writtens+ resultSet = Set.fromList result+ writtenSet = Set.fromList written+ length result `T.shouldBe` length written+ (writtenSet `Set.difference` resultSet) `T.shouldBe` Set.empty+ checkEachResult = TF.traverse checkEachItems+ checkEachItems = L.foldl' checkItems $ Right Map.empty+ checkItems (Right mp) (thnum, num)+ | Map.lookup thnum mp < Just num = Right $ Map.insert thnum num mp+ | Map.lookup thnum mp > Just num = Left "broken order"+ | otherwise = Left "duplicated value"+ checkItems err _ = err+ readItem refItems refCount q = do+ r <- KQ.readQueueWithoutMask q+ Ref.modifyIORef refCount (1+)+ Ref.modifyIORef refItems (r:)+ tryReadItem refItems refCount q = do+ mr <- KQ.tryReadQueueWithoutMask q+ case mr of+ Just r -> do+ Ref.modifyIORef refCount (1+)+ Ref.modifyIORef refItems (r:)+ Nothing -> do+ CC.yield+ tryReadItem refItems refCount q+ readItemOne refItems refCount q = E.mask_ $ do+ select <- Q.generate Q.arbitrary+ if select+ then readItem refItems refCount q+ else tryReadItem refItems refCount q+ readItems refItems refCount q size restore !c = do+ M.void . T.ignoreException . restore $ readItemOne refItems refCount q+ count <- Ref.readIORef refCount+ M.when (count < size && c < size * 100) $+ readItems refItems refCount q size restore $ c + 1+ readConcurrent q (thsize, itemsize) = do+ ass <- E.mask $ \ restore ->+ M.replicateM thsize . AS.async $ do+ refItems <- Ref.newIORef []+ refCount <- Ref.newIORef 0+ readItems refItems refCount q itemsize restore (0 :: Int)+ reverse <$> Ref.readIORef refItems+ M.void . AS.async $ T.throwExceptionRandomly ass+ TF.for ass AS.wait+ writeItem refItems q = E.mask_ $ do+ items <- Ref.readIORef refItems+ case items of+ [] -> return Nothing+ v:next -> do+ KQ.writeQueueWithoutMask q v+ Ref.writeIORef refItems next+ return $ Just v+ writeItems refItems q restore !c = do+ mmwritten <- T.ignoreException . restore $ writeItem refItems q+ case mmwritten of+ Just Nothing -> return ()+ _ -> writeItems refItems q restore $ c + 1+ writeConcurrent q (thsize, itemsize) = do+ ass <- E.mask $ \ restore ->+ TF.for [1..thsize] $ \ thnum -> AS.async $ do+ let items = fmap (thnum,) [1..itemsize] :: [(Int, Int)]+ refItems <- Ref.newIORef items+ writeItems refItems q restore (0 :: Int)+ return items+ M.void . AS.async $ T.throwExceptionRandomly ass+ TF.for ass AS.wait spec :: HS.Spec spec = HS.describe "KazuraQueue concurrent specs" $ do
test/Test/Concurrent.hs view
@@ -3,7 +3,9 @@ module Test.Concurrent where -import qualified Test.QuickCheck as Q+import qualified Test.Hspec as HS+import qualified Test.Hspec.QuickCheck as HS+import qualified Test.QuickCheck as Q import qualified Control.Concurrent as CC import qualified Control.Concurrent.Async as AS@@ -17,6 +19,10 @@ import qualified Data.Traversable as TF import Data.Typeable (Typeable) +-- | Multiple times test enabled IO spec+ioprop :: (HS.HasCallStack, Q.Testable prop) => String -> prop -> HS.Spec+ioprop desc prop = HS.prop desc $ \ () -> prop+ class HasThread th where threadId :: th -> IO CC.ThreadId throwTo :: E.Exception e => th -> e -> IO ()@@ -57,9 +63,9 @@ mdelay2 <- Q.generate $ arbitraryDelay 20000 withWaitStart $ \ wait -> wrap wait mdelay1 act1 `AS.concurrently` wrap wait mdelay2 act2- where- wrap :: IO () -> Maybe Int -> IO a -> IO a- wrap wait mdelay act = wait >> TF.for mdelay CC.threadDelay >> act+ where+ wrap :: IO () -> Maybe Int -> IO a -> IO a+ wrap wait mdelay act = wait >> TF.for mdelay CC.threadDelay >> act mapConcurrently :: [IO a] -> IO [a] mapConcurrently acts = do@@ -67,9 +73,9 @@ mds <- Q.generate . Q.vectorOf len $ fmap (`mod` 20000) <$> Q.arbitrary withWaitStart $ \ wait -> do AS.mapConcurrently id $ wrap wait <$> zip mds acts- where- wrap :: IO () -> (Maybe Int, IO a) -> IO a- wrap wait (mdelay, act) = wait >> TF.for mdelay CC.threadDelay >> act+ where+ wrap :: IO () -> (Maybe Int, IO a) -> IO a+ wrap wait (mdelay, act) = wait >> TF.for mdelay CC.threadDelay >> act mapConcurrently_ :: [IO a] -> IO () mapConcurrently_ = M.void . mapConcurrently@@ -90,13 +96,13 @@ waitAnyAtLeast :: HasThread th => Int -> (CC.ThreadStatus -> Bool) -> [th] -> IO [(Int, CC.ThreadStatus)] waitAnyAtLeast num f ths = go- where- go = do- statuses <- M.sequence $ threadStatus <$> ths- let satisfied = filter (f . snd) $ zip [0..] statuses- if length satisfied >= num- then return satisfied- else CC.threadDelay 1 >> go+ where+ go = do+ statuses <- M.sequence $ threadStatus <$> ths+ let satisfied = filter (f . snd) $ zip [0..] statuses+ if length satisfied >= num+ then return satisfied+ else CC.threadDelay 1 >> go data RandomException = RandomException Int String deriving (Show, Typeable)@@ -120,20 +126,20 @@ throwExceptionRandomly :: HasThread th => [th] -> IO () throwExceptionRandomly ths = go (1 :: Int)- where- getAlives = fmap MB.catMaybes . M.sequence $ runningThreadId <$> ths- go !c = do- mdelay <- Q.generate $ arbitraryDelay $ 20000 * c- case mdelay of- Just delay -> CC.threadDelay delay- Nothing -> return ()- alives <- getAlives- if length alives == 0- then return ()- else do- alive <- Q.generate $ Q.elements alives- throwTo alive . RandomException c $ show mdelay ++ " : " ++ show (length alives)- go $ c+1+ where+ getAlives = fmap MB.catMaybes . M.sequence $ runningThreadId <$> ths+ go !c = do+ mdelay <- Q.generate $ arbitraryDelay $ 20000 * c+ case mdelay of+ Just delay -> CC.threadDelay delay+ Nothing -> return ()+ alives <- getAlives+ if length alives == 0+ then return ()+ else do+ alive <- Q.generate $ Q.elements alives+ throwTo alive . RandomException c $ show mdelay ++ " : " ++ show (length alives)+ go $ c+1 arbitraryDelay :: Int -> Q.Gen (Maybe Int) arbitraryDelay limit = do@@ -143,5 +149,4 @@ case mbase of Just base -> return . Just . (`mod` limit) $ base * multi1 * multi2 Nothing -> return Nothing-
test/Test/Expectations.hs view
@@ -33,17 +33,17 @@ assertFailure :: String -> IO x assertFailure desc = do- HU.assertFailure desc+ M.void $ HU.assertFailure desc error "dummy" failWithException :: (String -> String) -> IO x -> IO y failWithException descf wait = proc `E.catch` returnError- where- returnError (E.SomeException err) = do- assertFailure . descf $ "but aborted with: " <> show err- proc = do- M.void wait- assertFailure $ descf "died with no exception (test maybe wrong)"+ where+ returnError (E.SomeException err) = do+ assertFailure . descf $ "but aborted with: " <> show err+ proc = do+ M.void wait+ assertFailure $ descf "died with no exception (test maybe wrong)" -------------------- -- assertions@@ -54,19 +54,19 @@ assertEqual :: (Show x, Eq x) => x -> x -> IO () assertEqual expected actual = assertTrue (expected == actual) desc- where- desc = mkDesc 80 "expected" expectedStr <> "\n" <>- mkDesc 80 "actual " actualStr- expectedStr = show expected- actualStr = show actual+ where+ desc = mkDesc 80 "expected" expectedStr <> "\n" <>+ mkDesc 80 "actual " actualStr+ expectedStr = show expected+ actualStr = show actual assertNotEqual :: (Show x, Eq x) => x -> x -> IO () assertNotEqual expected actual = assertTrue (expected /= actual) desc- where- desc = mkDesc 80 "expected not to be" expectedStr <> "\n" <>- mkDesc 80 "actual" actualStr- expectedStr = show expected- actualStr = show actual+ where+ desc = mkDesc 80 "expected not to be" expectedStr <> "\n" <>+ mkDesc 80 "actual" actualStr+ expectedStr = show expected+ actualStr = show actual shouldBe :: (Show x, Eq x) => x -> x -> IO () shouldBe = flip assertEqual@@ -76,28 +76,28 @@ shouldSatisfy :: Show x => x -> (x -> Bool) -> IO () shouldSatisfy x f = assertTrue (f x) desc- where- desc = "assertion failed on: " ++ show x+ where+ desc = "assertion failed on: " ++ show x shouldContain :: (Show x, Eq x) => [x] -> [x] -> IO () shouldContain actual expected = assertTrue result $ desc- where- result = expected `L.isInfixOf` actual- desc = mkDesc 80 "expected to contain" expectedStr <> "\n" <>- mkDesc 80 "but actual" actualStr- expectedStr = show expected- actualStr = show actual+ where+ result = expected `L.isInfixOf` actual+ desc = mkDesc 80 "expected to contain" expectedStr <> "\n" <>+ mkDesc 80 "but actual" actualStr+ expectedStr = show expected+ actualStr = show actual shouldReturn :: (Show x, Eq x) => IO x -> x -> IO () shouldReturn act expected = do ex <- E.try act case ex of- Right x -> x `shouldBe` expected+ Right x -> x `shouldBe` expected Left (E.SomeException err) -> HU.assertFailure $ desc err- where- desc err = mkDesc 80 "expected" expectedStr <> "\n" <>- mkDesc 80 "but exception throwed" (show err)- expectedStr = show expected+ where+ desc err = mkDesc 80 "expected" expectedStr <> "\n" <>+ mkDesc 80 "but exception throwed" (show err)+ expectedStr = show expected shouldThrow :: (Show x, E.Exception e) => IO x -> Selector e -> IO () shouldThrow act selector = do@@ -108,14 +108,14 @@ Just e | selector e -> return () | otherwise -> HU.assertFailure $ descF err Nothing -> HU.assertFailure $ descE err- where- descX x = expectedStr <> mkDesc 80 "but returned" (show x)- descF e = expectedStr <> mkDesc 80 "but selector failed for" (show e)- descE e = expectedStr <> mkDesc 80 "but exception throwed" (show e)- expectedStr = mkDesc 80 "expected to throw" exceptedType <> "\n"- exceptedType = (show . TP.typeOf . instanceOf) selector- instanceOf :: Selector a -> a- instanceOf _ = error "dummy data of shouldThrow"+ where+ descX x = expectedStr <> mkDesc 80 "but returned" (show x)+ descF e = expectedStr <> mkDesc 80 "but selector failed for" (show e)+ descE e = expectedStr <> mkDesc 80 "but exception throwed" (show e)+ expectedStr = mkDesc 80 "expected to throw" exceptedType <> "\n"+ exceptedType = (show . TP.typeOf . instanceOf) selector+ instanceOf :: Selector a -> a+ instanceOf _ = error "dummy data of shouldThrow" -- gc expectations @@ -147,8 +147,8 @@ Just (CC.ThreadBlocked _) -> return () _ -> HU.assertFailure $ desc "but still running" return async- where- desc str = "expected to block in " <> show time <> " nanosec\n" <> str+ where+ desc str = "expected to block in " <> show time <> " nanosec\n" <> str shouldStillBlock :: AS.Async x -> Int -> IO () shouldStillBlock async time = M.void $ AS.wait async `shouldBlock` time@@ -166,9 +166,9 @@ CC.ThreadRunning -> HU.assertFailure . desc $ "but still running" wait- where- desc str = "expected to awake and finish in "- <> show time <> " nanosec\n" <> str+ where+ desc str = "expected to awake and finish in " <>+ show time <> " nanosec\n" <> str onlyOneShouldAwakeFinish :: [AS.Async x] -> Int -> IO (x, [AS.Async x]) onlyOneShouldAwakeFinish asyncs0 time = do@@ -184,9 +184,9 @@ CC.ThreadDied -> failWithException desc wait _ -> assertFailure . desc $ "unknown case" return (x, asyncs1)- where- desc str = "expected to awake only one and finish in "- <> show time <> " nanosec\n" <> str+ where+ desc str = "expected to awake only one and finish in " <>+ show time <> " nanosec\n" <> str shouldNotBlock :: IO x -> Int -> IO x shouldNotBlock act time = do@@ -200,9 +200,9 @@ HU.assertFailure . desc $ "but blocked with " <> show reason _ -> HU.assertFailure $ desc "but still running" wait- where- desc str = "expected not to block and finish in " <> show time <>- " nanosec\n" <> str+ where+ desc str = "expected not to block and finish in " <>+ show time <> " nanosec\n" <> str shouldFinish :: IO x -> Int -> IO x shouldFinish act time = do@@ -216,9 +216,9 @@ HU.assertFailure . desc $ "but blocked with " <> show reason _ -> HU.assertFailure $ desc "but still running" wait- where- desc str = "expected to finish in " <> show time <>- " nanosec\n" <> str+ where+ desc str = "expected to finish in " <> show time <>+ " nanosec\n" <> str --------------------------- --- util@@ -227,15 +227,15 @@ mkDesc len s1 s2 | length s1 + length str > len = s1 <> ":\n\t" <> str | otherwise = s1 <> ": " <> str- where- str = truncateString 512 s2+ where+ str = truncateString 512 s2 truncateString :: Int -> String -> String truncateString len str | null rest = res | otherwise = res <> "..."- where- (res, rest) = L.splitAt len str+ where+ (res, rest) = L.splitAt len str and :: [a -> Bool] -> (a -> Bool) and (c:cs) a | c a = and cs a
test/Test/KazuraQueue.hs view
@@ -26,25 +26,25 @@ whenQueueIsEmpty :: (((KQ.Queue x -> IO r) -> IO r) -> HS.Spec) -> HS.Spec whenQueueIsEmpty f = HS.describe "when Queue is empty" $ f prepare- where- prepare :: (KQ.Queue x -> IO r) -> IO r- prepare iof = do- q <- KQ.newQueue- timeout . prependIndefiniteBlock q $ iof q+ where+ prepare :: (KQ.Queue x -> IO r) -> IO r+ prepare iof = do+ q <- KQ.newQueue+ timeout . prependIndefiniteBlock q $ iof q whenItemsInQueue :: Q.Arbitrary x => (Int, Int) -> ((((KQ.Queue x, [x]) -> IO r) -> IO r) -> HS.Spec) -> HS.Spec whenItemsInQueue range f = HS.describe "when some items in Queue" $ f prepare- where- (minSize, maxSize) = range- len = maxSize - minSize + 1- prepare :: Q.Arbitrary x => ((KQ.Queue x, [x]) -> IO r) -> IO r- prepare iof = do- num <- (+ minSize) . (`mod` len) . abs <$> Q.generate Q.arbitrary- vals <- M.replicateM num $ Q.generate Q.arbitrary- queue <- KQ.newQueue- TF.for_ vals $ KQ.writeQueue queue- timeout . prependIndefiniteBlock queue $ iof (queue, vals)+ where+ (minSize, maxSize) = range+ len = maxSize - minSize + 1+ prepare :: Q.Arbitrary x => ((KQ.Queue x, [x]) -> IO r) -> IO r+ prepare iof = do+ num <- (+ minSize) . (`mod` len) . abs <$> Q.generate Q.arbitrary+ vals <- M.replicateM num $ Q.generate Q.arbitrary+ queue <- KQ.newQueue+ TF.for_ vals $ KQ.writeQueue queue+ timeout . prependIndefiniteBlock queue $ iof (queue, vals) prependIndefiniteBlock :: KQ.Queue x -> IO r -> IO r prependIndefiniteBlock queue io = do
test/Test/Util.hs view
@@ -19,20 +19,20 @@ oneOfWithIndex :: [IO x] -> IO (x, Int) oneOfWithIndex = go 0- where- go _ [] = error "actions must include at least one element"- go x (io:[]) = (, x) <$> io- go x (io:ios) = ((, x) <$> io)- `E.catch` \ (E.SomeException _) -> go (x+1) ios+ where+ go _ [] = error "actions must include at least one element"+ go x (io:[]) = (, x) <$> io+ go x (io:ios) = ((, x) <$> io)+ `E.catch` \ (E.SomeException _) -> go (x+1) ios genSatisfy :: Q.Arbitrary a => Int -> (a -> Bool) -> IO [a] genSatisfy num f = M.replicateM num . Q.generate $ Q.arbitrary `Q.suchThat` f pickUp :: Int -> [x] -> (x, [x]) pickUp idx xs = (rx, hxs ++ drop 1 txs)- where- (hxs, txs) = L.splitAt idx xs- rx = case take 1 txs of- r:_ -> r- _ -> error "invalid index to pickUp"+ where+ (hxs, txs) = L.splitAt idx xs+ rx = case take 1 txs of+ r:_ -> r+ _ -> error "invalid index to pickUp"
test/Test/WVar.hs view
@@ -11,52 +11,52 @@ withLatestCache :: (IO (v, v, WV.WVar v, WV.WCached v) -> r) -> IO (v, WV.WVar v) -> r withLatestCache f prepare = f prepare'- where- prepare' = do- (val, wv) <- prepare- wc <- WV.cacheWVar wv- return (val, val, wv, wc)+ where+ prepare' = do+ (val, wv) <- prepare+ wc <- WV.cacheWVar wv+ return (val, val, wv, wc) whenWVarIsFresh :: (IO (Int, WV.WVar Int) -> HS.Spec) -> HS.Spec whenWVarIsFresh f = HS.describe "when WVar is fresh" $ f prepare- where- prepare = do- val <- Q.generate Q.arbitrary- wv <- WV.newWVar val- return (val, wv)+ where+ prepare = do+ val <- Q.generate Q.arbitrary+ wv <- WV.newWVar val+ return (val, wv) whenWVarIsUpdating :: Q.Arbitrary v => (IO (v, WV.WVar v) -> HS.Spec) -> HS.Spec whenWVarIsUpdating f = HS.describe "when WVar is updating" $ f prepare- where- prepare = do- val <- Q.generate Q.arbitrary- wv <- WV.newWVar val- M.void $ WV.takeWVar wv- return (val, wv)+ where+ prepare = do+ val <- Q.generate Q.arbitrary+ wv <- WV.newWVar val+ M.void $ WV.takeWVar wv+ return (val, wv) whenWVarIsFreshButCacheStaled :: (Eq v, Q.Arbitrary v) => (IO (v, v, WV.WVar v, WV.WCached v) -> HS.Spec) -> HS.Spec whenWVarIsFreshButCacheStaled f = HS.describe "when WVar is fresh but cache staled" $ f prepare- where- prepare = do- val1 <- Q.generate Q.arbitrary- val2 <- Q.generate $ Q.arbitrary `Q.suchThat` (/= val1)- wv <- WV.newWVar val1- wc <- WV.cacheWVar wv- WV.putWVar wv val2- return (val1, val2, wv, wc)+ where+ prepare = do+ val1 <- Q.generate Q.arbitrary+ val2 <- Q.generate $ Q.arbitrary `Q.suchThat` (/= val1)+ wv <- WV.newWVar val1+ wc <- WV.cacheWVar wv+ WV.putWVar wv val2+ return (val1, val2, wv, wc) whenWVarIsUpdatingAndCacheStaled :: (Eq v, Q.Arbitrary v) => (IO (v, v, WV.WVar v, WV.WCached v) -> HS.Spec) -> HS.Spec whenWVarIsUpdatingAndCacheStaled f = HS.describe "when WVar is updating and cache staled" $ f prepare- where- prepare = do- val <- Q.generate Q.arbitrary- wv <- WV.newWVar val- wc <- WV.cacheWVar wv- M.void $ WV.takeWVar wv- return (val, val, wv, wc)+ where+ prepare = do+ val <- Q.generate Q.arbitrary+ wv <- WV.newWVar val+ wc <- WV.cacheWVar wv+ M.void $ WV.takeWVar wv+ return (val, val, wv, wc)
test/WVarConcurrentSpec.hs view
@@ -7,8 +7,7 @@ import qualified Test.Util as T import qualified Test.WVar as T -import qualified Test.Hspec as HS-import qualified Test.Hspec.QuickCheck as HS+import qualified Test.Hspec as HS import qualified Control.Concurrent.WVar as WV import qualified Control.Monad as M@@ -18,7 +17,7 @@ takeWVarSeqSpec :: HS.Spec takeWVarSeqSpec = HS.describe "takeWVar" $ do T.whenWVarIsFresh $ \ prepare -> do- HS.prop "takes the value before or after putWVar" $ do+ T.ioprop "takes the value before or after putWVar" $ do (val1, wv) <- prepare [val2] <- T.genSatisfy 1 (/= val1) M.void $ WV.putWVar wv val2 `T.concurrently` do@@ -27,7 +26,7 @@ [ ret `T.shouldBe` val1 , ret `T.shouldBe` val2 ]- HS.prop "take different value" $ do+ T.ioprop "take different value" $ do (val1, wv) <- prepare [val2, val3, val4] <- T.genSatisfy 3 (/= val1) ret <- T.mapConcurrently@@ -44,13 +43,13 @@ , ret `T.shouldBe` [val4,val2,val1] ] T.whenWVarIsUpdating $ \ prepare -> do- HS.prop "takes the value after putWVar" $ do+ T.ioprop "takes the value after putWVar" $ do (val1, wv) <- prepare [val2] <- T.genSatisfy 1 (/= val1) M.void $ WV.putWVar wv val2 `T.concurrently` do ret <- WV.takeWVar wv ret `T.shouldBe` val2- HS.prop "take different value" $ do+ T.ioprop "take different value" $ do (val1 :: Int, wv) <- prepare [val2, val3, val4, val5] <- T.genSatisfy 4 (/= val1) ret <- T.mapConcurrently@@ -71,7 +70,7 @@ tryTakeWVarSeqSpec :: HS.Spec tryTakeWVarSeqSpec = HS.describe "tryTakeWVar" $ do T.whenWVarIsFresh $ \ prepare -> do- HS.prop "takes the value before or after putWVar" $ do+ T.ioprop "takes the value before or after putWVar" $ do (val1 :: Int, wv) <- prepare [val2] <- T.genSatisfy 1 (/= val1) M.void $ WV.putWVar wv val2 `T.concurrently` do@@ -80,7 +79,7 @@ [ ret `T.shouldBe` (True, val1) , ret `T.shouldBe` (True, val2) ]- HS.prop "all read same value but only one succeeded" $ do+ T.ioprop "all read same value but only one succeeded" $ do (val :: Int, wv) <- prepare ret <- T.mapConcurrently [ WV.tryTakeWVar wv@@ -93,7 +92,7 @@ , ret `T.shouldBe` [(False,val),(False,val),(True,val)] ] T.whenWVarIsUpdating $ \ prepare -> do- HS.prop "takes the value before(failure) or after(success) putWVar" $ do+ T.ioprop "takes the value before(failure) or after(success) putWVar" $ do (val1 :: Int, wv) <- prepare [val2] <- T.genSatisfy 1 (/= val1) M.void $ WV.putWVar wv val2 `T.concurrently` do@@ -102,7 +101,7 @@ [ ret `T.shouldBe` (False, val1) , ret `T.shouldBe` (True, val2) ]- HS.prop "all read same value and fail" $ do+ T.ioprop "all read same value and fail" $ do (val :: Int, wv) <- prepare ret <- T.mapConcurrently [ WV.tryTakeWVar wv@@ -114,7 +113,7 @@ readFreshWVarSeqSpec :: HS.Spec readFreshWVarSeqSpec = HS.describe "readFreshWVar" $ do T.whenWVarIsFresh $ \ prepare -> do- HS.prop "reads the value before or after putWVar" $ do+ T.ioprop "reads the value before or after putWVar" $ do (val1 :: Int, wv) <- prepare [val2] <- T.genSatisfy 1 (/= val1) M.void $ WV.putWVar wv val2 `T.concurrently` do@@ -123,7 +122,7 @@ [ ret `T.shouldBe` val1 , ret `T.shouldBe` val2 ]- HS.prop "read same value" $ do+ T.ioprop "read same value" $ do (val :: Int, wv) <- prepare ret <- T.mapConcurrently [ WV.readFreshWVar wv@@ -132,13 +131,13 @@ ] ret `T.shouldBe` [val,val,val] T.whenWVarIsUpdating $ \ prepare -> do- HS.prop "reads the value after putWVar" $ do+ T.ioprop "reads the value after putWVar" $ do (val1 :: Int, wv) <- prepare [val2] <- T.genSatisfy 1 (/= val1) M.void $ WV.putWVar wv val2 `T.concurrently` do ret <- WV.readFreshWVar wv ret `T.shouldBe` val2- HS.prop "read same value" $ do+ T.ioprop "read same value" $ do (val1 :: Int, wv) <- prepare [val2] <- T.genSatisfy 1 (/= val1) ret <- T.mapConcurrently@@ -152,7 +151,7 @@ tryReadFreshWVarSeqSpec :: HS.Spec tryReadFreshWVarSeqSpec = HS.describe "tryReadWVar" $ do T.whenWVarIsFresh $ \ prepare -> do- HS.prop "reads the old value" $ do+ T.ioprop "reads the old value" $ do (val1 :: Int, wv) <- prepare [val2] <- T.genSatisfy 1 (/= val1) M.void $ WV.putWVar wv val2 `T.concurrently` do@@ -161,7 +160,7 @@ [ ret `T.shouldBe` (True, val1) , ret `T.shouldBe` (True, val2) ]- HS.prop "all read same value and succeed" $ do+ T.ioprop "all read same value and succeed" $ do (val :: Int, wv) <- prepare ret <- T.mapConcurrently [ WV.tryReadFreshWVar wv@@ -170,7 +169,7 @@ ] ret `T.shouldBe` [(True,val),(True,val),(True,val)] T.whenWVarIsUpdating $ \ prepare -> do- HS.prop "reads the value before(failure) or after(success) putWVar" $ do+ T.ioprop "reads the value before(failure) or after(success) putWVar" $ do (val1 :: Int, wv) <- prepare [val2] <- T.genSatisfy 1 (/= val1) M.void $ WV.putWVar wv val2 `T.concurrently` do@@ -179,7 +178,7 @@ [ ret `T.shouldBe` (False, val1) , ret `T.shouldBe` (True, val2) ]- HS.prop "all read same value and fail" $ do+ T.ioprop "all read same value and fail" $ do (val :: Int, wv) <- prepare ret <- T.mapConcurrently [ WV.tryReadFreshWVar wv@@ -191,7 +190,7 @@ takeWCachedSeqSpec :: HS.Spec takeWCachedSeqSpec = HS.describe "takeWCached" $ do T.whenWVarIsFresh . T.withLatestCache $ \ prepare -> do- HS.prop "takes the value before or after putWCached" $ do+ T.ioprop "takes the value before or after putWCached" $ do (_, val1 :: Int, _, wc) <- prepare [val2] <- T.genSatisfy 1 (/= val1) M.void $ WV.putWCached wc val2 `T.concurrently` do@@ -200,7 +199,7 @@ [ WV.readWTicket wt `T.shouldBe` val1 , WV.readWTicket wt `T.shouldBe` val2 ]- HS.prop "take different value" $ do+ T.ioprop "take different value" $ do (_, val1 :: Int, _, wc) <- prepare [val2, val3, val4] <- T.genSatisfy 3 (/= val1) ret <- fmap WV.readWTicket <$> T.mapConcurrently@@ -217,13 +216,13 @@ , ret `T.shouldBe` [val4,val2,val1] ] T.whenWVarIsUpdating . T.withLatestCache $ \ prepare -> do- HS.prop "takes the value after putWCached" $ do+ T.ioprop "takes the value after putWCached" $ do (_, val1 :: Int, _, wc) <- prepare [val2] <- T.genSatisfy 1 (/= val1) M.void $ WV.putWCached wc val2 `T.concurrently` do ret <- WV.takeWCached wc WV.readWTicket ret `T.shouldBe` val2- HS.prop "take different value" $ do+ T.ioprop "take different value" $ do (_, val1 :: Int, _, wc) <- prepare [val2, val3, val4, val5] <- T.genSatisfy 4 (/= val1) ret <- T.mapConcurrently@@ -241,7 +240,7 @@ , ret `T.shouldBe` [val2,val5,val3,val2] ] T.whenWVarIsFreshButCacheStaled $ \ prepare -> do- HS.prop "takes the value before or after putWCached" $ do+ T.ioprop "takes the value before or after putWCached" $ do (_, val1 :: Int, _, wc) <- prepare [val2] <- T.genSatisfy 1 (/= val1) M.void $ WV.putWCached wc val2 `T.concurrently` do@@ -250,7 +249,7 @@ [ WV.readWTicket wt `T.shouldBe` val1 , WV.readWTicket wt `T.shouldBe` val2 ]- HS.prop "take different value" $ do+ T.ioprop "take different value" $ do (_, val1 :: Int, _, wc) <- prepare [val2, val3, val4] <- T.genSatisfy 3 (/= val1) ret <- fmap WV.readWTicket <$> T.mapConcurrently@@ -267,13 +266,13 @@ , ret `T.shouldBe` [val4,val2,val1] ] T.whenWVarIsUpdatingAndCacheStaled $ \ prepare -> do- HS.prop "takes the value after putWCached" $ do+ T.ioprop "takes the value after putWCached" $ do (_, val1 :: Int, _, wc) <- prepare [val2] <- T.genSatisfy 1 (/= val1) M.void $ WV.putWCached wc val2 `T.concurrently` do ret <- WV.takeWCached wc WV.readWTicket ret `T.shouldBe` val2- HS.prop "take different value" $ do+ T.ioprop "take different value" $ do (_, val1 :: Int, _, wc) <- prepare [val2, val3, val4, val5] <- T.genSatisfy 4 (/= val1) ret <- T.mapConcurrently@@ -294,7 +293,7 @@ tryTakeWCachedSeqSpec :: HS.Spec tryTakeWCachedSeqSpec = HS.describe "tryTakeWCached" $ do T.whenWVarIsFresh . T.withLatestCache $ \ prepare -> do- HS.prop "takes the value before(failure)/after(success) putWCached" $ do+ T.ioprop "takes the value before(failure)/after(success) putWCached" $ do (_, val1 :: Int, _, wc) <- prepare [val2] <- T.genSatisfy 1 (/= val1) M.void $ WV.putWCached wc val2 `T.concurrently` do@@ -303,7 +302,7 @@ [ (ret, WV.readWTicket wt) `T.shouldBe` (True, val1) , (ret, WV.readWTicket wt) `T.shouldBe` (False, val2) ]- HS.prop "all read same value but only one succeeded" $ do+ T.ioprop "all read same value but only one succeeded" $ do (_, val1 :: Int, _, wc) <- prepare ret <- fmap (fmap WV.readWTicket) <$> T.mapConcurrently [ WV.tryTakeWCached wc@@ -316,7 +315,7 @@ , ret `T.shouldBe` [(False,val1),(False,val1),(True,val1)] ] T.whenWVarIsUpdating . T.withLatestCache $ \ prepare -> do- HS.prop "takes the value before or after putWCached with failure" $ do+ T.ioprop "takes the value before or after putWCached with failure" $ do (_, val1 :: Int, _, wc) <- prepare [val2] <- T.genSatisfy 1 (/= val1) M.void $ WV.putWCached wc val2 `T.concurrently` do@@ -325,7 +324,7 @@ [ (ret, WV.readWTicket wt) `T.shouldBe` (False, val1) , (ret, WV.readWTicket wt) `T.shouldBe` (False, val2) ]- HS.prop "all read same value and fail" $ do+ T.ioprop "all read same value and fail" $ do (_, val1 :: Int, _, wc) <- prepare ret <- fmap (fmap WV.readWTicket) <$> T.mapConcurrently [ WV.tryTakeWCached wc@@ -334,7 +333,7 @@ ] ret `T.shouldBe` [(False,val1),(False,val1),(False,val1)] T.whenWVarIsFreshButCacheStaled $ \ prepare -> do- HS.prop "takes the value before or after putWCached with failure" $ do+ T.ioprop "takes the value before or after putWCached with failure" $ do (_, val1 :: Int, _, wc) <- prepare [val2] <- T.genSatisfy 1 (/= val1) M.void $ WV.putWCached wc val2 `T.concurrently` do@@ -343,7 +342,7 @@ [ (ret, WV.readWTicket wt) `T.shouldBe` (False, val1) , (ret, WV.readWTicket wt) `T.shouldBe` (False, val2) ]- HS.prop "all read same value and fail" $ do+ T.ioprop "all read same value and fail" $ do (_, val1 :: Int, _, wc) <- prepare ret <- fmap (fmap WV.readWTicket) <$> T.mapConcurrently [ WV.tryTakeWCached wc@@ -352,7 +351,7 @@ ] ret `T.shouldBe` [(False,val1),(False,val1),(False,val1)] T.whenWVarIsUpdatingAndCacheStaled $ \ prepare -> do- HS.prop "takes the value before or after putWCached with failure" $ do+ T.ioprop "takes the value before or after putWCached with failure" $ do (_, val1 :: Int, _, wc) <- prepare [val2] <- T.genSatisfy 1 (/= val1) M.void $ WV.putWCached wc val2 `T.concurrently` do@@ -361,7 +360,7 @@ [ (ret, WV.readWTicket wt) `T.shouldBe` (False, val1) , (ret, WV.readWTicket wt) `T.shouldBe` (False, val2) ]- HS.prop "all read same value and fail" $ do+ T.ioprop "all read same value and fail" $ do (_, val1 :: Int, _, wc) <- prepare ret <- fmap (fmap WV.readWTicket) <$> T.mapConcurrently [ WV.tryTakeWCached wc@@ -373,13 +372,13 @@ readFreshWCachedSeqSpec :: HS.Spec readFreshWCachedSeqSpec = HS.describe "readFreshWCached" $ do T.whenWVarIsFresh . T.withLatestCache $ \ prepare -> do- HS.prop "reads the value before or after putWCached" $ do+ T.ioprop "reads the value before or after putWCached" $ do (val1 :: Int, _, _, wc) <- prepare [val2] <- T.genSatisfy 1 (/= val1) M.void $ WV.putWCached wc val2 `T.concurrently` do wt <- WV.readFreshWCached wc `T.shouldNotBlock` 500000 WV.readWTicket wt `T.shouldBe` val1- HS.prop "read same value" $ do+ T.ioprop "read same value" $ do (val1 :: Int, _, _, wc) <- prepare ret <- fmap WV.readWTicket <$> T.mapConcurrently [ WV.readFreshWCached wc@@ -388,13 +387,13 @@ ] ret `T.shouldBe` [val1,val1,val1] T.whenWVarIsUpdating . T.withLatestCache $ \ prepare -> do- HS.prop "reads the value after putWCached" $ do+ T.ioprop "reads the value after putWCached" $ do (val1 :: Int, _, _, wc) <- prepare [val2] <- T.genSatisfy 1 (/= val1) M.void $ WV.putWCached wc val2 `T.concurrently` do wt <- WV.readFreshWCached wc WV.readWTicket wt `T.shouldBe` val2- HS.prop "read same value" $ do+ T.ioprop "read same value" $ do (val1 :: Int, _, _, wc) <- prepare [val2] <- T.genSatisfy 1 (/= val1) ret <- T.mapConcurrently@@ -405,13 +404,13 @@ ] ret `T.shouldBe` [val2,val2,val2,val2] T.whenWVarIsFreshButCacheStaled $ \ prepare -> do- HS.prop "reads the value before or after putWCached" $ do+ T.ioprop "reads the value before or after putWCached" $ do (val1 :: Int, _, _, wc) <- prepare [val2] <- T.genSatisfy 1 (/= val1) M.void $ WV.putWCached wc val2 `T.concurrently` do wt <- WV.readFreshWCached wc `T.shouldNotBlock` 500000 WV.readWTicket wt `T.shouldBe` val1- HS.prop "read same value" $ do+ T.ioprop "read same value" $ do (val1 :: Int, _, _, wc) <- prepare ret <- fmap WV.readWTicket <$> T.mapConcurrently [ WV.readFreshWCached wc@@ -420,13 +419,13 @@ ] ret `T.shouldBe` [val1,val1,val1] T.whenWVarIsUpdatingAndCacheStaled $ \ prepare -> do- HS.prop "reads the value after putWCached" $ do+ T.ioprop "reads the value after putWCached" $ do (val1 :: Int, _, _, wc) <- prepare [val2] <- T.genSatisfy 1 (/= val1) M.void $ WV.putWCached wc val2 `T.concurrently` do ret <- WV.readWTicket <$> WV.readFreshWCached wc ret `T.shouldBe` val1- HS.prop "read same value" $ do+ T.ioprop "read same value" $ do (val1 :: Int, _, _, wc) <- prepare [val2] <- T.genSatisfy 1 (/= val1) ret <- T.mapConcurrently@@ -440,13 +439,13 @@ tryReadFreshWCachedSeqSpec :: HS.Spec tryReadFreshWCachedSeqSpec = HS.describe "tryReadWCached" $ do T.whenWVarIsFresh . T.withLatestCache $ \ prepare -> do- HS.prop "reads the old value and succeed" $ do+ T.ioprop "reads the old value and succeed" $ do (val1 :: Int, _, _, wc) <- prepare [val2] <- T.genSatisfy 1 (/= val1) M.void $ WV.putWCached wc val2 `T.concurrently` do ret <- WV.tryReadFreshWCached wc `T.shouldNotBlock` 500000 fmap WV.readWTicket ret `T.shouldBe` (True, val1)- HS.prop "all read same value and succeed" $ do+ T.ioprop "all read same value and succeed" $ do (val1 :: Int, _, _, wc) <- prepare ret <- fmap (fmap WV.readWTicket) <$> T.mapConcurrently [ WV.tryReadFreshWCached wc@@ -455,13 +454,13 @@ ] ret `T.shouldBe` [(True,val1),(True,val1),(True,val1)] T.whenWVarIsUpdating . T.withLatestCache $ \ prepare -> do- HS.prop "reads the old value and fail" $ do+ T.ioprop "reads the old value and fail" $ do (val1 :: Int, _, _, wc) <- prepare [val2] <- T.genSatisfy 1 (/= val1) M.void $ WV.putWCached wc val2 `T.concurrently` do ret <- WV.tryReadFreshWCached wc `T.shouldNotBlock` 500000 fmap WV.readWTicket ret `T.shouldBe` (False, val1)- HS.prop "all read same value and fail" $ do+ T.ioprop "all read same value and fail" $ do (val1 :: Int, _, _, wc) <- prepare ret <- fmap (fmap WV.readWTicket) <$> T.mapConcurrently [ WV.tryReadFreshWCached wc@@ -470,13 +469,13 @@ ] ret `T.shouldBe` [(False,val1),(False,val1),(False,val1)] T.whenWVarIsFreshButCacheStaled $ \ prepare -> do- HS.prop "reads the old value and succeed" $ do+ T.ioprop "reads the old value and succeed" $ do (val1 :: Int, _, _, wc) <- prepare [val2] <- T.genSatisfy 1 (/= val1) M.void $ WV.putWCached wc val2 `T.concurrently` do ret <- WV.tryReadFreshWCached wc `T.shouldNotBlock` 500000 fmap WV.readWTicket ret `T.shouldBe` (True, val1)- HS.prop "all read same value and succeed" $ do+ T.ioprop "all read same value and succeed" $ do (val1 :: Int, _, _, wc) <- prepare ret <- fmap (fmap WV.readWTicket) <$> T.mapConcurrently [ WV.tryReadFreshWCached wc@@ -485,13 +484,13 @@ ] ret `T.shouldBe` [(True,val1),(True,val1),(True,val1)] T.whenWVarIsUpdating . T.withLatestCache $ \ prepare -> do- HS.prop "reads the old value and fail" $ do+ T.ioprop "reads the old value and fail" $ do (val1 :: Int, _, _, wc) <- prepare [val2] <- T.genSatisfy 1 (/= val1) M.void $ WV.putWCached wc val2 `T.concurrently` do ret <- WV.tryReadFreshWCached wc `T.shouldNotBlock` 500000 fmap WV.readWTicket ret `T.shouldBe` (False, val1)- HS.prop "all read same value and fail" $ do+ T.ioprop "all read same value and fail" $ do (val1 :: Int, _, _, wc) <- prepare ret <- fmap (fmap WV.readWTicket) <$> T.mapConcurrently [ WV.tryReadFreshWCached wc@@ -502,24 +501,24 @@ tryTakeAndPutCachedSeqSpec :: HS.Spec tryTakeAndPutCachedSeqSpec =- HS.prop "tryTakeWCached and putWCached perform atomic modification" $ do+ T.ioprop "tryTakeWCached and putWCached perform atomic modification" $ do wv <- WV.newWVar (0 :: Int) wc <- WV.cacheWVar wv ret <- L.sort . L.concat <$> T.mapConcurrently (countConc10 wc) ret `T.shouldBe` [1..1000]- where- countConc10 wc = L.replicate 10 $ count100 wc- count100 wc = M.replicateM 100 $ countOne wc- countOne wc = do- (suc, wt1) <- WV.tryTakeWCached wc- let val = WV.readWTicket wt1- if suc- then do- wt2 <- WV.putWCached wc $ val + 1- return $ WV.readWTicket wt2- else do- wt2 <- WV.readFreshWCached wc { WV.cachedTicket = wt1 }- countOne wc { WV.cachedTicket = wt2 }+ where+ countConc10 wc = L.replicate 10 $ count100 wc+ count100 wc = M.replicateM 100 $ countOne wc+ countOne wc = do+ (suc, wt1) <- WV.tryTakeWCached wc+ let val = WV.readWTicket wt1+ if suc+ then do+ wt2 <- WV.putWCached wc $ val + 1+ return $ WV.readWTicket wt2+ else do+ wt2 <- WV.readFreshWCached wc { WV.cachedTicket = wt1 }+ countOne wc { WV.cachedTicket = wt2 } wvarSpec :: HS.Spec wvarSpec = do
test/WVarSpec.hs view
@@ -132,13 +132,13 @@ T.whenWVarIsUpdating $ T.withLatestCache failToTakeButReadLatest T.whenWVarIsFreshButCacheStaled failToTakeButReadLatest T.whenWVarIsUpdatingAndCacheStaled failToTakeButReadLatest- where- failToTakeButReadLatest prepare = do- HS.it "fails but reads the latest value without blocking" $ do- (_, val :: Int, _, wc) <- prepare- (ret, wt) <- WV.tryTakeWCached wc `T.shouldNotBlock` 500000- ret `T.shouldBe` False- WV.readWTicket wt `T.shouldBe` val+ where+ failToTakeButReadLatest prepare = do+ HS.it "fails but reads the latest value without blocking" $ do+ (_, val :: Int, _, wc) <- prepare+ (ret, wt) <- WV.tryTakeWCached wc `T.shouldNotBlock` 500000+ ret `T.shouldBe` False+ WV.readWTicket wt `T.shouldBe` val putWCachedSpec :: HS.Spec putWCachedSpec = HS.describe "putWCached" $ do@@ -146,13 +146,13 @@ T.whenWVarIsUpdating $ T.withLatestCache writeValueWithoutBlocking T.whenWVarIsFreshButCacheStaled writeValueWithoutBlocking T.whenWVarIsUpdatingAndCacheStaled writeValueWithoutBlocking- where- writeValueWithoutBlocking prepare = do- HS.it "writes the value without blocking" $ do- (_, val1 :: Int, _, wc) <- prepare- val2 <- Q.generate $ Q.arbitrary `Q.suchThat` (/= val1)- wt <- WV.putWCached wc val2 `T.shouldNotBlock` 500000- WV.readWTicket wt `T.shouldBe` val2+ where+ writeValueWithoutBlocking prepare = do+ HS.it "writes the value without blocking" $ do+ (_, val1 :: Int, _, wc) <- prepare+ val2 <- Q.generate $ Q.arbitrary `Q.suchThat` (/= val1)+ wt <- WV.putWCached wc val2 `T.shouldNotBlock` 500000+ WV.readWTicket wt `T.shouldBe` val2 tryPutWCachedSpec :: HS.Spec tryPutWCachedSpec = HS.describe "tryPutWCached" $ do@@ -160,21 +160,21 @@ T.whenWVarIsUpdating $ T.withLatestCache writeValueWithoutBlocking T.whenWVarIsFreshButCacheStaled failToWrite T.whenWVarIsUpdatingAndCacheStaled failToWrite- where- writeValueWithoutBlocking prepare = do- HS.it "writes the value without blocking" $ do- (_, val1 :: Int, _, wc) <- prepare- val2 <- Q.generate $ Q.arbitrary `Q.suchThat` (/= val1)- (ret, wt) <- WV.tryPutWCached wc val2 `T.shouldNotBlock` 500000- ret `T.shouldBe` True- WV.readWTicket wt `T.shouldBe` val2- failToWrite prepare = do- HS.it "fails to write the value without blocking" $ do- (_, val1 :: Int, _, wc) <- prepare- val2 <- Q.generate $ Q.arbitrary `Q.suchThat` (/= val1)- (ret, wt) <- WV.tryPutWCached wc val2 `T.shouldNotBlock` 500000- ret `T.shouldBe` False- WV.readWTicket wt `T.shouldBe` val1+ where+ writeValueWithoutBlocking prepare = do+ HS.it "writes the value without blocking" $ do+ (_, val1 :: Int, _, wc) <- prepare+ val2 <- Q.generate $ Q.arbitrary `Q.suchThat` (/= val1)+ (ret, wt) <- WV.tryPutWCached wc val2 `T.shouldNotBlock` 500000+ ret `T.shouldBe` True+ WV.readWTicket wt `T.shouldBe` val2+ failToWrite prepare = do+ HS.it "fails to write the value without blocking" $ do+ (_, val1 :: Int, _, wc) <- prepare+ val2 <- Q.generate $ Q.arbitrary `Q.suchThat` (/= val1)+ (ret, wt) <- WV.tryPutWCached wc val2 `T.shouldNotBlock` 500000+ ret `T.shouldBe` False+ WV.readWTicket wt `T.shouldBe` val1 readWCachedSpec :: HS.Spec readWCachedSpec = HS.describe "readWCached" $ do@@ -182,15 +182,15 @@ T.whenWVarIsUpdating $ T.withLatestCache readLatestValue T.whenWVarIsFreshButCacheStaled readOldValue T.whenWVarIsUpdatingAndCacheStaled readOldValue- where- readLatestValue prepare = do- HS.it "reads the latest value in the ticket" $ do- (_, val :: Int, _, wc) <- prepare- WV.readWCached wc `T.shouldBe` val- readOldValue prepare = do- HS.it "reads the old value in the ticket" $ do- (val :: Int, _, _, wc) <- prepare- WV.readWCached wc `T.shouldBe` val+ where+ readLatestValue prepare = do+ HS.it "reads the latest value in the ticket" $ do+ (_, val :: Int, _, wc) <- prepare+ WV.readWCached wc `T.shouldBe` val+ readOldValue prepare = do+ HS.it "reads the old value in the ticket" $ do+ (val :: Int, _, _, wc) <- prepare+ WV.readWCached wc `T.shouldBe` val readFreshWCachedSpec :: HS.Spec readFreshWCachedSpec = HS.describe "readFreshWCached" $ do@@ -211,12 +211,12 @@ WV.readWTicket wt `T.shouldBe` val2 T.whenWVarIsFreshButCacheStaled readOldValue T.whenWVarIsUpdatingAndCacheStaled readOldValue- where- readOldValue prepare = do- HS.it "reads the old value without blocking" $ do- (val :: Int, _, _, wc) <- prepare- wt <- WV.readFreshWCached wc `T.shouldNotBlock` 500000- WV.readWTicket wt `T.shouldBe` val+ where+ readOldValue prepare = do+ HS.it "reads the old value without blocking" $ do+ (val :: Int, _, _, wc) <- prepare+ wt <- WV.readFreshWCached wc `T.shouldNotBlock` 500000+ WV.readWTicket wt `T.shouldBe` val tryReadFreshWCachedSpec :: HS.Spec tryReadFreshWCachedSpec = HS.describe "tryReadFreshWCached" $ do
− test/doctest.hs
@@ -1,10 +0,0 @@-module Main where--import Test.DocTest--main :: IO ()-main = doctest- [ "-isrc"- , "src/Control/Concurrent/WVar.hs"- , "src/Control/Concurrent/KazuraQueue.hs"- ]
+ test/kazura-queue-doctest.hs view
@@ -0,0 +1,10 @@+module Main where++import qualified Test.DocTest as Doc++main :: IO ()+main = Doc.doctest+ [ "-isrc"+ , "src/Control/Concurrent/WVar.hs"+ , "src/Control/Concurrent/KazuraQueue.hs"+ ]