broadcast-chan-tests (empty) → 0.2.0
raw patch · 6 files changed
+880/−0 lines, 6 filesdep +asyncdep +basedep +bifunctorssetup-changed
Dependencies added: async, base, bifunctors, broadcast-chan, broadcast-chan-tests, clock, containers, foldl, monad-loops, optparse-applicative, paramtree, random, stm, tagged, tasty, tasty-golden, tasty-hunit, tasty-travis, temporary, text, transformers, unix
Files
- BroadcastChan/Test.hs +370/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- broadcast-chan-tests.cabal +105/−0
- tests/Basic.hs +321/−0
- tests/IOTest.hs +52/−0
+ BroadcastChan/Test.hs view
@@ -0,0 +1,370 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE ScopedTypeVariables #-}+-------------------------------------------------------------------------------+-- |+-- Module : BroadcastChan.Test+-- Copyright : (C) 2014-2018 Merijn Verstraaten+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Merijn Verstraaten <merijn@inconsistent.nl>+-- Stability : experimental+-- Portability : haha+--+-- Module containing testing helpers shared across all broadcast-chan packages.+-------------------------------------------------------------------------------+module BroadcastChan.Test+ ( (@?)+ , expect+ , genStreamTests+ , runTests+ , withLoggedOutput+ , MonadIO(..)+ , mapHandler+ -- * Re-exports of @tasty@ and @tasty-hunit@+ , module Test.Tasty+ , module Test.Tasty.HUnit+ ) where++import Prelude hiding (seq)+#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>),(<*>))+#endif+import Control.Concurrent (threadDelay)+import Control.Concurrent.Async (wait, withAsync)+import Control.Concurrent.MVar+import Control.Concurrent.STM+import Control.Monad (void, when)+import Control.Monad.IO.Class (MonadIO(liftIO))+import Control.Exception (Exception, throwIO, try)+import Data.Bifunctor (second)+import Data.IntSet (IntSet)+import qualified Data.IntSet as IS+import Data.List (sort)+import Data.Map (Map)+import qualified Data.Map as M+import Data.Monoid ((<>), mconcat)+import Data.Proxy (Proxy(Proxy))+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.IO as T+import Data.Tagged (Tagged, untag)+import Data.Typeable (Typeable)+import Options.Applicative (switch, long, help)+import System.Clock+ (Clock(Monotonic), TimeSpec, diffTimeSpec, getTime, toNanoSecs)+#if !MIN_VERSION_base(4,7,0)+import System.Posix.Env (setEnv)+#else+import System.Environment (setEnv)+#endif+import System.IO (Handle, SeekMode(AbsoluteSeek), hPrint, hSeek)+import System.IO.Temp (withSystemTempFile)+import Test.Tasty+import Test.Tasty.Golden.Advanced (goldenTest)+import Test.Tasty.HUnit hiding ((@?))+import qualified Test.Tasty.HUnit as HUnit+import Test.Tasty.Options+import Test.Tasty.Travis++import BroadcastChan.Extra (Action(..), Handler(..), mapHandler)+import ParamTree++data TestException = TestException deriving (Eq, Show, Typeable)+instance Exception TestException++infix 0 @?+-- | Monomorphised version of 'Test.Tasty.HUnit.@?' to avoid ambiguous type+-- errors when combined with predicates that are @MonadIO m => m Bool@.+(@?) :: IO Bool -> String -> Assertion+(@?) = (HUnit.@?)++-- | Test which fails if the expected exception is not thrown by the 'IO'+-- action.+expect :: (Eq e, Exception e) => e -> IO () -> Assertion+expect err act = do+ result <- try act+ case result of+ Left e | e == err -> return ()+ | otherwise -> assertFailure $+ "Expected: " ++ show err ++ "\nGot: " ++ show e+ Right _ -> assertFailure $ "Expected exception, got success."++-- | Pauses a number of microseconds before returning its input.+doNothing :: Int -> a -> IO a+doNothing threadPause x = do+ threadDelay threadPause+ return x++-- | Print a value, then return it.+doPrint :: Show a => Handle -> a -> IO a+doPrint hnd x = do+ hPrint hnd x+ return x++doDrop :: Show a => (a -> Bool) -> Handle -> a -> IO a+doDrop predicate hnd val+ | predicate val = throwIO TestException+ | otherwise = doPrint hnd val++fromTimeSpec :: Fractional n => TimeSpec -> n+fromTimeSpec = fromIntegral . toNanoSecs++speedupTest+ :: forall r . (Eq r, Show r)+ => IO (TVar (Map ([Int], Int) (MVar (r, Double))))+ -> ([Int] -> (Int -> IO Int) -> IO r)+ -> ([Int] -> (Int -> IO Int) -> Int -> IO r)+ -> Int+ -> [Int]+ -> Int+ -> String+ -> TestTree+speedupTest getCache seqSink parSink n inputs pause name = testCase name $ do+ withAsync cachedSequential $ \seqAsync ->+ withAsync (timed $ parSink inputs testFun n) $ \parAsync -> do+ (seqResult, seqTime) <- wait seqAsync+ (parResult, parTime) <- wait parAsync+ seqResult @=? parResult+ let lowerBound :: Double+ lowerBound = seqTime / (fromIntegral n + 1)++ upperBound :: Double+ upperBound = seqTime / (fromIntegral n - 1)++ errorMsg :: String+ errorMsg = mconcat+ [ "Parallel time should be 1/"+ , show n+ , "th of sequential time!\n"+ , "Actual time was 1/"+ , show (round $ seqTime / parTime :: Int)+ , "th (", show (seqTime/parTime), ")"+ ]+ assertBool errorMsg $ lowerBound < parTime && parTime < upperBound+ where+ testFun :: Int -> IO Int+ testFun = doNothing pause++ timed :: IO a -> IO (a, Double)+ timed = fmap (\(x, t) -> (x, fromTimeSpec t)) . withTime++ cachedSequential :: IO (r, Double)+ cachedSequential = do+ mvar <- newEmptyMVar+ cacheTVar <- getCache+ result <- atomically $ do+ cacheMap <- readTVar cacheTVar+ let (oldVal, newMap) = M.insertLookupWithKey+ (\_ _ v -> v)+ (inputs, pause)+ mvar+ cacheMap+ writeTVar cacheTVar newMap+ return oldVal++ case result of+ Just var -> readMVar var+ Nothing -> do+ timed (seqSink inputs testFun) >>= putMVar mvar+ readMVar mvar++-- | Run an IO action while logging the output to a @Handle@. Returns the+-- result and the logged output.+withLoggedOutput :: FilePath -> (Handle -> IO r) -> IO (r, Text)+withLoggedOutput filename act = withSystemTempFile filename $ \_ hnd ->+ (,) <$> act hnd <*> rewindAndRead hnd+ where+ rewindAndRead :: Handle -> IO Text+ rewindAndRead hnd = do+ hSeek hnd AbsoluteSeek 0+ T.hGetContents hnd++nonDeterministicGolden+ :: forall r+ . (Eq r, Show r)+ => String+ -> (Handle -> IO r)+ -> (Handle -> IO r)+ -> TestTree+nonDeterministicGolden label controlAction testAction =+ goldenTest label (normalise control) (normalise test) diff update+ where+ normalise :: MonadIO m => IO (a, Text) -> m (a, Text)+ normalise = liftIO . fmap (second (T.strip . T.unlines . sort . T.lines))++ control :: IO (r, Text)+ control = withLoggedOutput "control.out" controlAction++ test :: IO (r, Text)+ test = withLoggedOutput "test.out" testAction++ diff :: (r, Text) -> (r, Text) -> IO (Maybe String)+ diff (controlResult, controlOutput) (testResult, testOutput) =+ return $ resultDiff <> outputDiff+ where+ resultDiff :: Maybe String+ resultDiff+ | controlResult == testResult = Nothing+ | otherwise = Just "Results differ!\n"++ outputDiff :: Maybe String+ outputDiff+ | controlOutput == testOutput = Nothing+ | otherwise = Just . mconcat $+ [ "Outputs differ!\n"+ , "Expected:\n\"", T.unpack controlOutput, "\"\n\n"+ , "Got:\n\"", T.unpack testOutput, "\"\n"+ ]++ update :: (r, Text) -> IO ()+ update _ = return ()++outputTest+ :: forall r . (Eq r, Show r)+ => ([Int] -> (Int -> IO Int) -> IO r)+ -> ([Int] -> (Int -> IO Int) -> Int -> IO r)+ -> Int+ -> [Int]+ -> String+ -> TestTree+outputTest seqSink parSink threads inputs label =+ nonDeterministicGolden label seqTest parTest+ where+ seqTest :: Handle -> IO r+ seqTest = seqSink inputs . doPrint++ parTest :: Handle -> IO r+ parTest hndl = parSink inputs (doPrint hndl) threads++dropTest+ :: (Eq r, Show r)+ => ([Int] -> (Int -> IO Int) -> IO r)+ -> (Handler IO Int -> [Int] -> (Int -> IO Int) -> Int -> IO r)+ -> TestTree+dropTest seqImpl parImpl = nonDeterministicGolden "drop"+ (seqImpl filteredInputs . doPrint)+ (\hnd -> parImpl (Simple Drop) inputs (doDrop even hnd) 2)+ where+ inputs = [1..100]+ filteredInputs = filter (not . even) inputs++terminationTest+ :: (Handler IO Int -> [Int] -> (Int -> IO Int) -> Int -> IO r) -> TestTree+terminationTest parImpl = testCase "termination" $+ expect TestException . void $+ withSystemTempFile "terminate.out" $ \_ hndl ->+ parImpl (Simple Terminate) [1..100] (doDrop even hndl) 4++retryTest+ :: (Eq r, Show r)+ => ([Int] -> (Int -> IO Int) -> IO r)+ -> (Handler IO Int -> [Int] -> (Int -> IO Int) -> Int -> IO r)+ -> TestTree+retryTest seqImpl parImpl = withRetryCheck $ \getRetryCheck ->+ nonDeterministicGolden+ "retry"+ (seqImpl seqInputs . doPrint)+ (\h -> parImpl (Simple Retry) parInputs (dropAfterPrint getRetryCheck h) 4)+ where+ withRetryCheck = withResource alloc clean+ where+ alloc = updateRetry <$> newMVar IS.empty+ clean _ = return ()++ parInputs = [1..100]+ seqInputs = parInputs ++ filter even parInputs++ updateRetry :: MVar IntSet -> Int -> IO Bool+ updateRetry mvar val = modifyMVar mvar updateSet+ where+ updateSet :: IntSet -> IO (IntSet, Bool)+ updateSet set+ | IS.member val set = return (set, False)+ | otherwise = return (IS.insert val set, True)++ dropAfterPrint :: IO (Int -> IO Bool) -> Handle -> Int -> IO Int+ dropAfterPrint checkPresence hnd val = do+ hPrint hnd val+ when (even val) $ do+ isNotPresent <- checkPresence >>= ($val)+ when isNotPresent $ throwIO TestException+ return val++newtype SlowTests = SlowTests Bool+ deriving (Eq, Ord, Typeable)++instance IsOption SlowTests where+ defaultValue = SlowTests False+ parseValue = fmap SlowTests . safeRead+ optionName = return "slow-tests"+ optionHelp = return "Run slow tests."+ optionCLParser =+ fmap SlowTests $+ switch+ ( long (untag (optionName :: Tagged SlowTests String))+ <> help (untag (optionHelp :: Tagged SlowTests String))+ )++-- | Takes a name, a sequential sink, and a parallel sink and generates tasty+-- tests from these.+--+-- The parallel and sequential sink should perform the same tasks so their+-- results can be compared to check correctness.+--+-- The sinks should take a list of input data, a function processing the data,+-- and return a result that can be compared for equality.+--+-- Furthermore the parallel sink should take a number indicating how many+-- concurrent consumers should be used.+genStreamTests+ :: (Eq r, Show r)+ => String -- ^ Name to group tests under+ -> ([Int] -> (Int -> IO Int) -> IO r) -- ^ Sequential sink+ -> (Handler IO Int -> [Int] -> (Int -> IO Int) -> Int -> IO r)+ -- ^ Parallel sink+ -> TestTree+genStreamTests name seq par = askOption $ \(SlowTests slow) ->+ withResource (newTVarIO M.empty) (const $ return ()) $ \getCache ->+ let+ testTree = growTree (Just ".") testGroup+ threads = simpleParam "threads" [1,2,5]+ bigInputs | slow = derivedParam (enumFromTo 0) "inputs" [600]+ | otherwise = derivedParam (enumFromTo 0) "inputs" [300]+ smallInputs = derivedParam (enumFromTo 0) "inputs" [0,1,2]+ pause = simpleParam "pause" [10^(5 :: Int)]++ in testGroup name+ [ testTree "output" (outputTest seq (par term)) $+ threads . paramSets [ smallInputs, bigInputs ]+ , testTree "speedup" (speedupTest getCache seq (par term)) $+ threads . bigInputs . pause+ , testGroup "exceptions"+ [ dropTest seq par, terminationTest par, retryTest seq par ]+ ]+ where+ term = Simple Terminate++-- | Run a list of 'TestTree''s and group them under the specified name.+runTests :: String -> [TestTree] -> IO ()+runTests name tests = do+ setEnv "TASTY_NUM_THREADS" "100"+#if !MIN_VERSION_base(4,7,0)+ True+#endif+ travisTestReporter travisConfig ingredients $ testGroup name tests+ where+ ingredients = [ includingOptions [Option (Proxy :: Proxy SlowTests)] ]++ travisConfig = defaultConfig+ { travisFoldGroup = FoldMoreThan 1+ , travisSummaryWhen = SummaryAlways+ , travisTestOptions = setOption (SlowTests True)+ }++withTime :: IO a -> IO (a, TimeSpec)+withTime act = do+ start <- getTime Monotonic+ r <- act+ end <- getTime Monotonic+ return $ (r, diffTimeSpec start end)
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2013-2017, Merijn Verstraaten++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Merijn Verstraaten nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ broadcast-chan-tests.cabal view
@@ -0,0 +1,105 @@+Name: broadcast-chan-tests+Version: 0.2.0++Homepage: https://github.com/merijn/broadcast-chan+Bug-Reports: https://github.com/merijn/broadcast-chan/issues++Author: Merijn Verstraaten+Maintainer: Merijn Verstraaten <merijn@inconsistent.nl>+Copyright: Copyright © 2014-2018 Merijn Verstraaten++License: BSD3+License-File: LICENSE++Category: System+Cabal-Version: >= 1.10+Build-Type: Simple+Tested-With: GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.2,+ GHC == 8.2.2, GHC == 8.4.3, GHC == 8.6.1++Synopsis: Helpers for generating tests for broadcast-chan++Description:+ Provides helpers for implementing the streaming/concurrency tests used by+ broadcast-chan, broadcast-chan-conduit, and broadcast-chan-pipes.++Library+ Default-Language: Haskell2010+ GHC-Options: -Wall -O2 -fno-warn-unused-do-bind+ Exposed-Modules: BroadcastChan.Test++ Other-Extensions: CPP+ DeriveDataTypeable+ ScopedTypeVariables+ Trustworthy++ Build-Depends: base >= 4.6 && < 5+ , async >= 2.1 && < 2.3+ , broadcast-chan == 0.2.0+ , clock == 0.7.*+ , containers >= 0.4 && < 0.6+ , optparse-applicative >= 0.12 && < 0.15+ , paramtree >= 0.1.1 && < 0.2+ , stm >= 2.4 && < 2.5+ , tagged == 0.8.*+ , tasty >= 0.11 && < 1.2+ , tasty-golden >= 2.0 && < 2.4+ , tasty-hunit >= 0.9 && < 0.11+ , tasty-travis >= 0.2 && < 0.3+ , temporary >= 1.2 && < 1.4+ , text >= 1.0 && < 1.3++ if impl(ghc < 7.8)+ Build-Depends: unix >= 2.0 && < 2.8++ if impl(ghc < 7.10)+ Build-Depends: bifunctors >= 0.1 && < 5.6++ if impl(ghc < 8.0)+ Build-Depends: transformers >= 0.2 && < 0.6++Test-Suite basic+ Default-Language: Haskell2010+ Type: exitcode-stdio-1.0+ Main-Is: Basic.hs+ GHC-Options: -Wall -threaded -fno-warn-unused-do-bind+ Hs-Source-Dirs: tests+ Build-Depends: base+ , broadcast-chan+ , broadcast-chan-tests+ , foldl >= 1.4 && < 1.5+ , monad-loops >= 0.4.3 && < 0.5+ , random >= 1.1 && < 1.2++Test-Suite basic-unthreaded+ Default-Language: Haskell2010+ Type: exitcode-stdio-1.0+ Main-Is: Basic.hs+ GHC-Options: -Wall -fno-warn-unused-do-bind+ Hs-Source-Dirs: tests+ Build-Depends: base+ , broadcast-chan+ , broadcast-chan-tests+ , foldl >= 1.4 && < 1.5+ , monad-loops >= 0.4.3 && < 0.5+ , random >= 1.1 && < 1.2++Test-Suite parallel-io+ Default-Language: Haskell2010+ Type: exitcode-stdio-1.0+ Main-Is: IOTest.hs+ GHC-Options: -Wall -O2 -fno-warn-unused-do-bind+ Hs-Source-Dirs: tests+ Build-Depends: base+ , broadcast-chan+ , broadcast-chan-tests+ , containers >= 0.4 && < 0.6+++Source-Repository head+ Type: git+ Location: ssh://github.com:merijn/broadcast-chan.git++Source-Repository head+ Type: mercurial+ Location: https://bitbucket.org/merijnv/broadcast-chan
+ tests/Basic.hs view
@@ -0,0 +1,321 @@+{-# LANGUAGE CPP #-}+#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$), (<$>))+#endif+import Control.Foldl (Fold, FoldM)+import qualified Control.Foldl as Foldl+import Control.Monad (forM_)+import Control.Monad.Loops (unfoldM)+import Data.Maybe (isNothing)+import System.IO (Handle, hPrint)+import System.Random (getStdGen, randomIO, randoms)+import System.Timeout (timeout)++import BroadcastChan+import BroadcastChan.Test+import BroadcastChan.Throw (BChanError(..))+import qualified BroadcastChan.Throw as Throw++shouldn'tBlock :: IO a -> IO a+shouldn'tBlock act = do+ result <- timeout 2000000 act+ case result of+ Nothing -> assertFailure "Shouldn't block!"+ Just a -> return a++checkedWrite :: BroadcastChan In a -> a -> IO ()+checkedWrite chan val = writeBChan chan val @? "Write shouldn't fail"++randomList :: Int -> IO [Int]+randomList n = take n . randoms <$> getStdGen++readTests :: TestTree+readTests = testGroup "read tests"+ [ readNonEmpty+ , readNonEmptyThrow+ , readEmptyClosed+ , readEmptyClosedThrow+ ]+ where+ readNonEmpty :: TestTree+ readNonEmpty = testCase "read non-empty" $ do+ inChan <- newBroadcastChan+ outChan <- newBChanListener inChan+ val <- randomIO :: IO Int++ writeBChan inChan val+ result <- shouldn'tBlock $ readBChan outChan+ assertEqual "Read should match write" (Just val) result++ readNonEmptyThrow :: TestTree+ readNonEmptyThrow = testCase "read non-empty (throw)" $ do+ inChan <- newBroadcastChan+ outChan <- newBChanListener inChan+ val <- randomIO :: IO Int++ writeBChan inChan val+ result <- shouldn'tBlock $ Throw.readBChan outChan+ assertEqual "Read should match write" val result++ readEmptyClosed :: TestTree+ readEmptyClosed = testCase "read empty closed" $ do+ inChan <- newBroadcastChan+ outChan <- newBChanListener inChan+ closeBChan inChan+ isNothing <$> shouldn'tBlock (readBChan outChan) @? "Read should fail"++ readEmptyClosedThrow :: TestTree+ readEmptyClosedThrow = testCase "read empty closed (throw)" $ do+ inChan <- newBroadcastChan+ outChan <- newBChanListener inChan+ closeBChan inChan+ expect ReadFailed . shouldn'tBlock $ Throw.readBChan outChan++writeTests :: TestTree+writeTests = testGroup "write tests"+ [ writeClosed+ , writeClosedThrow+ , writeBeforeListener "write before listener" $ checkedWrite+ , writeBeforeListener "write before listener (throw)" $ Throw.writeBChan+ , writeBroadCast "write broadcast" $ checkedWrite+ , writeBroadCast "write broadcast (throw)" $ Throw.writeBChan+ ]+ where+ writeClosed :: TestTree+ writeClosed = testCase "write closed" $ do+ chan <- newBroadcastChan+ closeBChan chan+ not <$> writeBChan chan () @? "Write should fail"++ writeClosedThrow :: TestTree+ writeClosedThrow = testCase "write closed (throw)" $ do+ chan <- newBroadcastChan+ closeBChan chan+ expect WriteFailed $ Throw.writeBChan chan ()++ writeBeforeListener+ :: String -> (BroadcastChan In Int -> Int -> IO ()) -> TestTree+ writeBeforeListener name write = testCase name $ do+ inChan <- newBroadcastChan+ forM_ [1..10] $ write inChan+ closeBChan inChan+ outChan <- newBChanListener inChan+ isNothing <$> readBChan outChan @? "Read should fail"++ writeBroadCast+ :: String -> (BroadcastChan In Int -> Int -> IO ()) -> TestTree+ writeBroadCast name write = testCase name $ do+ inChan <- newBroadcastChan+ outChan1 <- newBChanListener inChan+ outChan2 <- newBChanListener inChan+ inputs <- randomList 10++ forM_ inputs $ write inChan+ closeBChan inChan+ result1 <- unfoldM $ readBChan outChan1+ result2 <- unfoldM $ readBChan outChan2+ assertEqual "Result should equal input" inputs result1+ assertEqual "Results should be equal" result1 result2++closedTests :: TestTree+closedTests = testGroup "closed tests"+ [ noBlockUnclosedIn+ , noBlockClosedIn+ , noBlockUnclosedOut+ , noBlockClosedOut+ , noBlockClosedEmptyOut+ ]+ where+ noBlockUnclosedIn :: TestTree+ noBlockUnclosedIn = testCase "no block unclosed in" $ do+ chan <- newBroadcastChan+ not <$> shouldn'tBlock (isClosedBChan chan) @? "Shouldn't be closed"++ noBlockClosedIn :: TestTree+ noBlockClosedIn = testCase "no block closed in" $ do+ chan <- newBroadcastChan+ closeBChan chan+ shouldn'tBlock (isClosedBChan chan) @? "Should be closed"++ noBlockUnclosedOut :: TestTree+ noBlockUnclosedOut = testCase "no block unclosed out" $ do+ inChan <- newBroadcastChan+ outChan <- newBChanListener inChan+ not <$> shouldn'tBlock (isClosedBChan outChan) @? "Shouldn't be closed"++ noBlockClosedOut :: TestTree+ noBlockClosedOut = testCase "no block closed out" $ do+ inChan <- newBroadcastChan+ outChan <- newBChanListener inChan+ Throw.writeBChan inChan ()+ closeBChan inChan+ not <$> shouldn'tBlock (isClosedBChan outChan) @? "Shouldn't be closed"++ noBlockClosedEmptyOut :: TestTree+ noBlockClosedEmptyOut = testCase "no block closed empty out" $ do+ inChan <- newBroadcastChan+ outChan <- newBChanListener inChan+ closeBChan inChan+ shouldn'tBlock (isClosedBChan outChan) @? "Should be closed"++chanContentsTests :: TestTree+chanContentsTests = testGroup "getBChanContents"+ [ noBlockOnEmptyIn+ , noBlockOnEmptyOut+ , noBlockOnFilledIn+ , noBlockOnFilledOut+ , checkConcurrencyOut+ ]+ where+ noBlockOnEmptyIn :: TestTree+ noBlockOnEmptyIn = testCase "no block on empty in" $ do+ chan <- newBroadcastChan+ results <- shouldn'tBlock $ getBChanContents chan+ closeBChan chan+ shouldn'tBlock $ assertBool "Should be empty list!" (null results)++ noBlockOnEmptyOut :: TestTree+ noBlockOnEmptyOut = testCase "no block on empty out" $ do+ inChan <- newBroadcastChan+ outChan <- newBChanListener inChan+ results <- shouldn'tBlock $ getBChanContents outChan+ closeBChan inChan+ shouldn'tBlock $ assertBool "Should be empty list!" (null results)++ noBlockOnFilledIn :: TestTree+ noBlockOnFilledIn = testCase "no block on filled in" $ do+ inChan <- newBroadcastChan+ throwawayInputs <- randomList 10+ forM_ throwawayInputs $ Throw.writeBChan inChan+ results <- shouldn'tBlock $ getBChanContents inChan+ inputs <- randomList 10+ forM_ inputs $ Throw.writeBChan inChan+ closeBChan inChan+ assertEqual "Should be only inputs after action" inputs results++ noBlockOnFilledOut :: TestTree+ noBlockOnFilledOut = testCase "no block on filled out" $ do+ inChan <- newBroadcastChan+ outChan <- newBChanListener inChan+ inputsBefore <- randomList 10+ forM_ inputsBefore $ Throw.writeBChan inChan+ results <- shouldn'tBlock $ getBChanContents outChan+ inputsAfter <- randomList 10+ forM_ inputsAfter $ Throw.writeBChan inChan+ closeBChan inChan+ let allInputs = inputsBefore ++ inputsAfter+ assertEqual "Should be both inputs" allInputs results++ checkConcurrencyOut :: TestTree+ checkConcurrencyOut = testCase "interleaved with readBChan" $ do+ inChan <- newBroadcastChan+ outChan <- newBChanListener inChan+ inputs <- randomList 10+ forM_ inputs $ Throw.writeBChan inChan+ closeBChan inChan+ contents <- getBChanContents outChan+ forM_ contents $ \val -> do+ result <- readBChan outChan+ case result of+ Nothing -> assertFailure "Element missing!"+ Just v -> assertEqual "Should be equal" val v++foldlTests :: TestTree+foldlTests = testGroup "foldl tests"+ [ foldBChanIn+ , foldBChanOut+ , foldBChanMIn+ , foldBChanMOut+ ]+ where+ pureFold :: Fold a b -> BroadcastChan d a -> IO (IO b)+ pureFold = Foldl.purely foldBChan++ printList :: Show a => Handle -> FoldM IO a [a]+ printList hnd = Foldl.premapM doPrint $ Foldl.generalize Foldl.list+ where+ doPrint val = val <$ hPrint hnd val++ impureFold :: FoldM IO a b -> BroadcastChan d a -> IO (IO b)+ impureFold = Foldl.impurely foldBChanM++ foldBChanIn :: TestTree+ foldBChanIn = testCase "foldBChan in" $ do+ inChan <- newBroadcastChan+ inputsBefore <- randomList 10+ forM_ inputsBefore $ Throw.writeBChan inChan+ foldList <- shouldn'tBlock $ pureFold Foldl.list inChan++ inputsAfter <- randomList 10+ forM_ inputsAfter $ Throw.writeBChan inChan+ closeBChan inChan+ (inputsAfter==) <$> shouldn'tBlock foldList @? "Lists should be equal"++ foldBChanOut :: TestTree+ foldBChanOut = testCase "foldBChan out" $ do+ inChan <- newBroadcastChan+ inputsBefore <- randomList 10+ forM_ inputsBefore $ Throw.writeBChan inChan+ outChan <- newBChanListener inChan+ inputsBetween <- randomList 10+ forM_ inputsBetween $ Throw.writeBChan inChan++ foldList <- shouldn'tBlock $ pureFold Foldl.list outChan++ inputsAfter <- randomList 10+ forM_ inputsAfter $ Throw.writeBChan inChan+ closeBChan inChan++ let expected = inputsBetween ++ inputsAfter+ (expected==) <$> shouldn'tBlock foldList @? "Lists should be equal"++ foldBChanMIn :: TestTree+ foldBChanMIn = testCase "foldBChanM in" $ do+ inChan <- newBroadcastChan+ inputsBefore <- randomList 10+ forM_ inputsBefore $ Throw.writeBChan inChan+ inputsAfter <- randomList 10++ control <- withLoggedOutput "foldBChanControl.out" $ \hnd -> do+ Foldl.foldM (printList hnd) inputsAfter++ validation <- withLoggedOutput "foldBChanM.out" $ \hnd -> do+ foldPrintList <- shouldn'tBlock $ impureFold (printList hnd) inChan+ forM_ inputsAfter $ Throw.writeBChan inChan+ closeBChan inChan+ foldPrintList++ assertEqual "Results and output should be equal" control validation++ foldBChanMOut :: TestTree+ foldBChanMOut = testCase "foldBChanM out" $ do+ inChan <- newBroadcastChan+ inputsBefore <- randomList 10+ forM_ inputsBefore $ Throw.writeBChan inChan+ outChan <- newBChanListener inChan+ inputsBetween <- randomList 10+ forM_ inputsBetween $ Throw.writeBChan inChan+ inputsAfter <- randomList 10+ let expected = inputsBetween ++ inputsAfter++ control <- withLoggedOutput "foldBChanControl.out" $ \hnd -> do+ Foldl.foldM (printList hnd) expected++ validation <- withLoggedOutput "foldBChanM.out" $ \hnd -> do+ foldPrintList <- shouldn'tBlock $+ impureFold (printList hnd) outChan++ forM_ inputsAfter $ Throw.writeBChan inChan+ closeBChan inChan+ foldPrintList++ assertEqual "Results and output should be equal" control validation++main :: IO ()+main = runTests "basic"+ [ readTests+ , writeTests+ , closedTests+ , chanContentsTests+ , foldlTests+ ]
+ tests/IOTest.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>))+import Data.Foldable (Foldable(..))+#endif++import Control.Monad (void)+import Data.Foldable (forM_, foldlM)+import Data.Set (Set)+import qualified Data.Set as S++import BroadcastChan+import BroadcastChan.Test++sequentialSink :: Foldable f => f a -> (a -> IO b) -> IO ()+sequentialSink set f = forM_ set (void . f)++parallelSink+ :: Foldable f => Handler IO a -> f a -> (a -> IO b) -> Int -> IO ()+parallelSink hnd input f n =+ parMapM_ hnd n (void . f) input++sequentialFold :: (Foldable f, Ord b) => f a -> (a -> IO b) -> IO (Set b)+sequentialFold input f = foldlM foldFun S.empty input+ where+ foldFun bs a = (\b -> S.insert b bs) <$> f a++parallelFold+ :: (Foldable f, Ord b)+ => Handler IO a -> f a -> (a -> IO b) -> Int -> IO (Set b)+parallelFold hnd input f n =+ parFoldMap hnd n f foldFun S.empty input+ where+ foldFun :: Ord b => Set b -> b -> Set b+ foldFun s b = S.insert b s++parallelFoldM+ :: (Foldable f, Ord b)+ => Handler IO a -> f a -> (a -> IO b) -> Int -> IO (Set b)+parallelFoldM hnd input f n =+ parFoldMapM hnd n f foldFun S.empty input+ where+ foldFun :: (Ord b, Monad m) => Set b -> b -> m (Set b)+ foldFun !z b = return $ S.insert b z++main :: IO ()+main = runTests "parallel-io" $+ [ genStreamTests "sink" sequentialSink parallelSink+ , genStreamTests "fold" sequentialFold parallelFold+ , genStreamTests "foldM" sequentialFold parallelFoldM+ ]