tasty 1.4 → 1.4.0.1

raw patch · 11 files changed

+343/−23 lines, 11 filesdep +base-orphansdep +ghc-primdep −asyncdep ~basedep ~timedep ~unbounded-delays

Dependencies added: base-orphans, ghc-prim

Dependencies removed: async

Dependency ranges changed: base, time, unbounded-delays

Files

• CHANGELOG.md +15/−0
• Control/Concurrent/Async.hs +269/−0
• Test/Tasty/CmdLine.hs +4/−3
• Test/Tasty/Core.hs +13/−1
• Test/Tasty/Ingredients/ConsoleReporter.hs +5/−4
• Test/Tasty/Options.hs +7/−1
• Test/Tasty/Options/Core.hs +5/−2
• Test/Tasty/Patterns.hs +1/−1
• Test/Tasty/Patterns/Parser.hs +4/−1
• Test/Tasty/Runners/Utils.hs +4/−3
• tasty.cabal +16/−7

@@ -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 ----------- 

@@ -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 #)

@@ -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

@@ -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

@@ -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.

@@ -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.

@@ -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

@@ -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)

@@ -1,4 +1,4 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-} -- | See <http://pubs.opengroup.org/onlinepubs/9699919799/utilities/awk.html> 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 

@@ -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

@@ -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