diff --git a/BroadcastChan/Test.hs b/BroadcastChan/Test.hs new file mode 100644 --- /dev/null +++ b/BroadcastChan/Test.hs @@ -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 +-- 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) diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/broadcast-chan-tests.cabal b/broadcast-chan-tests.cabal new file mode 100644 --- /dev/null +++ b/broadcast-chan-tests.cabal @@ -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 +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 diff --git a/tests/Basic.hs b/tests/Basic.hs new file mode 100644 --- /dev/null +++ b/tests/Basic.hs @@ -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 + ] diff --git a/tests/IOTest.hs b/tests/IOTest.hs new file mode 100644 --- /dev/null +++ b/tests/IOTest.hs @@ -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 + ]