-- | Running tests
{-# LANGUAGE ScopedTypeVariables, ExistentialQuantification, RankNTypes,
             FlexibleContexts, BangPatterns, CPP, DeriveDataTypeable #-}
module Test.Tasty.Run
  ( Status(..)
  , StatusMap
  , launchTestTree
  , DependencyException(..)
  ) where

import qualified Data.IntMap as IntMap
import qualified Data.Sequence as Seq
import qualified Data.Foldable as F
import Data.Int (Int64)
import Data.Maybe
import Data.Graph (SCC(..), stronglyConnComp)
import Data.Typeable
import Control.Monad (forever, guard, join, liftM)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Reader (ReaderT(..), local, ask)
import Control.Monad.Trans.Writer (WriterT(..), execWriterT, mapWriterT, tell)
import Control.Concurrent
import Control.Concurrent.STM
import Control.Concurrent.Async
import Control.Exception as E
import Control.Applicative
import Control.Arrow
import Data.Monoid (First(..))
import GHC.Conc (labelThread)
import Prelude  -- Silence AMP and FTP import warnings

#ifdef MIN_VERSION_unbounded_delays
import Control.Concurrent.Timeout (timeout)
#else
import System.Timeout (timeout)
#endif

import Test.Tasty.Core
import Test.Tasty.Parallel
import Test.Tasty.Patterns
import Test.Tasty.Patterns.Types
import Test.Tasty.Options
import Test.Tasty.Options.Core
import Test.Tasty.Runners.Reducers
import Test.Tasty.Runners.Utils (timed, forceElements)
import Test.Tasty.Providers.ConsoleFormat (noResultDetails)

-- | Current status of a test
data Status
  = NotStarted
    -- ^ test has not started running yet
  | Executing Progress
    -- ^ test is being run
  | Done Result
    -- ^ test finished with a given result
  deriving Int -> Status -> ShowS
[Status] -> ShowS
Status -> [Char]
(Int -> Status -> ShowS)
-> (Status -> [Char]) -> ([Status] -> ShowS) -> Show Status
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Status -> ShowS
showsPrec :: Int -> Status -> ShowS
$cshow :: Status -> [Char]
show :: Status -> [Char]
$cshowList :: [Status] -> ShowS
showList :: [Status] -> ShowS
Show

-- | Mapping from test numbers (starting from 0) to their status variables.
--
-- This is what an ingredient uses to analyse and display progress, and to
-- detect when tests finish.
type StatusMap = IntMap.IntMap (TVar Status)

data Resource r
  = NotCreated
  | BeingCreated
  | FailedToCreate SomeException
  | Created r
  | BeingDestroyed
  | Destroyed

instance Show (Resource r) where
  show :: Resource r -> [Char]
show Resource r
r = case Resource r
r of
    Resource r
NotCreated -> [Char]
"NotCreated"
    Resource r
BeingCreated -> [Char]
"BeingCreated"
    FailedToCreate SomeException
exn -> [Char]
"FailedToCreate " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ SomeException -> [Char]
forall a. Show a => a -> [Char]
show SomeException
exn
    Created {} -> [Char]
"Created"
    Resource r
BeingDestroyed -> [Char]
"BeingDestroyed"
    Resource r
Destroyed -> [Char]
"Destroyed"

data Initializer
  = forall res . Initializer
      (IO res)
      (TVar (Resource res))
data Finalizer
  = forall res . Finalizer
      (res -> IO ())
      (TVar (Resource res))
      (TVar Int)

-- | Execute a test taking care of resources
executeTest
  :: ((Progress -> IO ()) -> IO Result)
    -- ^ the action to execute the test, which takes a progress callback as
    -- a parameter
  -> TVar Status -- ^ variable to write status to
  -> Timeout -- ^ optional timeout to apply
  -> Seq.Seq Initializer -- ^ initializers (to be executed in this order)
  -> Seq.Seq Finalizer -- ^ finalizers (to be executed in this order)
  -> IO ()
executeTest :: ((Progress -> IO ()) -> IO Result)
-> TVar Status
-> Timeout
-> Seq Initializer
-> Seq Finalizer
-> IO ()
executeTest (Progress -> IO ()) -> IO Result
action TVar Status
statusVar Timeout
timeoutOpt Seq Initializer
inits Seq Finalizer
fins = ((forall a. IO a -> IO a) -> IO ()) -> IO ()
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask (((forall a. IO a -> IO a) -> IO ()) -> IO ())
-> ((forall a. IO a -> IO a) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> do
  resultOrExn <- IO (Time, Result) -> IO (Either SomeException (Time, Result))
forall e a. Exception e => IO a -> IO (Either e a)
try (IO (Time, Result) -> IO (Either SomeException (Time, Result)))
-> IO (Time, Result) -> IO (Either SomeException (Time, Result))
forall a b. (a -> b) -> a -> b
$ IO (Time, Result) -> IO (Time, Result)
forall a. IO a -> IO a
restore (IO (Time, Result) -> IO (Time, Result))
-> IO (Time, Result) -> IO (Time, Result)
forall a b. (a -> b) -> a -> b
$ do
    -- N.B. this can (re-)throw an exception. It's okay. By design, the
    -- actual test will not be run, then. We still run all the
    -- finalizers.
    --
    -- There's no point to transform these exceptions to something like
    -- EitherT, because an async exception (cancellation) can strike
    -- anyway.
    IO ()
initResources

    -- If all initializers ran successfully, actually run the test.
    -- We run it in a separate thread, so that the test's exception
    -- handler doesn't interfere with our timeout.
    IO Result
-> (Async Result -> IO (Time, Result)) -> IO (Time, Result)
forall a b. IO a -> (Async a -> IO b) -> IO b
withAsync ((Progress -> IO ()) -> IO Result
action Progress -> IO ()
forall {m :: * -> *} {p}. Monad m => p -> m ()
yieldProgress) ((Async Result -> IO (Time, Result)) -> IO (Time, Result))
-> (Async Result -> IO (Time, Result)) -> IO (Time, Result)
forall a b. (a -> b) -> a -> b
$ \Async Result
asy -> do
      ThreadId -> [Char] -> IO ()
labelThread (Async Result -> ThreadId
forall a. Async a -> ThreadId
asyncThreadId Async Result
asy) [Char]
"tasty_test_execution_thread"
      IO Result -> IO (Time, Result)
forall a. IO a -> IO (Time, a)
timed (IO Result -> IO (Time, Result)) -> IO Result -> IO (Time, Result)
forall a b. (a -> b) -> a -> b
$ Timeout -> IO Result -> IO Result
applyTimeout Timeout
timeoutOpt (IO Result -> IO Result) -> IO Result -> IO Result
forall a b. (a -> b) -> a -> b
$ do
        r <- Async Result -> IO Result
forall a. Async a -> IO a
wait Async Result
asy
        -- Not only wait for the result to be returned, but make sure to
        -- evalute it inside applyTimeout; see #280.
        evaluate $
          resultOutcome r `seq`
          forceElements (resultDescription r) `seq`
          forceElements (resultShortDescription r)
        return r

  -- no matter what, try to run each finalizer
  mbExn <- destroyResources restore

  atomically . writeTVar statusVar $ Done $
    case resultOrExn <* maybe (Right ()) Left mbExn of
      Left SomeException
ex -> SomeException -> Result
exceptionResult SomeException
ex
      Right (Time
t,Result
r) -> Result
r { resultTime = t }

  where
    initResources :: IO ()
    initResources :: IO ()
initResources =
      Seq Initializer -> (Initializer -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
F.forM_ Seq Initializer
inits ((Initializer -> IO ()) -> IO ())
-> (Initializer -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Initializer IO res
doInit TVar (Resource res)
initVar) -> do
        IO (IO ()) -> IO ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO ()) -> IO ()) -> IO (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ STM (IO ()) -> IO (IO ())
forall a. STM a -> IO a
atomically (STM (IO ()) -> IO (IO ())) -> STM (IO ()) -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ do
          resStatus <- TVar (Resource res) -> STM (Resource res)
forall a. TVar a -> STM a
readTVar TVar (Resource res)
initVar
          case resStatus of
            Resource res
NotCreated -> do
              -- signal to others that we're taking care of the resource
              -- initialization
              TVar (Resource res) -> Resource res -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Resource res)
initVar Resource res
forall r. Resource r
BeingCreated
              IO () -> STM (IO ())
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> STM (IO ())) -> IO () -> STM (IO ())
forall a b. (a -> b) -> a -> b
$
                (do
                  res <- IO res
doInit
                  atomically $ writeTVar initVar $ Created res
                 ) IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` \SomeException
exn -> do
                  STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar (Resource res) -> Resource res -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Resource res)
initVar (Resource res -> STM ()) -> Resource res -> STM ()
forall a b. (a -> b) -> a -> b
$ SomeException -> Resource res
forall r. SomeException -> Resource r
FailedToCreate SomeException
exn
                  SomeException -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO SomeException
exn
            Resource res
BeingCreated -> STM (IO ())
forall a. STM a
retry
            Created {} -> IO () -> STM (IO ())
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> STM (IO ())) -> IO () -> STM (IO ())
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            FailedToCreate SomeException
exn -> IO () -> STM (IO ())
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> STM (IO ())) -> IO () -> STM (IO ())
forall a b. (a -> b) -> a -> b
$ SomeException -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO SomeException
exn
            -- If the resource is destroyed or being destroyed
            -- while we're starting a test, the test suite is probably
            -- shutting down. We are about to be killed.
            -- (In fact we are probably killed already, so these cases are
            -- unlikely to occur.)
            -- In any case, the most sensible thing to do is to go to
            -- sleep, awaiting our fate.
            Resource res
Destroyed      -> IO () -> STM (IO ())
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> STM (IO ())) -> IO () -> STM (IO ())
forall a b. (a -> b) -> a -> b
$ IO ()
sleepIndefinitely
            Resource res
BeingDestroyed -> IO () -> STM (IO ())
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> STM (IO ())) -> IO () -> STM (IO ())
forall a b. (a -> b) -> a -> b
$ IO ()
sleepIndefinitely

    applyTimeout :: Timeout -> IO Result -> IO Result
    applyTimeout :: Timeout -> IO Result -> IO Result
applyTimeout Timeout
NoTimeout IO Result
a = IO Result
a
    applyTimeout (Timeout Integer
t [Char]
tstr) IO Result
a = do
      let
        timeoutResult :: Result
timeoutResult =
          Result
            { resultOutcome :: Outcome
resultOutcome = FailureReason -> Outcome
Failure (FailureReason -> Outcome) -> FailureReason -> Outcome
forall a b. (a -> b) -> a -> b
$ Integer -> FailureReason
TestTimedOut Integer
t
            , resultDescription :: [Char]
resultDescription =
                [Char]
"Timed out after " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
tstr
            , resultShortDescription :: [Char]
resultShortDescription = [Char]
"TIMEOUT"
            , resultTime :: Time
resultTime = Integer -> Time
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
t
            , resultDetailsPrinter :: ResultDetailsPrinter
resultDetailsPrinter = ResultDetailsPrinter
noResultDetails
            }
      -- If compiled with unbounded-delays then t' :: Integer, otherwise t' :: Int
      let t' :: Int
t' = Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
min (Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
max Integer
0 Integer
t) (Int64 -> Integer
forall a. Integral a => a -> Integer
toInteger (Int64
forall a. Bounded a => a
maxBound :: Int64)))
      Result -> Maybe Result -> Result
forall a. a -> Maybe a -> a
fromMaybe Result
timeoutResult (Maybe Result -> Result) -> IO (Maybe Result) -> IO Result
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> IO Result -> IO (Maybe Result)
forall a. Int -> IO a -> IO (Maybe a)
timeout Int
t' IO Result
a

    -- destroyResources should not be interrupted by an exception
    -- Here's how we ensure this:
    --
    -- * the finalizer is wrapped in 'try'
    -- * async exceptions are masked by the caller
    -- * we don't use any interruptible operations here (outside of 'try')
    destroyResources :: (forall a . IO a -> IO a) -> IO (Maybe SomeException)
    destroyResources :: (forall a. IO a -> IO a) -> IO (Maybe SomeException)
destroyResources forall a. IO a -> IO a
restore = do
      -- remember the first exception that occurred
      (First SomeException -> Maybe SomeException)
-> IO (First SomeException) -> IO (Maybe SomeException)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM First SomeException -> Maybe SomeException
forall a. First a -> Maybe a
getFirst (IO (First SomeException) -> IO (Maybe SomeException))
-> (Traversal (WriterT (First SomeException) IO)
    -> IO (First SomeException))
-> Traversal (WriterT (First SomeException) IO)
-> IO (Maybe SomeException)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WriterT (First SomeException) IO () -> IO (First SomeException)
forall (m :: * -> *) w a. Monad m => WriterT w m a -> m w
execWriterT (WriterT (First SomeException) IO () -> IO (First SomeException))
-> (Traversal (WriterT (First SomeException) IO)
    -> WriterT (First SomeException) IO ())
-> Traversal (WriterT (First SomeException) IO)
-> IO (First SomeException)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Traversal (WriterT (First SomeException) IO)
-> WriterT (First SomeException) IO ()
forall (f :: * -> *). Traversal f -> f ()
getTraversal (Traversal (WriterT (First SomeException) IO)
 -> IO (Maybe SomeException))
-> Traversal (WriterT (First SomeException) IO)
-> IO (Maybe SomeException)
forall a b. (a -> b) -> a -> b
$
        ((Finalizer -> Traversal (WriterT (First SomeException) IO))
 -> Seq Finalizer -> Traversal (WriterT (First SomeException) IO))
-> Seq Finalizer
-> (Finalizer -> Traversal (WriterT (First SomeException) IO))
-> Traversal (WriterT (First SomeException) IO)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Finalizer -> Traversal (WriterT (First SomeException) IO))
-> Seq Finalizer -> Traversal (WriterT (First SomeException) IO)
forall m a. Monoid m => (a -> m) -> Seq a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
F.foldMap Seq Finalizer
fins ((Finalizer -> Traversal (WriterT (First SomeException) IO))
 -> Traversal (WriterT (First SomeException) IO))
-> (Finalizer -> Traversal (WriterT (First SomeException) IO))
-> Traversal (WriterT (First SomeException) IO)
forall a b. (a -> b) -> a -> b
$ \fin :: Finalizer
fin@(Finalizer res -> IO ()
_ TVar (Resource res)
_ TVar Int
finishVar) ->
          WriterT (First SomeException) IO ()
-> Traversal (WriterT (First SomeException) IO)
forall (f :: * -> *). f () -> Traversal f
Traversal (WriterT (First SomeException) IO ()
 -> Traversal (WriterT (First SomeException) IO))
-> WriterT (First SomeException) IO ()
-> Traversal (WriterT (First SomeException) IO)
forall a b. (a -> b) -> a -> b
$ do
            iAmLast <- IO Bool -> WriterT (First SomeException) IO Bool
forall a. IO a -> WriterT (First SomeException) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> WriterT (First SomeException) IO Bool)
-> IO Bool -> WriterT (First SomeException) IO Bool
forall a b. (a -> b) -> a -> b
$ STM Bool -> IO Bool
forall a. STM a -> IO a
atomically (STM Bool -> IO Bool) -> STM Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ do
              nUsers <- TVar Int -> STM Int
forall a. TVar a -> STM a
readTVar TVar Int
finishVar
              let nUsers' = Int
nUsers Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
              writeTVar finishVar nUsers'
              return $ nUsers' == 0

            mbExcn <- liftIO $
              if iAmLast
              then destroyResource restore fin
              else return Nothing

            tell $ First mbExcn

    -- The callback
    -- Since this is not used yet anyway, disable for now.
    -- I'm not sure whether we should get rid of this altogether. For most
    -- providers this is either difficult to implement or doesn't make
    -- sense at all.
    -- See also https://github.com/UnkindPartition/tasty/issues/33
    yieldProgress :: p -> m ()
yieldProgress p
_ = () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

type InitFinPair = (Seq.Seq Initializer, Seq.Seq Finalizer)

-- | Dependencies of a test
type Deps = [(DependencyType, Expr)]

-- | Traversal type used in 'createTestActions'
type Tr = Traversal
        (WriterT ([(InitFinPair -> IO (), (TVar Status, Path, Deps))], Seq.Seq Finalizer)
        (ReaderT (Path, Deps)
        IO))

-- | Exceptions related to dependencies between tests.
data DependencyException
  = DependencyLoop
    -- ^ Test dependencies form a loop. In other words, test A cannot start
    -- until test B finishes, and test B cannot start until test
    -- A finishes.
  deriving (Typeable)

instance Show DependencyException where
  show :: DependencyException -> [Char]
show DependencyException
DependencyLoop = [Char]
"Test dependencies form a loop."

instance Exception DependencyException

-- | Turn a test tree into a list of actions to run tests coupled with
-- variables to watch them.
createTestActions
  :: OptionSet
  -> TestTree
  -> IO ([(Action, TVar Status)], Seq.Seq Finalizer)
createTestActions :: OptionSet
-> TestTree -> IO ([(Action, TVar Status)], Seq Finalizer)
createTestActions OptionSet
opts0 TestTree
tree = do
  let
    traversal :: Tr
    traversal :: Tr
traversal =
      TreeFold Tr -> OptionSet -> TestTree -> Tr
forall b. Monoid b => TreeFold b -> OptionSet -> TestTree -> b
foldTestTree
        (TreeFold Tr
forall b. Monoid b => TreeFold b
trivialFold :: TreeFold Tr)
          { foldSingle = runSingleTest
          , foldResource = addInitAndRelease
          , foldGroup = \OptionSet
_opts [Char]
name (Traversal WriterT
  ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
   Seq Finalizer)
  (ReaderT (Path, Deps) IO)
  ()
a) ->
              WriterT
  ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
   Seq Finalizer)
  (ReaderT (Path, Deps) IO)
  ()
-> Tr
forall (f :: * -> *). f () -> Traversal f
Traversal (WriterT
   ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
    Seq Finalizer)
   (ReaderT (Path, Deps) IO)
   ()
 -> Tr)
-> WriterT
     ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
      Seq Finalizer)
     (ReaderT (Path, Deps) IO)
     ()
-> Tr
forall a b. (a -> b) -> a -> b
$ (ReaderT
   (Path, Deps)
   IO
   ((),
    ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
     Seq Finalizer))
 -> ReaderT
      (Path, Deps)
      IO
      ((),
       ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
        Seq Finalizer)))
-> WriterT
     ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
      Seq Finalizer)
     (ReaderT (Path, Deps) IO)
     ()
-> WriterT
     ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
      Seq Finalizer)
     (ReaderT (Path, Deps) IO)
     ()
forall (m :: * -> *) a w (n :: * -> *) b w'.
(m (a, w) -> n (b, w')) -> WriterT w m a -> WriterT w' n b
mapWriterT (((Path, Deps) -> (Path, Deps))
-> ReaderT
     (Path, Deps)
     IO
     ((),
      ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
       Seq Finalizer))
-> ReaderT
     (Path, Deps)
     IO
     ((),
      ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
       Seq Finalizer))
forall r (m :: * -> *) a.
(r -> r) -> ReaderT r m a -> ReaderT r m a
local ((Path -> Path) -> (Path, Deps) -> (Path, Deps)
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (Path -> [Char] -> Path
forall a. Seq a -> a -> Seq a
Seq.|> [Char]
name))) WriterT
  ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
   Seq Finalizer)
  (ReaderT (Path, Deps) IO)
  ()
a
          , foldAfter = \OptionSet
_opts DependencyType
deptype Expr
pat (Traversal WriterT
  ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
   Seq Finalizer)
  (ReaderT (Path, Deps) IO)
  ()
a) ->
              WriterT
  ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
   Seq Finalizer)
  (ReaderT (Path, Deps) IO)
  ()
-> Tr
forall (f :: * -> *). f () -> Traversal f
Traversal (WriterT
   ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
    Seq Finalizer)
   (ReaderT (Path, Deps) IO)
   ()
 -> Tr)
-> WriterT
     ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
      Seq Finalizer)
     (ReaderT (Path, Deps) IO)
     ()
-> Tr
forall a b. (a -> b) -> a -> b
$ (ReaderT
   (Path, Deps)
   IO
   ((),
    ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
     Seq Finalizer))
 -> ReaderT
      (Path, Deps)
      IO
      ((),
       ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
        Seq Finalizer)))
-> WriterT
     ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
      Seq Finalizer)
     (ReaderT (Path, Deps) IO)
     ()
-> WriterT
     ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
      Seq Finalizer)
     (ReaderT (Path, Deps) IO)
     ()
forall (m :: * -> *) a w (n :: * -> *) b w'.
(m (a, w) -> n (b, w')) -> WriterT w m a -> WriterT w' n b
mapWriterT (((Path, Deps) -> (Path, Deps))
-> ReaderT
     (Path, Deps)
     IO
     ((),
      ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
       Seq Finalizer))
-> ReaderT
     (Path, Deps)
     IO
     ((),
      ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
       Seq Finalizer))
forall r (m :: * -> *) a.
(r -> r) -> ReaderT r m a -> ReaderT r m a
local ((Deps -> Deps) -> (Path, Deps) -> (Path, Deps)
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second ((DependencyType
deptype, Expr
pat) (DependencyType, Expr) -> Deps -> Deps
forall a. a -> [a] -> [a]
:))) WriterT
  ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
   Seq Finalizer)
  (ReaderT (Path, Deps) IO)
  ()
a
          }
        OptionSet
opts0 TestTree
tree
  (tests, fins) <- Path
-> Deps
-> Tr
-> IO
     ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
      Seq Finalizer)
unwrap (Path
forall a. Monoid a => a
mempty :: Path) (Deps
forall a. Monoid a => a
mempty :: Deps) Tr
traversal
  let
    mb_tests :: Maybe [(Action, TVar Status)]
    mb_tests = [(IO (), (TVar Status, Path, Deps))]
-> Maybe [(Action, TVar Status)]
resolveDeps ([(IO (), (TVar Status, Path, Deps))]
 -> Maybe [(Action, TVar Status)])
-> [(IO (), (TVar Status, Path, Deps))]
-> Maybe [(Action, TVar Status)]
forall a b. (a -> b) -> a -> b
$ ((InitFinPair -> IO (), (TVar Status, Path, Deps))
 -> (IO (), (TVar Status, Path, Deps)))
-> [(InitFinPair -> IO (), (TVar Status, Path, Deps))]
-> [(IO (), (TVar Status, Path, Deps))]
forall a b. (a -> b) -> [a] -> [b]
map
      (\(InitFinPair -> IO ()
act, (TVar Status, Path, Deps)
testInfo) ->
        (InitFinPair -> IO ()
act (Seq Initializer
forall a. Seq a
Seq.empty, Seq Finalizer
forall a. Seq a
Seq.empty), (TVar Status, Path, Deps)
testInfo))
      [(InitFinPair -> IO (), (TVar Status, Path, Deps))]
tests
  case mb_tests of
    Just [(Action, TVar Status)]
tests' -> ([(Action, TVar Status)], Seq Finalizer)
-> IO ([(Action, TVar Status)], Seq Finalizer)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Action, TVar Status)]
tests', Seq Finalizer
fins)
    Maybe [(Action, TVar Status)]
Nothing -> DependencyException -> IO ([(Action, TVar Status)], Seq Finalizer)
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO DependencyException
DependencyLoop

  where
    runSingleTest :: IsTest t => OptionSet -> TestName -> t -> Tr
    runSingleTest :: forall t. IsTest t => OptionSet -> [Char] -> t -> Tr
runSingleTest OptionSet
opts [Char]
name t
test = WriterT
  ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
   Seq Finalizer)
  (ReaderT (Path, Deps) IO)
  ()
-> Tr
forall (f :: * -> *). f () -> Traversal f
Traversal (WriterT
   ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
    Seq Finalizer)
   (ReaderT (Path, Deps) IO)
   ()
 -> Tr)
-> WriterT
     ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
      Seq Finalizer)
     (ReaderT (Path, Deps) IO)
     ()
-> Tr
forall a b. (a -> b) -> a -> b
$ do
      statusVar <- IO (TVar Status)
-> WriterT
     ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
      Seq Finalizer)
     (ReaderT (Path, Deps) IO)
     (TVar Status)
forall a.
IO a
-> WriterT
     ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
      Seq Finalizer)
     (ReaderT (Path, Deps) IO)
     a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (TVar Status)
 -> WriterT
      ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
       Seq Finalizer)
      (ReaderT (Path, Deps) IO)
      (TVar Status))
-> IO (TVar Status)
-> WriterT
     ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
      Seq Finalizer)
     (ReaderT (Path, Deps) IO)
     (TVar Status)
forall a b. (a -> b) -> a -> b
$ STM (TVar Status) -> IO (TVar Status)
forall a. STM a -> IO a
atomically (STM (TVar Status) -> IO (TVar Status))
-> STM (TVar Status) -> IO (TVar Status)
forall a b. (a -> b) -> a -> b
$ Status -> STM (TVar Status)
forall a. a -> STM (TVar a)
newTVar Status
NotStarted
      (parentPath, deps) <- lift ask
      let
        path = Path
parentPath Path -> [Char] -> Path
forall a. Seq a -> a -> Seq a
Seq.|> [Char]
name
        act (Seq Initializer
inits, Seq Finalizer
fins) =
          ((Progress -> IO ()) -> IO Result)
-> TVar Status
-> Timeout
-> Seq Initializer
-> Seq Finalizer
-> IO ()
executeTest (OptionSet -> t -> (Progress -> IO ()) -> IO Result
forall t.
IsTest t =>
OptionSet -> t -> (Progress -> IO ()) -> IO Result
run OptionSet
opts t
test) TVar Status
statusVar (OptionSet -> Timeout
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts) Seq Initializer
inits Seq Finalizer
fins
      tell ([(act, (statusVar, path, deps))], mempty)
    addInitAndRelease :: OptionSet -> ResourceSpec a -> (IO a -> Tr) -> Tr
    addInitAndRelease :: forall a. OptionSet -> ResourceSpec a -> (IO a -> Tr) -> Tr
addInitAndRelease OptionSet
_opts (ResourceSpec IO a
doInit a -> IO ()
doRelease) IO a -> Tr
a = (Path
 -> Deps
 -> IO
      ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
       Seq Finalizer))
-> Tr
wrap ((Path
  -> Deps
  -> IO
       ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
        Seq Finalizer))
 -> Tr)
-> (Path
    -> Deps
    -> IO
         ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
          Seq Finalizer))
-> Tr
forall a b. (a -> b) -> a -> b
$ \Path
path Deps
deps -> do
      initVar <- STM (TVar (Resource a)) -> IO (TVar (Resource a))
forall a. STM a -> IO a
atomically (STM (TVar (Resource a)) -> IO (TVar (Resource a)))
-> STM (TVar (Resource a)) -> IO (TVar (Resource a))
forall a b. (a -> b) -> a -> b
$ Resource a -> STM (TVar (Resource a))
forall a. a -> STM (TVar a)
newTVar Resource a
forall r. Resource r
NotCreated
      (tests, fins) <- unwrap path deps $ a (getResource initVar)
      let ntests = [(InitFinPair -> IO (), (TVar Status, Path, Deps))] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(InitFinPair -> IO (), (TVar Status, Path, Deps))]
tests
      finishVar <- atomically $ newTVar ntests
      let
        ini = IO a -> TVar (Resource a) -> Initializer
forall res. IO res -> TVar (Resource res) -> Initializer
Initializer IO a
doInit TVar (Resource a)
initVar
        fin = (a -> IO ()) -> TVar (Resource a) -> TVar Int -> Finalizer
forall res.
(res -> IO ()) -> TVar (Resource res) -> TVar Int -> Finalizer
Finalizer a -> IO ()
doRelease TVar (Resource a)
initVar TVar Int
finishVar
        tests' = ((InitFinPair -> IO (), (TVar Status, Path, Deps))
 -> (InitFinPair -> IO (), (TVar Status, Path, Deps)))
-> [(InitFinPair -> IO (), (TVar Status, Path, Deps))]
-> [(InitFinPair -> IO (), (TVar Status, Path, Deps))]
forall a b. (a -> b) -> [a] -> [b]
map (((InitFinPair -> IO ()) -> InitFinPair -> IO ())
-> (InitFinPair -> IO (), (TVar Status, Path, Deps))
-> (InitFinPair -> IO (), (TVar Status, Path, Deps))
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (\InitFinPair -> IO ()
f (Seq Initializer
x, Seq Finalizer
y) -> InitFinPair -> IO ()
f (Seq Initializer
x Seq Initializer -> Initializer -> Seq Initializer
forall a. Seq a -> a -> Seq a
Seq.|> Initializer
ini, Finalizer
fin Finalizer -> Seq Finalizer -> Seq Finalizer
forall a. a -> Seq a -> Seq a
Seq.<| Seq Finalizer
y))) [(InitFinPair -> IO (), (TVar Status, Path, Deps))]
tests
      return (tests', fins Seq.|> fin)
    wrap
      :: (Path ->
          Deps ->
          IO ([(InitFinPair -> IO (), (TVar Status, Path, Deps))], Seq.Seq Finalizer))
      -> Tr
    wrap :: (Path
 -> Deps
 -> IO
      ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
       Seq Finalizer))
-> Tr
wrap = WriterT
  ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
   Seq Finalizer)
  (ReaderT (Path, Deps) IO)
  ()
-> Tr
forall (f :: * -> *). f () -> Traversal f
Traversal (WriterT
   ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
    Seq Finalizer)
   (ReaderT (Path, Deps) IO)
   ()
 -> Tr)
-> ((Path
     -> Deps
     -> IO
          ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
           Seq Finalizer))
    -> WriterT
         ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
          Seq Finalizer)
         (ReaderT (Path, Deps) IO)
         ())
-> (Path
    -> Deps
    -> IO
         ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
          Seq Finalizer))
-> Tr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT
  (Path, Deps)
  IO
  ((),
   ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
    Seq Finalizer))
-> WriterT
     ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
      Seq Finalizer)
     (ReaderT (Path, Deps) IO)
     ()
forall w (m :: * -> *) a. m (a, w) -> WriterT w m a
WriterT (ReaderT
   (Path, Deps)
   IO
   ((),
    ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
     Seq Finalizer))
 -> WriterT
      ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
       Seq Finalizer)
      (ReaderT (Path, Deps) IO)
      ())
-> ((Path
     -> Deps
     -> IO
          ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
           Seq Finalizer))
    -> ReaderT
         (Path, Deps)
         IO
         ((),
          ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
           Seq Finalizer)))
-> (Path
    -> Deps
    -> IO
         ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
          Seq Finalizer))
-> WriterT
     ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
      Seq Finalizer)
     (ReaderT (Path, Deps) IO)
     ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
  Seq Finalizer)
 -> ((),
     ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
      Seq Finalizer)))
-> ReaderT
     (Path, Deps)
     IO
     ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
      Seq Finalizer)
-> ReaderT
     (Path, Deps)
     IO
     ((),
      ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
       Seq Finalizer))
forall a b.
(a -> b) -> ReaderT (Path, Deps) IO a -> ReaderT (Path, Deps) IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((,) ()) (ReaderT
   (Path, Deps)
   IO
   ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
    Seq Finalizer)
 -> ReaderT
      (Path, Deps)
      IO
      ((),
       ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
        Seq Finalizer)))
-> ((Path
     -> Deps
     -> IO
          ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
           Seq Finalizer))
    -> ReaderT
         (Path, Deps)
         IO
         ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
          Seq Finalizer))
-> (Path
    -> Deps
    -> IO
         ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
          Seq Finalizer))
-> ReaderT
     (Path, Deps)
     IO
     ((),
      ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
       Seq Finalizer))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Path, Deps)
 -> IO
      ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
       Seq Finalizer))
-> ReaderT
     (Path, Deps)
     IO
     ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
      Seq Finalizer)
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT (((Path, Deps)
  -> IO
       ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
        Seq Finalizer))
 -> ReaderT
      (Path, Deps)
      IO
      ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
       Seq Finalizer))
-> ((Path
     -> Deps
     -> IO
          ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
           Seq Finalizer))
    -> (Path, Deps)
    -> IO
         ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
          Seq Finalizer))
-> (Path
    -> Deps
    -> IO
         ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
          Seq Finalizer))
-> ReaderT
     (Path, Deps)
     IO
     ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
      Seq Finalizer)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Path
 -> Deps
 -> IO
      ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
       Seq Finalizer))
-> (Path, Deps)
-> IO
     ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
      Seq Finalizer)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry
    unwrap
      :: Path
      -> Deps
      -> Tr
      -> IO ([(InitFinPair -> IO (), (TVar Status, Path, Deps))], Seq.Seq Finalizer)
    unwrap :: Path
-> Deps
-> Tr
-> IO
     ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
      Seq Finalizer)
unwrap Path
path Deps
deps = (ReaderT
   (Path, Deps)
   IO
   ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
    Seq Finalizer)
 -> (Path, Deps)
 -> IO
      ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
       Seq Finalizer))
-> (Path, Deps)
-> ReaderT
     (Path, Deps)
     IO
     ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
      Seq Finalizer)
-> IO
     ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
      Seq Finalizer)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT
  (Path, Deps)
  IO
  ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
   Seq Finalizer)
-> (Path, Deps)
-> IO
     ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
      Seq Finalizer)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Path
path, Deps
deps) (ReaderT
   (Path, Deps)
   IO
   ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
    Seq Finalizer)
 -> IO
      ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
       Seq Finalizer))
-> (Tr
    -> ReaderT
         (Path, Deps)
         IO
         ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
          Seq Finalizer))
-> Tr
-> IO
     ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
      Seq Finalizer)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WriterT
  ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
   Seq Finalizer)
  (ReaderT (Path, Deps) IO)
  ()
-> ReaderT
     (Path, Deps)
     IO
     ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
      Seq Finalizer)
forall (m :: * -> *) w a. Monad m => WriterT w m a -> m w
execWriterT (WriterT
   ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
    Seq Finalizer)
   (ReaderT (Path, Deps) IO)
   ()
 -> ReaderT
      (Path, Deps)
      IO
      ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
       Seq Finalizer))
-> (Tr
    -> WriterT
         ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
          Seq Finalizer)
         (ReaderT (Path, Deps) IO)
         ())
-> Tr
-> ReaderT
     (Path, Deps)
     IO
     ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
      Seq Finalizer)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tr
-> WriterT
     ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
      Seq Finalizer)
     (ReaderT (Path, Deps) IO)
     ()
forall (f :: * -> *). Traversal f -> f ()
getTraversal

-- | Take care of the dependencies.
--
-- Return 'Nothing' if there is a dependency cycle.
resolveDeps :: [(IO (), (TVar Status, Path, Deps))] -> Maybe [(Action, TVar Status)]
resolveDeps :: [(IO (), (TVar Status, Path, Deps))]
-> Maybe [(Action, TVar Status)]
resolveDeps [(IO (), (TVar Status, Path, Deps))]
tests = [((Action, TVar Status), (Path, [Path]))]
-> Maybe [(Action, TVar Status)]
forall b a. Ord b => [(a, (b, [b]))] -> Maybe [a]
checkCycles ([((Action, TVar Status), (Path, [Path]))]
 -> Maybe [(Action, TVar Status)])
-> [((Action, TVar Status), (Path, [Path]))]
-> Maybe [(Action, TVar Status)]
forall a b. (a -> b) -> a -> b
$ do
  (run_test, (statusVar, path0, deps)) <- [(IO (), (TVar Status, Path, Deps))]
tests
  let
    -- Note: Duplicate dependencies may arise if the same test name matches
    -- multiple patterns. It's not clear that removing them is worth the
    -- trouble; might consider this in the future.
    deps' :: [(DependencyType, TVar Status, Path)]
    deps' = do
      (deptype, depexpr) <- Deps
deps
      (_, (statusVar1, path, _)) <- tests
      guard $ exprMatches depexpr path
      return (deptype, statusVar1, path)

    getStatus :: STM ActionStatus
    getStatus = ((DependencyType, TVar Status, Path)
 -> STM ActionStatus -> STM ActionStatus)
-> STM ActionStatus
-> [(DependencyType, TVar Status, Path)]
-> STM ActionStatus
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
      (\(DependencyType
deptype, TVar Status
statusvar, Path
_) STM ActionStatus
k -> do
        status <- TVar Status -> STM Status
forall a. TVar a -> STM a
readTVar TVar Status
statusvar
        case status of
          Done Result
result
            | DependencyType
deptype DependencyType -> DependencyType -> Bool
forall a. Eq a => a -> a -> Bool
== DependencyType
AllFinish Bool -> Bool -> Bool
|| Result -> Bool
resultSuccessful Result
result -> STM ActionStatus
k
            | Bool
otherwise -> ActionStatus -> STM ActionStatus
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return ActionStatus
ActionSkip
          Status
_ -> ActionStatus -> STM ActionStatus
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return ActionStatus
ActionWait
      )
      (ActionStatus -> STM ActionStatus
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return ActionStatus
ActionReady)
      [(DependencyType, TVar Status, Path)]
deps'
  let
    dep_paths = ((DependencyType, TVar Status, Path) -> Path)
-> [(DependencyType, TVar Status, Path)] -> [Path]
forall a b. (a -> b) -> [a] -> [b]
map (\(DependencyType
_, TVar Status
_, Path
path) -> Path
path) [(DependencyType, TVar Status, Path)]
deps'
    action = Action
      { actionStatus :: STM ActionStatus
actionStatus = STM ActionStatus
getStatus
      , actionRun :: IO ()
actionRun = IO ()
run_test
      , actionSkip :: STM ()
actionSkip = TVar Status -> Status -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Status
statusVar (Status -> STM ()) -> Status -> STM ()
forall a b. (a -> b) -> a -> b
$ Result -> Status
Done (Result -> Status) -> Result -> Status
forall a b. (a -> b) -> a -> b
$ Result
          -- See Note [Skipped tests]
          { resultOutcome :: Outcome
resultOutcome = FailureReason -> Outcome
Failure FailureReason
TestDepFailed
          , resultDescription :: [Char]
resultDescription = [Char]
""
          , resultShortDescription :: [Char]
resultShortDescription = [Char]
"SKIP"
          , resultTime :: Time
resultTime = Time
0
          , resultDetailsPrinter :: ResultDetailsPrinter
resultDetailsPrinter = ResultDetailsPrinter
noResultDetails
          }
      }
  return ((action, statusVar), (path0, dep_paths))

checkCycles :: Ord b => [(a, (b, [b]))] -> Maybe [a]
checkCycles :: forall b a. Ord b => [(a, (b, [b]))] -> Maybe [a]
checkCycles [(a, (b, [b]))]
tests = do
  let
    result :: [a]
result = (a, (b, [b])) -> a
forall a b. (a, b) -> a
fst ((a, (b, [b])) -> a) -> [(a, (b, [b]))] -> [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(a, (b, [b]))]
tests
    graph :: [((), b, [b])]
graph = [ ((), b
v, [b]
vs) | (b
v, [b]
vs) <- (a, (b, [b])) -> (b, [b])
forall a b. (a, b) -> b
snd ((a, (b, [b])) -> (b, [b])) -> [(a, (b, [b]))] -> [(b, [b])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(a, (b, [b]))]
tests ]
    sccs :: [SCC ()]
sccs = [((), b, [b])] -> [SCC ()]
forall key node. Ord key => [(node, key, [key])] -> [SCC node]
stronglyConnComp [((), b, [b])]
graph
    not_cyclic :: Bool
not_cyclic = (SCC () -> Bool) -> [SCC ()] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\SCC ()
scc -> case SCC ()
scc of
        AcyclicSCC{} -> Bool
True
        CyclicSCC{}  -> Bool
False)
      [SCC ()]
sccs
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard Bool
not_cyclic
  [a] -> Maybe [a]
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return [a]
result

-- | Used to create the IO action which is passed in a WithResource node
getResource :: TVar (Resource r) -> IO r
getResource :: forall r. TVar (Resource r) -> IO r
getResource TVar (Resource r)
var =
  STM r -> IO r
forall a. STM a -> IO a
atomically (STM r -> IO r) -> STM r -> IO r
forall a b. (a -> b) -> a -> b
$ do
    rState <- TVar (Resource r) -> STM (Resource r)
forall a. TVar a -> STM a
readTVar TVar (Resource r)
var
    case rState of
      Created r
r -> r -> STM r
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return r
r
      Resource r
Destroyed -> ResourceError -> STM r
forall e a. Exception e => e -> STM a
throwSTM ResourceError
UseOutsideOfTest
      Resource r
_ -> SomeException -> STM r
forall e a. Exception e => e -> STM a
throwSTM (SomeException -> STM r) -> SomeException -> STM r
forall a b. (a -> b) -> a -> b
$ [Char] -> Resource r -> SomeException
forall r. [Char] -> Resource r -> SomeException
unexpectedState [Char]
"getResource" Resource r
rState

-- | Run a resource finalizer.
--
-- This function is called from two different places:
--
-- 1. A test thread, which is the last one to use the resource.
-- 2. The main thread, if an exception (e.g. Ctrl-C) is received.
--
-- Therefore, it is possible that this function is called multiple
-- times concurrently on the same finalizer.
--
-- This function should be run with async exceptions masked,
-- and the restore function should be passed as an argument.
destroyResource :: (forall a . IO a -> IO a) -> Finalizer -> IO (Maybe SomeException)
destroyResource :: (forall a. IO a -> IO a) -> Finalizer -> IO (Maybe SomeException)
destroyResource forall a. IO a -> IO a
restore (Finalizer res -> IO ()
doRelease TVar (Resource res)
stateVar TVar Int
_) = IO (IO (Maybe SomeException)) -> IO (Maybe SomeException)
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO (Maybe SomeException)) -> IO (Maybe SomeException))
-> (STM (IO (Maybe SomeException))
    -> IO (IO (Maybe SomeException)))
-> STM (IO (Maybe SomeException))
-> IO (Maybe SomeException)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM (IO (Maybe SomeException)) -> IO (IO (Maybe SomeException))
forall a. STM a -> IO a
atomically (STM (IO (Maybe SomeException)) -> IO (Maybe SomeException))
-> STM (IO (Maybe SomeException)) -> IO (Maybe SomeException)
forall a b. (a -> b) -> a -> b
$ do
  rState <- TVar (Resource res) -> STM (Resource res)
forall a. TVar a -> STM a
readTVar TVar (Resource res)
stateVar
  case rState of
    Created res
res -> do
      TVar (Resource res) -> Resource res -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Resource res)
stateVar Resource res
forall r. Resource r
BeingDestroyed
      IO (Maybe SomeException) -> STM (IO (Maybe SomeException))
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (IO (Maybe SomeException) -> STM (IO (Maybe SomeException)))
-> IO (Maybe SomeException) -> STM (IO (Maybe SomeException))
forall a b. (a -> b) -> a -> b
$
        ((SomeException -> Maybe SomeException)
-> (() -> Maybe SomeException)
-> Either SomeException ()
-> Maybe SomeException
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either SomeException -> Maybe SomeException
forall a. a -> Maybe a
Just (Maybe SomeException -> () -> Maybe SomeException
forall a b. a -> b -> a
const Maybe SomeException
forall a. Maybe a
Nothing)
          (Either SomeException () -> Maybe SomeException)
-> IO (Either SomeException ()) -> IO (Maybe SomeException)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO () -> IO (Either SomeException ())
forall e a. Exception e => IO a -> IO (Either e a)
try (IO () -> IO ()
forall a. IO a -> IO a
restore (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ res -> IO ()
doRelease res
res))
          IO (Maybe SomeException) -> IO () -> IO (Maybe SomeException)
forall a b. IO a -> IO b -> IO a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* STM () -> IO ()
forall a. STM a -> IO a
atomically (TVar (Resource res) -> Resource res -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Resource res)
stateVar Resource res
forall r. Resource r
Destroyed)
    Resource res
BeingCreated   -> STM (IO (Maybe SomeException))
forall a. STM a
retry
    -- If the resource is being destroyed, wait until it is destroyed.
    -- This is so that we don't start destroying the next resource out of
    -- order.
    Resource res
BeingDestroyed -> STM (IO (Maybe SomeException))
forall a. STM a
retry
    Resource res
NotCreated -> do
      -- prevent the resource from being created by a competing thread
      TVar (Resource res) -> Resource res -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Resource res)
stateVar Resource res
forall r. Resource r
Destroyed
      IO (Maybe SomeException) -> STM (IO (Maybe SomeException))
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (IO (Maybe SomeException) -> STM (IO (Maybe SomeException)))
-> IO (Maybe SomeException) -> STM (IO (Maybe SomeException))
forall a b. (a -> b) -> a -> b
$ Maybe SomeException -> IO (Maybe SomeException)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SomeException
forall a. Maybe a
Nothing
    FailedToCreate {} -> IO (Maybe SomeException) -> STM (IO (Maybe SomeException))
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (IO (Maybe SomeException) -> STM (IO (Maybe SomeException)))
-> IO (Maybe SomeException) -> STM (IO (Maybe SomeException))
forall a b. (a -> b) -> a -> b
$ Maybe SomeException -> IO (Maybe SomeException)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SomeException
forall a. Maybe a
Nothing
    Resource res
Destroyed         -> IO (Maybe SomeException) -> STM (IO (Maybe SomeException))
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (IO (Maybe SomeException) -> STM (IO (Maybe SomeException)))
-> IO (Maybe SomeException) -> STM (IO (Maybe SomeException))
forall a b. (a -> b) -> a -> b
$ Maybe SomeException -> IO (Maybe SomeException)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SomeException
forall a. Maybe a
Nothing

-- | Start running the tests (in background, in parallel) and pass control
-- to the callback.
--
-- Once the callback returns, stop running the tests.
--
-- The number of test running threads is determined by the 'NumThreads'
-- option.
launchTestTree
  :: OptionSet
  -> TestTree
  -> (StatusMap -> IO (Time -> IO a))
    -- ^ A callback. First, it receives the 'StatusMap' through which it
    -- can observe the execution of tests in real time. Typically (but not
    -- necessarily), it waits until all the tests are finished.
    --
    -- After this callback returns, the test-running threads (if any) are
    -- terminated and all resources acquired by tests are released.
    --
    -- The callback must return another callback (of type @'Time' -> 'IO'
    -- a@) which additionally can report and/or record the total time
    -- taken by the test suite. This time includes the time taken to run
    -- all resource initializers and finalizers, which is why it is more
    -- accurate than what could be measured from inside the first callback.
  -> IO a
launchTestTree :: forall a.
OptionSet -> TestTree -> (StatusMap -> IO (Time -> IO a)) -> IO a
launchTestTree OptionSet
opts TestTree
tree StatusMap -> IO (Time -> IO a)
k0 = do
  (testActions, fins) <- OptionSet
-> TestTree -> IO ([(Action, TVar Status)], Seq Finalizer)
createTestActions OptionSet
opts TestTree
tree
  let NumThreads numTheads = lookupOption opts
  (t,k1) <- timed $ do
     abortTests <- runInParallel numTheads (fst <$> testActions)
     (do let smap = [(Int, TVar Status)] -> StatusMap
forall a. [(Int, a)] -> IntMap a
IntMap.fromList ([(Int, TVar Status)] -> StatusMap)
-> [(Int, TVar Status)] -> StatusMap
forall a b. (a -> b) -> a -> b
$ [Int] -> [TVar Status] -> [(Int, TVar Status)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] ((Action, TVar Status) -> TVar Status
forall a b. (a, b) -> b
snd ((Action, TVar Status) -> TVar Status)
-> [(Action, TVar Status)] -> [TVar Status]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Action, TVar Status)]
testActions)
         k0 smap)
      `finallyRestore` \forall a. IO a -> IO a
restore -> do
         -- Tell all running tests to wrap up.
         IO ()
abortTests
         -- Destroy all allocated resources in the case they didn't get
         -- destroyed by their tests. (See #75.)
         (Finalizer -> IO (Maybe SomeException)) -> Seq Finalizer -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
F.mapM_ ((forall a. IO a -> IO a) -> Finalizer -> IO (Maybe SomeException)
destroyResource IO a -> IO a
forall a. IO a -> IO a
restore) Seq Finalizer
fins
         -- Wait until all resources are destroyed. (Specifically, those
         -- that were being destroyed by their tests, not those that were
         -- destroyed by destroyResource above.)
         IO () -> IO ()
forall a. IO a -> IO a
restore (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Seq Finalizer -> IO ()
forall {t :: * -> *}. Foldable t => t Finalizer -> IO ()
waitForResources Seq Finalizer
fins
  k1 t
  where
    alive :: Resource r -> Bool
    alive :: forall r. Resource r -> Bool
alive Resource r
r = case Resource r
r of
      Resource r
NotCreated -> Bool
False
      Resource r
BeingCreated -> Bool
True
      FailedToCreate {} -> Bool
False
      Created {} -> Bool
True
      Resource r
BeingDestroyed -> Bool
True
      Resource r
Destroyed -> Bool
False

    waitForResources :: t Finalizer -> IO ()
waitForResources t Finalizer
fins = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$
      t Finalizer -> (Finalizer -> STM ()) -> STM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
F.forM_ t Finalizer
fins ((Finalizer -> STM ()) -> STM ())
-> (Finalizer -> STM ()) -> STM ()
forall a b. (a -> b) -> a -> b
$ \(Finalizer res -> IO ()
_ TVar (Resource res)
rvar TVar Int
_) -> do
        res <- TVar (Resource res) -> STM (Resource res)
forall a. TVar a -> STM a
readTVar TVar (Resource res)
rvar
        check $ not $ alive res

unexpectedState :: String -> Resource r -> SomeException
unexpectedState :: forall r. [Char] -> Resource r -> SomeException
unexpectedState [Char]
where_ Resource r
r = ResourceError -> SomeException
forall e. Exception e => e -> SomeException
toException (ResourceError -> SomeException) -> ResourceError -> SomeException
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> ResourceError
UnexpectedState [Char]
where_ (Resource r -> [Char]
forall a. Show a => a -> [Char]
show Resource r
r)

sleepIndefinitely :: IO ()
sleepIndefinitely :: IO ()
sleepIndefinitely = IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay (Int
10Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^(Int
7::Int))

-- | Like 'finally' (which also masks its finalizers), but pass the restore
-- action to the finalizer.
finallyRestore
  :: IO a
    -- ^ computation to run first
  -> ((forall c . IO c -> IO c) -> IO b)
    -- ^ computation to run afterward (even if an exception was raised)
  -> IO a
    -- ^ returns the value from the first computation
IO a
a finallyRestore :: forall a b. IO a -> ((forall a. IO a -> IO a) -> IO b) -> IO a
`finallyRestore` (forall a. IO a -> IO a) -> IO b
sequel =
  ((forall a. IO a -> IO a) -> IO a) -> IO a
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask (((forall a. IO a -> IO a) -> IO a) -> IO a)
-> ((forall a. IO a -> IO a) -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> do
    r <- IO a -> IO a
forall a. IO a -> IO a
restore IO a
a IO a -> IO b -> IO a
forall a b. IO a -> IO b -> IO a
`onException` (forall a. IO a -> IO a) -> IO b
sequel IO c -> IO c
forall a. IO a -> IO a
restore
    _ <- sequel restore
    return r