-- | 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.Maybe
import Data.Graph (SCC(..), stronglyConnComp)
import Data.Typeable
import Control.Monad.State
import Control.Monad.Writer
import Control.Monad.Reader
import Control.Concurrent
import Control.Concurrent.STM
import Control.Concurrent.Timeout (timeout)
import Control.Concurrent.Async
import Control.Exception as E
import Control.Applicative
import Control.Arrow
import GHC.Conc (labelThread)
import Prelude  -- Silence AMP and FTP import warnings

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 -> String
(Int -> Status -> ShowS)
-> (Status -> String) -> ([Status] -> ShowS) -> Show Status
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Status] -> ShowS
$cshowList :: [Status] -> ShowS
show :: Status -> String
$cshow :: Status -> String
showsPrec :: Int -> Status -> ShowS
$cshowsPrec :: Int -> 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 -> String
show Resource r
r = case Resource r
r of
    Resource r
NotCreated -> String
"NotCreated"
    Resource r
BeingCreated -> String
"BeingCreated"
    FailedToCreate SomeException
exn -> String
"FailedToCreate " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SomeException -> String
forall a. Show a => a -> String
show SomeException
exn
    Created {} -> String
"Created"
    Resource r
BeingDestroyed -> String
"BeingDestroyed"
    Resource r
Destroyed -> String
"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
  Either SomeException (Time, Result)
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 -> String -> IO ()
labelThread (Async Result -> ThreadId
forall a. Async a -> ThreadId
asyncThreadId Async Result
asy) String
"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
        Result
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.
        () -> IO ()
forall a. a -> IO a
evaluate (() -> IO ()) -> () -> IO ()
forall a b. (a -> b) -> a -> b
$
          Result -> Outcome
resultOutcome Result
r Outcome -> () -> ()
`seq`
          String -> ()
forall a. [a] -> ()
forceElements (Result -> String
resultDescription Result
r) () -> () -> ()
`seq`
          String -> ()
forall a. [a] -> ()
forceElements (Result -> String
resultShortDescription Result
r)
        Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
r

  -- no matter what, try to run each finalizer
  Maybe SomeException
mbExn <- (forall a. IO a -> IO a) -> IO (Maybe SomeException)
destroyResources forall a. IO a -> IO a
restore

  STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> (Status -> STM ()) -> Status -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar Status -> Status -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Status
statusVar (Status -> IO ()) -> Status -> IO ()
forall a b. (a -> b) -> a -> b
$ Result -> Status
Done (Result -> Status) -> Result -> Status
forall a b. (a -> b) -> a -> b
$
    case Either SomeException (Time, Result)
resultOrExn Either SomeException (Time, Result)
-> Either SomeException () -> Either SomeException (Time, Result)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Either SomeException ()
-> (SomeException -> Either SomeException ())
-> Maybe SomeException
-> Either SomeException ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> Either SomeException ()
forall a b. b -> Either a b
Right ()) SomeException -> Either SomeException ()
forall a b. a -> Either a b
Left Maybe SomeException
mbExn of
      Left SomeException
