diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for kazura-queue-z + +## Unreleased changes diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,1 @@ +# kazura-queue diff --git a/bench/Main.hs b/bench/Main.hs --- a/bench/Main.hs +++ b/bench/Main.hs @@ -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 diff --git a/kazura-queue.cabal b/kazura-queue.cabal --- a/kazura-queue.cabal +++ b/kazura-queue.cabal @@ -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 diff --git a/src/Control/Concurrent/KazuraQueue.hs b/src/Control/Concurrent/KazuraQueue.hs --- a/src/Control/Concurrent/KazuraQueue.hs +++ b/src/Control/Concurrent/KazuraQueue.hs @@ -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 diff --git a/src/Control/Concurrent/WVar.hs b/src/Control/Concurrent/WVar.hs --- a/src/Control/Concurrent/WVar.hs +++ b/src/Control/Concurrent/WVar.hs @@ -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. diff --git a/test/KazuraQueueConcurrentSpec.hs b/test/KazuraQueueConcurrentSpec.hs --- a/test/KazuraQueueConcurrentSpec.hs +++ b/test/KazuraQueueConcurrentSpec.hs @@ -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 diff --git a/test/Test/Concurrent.hs b/test/Test/Concurrent.hs --- a/test/Test/Concurrent.hs +++ b/test/Test/Concurrent.hs @@ -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 - diff --git a/test/Test/Expectations.hs b/test/Test/Expectations.hs --- a/test/Test/Expectations.hs +++ b/test/Test/Expectations.hs @@ -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 diff --git a/test/Test/KazuraQueue.hs b/test/Test/KazuraQueue.hs --- a/test/Test/KazuraQueue.hs +++ b/test/Test/KazuraQueue.hs @@ -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 diff --git a/test/Test/Util.hs b/test/Test/Util.hs --- a/test/Test/Util.hs +++ b/test/Test/Util.hs @@ -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" diff --git a/test/Test/WVar.hs b/test/Test/WVar.hs --- a/test/Test/WVar.hs +++ b/test/Test/WVar.hs @@ -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) diff --git a/test/WVarConcurrentSpec.hs b/test/WVarConcurrentSpec.hs --- a/test/WVarConcurrentSpec.hs +++ b/test/WVarConcurrentSpec.hs @@ -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 diff --git a/test/WVarSpec.hs b/test/WVarSpec.hs --- a/test/WVarSpec.hs +++ b/test/WVarSpec.hs @@ -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 diff --git a/test/doctest.hs b/test/doctest.hs deleted file mode 100644 --- a/test/doctest.hs +++ /dev/null @@ -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" - ] diff --git a/test/kazura-queue-doctest.hs b/test/kazura-queue-doctest.hs new file mode 100644 --- /dev/null +++ b/test/kazura-queue-doctest.hs @@ -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" + ]