-- | Running tests
{-# LANGUAGE ScopedTypeVariables, ExistentialQuantification, RankNTypes,
             FlexibleContexts, CPP, DeriveDataTypeable, LambdaCase,
             RecordWildCards, NamedFieldPuns #-}
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.List (intercalate)
import Data.Graph (SCC(..), stronglyConnComp)
import Data.Sequence (Seq, (|>), (<|), (><))
import Data.Typeable
import Control.Monad (forever, guard, join, liftM)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Reader (ReaderT(..), local, ask)
import Control.Monad.Trans.Writer (execWriterT, 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

#if MIN_VERSION_base(4,18,0)
import Data.Traversable (mapAccumM)
#endif

#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.
--
-- @since 0.1
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
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 -- ^ @since 1.2
  )

-- | 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.
--
-- @since 0.1
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 " forall a. [a] -> [a] -> [a]
++ 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
  -> HideProgress -- ^ hide progress option
  -> Seq Initializer -- ^ initializers (to be executed in this order)
  -> Seq Finalizer -- ^ finalizers (to be executed in this order)
  -> IO ()
executeTest :: ((Progress -> IO ()) -> IO Result)
-> TVar Status
-> Timeout
-> HideProgress
-> Seq Initializer
-> Seq Finalizer
-> IO ()
executeTest (Progress -> IO ()) -> IO Result
action TVar Status
statusVar Timeout
timeoutOpt HideProgress
hideProgressOpt Seq Initializer
inits Seq Finalizer
fins = forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> do
  Either SomeException (Time, Result)
resultOrExn <- forall e a. Exception e => IO a -> IO (Either e a)
try forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IO a -> IO a
restore 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

    let
      cursorMischiefManaged :: IO Result
cursorMischiefManaged = do
        forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> a -> STM ()
writeTVar TVar Status
statusVar (Progress -> Status
Executing Progress
emptyProgress)
        (Progress -> IO ()) -> IO Result
action forall {f :: * -> *}. MonadIO f => Progress -> f ()
yieldProgress

    -- 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.
    forall a b. IO a -> (Async a -> IO b) -> IO b
withAsync IO Result
cursorMischiefManaged forall a b. (a -> b) -> a -> b
$ \Async Result
asy -> do
      ThreadId -> String -> IO ()
labelThread (forall a. Async a -> ThreadId
asyncThreadId Async Result
asy) String
"tasty_test_execution_thread"
      forall a. IO a -> IO (Time, a)
timed forall a b. (a -> b) -> a -> b
$ Timeout -> IO Result -> IO Result
applyTimeout Timeout
timeoutOpt forall a b. (a -> b) -> a -> b
$ do
        Result
r <- 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.
        forall a. a -> IO a
evaluate forall a b. (a -> b) -> a -> b
$
          Result -> Outcome
resultOutcome Result
r seq :: forall a b. a -> b -> b
`seq`
          forall a. [a] -> ()
forceElements (Result -> String
resultDescription Result
r) seq :: forall a b. a -> b -> b
`seq`
          forall a. [a] -> ()
forceElements (Result -> String
resultShortDescription Result
r)
        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

  forall a. STM a -> IO a
atomically forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. TVar a -> a -> STM ()
writeTVar TVar Status
statusVar forall b c a. (b -> c) -> (a -> b) -> a -> c
. Result -> Status
Done forall a b. (a -> b) -> a -> b
$
    case Either SomeException (Time, Result)
resultOrExn forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. b -> Either a b
Right ()) 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 =
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
F.forM_ Seq Initializer
inits forall a b. (a -> b) -> a -> b
$ \(Initializer IO res
doInit TVar (Resource res)
initVar) -> do
        forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$ forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
          Resource res
resStatus <- 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
              forall a. TVar a -> a -> STM ()