ex -> SomeException -> Result
exceptionResult SomeException
ex
      Right (Time
t,Result
r) -> Result
r { resultTime :: Time
resultTime = Time
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
          Resource res
resStatus <- TVar (Resource res) -> STM (Resource res)
forall a. TVar a -> STM a
readTVar TVar (Resource res)
initVar
          case Resource res
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 (m :: * -> *) a. Monad m => a -> m a
return (IO () -> STM (IO ())) -> IO () -> STM (IO ())
forall a b. (a -> b) -> a -> b
$
                (do
                  res
res <- IO res
doInit
                  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
$ res -> Resource res
forall r. r -> Resource r
Created res
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. Exception e => e -> IO a
throwIO SomeException
exn
            Resource res
BeingCreated -> STM (IO ())
forall a. STM a
retry
            Created {} -> IO () -> STM (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> STM (IO ())) -> IO () -> STM (IO ())
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            FailedToCreate SomeException
exn -> IO () -> STM (IO ())
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. 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 (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 (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 String
tstr) IO Result
a = do
      let
        timeoutResult :: Result
timeoutResult =
          Result :: Outcome
-> String -> String -> Time -> ResultDetailsPrinter -> Result
Result
            { resultOutcome :: Outcome
resultOutcome = FailureReason -> Outcome
Failure (FailureReason -> Outcome) -> FailureReason -> Outcome
forall a b. (a -> b) -> a -> b
$ Integer -> FailureReason
TestTimedOut Integer
t
            , resultDescription :: String
resultDescription =
                String
"Timed out after " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
tstr
            , resultShortDescription :: String
resultShortDescription = String
"TIMEOUT"
            , resultTime :: Time
resultTime = Integer -> Time
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
t
            , resultDetailsPrinter :: ResultDetailsPrinter
resultDetailsPrinter = ResultDetailsPrinter
noResultDetails
            }
      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
<$> Integer -> IO Result -> IO (Maybe Result)
forall α. Integer -> IO α -> IO (Maybe α)
timeout Integer
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 (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
            Bool
iAmLast <- IO Bool -> WriterT (First SomeException) IO Bool
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
              Int
nUsers <- TVar Int -> STM Int
forall a. TVar a -> STM a
readTVar TVar Int
finishVar
              let nUsers' :: Int
nUsers' = Int
nUsers Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
              TVar Int -> Int -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Int
finishVar Int
nUsers'
              Bool -> STM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> STM Bool) -> Bool -> STM Bool
forall a b. (a -> b) -> a -> b
$ Int
nUsers' Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0

            Maybe SomeException
mbExcn <- IO (Maybe SomeException)
-> WriterT (First SomeException) IO (Maybe SomeException)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe SomeException)
 -> WriterT (First SomeException) IO (Maybe SomeException))
-> IO (Maybe SomeException)
-> WriterT (First SomeException) IO (Maybe SomeException)
forall a b. (a -> b) -> a -> b
$
              if Bool
iAmLast
              then (forall a. IO a -> IO a) -> Finalizer -> IO (Maybe SomeException)
destroyResource forall a. IO a -> IO a
restore Finalizer
fin
              else Maybe SomeException -> IO (Maybe SomeException)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SomeException
forall a. Maybe a
Nothing

            First SomeException -> WriterT (First SomeException) IO ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (First SomeException -> WriterT (First SomeException) IO ())
-> First SomeException -> WriterT (First SomeException) IO ()
forall a b. (a -> b) -> a -> b
$ Maybe SomeException -> First SomeException
forall a. Maybe a -> First a
First Maybe SomeException
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 (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 -> String
show DependencyException
DependencyLoop = String
"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 :: forall t. IsTest t => OptionSet -> String -> t -> Tr
foldSingle = forall t. IsTest t => OptionSet -> String -> t -> Tr
runSingleTest
          , foldResource :: forall a. OptionSet -> ResourceSpec a -> (IO a -> Tr) -> Tr
foldResource = forall a. OptionSet -> ResourceSpec a -> (IO a -> Tr) -> Tr
addInitAndRelease
          , foldGroup :: OptionSet -> String -> Tr -> Tr
foldGroup = \OptionSet
_opts String
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
$ ((Path, Deps) -> (Path, Deps))
-> 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 r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local ((Path -> Path) -> (Path, Deps) -> (Path, Deps)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (Path -> String -> Path
forall a. Seq a -> a -> Seq a
Seq.|> String
name)) WriterT
  ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
   Seq Finalizer)
  (ReaderT (Path, Deps) IO)
  ()
a
          , foldAfter :: OptionSet -> DependencyType -> Expr -> Tr -> Tr
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
$ ((Path, Deps) -> (Path, Deps))
-> 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 r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local ((Deps -> Deps) -> (Path, Deps) -> (Path, Deps)
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
  ([(InitFinPair -> IO (), (TVar Status, Path, Deps))]
tests, Seq Finalizer
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 :: 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 Maybe [(Action, TVar Status)]
mb_tests of
    Just [(Action, TVar Status)]
tests' -> ([(Action, TVar Status)], Seq Finalizer)
-> IO ([(Action, TVar Status)], Seq Finalizer)
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. Exception e => e -> IO a
throwIO DependencyException
DependencyLoop

  where
    runSingleTest :: IsTest t => OptionSet -> TestName -> t -> Tr
    runSingleTest :: OptionSet -> String -> t -> Tr
runSingleTest OptionSet
opts String
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
      TVar Status
statusVar <- IO (TVar Status)
-> WriterT
     ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
      Seq Finalizer)
     (ReaderT (Path, Deps) IO)
     (TVar Status)
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
      (Path
parentPath, Deps
deps) <- WriterT
  ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
   Seq Finalizer)
  (ReaderT (Path, Deps) IO)
  (Path, Deps)
forall r (m :: * -> *). MonadReader r m => m r
ask
      let
        path :: Path
path = Path
parentPath Path -> String -> Path
forall a. Seq a -> a -> Seq a
Seq.|> String
name
        act :: InitFinPair -> IO ()
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
      ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
 Seq Finalizer)
