diff --git a/BroadcastChan/Test.hs b/BroadcastChan/Test.hs --- a/BroadcastChan/Test.hs +++ b/BroadcastChan/Test.hs @@ -4,7 +4,7 @@ ------------------------------------------------------------------------------- -- | -- Module : BroadcastChan.Test --- Copyright : (C) 2014-2018 Merijn Verstraaten +-- Copyright : (C) 2014-2021 Merijn Verstraaten -- License : BSD-style (see the file LICENSE) -- Maintainer : Merijn Verstraaten -- Stability : experimental @@ -26,9 +26,10 @@ ) where import Prelude hiding (seq) -import Control.Concurrent (threadDelay) +import Control.Concurrent (forkIO, setNumCapabilities, threadDelay) import Control.Concurrent.Async (wait, withAsync) import Control.Concurrent.MVar +import Control.Concurrent.QSemN import Control.Concurrent.STM import Control.Monad (void, when) import Control.Monad.IO.Class (MonadIO(liftIO)) @@ -39,14 +40,13 @@ 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 Options.Applicative (flag', long, help) import System.Clock (Clock(Monotonic), TimeSpec, diffTimeSpec, getTime, toNanoSecs) import System.Environment (setEnv) @@ -99,6 +99,14 @@ | predicate val = throwIO TestException | otherwise = doPrint hnd val +doRace :: MVar () -> QSemN -> a -> IO a +doRace mvar sem _ = do + result <- tryReadMVar mvar + case result of + Nothing -> signalQSemN sem 1 >> readMVar mvar + Just () -> return () + throwIO TestException + fromTimeSpec :: Fractional n => TimeSpec -> n fromTimeSpec = fromIntegral . toNanoSecs @@ -193,7 +201,7 @@ diff :: (r, Text) -> (r, Text) -> IO (Maybe String) diff (controlResult, controlOutput) (testResult, testOutput) = - return $ resultDiff <> outputDiff + return $ resultDiff `mappend` outputDiff where resultDiff :: Maybe String resultDiff @@ -248,6 +256,20 @@ withSystemTempFile "terminate.out" $ \_ hndl -> parImpl (Simple Terminate) [1..100] (doDrop even hndl) 4 +raceTest + :: (Handler IO Int -> [Int] -> (Int -> IO Int) -> Int -> IO r) -> TestTree +raceTest parImpl = testCase "race" $ + expect TestException . void $ do + sem <- newQSemN 0 + mvar <- newEmptyMVar + forkIO $ do + waitQSemN sem parCount + putMVar mvar () + parImpl (Simple Terminate) [1..100] (doRace mvar sem) parCount + where + parCount :: Int + parCount = 4 + retryTest :: (Eq r, Show r) => ([Int] -> (Int -> IO Int) -> IO r) @@ -279,7 +301,7 @@ dropAfterPrint checkPresence hnd val = do hPrint hnd val when (even val) $ do - isNotPresent <- checkPresence >>= ($val) + isNotPresent <- checkPresence >>= ($ val) when isNotPresent $ throwIO TestException return val @@ -291,12 +313,10 @@ 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)) - ) + optionCLParser = flag' (SlowTests True) $ mconcat + [ 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. @@ -324,7 +344,7 @@ 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)] + pause = simpleParam "pause" [10^(4 :: Int)] in testGroup name [ testTree "output" (outputTest seq (par term)) $ @@ -332,7 +352,11 @@ , testTree "speedup" (speedupTest getCache seq (par term)) $ threads . bigInputs . pause , testGroup "exceptions" - [ dropTest seq par, terminationTest par, retryTest seq par ] + [ dropTest seq par + , terminationTest par + , raceTest par + , retryTest seq par + ] ] where term = Simple Terminate @@ -340,6 +364,7 @@ -- | Run a list of 'TestTree'​'s and group them under the specified name. runTests :: String -> [TestTree] -> IO () runTests name tests = do + setNumCapabilities 5 setEnv "TASTY_NUM_THREADS" "100" travisTestReporter travisConfig ingredients $ testGroup name tests where diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,7 @@ +0.2.1.2 [2021.12.01] +-------------------- +* Fix errors/warnings for GHC 9.2. + 0.2.1.1 [2020.03.05] -------------------- * Bump for new release of broadcast-chan. diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2013-2017, Merijn Verstraaten +Copyright (c) 2013-2021, Merijn Verstraaten All rights reserved. diff --git a/broadcast-chan-tests.cabal b/broadcast-chan-tests.cabal --- a/broadcast-chan-tests.cabal +++ b/broadcast-chan-tests.cabal @@ -1,21 +1,21 @@ +Cabal-Version: 2.2 Name: broadcast-chan-tests -Version: 0.2.1.1 +Version: 0.2.1.2 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-2019 Merijn Verstraaten +Copyright: Copyright © 2014-2021 Merijn Verstraaten -License: BSD3 +License: BSD-3-Clause License-File: LICENSE Category: System -Cabal-Version: >= 1.10 Build-Type: Simple Tested-With: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5, - GHC == 8.8.3, GHC == 8.10.1 + GHC == 8.8.4, GHC == 8.10.7, GHC == 9.0.1, GHC == 9.2.1 Extra-Source-Files: CHANGELOG.md @@ -27,60 +27,63 @@ Library Default-Language: Haskell2010 - GHC-Options: -Wall -O2 -fno-warn-unused-do-bind + GHC-Options: -Wall -O2 -Wno-unused-do-bind Exposed-Modules: BroadcastChan.Test Other-Extensions: DeriveDataTypeable ScopedTypeVariables Trustworthy - Build-Depends: base >= 4.7 && < 4.15 + Build-Depends: base >= 4.8 && < 4.17 , async >= 2.1 && < 2.3 - , broadcast-chan == 0.2.1.1 + , broadcast-chan == 0.2.1.2 , clock >= 0.7 && < 0.9 , containers >= 0.4 && < 0.7 - , optparse-applicative >= 0.12 && < 0.16 + , optparse-applicative >= 0.12 && < 0.17 , paramtree >= 0.1.1 && < 0.2 , stm >= 2.4 && < 2.6 , tagged == 0.8.* - , tasty >= 0.11 && < 1.3 + , tasty >= 0.11 && < 1.5 , 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.10) + Build-Depends: transformers >= 0.2 && < 0.7 + Test-Suite basic Default-Language: Haskell2010 Type: exitcode-stdio-1.0 Main-Is: Basic.hs - GHC-Options: -Wall -threaded -fno-warn-unused-do-bind + GHC-Options: -Wall -threaded -Wno-unused-do-bind -with-rtsopts=-qg 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 + , random >= 1.1 && < 1.3 Test-Suite basic-unthreaded Default-Language: Haskell2010 Type: exitcode-stdio-1.0 Main-Is: Basic.hs - GHC-Options: -Wall -fno-warn-unused-do-bind + GHC-Options: -Wall -Wno-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 + , random >= 1.1 && < 1.3 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 + GHC-Options: -Wall -O2 -Wno-unused-do-bind -threaded -with-rtsopts=-qg Hs-Source-Dirs: tests Build-Depends: base , broadcast-chan