diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,21 @@ Changes ======= +Version 1.4.0.1 +--------------- + +The only point of this release is to introduce compatibility with GHCs back to 7.0 +(see https://github.com/feuerbach/tasty/pull/287). + +Note, however, that these changes are not merged to the master branch, and the +future releases will only support the GHC/base versions from the last 5 years, +as per our usual policy. To test with even older GHCs, you'll have to use this +particular version of tasty (or have the constraint solver pick it for you when +testing with older GHCs). + +The source of this release is in the `support-old-ghcs` branch of the tasty +repository. + Version 1.4 ----------- diff --git a/Control/Concurrent/Async.hs b/Control/Concurrent/Async.hs new file mode 100644 --- /dev/null +++ b/Control/Concurrent/Async.hs @@ -0,0 +1,269 @@ +-- | Operations for running IO operations asynchronously. + +-- These are the same as in the 'async' package. We do not use +-- 'async' to avoid its dependencies. + +{- License for the 'async' package +Copyright (c) 2012, Simon Marlow + +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 Simon Marlow 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. +-} + +{-# LANGUAGE DeriveDataTypeable, MagicHash, UnboxedTuples #-} + +module Control.Concurrent.Async ( + async, withAsync, wait, asyncThreadId, cancel, concurrently + ) where + +import Control.Concurrent.STM +import Control.Exception +import Control.Concurrent +import Control.Monad +import Data.IORef +import Data.Typeable +import GHC.Conc +import GHC.Exts +import GHC.IO hiding (onException) + +-- | An asynchronous action spawned by 'async' or 'withAsync'. +-- Asynchronous actions are executed in a separate thread, and +-- operations are provided for waiting for asynchronous actions to +-- complete and obtaining their results (see e.g. 'wait'). +-- +data Async a = Async + { asyncThreadId :: {-# UNPACK #-} !ThreadId + -- ^ Returns the 'ThreadId' of the thread running + -- the given 'Async'. + , _asyncWait :: STM (Either SomeException a) + } + +-- | Spawn an asynchronous action in a separate thread. +async :: IO a -> IO (Async a) +async = inline asyncUsing rawForkIO + +asyncUsing :: (IO () -> IO ThreadId) + -> IO a -> IO (Async a) +asyncUsing doFork = \action -> do + var <- newEmptyTMVarIO + -- t <- forkFinally action (\r -> atomically $ putTMVar var r) + -- slightly faster: + t <- mask $ \restore -> + doFork $ try (restore action) >>= atomically . putTMVar var + return (Async t (readTMVar var)) + +-- | Spawn an asynchronous action in a separate thread, and pass its +-- @Async@ handle to the supplied function. When the function returns +-- or throws an exception, 'uninterruptibleCancel' is called on the @Async@. +-- +-- > withAsync action inner = mask $ \restore -> do +-- > a <- async (restore action) +-- > restore (inner a) `finally` uninterruptibleCancel a +-- +-- This is a useful variant of 'async' that ensures an @Async@ is +-- never left running unintentionally. +-- +-- Note: a reference to the child thread is kept alive until the call +-- to `withAsync` returns, so nesting many `withAsync` calls requires +-- linear memory. +-- +withAsync :: IO a -> (Async a -> IO b) -> IO b +withAsync = inline withAsyncUsing rawForkIO + +withAsyncUsing :: (IO () -> IO ThreadId) + -> IO a -> (Async a -> IO b) -> IO b +-- The bracket version works, but is slow. We can do better by +-- hand-coding it: +withAsyncUsing doFork = \action inner -> do + var <- newEmptyTMVarIO + mask $ \restore -> do + t <- doFork $ try (restore action) >>= atomically . putTMVar var + let a = Async t (readTMVar var) + r <- restore (inner a) `catchAll` \e -> do + uninterruptibleCancel a + throwIO e + uninterruptibleCancel a + return r + +-- | Wait for an asynchronous action to complete, and return its +-- value. If the asynchronous action threw an exception, then the +-- exception is re-thrown by 'wait'. +-- +-- > wait = atomically . waitSTM +-- +{-# INLINE wait #-} +wait :: Async a -> IO a +wait = tryAgain . atomically . waitSTM + where + -- See: https://github.com/simonmar/async/issues/14 + tryAgain f = f `Control.Exception.catch` \BlockedIndefinitelyOnSTM -> f + +-- | Wait for an asynchronous action to complete, and return either +-- @Left e@ if the action raised an exception @e@, or @Right a@ if it +-- returned a value @a@. +-- +-- > waitCatch = atomically . waitCatchSTM +-- +{-# INLINE waitCatch #-} +waitCatch :: Async a -> IO (Either SomeException a) +waitCatch = tryAgain . atomically . waitCatchSTM + where + -- See: https://github.com/simonmar/async/issues/14 + tryAgain f = f `Control.Exception.catch` \BlockedIndefinitelyOnSTM -> f + +-- | A version of 'wait' that can be used inside an STM transaction. +-- +waitSTM :: Async a -> STM a +waitSTM a = do + r <- waitCatchSTM a + either throwSTM return r + +-- | A version of 'waitCatch' that can be used inside an STM transaction. +-- +{-# INLINE waitCatchSTM #-} +waitCatchSTM :: Async a -> STM (Either SomeException a) +waitCatchSTM (Async _ w) = w + +-- | Cancel an asynchronous action by throwing the @AsyncCancelled@ +-- exception to it, and waiting for the `Async` thread to quit. +-- Has no effect if the 'Async' has already completed. +-- +-- > cancel a = throwTo (asyncThreadId a) AsyncCancelled <* waitCatch a +-- +-- Note that 'cancel' will not terminate until the thread the 'Async' +-- refers to has terminated. This means that 'cancel' will block for +-- as long said thread blocks when receiving an asynchronous exception. +-- +-- For example, it could block if: +-- +-- * It's executing a foreign call, and thus cannot receive the asynchronous +-- exception; +-- * It's executing some cleanup handler after having received the exception, +-- and the handler is blocking. +{-# INLINE cancel #-} +cancel :: Async a -> IO () +cancel a@(Async t _) = throwTo t AsyncCancelled >> void (waitCatch a) + +-- | The exception thrown by `cancel` to terminate a thread. +data AsyncCancelled = AsyncCancelled + deriving (Show, Eq, Typeable) + +instance Exception AsyncCancelled where +#if __GLASGOW_HASKELL__ >= 708 + fromException = asyncExceptionFromException + toException = asyncExceptionToException +#endif + +-- | Cancel an asynchronous action +-- +-- This is a variant of `cancel`, but it is not interruptible. +{-# INLINE uninterruptibleCancel #-} +uninterruptibleCancel :: Async a -> IO () +uninterruptibleCancel = uninterruptibleMask_ . cancel + +-- | Run two @IO@ actions concurrently, and return both results. If +-- either action throws an exception at any time, then the other +-- action is 'cancel'led, and the exception is re-thrown by +-- 'concurrently'. +-- +-- > concurrently left right = +-- > withAsync left $ \a -> +-- > withAsync right $ \b -> +-- > waitBoth a b +concurrently :: IO a -> IO b -> IO (a,b) +concurrently left right = concurrently' left right (collect []) + where + collect [Left a, Right b] _ = return (a,b) + collect [Right b, Left a] _ = return (a,b) + collect xs m = do + e <- m + case e of + Left ex -> throwIO ex + Right r -> collect (r:xs) m + +concurrently' :: IO a -> IO b + -> (IO (Either SomeException (Either a b)) -> IO r) + -> IO r +concurrently' left right collect = do + done <- newEmptyMVar + mask $ \restore -> do + -- Note: uninterruptibleMask here is because we must not allow + -- the putMVar in the exception handler to be interrupted, + -- otherwise the parent thread will deadlock when it waits for + -- the thread to terminate. + lid <- forkIO $ uninterruptibleMask_ $ + restore (left >>= putMVar done . Right . Left) + `catchAll` (putMVar done . Left) + rid <- forkIO $ uninterruptibleMask_ $ + restore (right >>= putMVar done . Right . Right) + `catchAll` (putMVar done . Left) + + count <- newIORef (2 :: Int) + let takeDone = do + r <- takeMVar done -- interruptible + -- Decrement the counter so we know how many takes are left. + -- Since only the parent thread is calling this, we can + -- use non-atomic modifications. + -- NB. do this *after* takeMVar, because takeMVar might be + -- interrupted. + modifyIORef count (subtract 1) + return r + + let tryAgain f = f `Control.Exception.catch` \BlockedIndefinitelyOnMVar -> f + + stop = do + -- kill right before left, to match the semantics of + -- the version using withAsync. (#27) + uninterruptibleMask_ $ do + count' <- readIORef count + -- we only need to use killThread if there are still + -- children alive. Note: forkIO here is because the + -- child thread could be in an uninterruptible + -- putMVar. + when (count' > 0) $ + void $ forkIO $ do + throwTo rid AsyncCancelled + throwTo lid AsyncCancelled + -- ensure the children are really dead + replicateM_ count' (tryAgain $ takeMVar done) + + r <- collect (tryAgain $ takeDone) `onException` stop + stop + return r + +catchAll :: IO a -> (SomeException -> IO a) -> IO a +catchAll = Control.Exception.catch + +-- A version of forkIO that does not include the outer exception +-- handler: saves a bit of time when we will be installing our own +-- exception handler. +{-# INLINE rawForkIO #-} +rawForkIO :: IO () -> IO ThreadId +rawForkIO action = IO $ \ s -> + case (fork# action s) of (# s1, tid #) -> (# s1, ThreadId tid #) diff --git a/Test/Tasty/CmdLine.hs b/Test/Tasty/CmdLine.hs --- a/Test/Tasty/CmdLine.hs +++ b/Test/Tasty/CmdLine.hs @@ -11,7 +11,7 @@ import Control.Monad import Data.Maybe import Data.Proxy -import Data.Typeable (typeRep) +import Data.Typeable (typeOf1) import Options.Applicative import Options.Applicative.Common (evalParser) import qualified Options.Applicative.Types as Applicative (Option(..)) @@ -20,8 +20,9 @@ import System.Exit import System.IO #if !MIN_VERSION_base(4,11,0) -import Data.Monoid import Data.Foldable (foldMap) +import Data.Monoid (mempty) +import Data.Semigroup (Semigroup((<>))) #endif import Test.Tasty.Core @@ -96,7 +97,7 @@ prov :: String prov = "WARNING (in the IsOption instance for " - ++ show (typeRep (Proxy :: Proxy v)) ++ "):" + ++ show (typeOf1 (Proxy :: Proxy v)) ++ "):" -- Replace an `optionCLParser`'s 'propShowDefault' with 'showDefaultValue' from -- the 'IsOption' class. It's tempting to try doing this when constructing the diff --git a/Test/Tasty/Core.hs b/Test/Tasty/Core.hs --- a/Test/Tasty/Core.hs +++ b/Test/Tasty/Core.hs @@ -1,7 +1,11 @@ -- | Core types and definitions {-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleContexts, ExistentialQuantification, RankNTypes, DeriveDataTypeable, NoMonomorphismRestriction, - DeriveGeneric #-} + CPP #-} +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE DeriveGeneric #-} +#endif + module Test.Tasty.Core where import Control.Exception @@ -12,6 +16,10 @@ import Data.Foldable import qualified Data.Sequence as Seq import Data.Monoid +#if !MIN_VERSION_base(4,11,0) +import Data.Semigroup (Semigroup) +import qualified Data.Semigroup (Semigroup((<>))) +#endif import Data.Typeable import qualified Data.Map as Map import Data.Tagged @@ -43,7 +51,11 @@ data Outcome = Success -- ^ test succeeded | Failure FailureReason -- ^ test failed because of the 'FailureReason' +#if __GLASGOW_HASKELL__ >= 702 deriving (Show, Generic) +#else + deriving (Show) +#endif -- | Time in seconds. Used to measure how long the tests took to run. type Time = Double diff --git a/Test/Tasty/Ingredients/ConsoleReporter.hs b/Test/Tasty/Ingredients/ConsoleReporter.hs --- a/Test/Tasty/Ingredients/ConsoleReporter.hs +++ b/Test/Tasty/Ingredients/ConsoleReporter.hs @@ -41,12 +41,13 @@ import Text.Printf import qualified Data.IntMap as IntMap import Data.Char -#ifdef UNIX +#ifdef VERSION_wcwidth import Data.Char.WCWidth (wcwidth) #endif import Data.Maybe import Data.Monoid (Any(..)) -import Data.Typeable +import Data.Proxy (Proxy(..)) +import Data.Typeable (Typeable) import Options.Applicative hiding (action, str, Success, Failure) import System.IO import System.Console.ANSI @@ -331,7 +332,7 @@ | IntMap.null smap = return True | otherwise = join . atomically $ - IntMap.foldrWithKey f finish smap mempty lookahead0 + foldr (uncurry f) finish (IntMap.toAscList smap) mempty lookahead0 where f :: Int -> TVar Status @@ -612,7 +613,7 @@ -- (This only works properly on Unix at the moment; on Windows, the function -- treats every character as width-1 like 'Data.List.length' does.) stringWidth :: String -> Int -#ifdef UNIX +#ifdef VERSION_wcwidth stringWidth = Prelude.sum . map charWidth where charWidth c = case wcwidth c of -1 -> 1 -- many chars have "undefined" width; default to 1 for these. diff --git a/Test/Tasty/Options.hs b/Test/Tasty/Options.hs --- a/Test/Tasty/Options.hs +++ b/Test/Tasty/Options.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable, +{-# LANGUAGE CPP, ScopedTypeVariables, DeriveDataTypeable, ExistentialQuantification, GADTs, FlexibleInstances, UndecidableInstances, TypeOperators #-} @@ -37,6 +37,12 @@ #if !MIN_VERSION_base(4,11,0) import Data.Semigroup (Semigroup) import qualified Data.Semigroup (Semigroup((<>))) +#endif +#if !MIN_VERSION_base(4,5,0) +import Data.Semigroup (Semigroup((<>))) +#endif +#if !MIN_VERSION_base(4,4,0) +import Data.Orphans () #endif -- | An option is a data type that inhabits the `IsOption` type class. diff --git a/Test/Tasty/Options/Core.hs b/Test/Tasty/Options/Core.hs --- a/Test/Tasty/Options/Core.hs +++ b/Test/Tasty/Options/Core.hs @@ -16,8 +16,11 @@ import Options.Applicative hiding (str) import GHC.Conc #if !MIN_VERSION_base(4,11,0) -import Data.Monoid +import Data.Semigroup (Semigroup((<>))) #endif +#if !MIN_VERSION_base(4,4,0) +import Data.Orphans () +#endif import Test.Tasty.Options import Test.Tasty.Patterns @@ -30,7 +33,7 @@ -- reporters are handled already involves parallelism. Other ingredients -- may also choose to include this option. newtype NumThreads = NumThreads { getNumThreads :: Int } - deriving (Eq, Ord, Num, Typeable) + deriving (Eq, Ord, Num, Show, Typeable) instance IsOption NumThreads where defaultValue = NumThreads numCapabilities parseValue = mfilter onlyPositive . fmap NumThreads . safeRead diff --git a/Test/Tasty/Patterns.hs b/Test/Tasty/Patterns.hs --- a/Test/Tasty/Patterns.hs +++ b/Test/Tasty/Patterns.hs @@ -21,7 +21,7 @@ import Data.Typeable import Options.Applicative hiding (Success) #if !MIN_VERSION_base(4,11,0) -import Data.Monoid +import Data.Semigroup (Semigroup((<>))) #endif newtype TestPattern = TestPattern (Maybe Expr) diff --git a/Test/Tasty/Patterns/Parser.hs b/Test/Tasty/Patterns/Parser.hs --- a/Test/Tasty/Patterns/Parser.hs +++ b/Test/Tasty/Patterns/Parser.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-} -- | See for the -- full awk grammar. module Test.Tasty.Patterns.Parser @@ -20,6 +20,9 @@ import Control.Monad import Test.Tasty.Patterns.Types import Test.Tasty.Patterns.Expr +#if !MIN_VERSION_base(4,6,0) +import Data.Orphans () +#endif type Token = ReadP diff --git a/Test/Tasty/Runners/Utils.hs b/Test/Tasty/Runners/Utils.hs --- a/Test/Tasty/Runners/Utils.hs +++ b/Test/Tasty/Runners/Utils.hs @@ -5,7 +5,6 @@ import Control.Exception import Control.Applicative -import Control.Concurrent (mkWeakThreadId, myThreadId) import Control.Monad (forM_) #ifndef VERSION_clock import Data.Time.Clock.POSIX (getPOSIXTime) @@ -18,10 +17,12 @@ import qualified System.Clock as Clock #endif --- Install handlers only on UNIX -#define INSTALL_HANDLERS defined __UNIX__ +-- Install handlers only on UNIX and on GHC >= 7.6 +-- because GHC 7.4 lacks mkWeakThreadId (see #181). +#define INSTALL_HANDLERS defined VERSION_unix && MIN_VERSION_base(4,6,0) #if INSTALL_HANDLERS +import Control.Concurrent (mkWeakThreadId, myThreadId) import System.Posix.Signals import System.Mem.Weak (deRefWeak) #endif diff --git a/tasty.cabal b/tasty.cabal --- a/tasty.cabal +++ b/tasty.cabal @@ -2,7 +2,7 @@ -- see http://haskell.org/cabal/users-guide/ name: tasty -version: 1.4 +version: 1.4.0.1 synopsis: Modern and extensible testing framework description: Tasty is a modern testing framework for Haskell. It lets you combine your unit tests, golden @@ -30,6 +30,11 @@ Depend on the clock package for more accurate time measurement default: True +flag unix + description: + Depend on the unix package to install signal handlers + default: True + library exposed-modules: Test.Tasty, @@ -46,6 +51,7 @@ Test.Tasty.Patterns.Parser Test.Tasty.Patterns.Eval other-modules: + Control.Concurrent.Async Test.Tasty.Parallel, Test.Tasty.Core, Test.Tasty.Options.Core, @@ -59,27 +65,30 @@ Test.Tasty.Ingredients.ListTests Test.Tasty.Ingredients.IncludingOptions build-depends: - base >= 4.7 && < 5, + base >= 4.3 && < 5, stm >= 2.3, containers, mtl >= 2.1.3.1, tagged >= 0.5, optparse-applicative >= 0.14, unbounded-delays >= 0.1, - async >= 2.0, ansi-terminal >= 0.9 if(!impl(ghc >= 8.0)) build-depends: semigroups + if(!impl(ghc >= 7.6)) + build-depends: base-orphans >= 0.8.4, ghc-prim + if(!impl(ghc >= 7.2)) + build-depends: unbounded-delays < 0.1.0.10 if flag(clock) build-depends: clock >= 0.4.4.0 else - build-depends: time >= 1.4 + build-depends: time if !os(windows) && !impl(ghcjs) - build-depends: unix, - wcwidth - cpp-options: -D__UNIX__ + build-depends: wcwidth + if flag(unix) + build-depends: unix -- hs-source-dirs: default-language: Haskell2010