-> WriterT
     ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
      Seq Finalizer)
     (ReaderT (Path, Deps) IO)
     ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell ([(InitFinPair -> IO ()
act, (TVar Status
statusVar, Path
path, Deps
deps))], Seq Finalizer
forall a. Monoid a => a
mempty)
    addInitAndRelease :: OptionSet -> ResourceSpec a -> (IO a -> Tr) -> Tr
    addInitAndRelease :: 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
      TVar (Resource a)
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
      ([(InitFinPair -> IO (), (TVar Status, Path, Deps))]
tests, Seq Finalizer
fins) <- Path
-> Deps
-> Tr
-> IO
     ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
      Seq Finalizer)
unwrap Path
path Deps
deps (Tr
 -> IO
      ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
       Seq Finalizer))
-> Tr
-> IO
     ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
      Seq Finalizer)
forall a b. (a -> b) -> a -> b
$ IO a -> Tr
a (TVar (Resource a) -> IO a
forall r. TVar (Resource r) -> IO r
getResource TVar (Resource a)
initVar)
      let ntests :: Int
ntests = [(InitFinPair -> IO (), (TVar Status, Path, Deps))] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(InitFinPair -> IO (), (TVar Status, Path, Deps))]
tests
      TVar Int
finishVar <- STM (TVar Int) -> IO (TVar Int)
forall a. STM a -> IO a
atomically (STM (TVar Int) -> IO (TVar Int))
-> STM (TVar Int) -> IO (TVar Int)
forall a b. (a -> b) -> a -> b
$ Int -> STM (TVar Int)
forall a. a -> STM (TVar a)
newTVar Int
ntests
      let
        ini :: Initializer