writeTVar TVar (Resource res)
initVar forall r. Resource r
BeingCreated
              forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
                (do
                  res
res <- IO res
doInit
                  forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> a -> STM ()
writeTVar TVar (Resource res)
initVar forall a b. (a -> b) -> a -> b
$ forall r. r -> Resource r
Created res
res
                 ) forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` \SomeException
exn -> do
                  forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> a -> STM ()
writeTVar TVar (Resource res)
initVar forall a b. (a -> b) -> a -> b
$ forall r. SomeException -> Resource r
FailedToCreate SomeException
exn
                  forall e a. Exception e => e -> IO a
throwIO SomeException
exn
            Resource res
BeingCreated -> forall a. STM a
retry
            Created {} -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ()
            FailedToCreate SomeException
exn -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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      -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ IO ()
sleepIndefinitely
            Resource res
BeingDestroyed -> forall (m :: * -> *) a. Monad m => a -> m a
return 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
            { resultOutcome :: Outcome
resultOutcome = FailureReason -> Outcome
Failure forall a b. (a -> b) -> a -> b
$ Integer -> FailureReason
TestTimedOut Integer
t
            , resultDescription :: String
resultDescription =
                String
"Timed out after " forall a. [a] -> [a] -> [a]
++ String
tstr
            , resultShortDescription :: String
resultShortDescription = String
"TIMEOUT"
            , resultTime :: Time
resultTime = 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' = forall a. Num a => Integer -> a
fromInteger (forall a. Ord a => a -> a -> a
min (forall a. Ord a => a -> a -> a
max Integer
0 Integer
t) (forall a. Integral a => a -> Integer
toInteger (forall a. Bounded a => a
maxBound :: Int64)))
      forall a. a -> Maybe a -> a
fromMaybe Result
timeoutResult forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
      forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a. First a -> Maybe a
getFirst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) w a. Monad m => WriterT w m a -> m w
execWriterT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Traversal f -> f ()
getTraversal forall a b. (a -> b) -> a -> b
$
        forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
F.foldMap Seq Finalizer
fins forall a b. (a -> b) -> a -> b
$ \fin :: Finalizer
fin@(Finalizer res -> IO ()
_ TVar (Resource res)
_ TVar Int
finishVar) ->
          forall (f :: * -> *). f () -> Traversal f
Traversal forall a b. (a -> b) -> a -> b
$ do
            Bool
iAmLast <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
              Int
nUsers <- forall a. TVar a -> STM a
readTVar TVar Int
finishVar
              let nUsers' :: Int
nUsers' = Int
nUsers forall a. Num a => a -> a -> a
- Int
1
              forall a. TVar a -> a -> STM ()
writeTVar TVar Int
finishVar Int
nUsers'
              forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Int
nUsers' forall a. Eq a => a -> a -> Bool
== Int
0

            Maybe SomeException
mbExcn <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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 forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

            forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
tell forall a b. (a -> b) -> a -> b
$ forall a. Maybe a -> First a
First Maybe SomeException
mbExcn

    yieldProgress :: Progress -> f ()
yieldProgress Progress
_newP | HideProgress -> Bool
getHideProgress HideProgress
hideProgressOpt =
      forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    yieldProgress Progress
newP | Progress
newP forall a. Eq a => a -> a -> Bool
== Progress
emptyProgress =
      -- This could be changed to `Maybe Progress` to lets more easily indicate
      -- when progress should try to be printed ?
      forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    yieldProgress Progress
newP = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. STM a -> IO a
atomically
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. TVar a -> a -> STM ()
writeTVar TVar Status
statusVar
      forall a b. (a -> b) -> a -> b
$ Progress -> Status
Executing Progress
newP

-- | Traversal type used in 'createTestActions'
type Tr = ReaderT (Path, Seq Dependency) IO (TestActionTree UnresolvedAction)

-- | Exceptions related to dependencies between tests.
--
-- @since 1.2
newtype DependencyException
  = DependencyLoop [[Path]]
    -- ^ Test dependencies form cycles. In other words, test A cannot start
    -- until test B finishes, and test B cannot start until test
    -- A finishes. Field lists detected cycles.
    --
    -- @since 1.5
  deriving (Typeable)

instance Show DependencyException where
  show :: DependencyException -> String
show (DependencyLoop [[Path]]
css) = String
"Test dependencies have cycles:\n" forall a. [a] -> [a] -> [a]
++ [[Path]] -> String
showCycles [[Path]]
css
    where
      showCycles :: [[Path]] -> String
showCycles = forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map [Path] -> String
showCycle
      showPath :: Path -> String
showPath = forall a. [a] -> [[a]] -> [a]
intercalate String
"." forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList

      -- For clarity in the error message, the first element is repeated at the end
      showCycle :: [Path] -> String
showCycle []     = String
"- <empty cycle>"
      showCycle (Path
x:[Path]
xs) = String
"- " forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate String
", " (forall a b. (a -> b) -> [a] -> [b]
map Path -> String
showPath (Path
xforall a. a -> [a] -> [a]
:[Path]
xs forall a. [a] -> [a] -> [a]
++ [Path
x]))

instance Exception DependencyException

-- | Specifies how to calculate a dependency
data DependencySpec
  = ExactDep (Seq TestName) (TVar Status)
  -- ^ Dependency specified by 'TestGroup'. Note that the first field is only
  -- there for dependency cycle detection - which can be introduced by using
  -- 'PatternDep'.
  | PatternDep Expr
  -- ^ All tests matching this 'Expr' should be considered dependencies
  deriving (DependencySpec -> DependencySpec -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DependencySpec -> DependencySpec -> Bool
$c/= :: DependencySpec -> DependencySpec -> Bool
== :: DependencySpec -> DependencySpec -> Bool
$c== :: DependencySpec -> DependencySpec -> Bool
Eq)

instance Show DependencySpec where
  show :: DependencySpec -> String
show (PatternDep Expr
dep) = String
"PatternDep (" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Expr
dep forall a. [a] -> [a] -> [a]
++ String
")"
  show (ExactDep Path
testName TVar Status
_) = String
"ExactDep (" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Path
testName forall a. [a] -> [a] -> [a]
++ String
") (<TVar>)"

-- | Dependency of a test. Either it points to an exact path it depends on, or
-- contains a pattern that should be tested against all tests in a 'TestTree'.
data Dependency = Dependency DependencyType DependencySpec
  deriving (Dependency -> Dependency -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Dependency -> Dependency -> Bool
$c/= :: Dependency -> Dependency -> Bool
== :: Dependency -> Dependency -> Bool
$c== :: Dependency -> Dependency -> Bool
Eq, Int -> Dependency -> ShowS
[Dependency] -> ShowS
Dependency -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Dependency] -> ShowS
$cshowList :: [Dependency] -> ShowS
show :: Dependency -> String
$cshow :: Dependency -> String
showsPrec :: Int -> Dependency -> ShowS
$cshowsPrec :: Int -> Dependency -> ShowS
Show)

-- | Is given 'Dependency' a dependency that was introduced with 'After'?
isPatternDependency :: Dependency -> Bool
isPatternDependency :: Dependency -> Bool
isPatternDependency (Dependency DependencyType
_ (PatternDep {})) = Bool
True
isPatternDependency Dependency
_ = Bool
False

#if !MIN_VERSION_base(4,18,0)
-- The mapAccumM function behaves like a combination of mapM and mapAccumL that
-- traverses the structure while evaluating the actions and passing an accumulating
-- parameter from left to right. It returns a final value of this accumulator
-- together with the new structure. The accummulator is often used for caching the
-- intermediate results of a computation.
mapAccumM :: Monad m => (acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumM :: forall (m :: * -> *) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumM acc -> x -> m (acc, y)
_ acc
acc [] = forall (m :: * -> *) a. Monad m => a -> m a
return (acc
acc, [])
mapAccumM acc -> x -> m (acc, y)
f acc
acc (x
x:[x]
xs) = do
  (acc
acc', y
y) <- acc -> x -> m (acc, y)
f acc
acc x
x
  (acc
acc'', [y]
ys) <- forall (m :: * -> *) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumM acc -> x -> m (acc, y)
f acc
acc' [x]
xs
  forall (m :: * -> *) a. Monad m => a -> m a
return (acc
acc'', y
yforall a. a -> [a] -> [a]
:[y]
ys)
#endif

-- | An action with meta information
data TestAction act = TestAction
  { forall act. TestAction act -> act
testAction :: act
    -- ^ Some action, typically 'UnresolvedAction', 'ResolvedAction', or 'Action'.
  , forall act. TestAction act -> Path
testPath :: Path
    -- ^ Path pointing to this action (a series of group names + a test name)
  , forall act. TestAction act -> Seq Dependency
testDeps :: Seq Dependency
    -- ^ Dependencies introduced by AWK-like patterns
  , forall act. TestAction act -> TVar Status
testStatus :: TVar Status
    -- ^ Status var that can be used to monitor test progress
  }

-- | A test that still needs to be given its resource initializers and finalizers
type UnresolvedAction = Seq Initializer -> Seq Finalizer -> IO ()

-- | A test that, unlike 'UnresolvedAction', has been given its initializers and
-- finalizers.
type ResolvedAction = IO ()

-- | Number of 'TAction' leafs in a 'TestActionTree'. Used to prevent repeated
-- size calculations.
type Size = Int

-- | Simplified version of 'TestTree' that only includes the tests to be run (as
-- a 'TestAction') and the resources needed to run them (as 'Initializer's and
-- 'Finalizer's).
data TestActionTree act
  = TResource Initializer Finalizer (TestActionTree act)
  | TGroup Size [TestActionTree act]
  -- ^ Note the 'Size' field of this constructor: it stores how many 'TAction's
  -- are present in the tree. Functions using constructing this constructor
  -- should take care, or use 'tGroup' instead. If this constructor is ever
  -- exported, we should probably move it to its own module and expose only a
  -- smart constructor using pattern synonyms. For now, this seems more trouble
  -- than it's worth, given the number of types it needs defined in this module.
  | TAction (TestAction act)

-- | Smart constructor for 'TGroup'. Fills in 'Size' field by summing the size
-- of the given test trees.
tGroup :: [TestActionTree act] -> TestActionTree act
tGroup :: forall act. [TestActionTree act] -> TestActionTree act
tGroup [TestActionTree act]
trees = forall act. Int -> [TestActionTree act] -> TestActionTree act
TGroup (forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (forall a b. (a -> b) -> [a] -> [b]
map forall act. TestActionTree act -> Int
testActionTreeSize [TestActionTree act]
trees)) [TestActionTree act]
trees

-- | Size of a 'TestActionTree', i.e. the number of 'TAction's it contains.
testActionTreeSize :: TestActionTree act -> Int
testActionTreeSize :: forall act. TestActionTree act -> Int
testActionTreeSize = \case
  TResource Initializer
_ Finalizer
_ TestActionTree act
tree -> forall act. TestActionTree act -> Int
testActionTreeSize TestActionTree act
tree
  TGroup Int
size [TestActionTree act]
_ -> Int
size
  TAction TestAction act
_ -> Int
1

-- | Collect initializers and finalizers introduced by 'TResource' and apply them
-- to each action.
resolveTestActions :: TestActionTree UnresolvedAction -> TestActionTree ResolvedAction
resolveTestActions :: TestActionTree (Seq Initializer -> Seq Finalizer -> IO ())
-> TestActionTree (IO ())
resolveTestActions = forall {act}.
Seq Initializer
-> Seq Finalizer
-> TestActionTree (Seq Initializer -> Seq Finalizer -> act)
-> TestActionTree act
go forall a. Seq a
Seq.empty forall a. Seq a
Seq.empty
 where
  go :: Seq Initializer
-> Seq Finalizer
-> TestActionTree (Seq Initializer -> Seq Finalizer -> act)
-> TestActionTree act
go Seq Initializer
inits Seq Finalizer
fins = \case
    TResource Initializer
ini Finalizer
fin TestActionTree (Seq Initializer -> Seq Finalizer -> act)
tree ->
      forall act.
Initializer
-> Finalizer -> TestActionTree act -> TestActionTree act
TResource Initializer
ini Finalizer
fin forall a b. (a -> b) -> a -> b
$ Seq Initializer
-> Seq Finalizer
-> TestActionTree (Seq Initializer -> Seq Finalizer -> act)
-> TestActionTree act
go (Seq Initializer
inits forall a. Seq a -> a -> Seq a
|> Initializer
ini) (Finalizer
fin forall a. a -> Seq a -> Seq a
<| Seq Finalizer
fins) TestActionTree (Seq Initializer -> Seq Finalizer -> act)
tree
    TGroup Int
size [TestActionTree (Seq Initializer -> Seq Finalizer -> act)]
trees ->
      forall act. Int -> [TestActionTree act] -> TestActionTree act
TGroup Int
size forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Seq Initializer
-> Seq Finalizer
-> TestActionTree (Seq Initializer -> Seq Finalizer -> act)
-> TestActionTree act
go Seq Initializer
inits Seq Finalizer
fins) [TestActionTree (Seq Initializer -> Seq Finalizer -> act)]
trees
    TAction (TestAction {TVar Status
Path
Seq Dependency
Seq Initializer -> Seq Finalizer -> act
testStatus :: TVar Status
testDeps :: Seq Dependency
testPath :: Path
testAction :: Seq Initializer -> Seq Finalizer -> act
testStatus :: forall act. TestAction act -> TVar Status
testDeps :: forall act. TestAction act -> Seq Dependency
testPath :: forall act. TestAction act -> Path
testAction :: forall act. TestAction act -> act
..})->
      forall act. TestAction act -> TestActionTree act
TAction forall a b. (a -> b) -> a -> b
$ TestAction { testAction :: act
testAction = Seq Initializer -> Seq Finalizer -> act
testAction Seq Initializer
inits Seq Finalizer
fins, TVar Status
Path
Seq Dependency
testStatus :: TVar Status
testDeps :: Seq Dependency
testPath :: Path
testStatus :: TVar Status
testDeps :: Seq Dependency
testPath :: Path
.. }

-- | Turn a test tree into a list of actions to run tests coupled with
-- variables to watch them. Additionally, a collection of finalizers is
-- returned that can be used to clean up resources in case of unexpected
-- events.
createTestActions
  :: OptionSet
  -> TestTree
  -> IO ([TestAction Action], Seq Finalizer)
createTestActions :: OptionSet -> TestTree -> IO ([TestAction Action], Seq Finalizer)
createTestActions OptionSet
opts0 TestTree
tree = do
  -- Folding the test tree reduces it to a 'TestActionTree', which is a simplified
  -- version of 'TestTree' that only includes the tests to be run, resources needed
  -- to run them, and meta information needed to watch test progress and calculate
  -- dependencies in 'resolveDeps'.
  TestActionTree (Seq Initializer -> Seq Finalizer -> IO ())
unresolvedTestTree :: TestActionTree UnresolvedAction <-
    forall a b c. (a -> b -> c) -> b -> a -> c
flip forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (forall a. Monoid a => a
mempty :: (Path, Seq Dependency)) forall a b. (a -> b) -> a -> b
$
      forall b. b -> TreeFold b -> OptionSet -> TestTree -> b
foldTestTree0 (forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall act. [TestActionTree act] -> TestActionTree act
tGroup [])) (TreeFold { OptionSet -> String -> [Tr] -> Tr
OptionSet -> DependencyType -> Expr -> Tr -> Tr
forall a. OptionSet -> ResourceSpec a -> (IO a -> Tr) -> Tr
forall t. IsTest t => OptionSet -> String -> t -> Tr
foldAfter :: OptionSet -> DependencyType -> Expr -> Tr -> Tr
foldResource :: forall a. OptionSet -> ResourceSpec a -> (IO a -> Tr) -> Tr
foldGroup :: OptionSet -> String -> [Tr] -> Tr
foldSingle :: forall t. IsTest t => OptionSet -> String -> t -> Tr
foldGroup :: OptionSet -> String -> [Tr] -> Tr
foldAfter :: OptionSet -> DependencyType -> Expr -> Tr -> Tr
foldResource :: forall a. OptionSet -> ResourceSpec a -> (IO a -> Tr) -> Tr
foldSingle :: forall t. IsTest t => OptionSet -> String -> t -> Tr
.. }) OptionSet
opts0 TestTree
tree

  let
    finalizers :: Seq Finalizer
    finalizers :: Seq Finalizer
finalizers = forall act. TestActionTree act -> Seq Finalizer
collectFinalizers TestActionTree (Seq Initializer -> Seq Finalizer -> IO ())
unresolvedTestTree

    tests :: [TestAction ResolvedAction]
    tests :: [TestAction (IO ())]
tests = forall act. TestActionTree act -> [TestAction act]
collectTests (TestActionTree (Seq Initializer -> Seq Finalizer -> IO ())
-> TestActionTree (IO ())
resolveTestActions TestActionTree (Seq Initializer -> Seq Finalizer -> IO ())
unresolvedTestTree)

  case [TestAction (IO ())] -> Either [[Path]] [TestAction Action]
resolveDeps [TestAction (IO ())]
tests of
    Right [TestAction Action]
tests' -> forall (m :: * -> *) a. Monad m => a -> m a
return ([TestAction Action]
tests', Seq Finalizer
finalizers)
    Left [[Path]]
cycles  -> forall e a. Exception e => e -> IO a
throwIO ([[Path]] -> DependencyException
DependencyLoop [[Path]]
cycles)

  where
    -- * Functions used in 'TreeFold'
    foldSingle :: IsTest t => OptionSet -> TestName -> t -> Tr
    foldSingle :: forall t. IsTest t => OptionSet -> String -> t -> Tr
foldSingle OptionSet
opts String
name t
test = do
      TVar Status
testStatus <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (TVar a)
newTVarIO Status
NotStarted
      (Path
parentPath, Seq Dependency
testDeps) <- forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
      let
        testPath :: Path
testPath = Path
parentPath forall a. Seq a -> a -> Seq a
|> String
name
        testAction :: Seq Initializer -> Seq Finalizer -> IO ()
testAction = ((Progress -> IO ()) -> IO Result)
-> TVar Status
-> Timeout
-> HideProgress
-> Seq Initializer
-> Seq Finalizer
-> IO ()
executeTest (forall t.
IsTest t =>
OptionSet -> t -> (Progress -> IO ()) -> IO Result
run OptionSet
opts t
test) TVar Status
testStatus (forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts) (forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts)
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall act. TestAction act -> TestActionTree act
TAction (TestAction {TVar Status
Path
Seq Dependency
Seq Initializer -> Seq Finalizer -> IO ()
testAction :: Seq Initializer -> Seq Finalizer -> IO ()
testPath :: Path
testDeps :: Seq Dependency
testStatus :: TVar Status
testStatus :: TVar Status
testDeps :: Seq Dependency
testPath :: Path
testAction :: Seq Initializer -> Seq Finalizer -> IO ()
..})

    foldResource :: OptionSet -> ResourceSpec a -> (IO a -> Tr) -> Tr
    foldResource :: forall a. OptionSet -> ResourceSpec a -> (IO a -> Tr) -> Tr
foldResource OptionSet
_opts (ResourceSpec IO a
doInit a -> IO ()
doRelease) IO a -> Tr
a = do
      TVar (Resource a)
initVar <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (TVar a)
newTVarIO forall r. Resource r
NotCreated
      TestActionTree (Seq Initializer -> Seq Finalizer -> IO ())
testTree <- IO a -> Tr
a (forall r. TVar (Resource r) -> IO r
getResource TVar (Resource a)
initVar)
      TVar Int
finishVar <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (TVar a)
newTVarIO (forall act. TestActionTree act -> Int
testActionTreeSize TestActionTree (Seq Initializer -> Seq Finalizer -> IO ())
testTree)
      let
        ini :: Initializer
ini = forall res. IO res -> TVar (Resource res) -> Initializer
Initializer IO a
doInit TVar (Resource a)
initVar
        fin :: Finalizer
fin = forall res.
(res -> IO ()) -> TVar (Resource res) -> TVar Int -> Finalizer
Finalizer a -> IO ()
doRelease TVar (Resource a)
initVar TVar Int
finishVar
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall act.
Initializer
-> Finalizer -> TestActionTree act -> TestActionTree act
TResource Initializer
ini Finalizer
fin TestActionTree (Seq Initializer -> Seq Finalizer -> IO ())
testTree

    foldAfter :: OptionSet -> DependencyType -> Expr -> Tr -> Tr
    foldAfter :: OptionSet -> DependencyType -> Expr -> Tr -> Tr
foldAfter OptionSet
_opts DependencyType
depType Expr
pat = forall r (m :: * -> *) a.
(r -> r) -> ReaderT r m a -> ReaderT r m a
local (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (DependencyType -> DependencySpec -> Dependency
Dependency DependencyType
depType (Expr -> DependencySpec
PatternDep Expr
pat) forall a. a -> Seq a -> Seq a
<|))

    foldGroup :: OptionSet -> TestName -> [Tr] -> Tr
    foldGroup :: OptionSet -> String -> [Tr] -> Tr
foldGroup OptionSet
opts String
name [Tr]
trees =
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall act. [TestActionTree act] -> TestActionTree act
tGroup forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a.
(r -> r) -> ReaderT r m a -> ReaderT r m a
local (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (forall a. Seq a -> a -> Seq a
|> String
name)) forall a b. (a -> b) -> a -> b
$
        case forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts of
          ExecutionMode
Parallel ->
            forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Tr]
trees
          Sequential DependencyType
depType ->
            forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumM (DependencyType
-> Seq Dependency
-> Tr
-> ReaderT
     (Path, Seq Dependency)
     IO
     (Seq Dependency,
      TestActionTree (Seq Initializer -> Seq Finalizer -> IO ()))
goSeqGroup DependencyType
depType) forall a. Monoid a => a
mempty [Tr]
trees

    -- * Utility functions
    collectTests :: TestActionTree act -> [TestAction act]
    collectTests :: forall act. TestActionTree act -> [TestAction act]
collectTests = \case
      TResource Initializer
_ Finalizer
_ TestActionTree act
t -> forall act. TestActionTree act -> [TestAction act]
collectTests TestActionTree act
t
      TGroup Int
_ [TestActionTree act]
trees  -> forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall act. TestActionTree act -> [TestAction act]
collectTests [TestActionTree act]
trees
      TAction TestAction act
action  -> [TestAction act
action]

    collectFinalizers :: TestActionTree act -> Seq Finalizer
    collectFinalizers :: forall act. TestActionTree act -> Seq Finalizer
collectFinalizers = \case
      TResource Initializer
_ Finalizer
fin TestActionTree act
t -> forall act. TestActionTree act -> Seq Finalizer
collectFinalizers TestActionTree act
t forall a. Seq a -> a -> Seq a
|> Finalizer
fin
      TGroup Int
_ [TestActionTree act]
trees    -> forall a. Monoid a => [a] -> a
mconcat (forall a b. (a -> b) -> [a] -> [b]
map forall act. TestActionTree act -> Seq Finalizer
collectFinalizers [TestActionTree act]
trees)
      TAction TestAction act
_         -> forall a. Monoid a => a
mempty

    goSeqGroup 
      :: DependencyType
      -> Seq Dependency
      -> Tr
      -> ReaderT (Path, Seq Dependency) IO (Seq Dependency, TestActionTree UnresolvedAction)
    goSeqGroup :: DependencyType
-> Seq Dependency
-> Tr
-> ReaderT
     (Path, Seq Dependency)
     IO
     (Seq Dependency,
      TestActionTree (Seq Initializer -> Seq Finalizer -> IO ()))
goSeqGroup DependencyType
depType Seq Dependency
prevDeps Tr
treeM = do
      TestActionTree (Seq Initializer -> Seq Finalizer -> IO ())
tree0 <- forall r (m :: * -> *) a.
(r -> r) -> ReaderT r m a -> ReaderT r m a
local (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (Seq Dependency
prevDeps forall a. Seq a -> Seq a -> Seq a
><)) Tr
treeM

      let
        toDep :: TestAction act -> Dependency
toDep TestAction {act
TVar Status
Path
Seq Dependency
testStatus :: TVar Status
testDeps :: Seq Dependency
testPath :: Path
testAction :: act
testStatus :: forall act. TestAction act -> TVar Status
testDeps :: forall act. TestAction act -> Seq Dependency
testPath :: forall act. TestAction act -> Path
testAction :: forall act. TestAction act -> act
..} = DependencyType -> DependencySpec -> Dependency
Dependency DependencyType
depType (Path -> TVar Status -> DependencySpec
ExactDep Path
testPath TVar Status
testStatus)
        deps0 :: Seq Dependency
deps0 = forall a. [a] -> Seq a
Seq.fromList (forall {act}. TestAction act -> Dependency
toDep forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall act. TestActionTree act -> [TestAction act]
collectTests TestActionTree (Seq Initializer -> Seq Finalizer -> IO ())
tree0)

        -- If this test tree is empty (either due to it being actually empty, or due
        -- to all tests being filtered) we need to propagate the previous dependencies.
        deps1 :: Seq Dependency
deps1 = if forall a. Seq a -> Bool
Seq.null Seq Dependency
deps0 then Seq Dependency
prevDeps else Seq Dependency
deps0

      forall (f :: * -> *) a. Applicative f => a -> f a
pure (Seq Dependency
deps1, TestActionTree (Seq Initializer -> Seq Finalizer -> IO ())
tree0)

-- | Take care of the dependencies.
--
-- Return 'Left' if there is a dependency cycle, containing the detected cycles.
resolveDeps
  :: [TestAction ResolvedAction]
  -> Either [[Path]] [TestAction Action]
resolveDeps :: [TestAction (IO ())] -> Either [[Path]] [TestAction Action]
resolveDeps [TestAction (IO ())]
tests = forall {a}. [(a, (Path, [Path]))] -> Either [[Path]] [a]
maybeCheckCycles forall a b. (a -> b) -> a -> b
$ do
  TestAction { testAction :: forall act. TestAction act -> act
testAction=IO ()
run_test, TVar Status
Path
Seq Dependency
testStatus :: TVar Status
testDeps :: Seq Dependency
testPath :: Path
testStatus :: forall act. TestAction act -> TVar Status
testDeps :: forall act. TestAction act -> Seq Dependency
testPath :: forall act. TestAction act -> Path
.. } <- [TestAction (IO ())]
tests

  let
    deps' :: [(DependencyType, TVar Status, Path)]
deps' = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Dependency -> [(DependencyType, TVar Status, Path)]
findDeps Seq Dependency
testDeps

    getStatus :: STM ActionStatus
    getStatus :: STM ActionStatus
getStatus = 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 <- forall a. TVar a -> STM a
readTVar TVar Status
statusvar
        case Status
status of
          Done Result
result
            | DependencyType
deptype forall a. Eq a => a -> a -> Bool
== DependencyType
AllFinish Bool -> Bool -> Bool
|| Result -> Bool
resultSuccessful Result
result -> STM ActionStatus
k
            | Bool
otherwise -> forall (m :: * -> *) a. Monad m => a -> m a
return ActionStatus
ActionSkip
          Status
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ActionStatus
ActionWait
      )
      (forall (m :: * -> *) a. Monad m => a -> m a
return ActionStatus
ActionReady)
      [(DependencyType, TVar Status, Path)]
deps'
  let
    dep_paths :: [Path]
dep_paths = forall a b. (a -> b) -> [a] -> [b]
map (\(DependencyType
_, TVar Status
_, Path
path) -> Path
path) [(DependencyType, TVar Status, Path)]
deps'
    action :: Action
action = Action
      { actionStatus :: STM ActionStatus
actionStatus = STM ActionStatus
getStatus
      , actionRun :: IO ()
actionRun = IO ()
run_test
      , actionSkip :: STM ()
actionSkip = forall a. TVar a -> a -> STM ()
writeTVar TVar Status
testStatus forall a b. (a -> b) -> a -> b
$ Result -> Status
Done forall a b. (a -> b) -> a -> b
$ 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
          }
      }
  forall (m :: * -> *) a. Monad m => a -> m a
return (TestAction { testAction :: Action
testAction = Action
action, TVar Status
Path
Seq Dependency
testStatus :: TVar Status
testDeps :: Seq Dependency
testPath :: Path
testStatus :: TVar Status
testDeps :: Seq Dependency
testPath :: Path
.. }, (Path
testPath, [Path]
dep_paths))
 where
  -- Skip cycle checking if no patterns are used: sequential test groups can't
  -- introduce cycles on their own.
  maybeCheckCycles :: [(a, (Path, [Path]))] -> Either [[Path]] [a]
maybeCheckCycles
    | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Dependency -> Bool
isPatternDependency forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall act. TestAction act -> Seq Dependency
testDeps) [TestAction (IO ())]
tests = forall b a. Ord b => [(a, (b, [b]))] -> Either [[b]] [a]
checkCycles
    | Bool
otherwise = forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst

  findDeps :: Dependency -> [(DependencyType, TVar Status, Seq TestName)]
  findDeps :: Dependency -> [(DependencyType, TVar Status, Path)]
findDeps (Dependency DependencyType
depType DependencySpec
depSpec) =
    case DependencySpec
depSpec of
      ExactDep Path
testPath TVar Status
statusVar ->
        -- A dependency defined using 'TestGroup' has already been pinpointed
        -- to its 'statusVar' in 'createTestActions'.
        [(DependencyType
depType, TVar Status
statusVar, Path
testPath)]
      PatternDep Expr
expr -> do
        -- A dependency defined using patterns needs to scan the whole test
        -- tree for matching tests.
        TestAction{Path
testPath :: Path
testPath :: forall act. TestAction act -> Path
testPath, TVar Status
testStatus :: TVar Status
testStatus :: forall act. TestAction act -> TVar Status
testStatus} <- [TestAction (IO ())]
tests
        forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Expr -> Path -> Bool
exprMatches Expr
expr Path
testPath
        [(DependencyType
depType, TVar Status
testStatus, Path
testPath)]

-- | Check a graph, given as an adjacency list, for cycles. Return 'Left' if the
-- graph contained cycles, or return all nodes in the graph as a 'Right' if it
-- didn't.
checkCycles :: Ord b => [(a, (b, [b]))] -> Either [[b]] [a]
checkCycles :: forall b a. Ord b => [(a, (b, [b]))] -> Either [[b]] [a]
checkCycles [(a, (b, [b]))]
tests = do
  let
    result :: [a]
result = forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(a, (b, [b]))]
tests
    graph :: [(b, b, [b])]
graph = [ (b
v, b
v, [b]
vs) | (b
v, [b]
vs) <- forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(a, (b, [b]))]
tests ]
    sccs :: [SCC b]
sccs = forall key node. Ord key => [(node, key, [key])] -> [SCC node]
stronglyConnComp [(b, b, [b])]
graph
    cycles :: [[b]]
cycles =
      forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe [SCC b]
sccs forall a b. (a -> b) -> a -> b
$ \case
        AcyclicSCC{} -> forall a. Maybe a
Nothing
        CyclicSCC [b]
vs -> forall a. a -> Maybe a
Just [b]
vs

  case [[b]]
cycles of
    [] -> forall a b. b -> Either a b
Right [a]
result
    [[b]]
_  -> forall a b. a -> Either a b
Left [[b]]
cycles

-- | 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 =
  forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
    Resource r
rState <- forall a. TVar a -> STM a
readTVar TVar (Resource r)
var
    case Resource r
rState of
      Created r
r -> forall (m :: * -> *) a. Monad m => a -> m a
return r
r
      Resource r
Destroyed -> forall e a. Exception e => e -> STM a
throwSTM ResourceError
UseOutsideOfTest
      Resource r
_ -> forall e a. Exception e => e -> STM a
throwSTM forall a b. (a -> b) -> a -> b
$ 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
_) = forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
  Resource res
rState <- forall a. TVar a -> STM a
readTVar TVar (Resource res)
stateVar
  case Resource res
rState of
    Created res
res -> do
      forall a. TVar a -> a -> STM ()
writeTVar TVar (Resource res)
stateVar forall r. Resource r
BeingDestroyed
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
        (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. a -> Maybe a
Just (forall a b. a -> b -> a
const forall a. Maybe a
Nothing)
          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e a. Exception e => IO a -> IO (Either e a)
try (forall a. IO a -> IO a
restore forall a b. (a -> b) -> a -> b
$ res -> IO ()
doRelease res
res))
          forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall a. STM a -> IO a
atomically (forall a. TVar a -> a -> STM ()
writeTVar TVar (Resource res)
stateVar forall r. Resource r
Destroyed)
    Resource res
BeingCreated   -> 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 -> forall a. STM a
retry
    Resource res
NotCreated -> do
      -- prevent the resource from being created by a competing thread
      forall a. TVar a -> a -> STM ()
writeTVar TVar (Resource res)
stateVar forall r. Resource r
Destroyed
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    FailedToCreate {} -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    Resource res
Destroyed         -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return 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.
--
-- @since 0.10
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
  ([TestAction Action]
testActions, Seq Finalizer
fins) <- OptionSet -> TestTree -> IO ([TestAction Action], Seq Finalizer)
createTestActions OptionSet
opts TestTree
tree
  let NumThreads Int
numTheads = forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts
  (Time
t,Time -> IO a
k1) <- forall a. IO a -> IO (Time, a)
timed forall a b. (a -> b) -> a -> b
$ do
     IO ()
abortTests <- Int -> [Action] -> IO (IO ())
runInParallel Int
numTheads (forall act. TestAction act -> act
testAction forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TestAction Action]
testActions)
     (do let smap :: StatusMap
smap = forall a. [(Int, a)] -> IntMap a
IntMap.fromList forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] (forall act. TestAction act -> TVar Status
testStatus forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TestAction Action]
testActions)
         StatusMap -> IO (Time -> IO a)
k0 StatusMap
smap)
      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.)
         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.)
         forall a. IO a -> IO a
restore forall a b. (a -> b) -> a -> b
$ forall {t :: * -> *}. Foldable t => t Finalizer -> IO ()
waitForResources Seq Finalizer
fins
  Time -> IO a
k1 Time
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 = forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
F.forM_ t Finalizer
fins forall a b. (a -> b) -> a -> b
$ \(Finalizer res -> IO ()
_ TVar (Resource res)
rvar TVar Int
_) -> do
        Resource res
res <- forall a. TVar a -> STM a
readTVar TVar (Resource res)
rvar
        Bool -> STM ()
check forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall r. Resource r -> Bool
alive Resource res
res

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

sleepIndefinitely :: IO ()
sleepIndefinitely :: IO ()
sleepIndefinitely = forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay (Int
10forall 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 b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> do
    a
r <- forall a. IO a -> IO a
restore IO a
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
    forall (m :: * -> *) a. Monad m => a -> m a
return a
r