ini = IO a -> TVar (Resource a) -> Initializer
forall res. IO res -> TVar (Resource res) -> Initializer
Initializer IO a
doInit TVar (Resource a)
initVar
        fin :: Finalizer
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))]
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 (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (((InitFinPair -> IO ()) -> InitFinPair -> IO ())
 -> (InitFinPair -> IO (), (TVar Status, Path, Deps))
 -> (InitFinPair -> IO (), (TVar Status, Path, Deps)))
-> ((InitFinPair -> IO ()) -> InitFinPair -> IO ())
-> (InitFinPair -> IO (), (TVar Status, Path, Deps))
-> (InitFinPair -> IO (), (TVar Status, Path, Deps))
forall a b. (a -> b) -> a -> b
$ (InitFinPair -> InitFinPair)
-> (InitFinPair -> IO ()) -> InitFinPair -> IO ()
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local ((InitFinPair -> InitFinPair)
 -> (InitFinPair -> IO ()) -> InitFinPair -> IO ())
-> (InitFinPair -> InitFinPair)
-> (InitFinPair -> IO ())
-> InitFinPair
-> IO ()
forall a b. (a -> b) -> a -> b
$ (Seq Initializer -> Initializer -> Seq Initializer
forall a. Seq a -> a -> Seq a
Seq.|> Initializer
ini) (Seq Initializer -> Seq Initializer)
-> (Seq Finalizer -> Seq Finalizer) -> InitFinPair -> InitFinPair
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** (Finalizer
fin Finalizer -> Seq Finalizer -> Seq Finalizer
forall a. a -> Seq a -> Seq a
Seq.<|)) [(InitFinPair -> IO (), (TVar Status, Path, Deps))]
tests
      ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
 Seq Finalizer)
-> IO
     ([(InitFinPair -> IO (), (TVar Status, Path, Deps))],
      Seq Finalizer)
forall (m :: * -> *) a. Monad m => a -> m a
return ([(InitFinPair -> IO (), (TVar Status, Path, Deps))]
tests', Seq Finalizer
fins Seq Finalizer -> Finalizer -> Seq Finalizer
forall a. Seq a -> a -> Seq a
Seq.|> Finalizer
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 (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
  (IO ()
run_test, (TVar Status
statusVar, Path
path0, Deps
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' :: [(DependencyType, TVar Status, Path)]
deps' = do
      (DependencyType
deptype, Expr
depexpr) <- Deps
deps
      (IO ()
_, (TVar Status
statusVar1, Path
path, Deps
_)) <- [(IO (), (TVar Status, Path, Deps))]
tests
      Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> [()]) -> Bool -> [()]
forall a b. (a -> b) -> a -> b
$ Expr -> Path -> Bool
exprMatches Expr
depexpr Path
path
      (DependencyType, TVar Status, Path)
-> [(DependencyType, TVar Status, Path)]
forall (m :: * -> *) a. Monad m => a -> m a
return (DependencyType
deptype, TVar Status
statusVar1, Path
path)

    getStatus :: STM ActionStatus
    getStatus :: STM ActionStatus
getStatus = ((DependencyType, TVar Status, Path)
 -> STM ActionStatus -> STM ActionStatus)
-> STM ActionStatus
-> [(DependencyType, TVar Status, Path)]
-> STM ActionStatus
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
status <- TVar Status -> STM Status
forall a. TVar a -> STM a
readTVar TVar Status
statusvar
        case Status
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 (m :: * -> *) a. Monad m => a -> m a
return ActionStatus
ActionSkip
          Status
_ -> ActionStatus -> STM ActionStatus
forall (m :: * -> *) a. Monad m => a -> m a
return ActionStatus
ActionWait
      )
      (ActionStatus -> STM ActionStatus
forall (m :: * -> *) a. Monad m => a -> m a
return ActionStatus
ActionReady)
      [(DependencyType, TVar Status, Path)]
deps'
  let
    dep_paths :: [Path]
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
action = Action :: STM ActionStatus -> IO () -> STM () -> 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 :: Outcome
-> String -> String -> Time -> ResultDetailsPrinter -> Result
Result
          -- See Note [Skipped tests]
          { resultOutcome :: Outcome
resultOutcome = FailureReason -> Outcome
Failure FailureReason
TestDepFailed
          , resultDescription :: String
resultDescription = String
""
          , resultShortDescription :: String
resultShortDescription = String
"SKIP"
          , resultTime :: Time
resultTime = Time
0
          , resultDetailsPrinter :: ResultDetailsPrinter
resultDetailsPrinter = ResultDetailsPrinter
noResultDetails
          }
      }
  ((Action, TVar Status), (Path, [Path]))
-> [((Action, TVar Status), (Path, [Path]))]
forall (m :: * -> *) a. Monad m => a -> m a
return ((Action
action, TVar Status
statusVar), (Path
path0, [Path]
dep_paths))

checkCycles :: Ord b => [(a, (b, [b]))] -> Maybe [a]
checkCycles :: [(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 (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 :: 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
    Resource r
rState <- TVar (Resource r) -> STM (Resource r)
forall a. TVar a -> STM a
readTVar TVar (Resource r)
var
    case Resource r
rState of
      Created r
r -> r -> STM r
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
$ String -> Resource r -> SomeException
forall r. String -> Resource r -> SomeException
unexpectedState String
"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
  Resource res
rState <- TVar (Resource res) -> STM (Resource res)
forall a. TVar a -> STM a
readTVar TVar (Resource res)
stateVar
  case Resource res
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 (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 (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 (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 (m :: * -> *) a. Monad m => a -> m a
return Maybe SomeException
forall a. Maybe a
Nothing
    FailedToCreate {} -> IO (Maybe SomeException) -> STM (IO (Maybe SomeException))
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 (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 (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 (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 :: OptionSet -> TestTree -> (StatusMap -> IO (Time -> IO a)) -> IO a
launchTestTree OptionSet
opts TestTree
tree StatusMap -> IO (Time -> IO a)
k0 = do
  ([(Action, TVar Status)]
testActions, Seq Finalizer
fins) <- OptionSet
-> TestTree -> IO ([(Action, TVar Status)], Seq Finalizer)
createTestActions OptionSet
opts TestTree
tree
  let NumThreads Int
numTheads = OptionSet -> NumThreads
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts
  (Time
t,Time -> IO a
k1) <- IO (Time -> IO a) -> IO (Time, Time -> IO a)
forall a. IO a -> IO (Time, a)
timed (IO (Time -> IO a) -> IO (Time, Time -> IO a))
-> IO (Time -> IO a) -> IO (Time, Time -> IO a)
forall a b. (a -> b) -> a -> b
$ do
     IO ()
abortTests <- Int -> [Action] -> IO (IO ())
runInParallel Int
numTheads ((Action, TVar Status) -> Action
forall a b. (a, b) -> a
fst ((Action, TVar Status) -> Action)
-> [(Action, TVar Status)] -> [Action]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Action, TVar Status)]
testActions)
     (do let smap :: StatusMap
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)
         StatusMap -> IO (Time -> IO a)
k0 StatusMap
smap)
      IO (Time -> IO a)
-> ((forall a. IO a -> IO a) -> IO ()) -> IO (Time -> IO a)
forall a b. IO a -> ((forall a. IO a -> IO a) -> IO b) -> IO a
`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 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
  Time -> IO a
k1 Time
t
  where
    alive :: Resource r -> Bool
    alive :: 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
        Resource res
res <- TVar (Resource res) -> STM (Resource res)
forall a. TVar a -> STM a
readTVar TVar (Resource res)
rvar
        Bool -> STM ()
check (Bool -> STM ()) -> Bool -> STM ()
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Resource res -> Bool
forall r. Resource r -> Bool
alive Resource res
res

unexpectedState :: String -> Resource r -> SomeException
unexpectedState :: String -> Resource r -> SomeException
unexpectedState String
where_ Resource r
r = ResourceError -> SomeException
forall e. Exception e => e -> SomeException
toException (ResourceError -> SomeException) -> ResourceError -> SomeException
forall a b. (a -> b) -> a -> b
$ String -> String -> ResourceError
UnexpectedState String
where_ (Resource r -> String
forall a. Show a => a -> String
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 :: 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
    a
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 forall a. IO a -> IO a
restore
    b
_ <- (forall a. IO a -> IO a) -> IO b
sequel forall a. IO a -> IO a
restore
    a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
r