{-# 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
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)
data Status
= NotStarted
| Executing Progress
| Done 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
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 r :: Resource r
r = case Resource r
r of
NotCreated -> "NotCreated"
BeingCreated -> "BeingCreated"
FailedToCreate exn :: SomeException
exn -> "FailedToCreate " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SomeException -> String
forall a. Show a => a -> String
show SomeException
exn
Created {} -> "Created"
BeingDestroyed -> "BeingDestroyed"
Destroyed -> "Destroyed"
data Initializer
= forall res . Initializer
(IO res)
(TVar (Resource res))
data Finalizer
= forall res . Finalizer
(res -> IO ())
(TVar (Resource res))
(TVar Int)
executeTest
:: ((Progress -> IO ()) -> IO Result)
-> TVar Status
-> Timeout
-> Seq.Seq Initializer
-> Seq.Seq Finalizer
-> IO ()
executeTest :: ((Progress -> IO ()) -> IO Result)
-> TVar Status
-> Timeout
-> Seq Initializer
-> Seq Finalizer
-> IO ()
executeTest action :: (Progress -> IO ()) -> IO Result
action statusVar :: TVar Status
statusVar timeoutOpt :: Timeout
timeoutOpt inits :: Seq Initializer
inits fins :: 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
$ \restore :: 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
IO ()
initResources
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
$ \asy :: Async Result
asy -> do
ThreadId -> String -> IO ()
labelThread (Async Result -> ThreadId
forall a. Async a -> ThreadId
asyncThreadId Async Result
asy) "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
$ Async Result -> IO Result
forall a. Async a -> IO a
wait Async Result
asy
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 ex :: SomeException
ex -> SomeException -> Result
exceptionResult SomeException
ex
Right (t :: Time
t,r :: 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 doInit :: IO res
doInit initVar :: 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
NotCreated -> do
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` \exn :: 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
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 exn :: 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
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
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 NoTimeout a :: IO Result
a = IO Result
a
applyTimeout (Timeout t :: Integer
t tstr :: String
tstr) a :: IO Result
a = do
let
timeoutResult :: Result
timeoutResult =
Result :: Outcome -> String -> String -> Time -> 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 =
"Timed out after " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
tstr
, resultShortDescription :: String
resultShortDescription = "TIMEOUT"
, resultTime :: Time
resultTime = Integer -> Time
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
t
}
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 :: (forall a . IO a -> IO a) -> IO (Maybe SomeException)
destroyResources :: (forall a. IO a -> IO a) -> IO (Maybe SomeException)
destroyResources restore :: forall a. IO a -> IO a
restore = do
(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 _ _ finishVar :: 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
- 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
== 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
yieldProgress :: p -> m ()
yieldProgress _ = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
type InitFinPair = (Seq.Seq Initializer, Seq.Seq Finalizer)
type Deps = [(DependencyType, Expr)]
type Tr = Traversal
(WriterT ([(InitFinPair -> IO (), (TVar Status, Path, Deps))], Seq.Seq Finalizer)
(ReaderT (Path, Deps)
IO))
data DependencyException
= DependencyLoop
deriving (Typeable)
instance Show DependencyException where
show :: DependencyException -> String
show DependencyLoop = "Test dependencies form a loop."
instance Exception DependencyException
createTestActions
:: OptionSet
-> TestTree
-> IO ([(Action, TVar Status)], Seq.Seq Finalizer)
createTestActions :: OptionSet
-> TestTree -> IO ([(Action, TVar Status)], Seq Finalizer)
createTestActions opts0 :: OptionSet
opts0 tree :: 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. ResourceSpec a -> (IO a -> Tr) -> Tr
foldResource = forall a. ResourceSpec a -> (IO a -> Tr) -> Tr
addInitAndRelease
, foldGroup :: String -> Tr -> Tr
foldGroup = \name :: String
name (Traversal a :: 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 :: DependencyType -> Expr -> Tr -> Tr
foldAfter = \deptype :: DependencyType
deptype pat :: Expr
pat (Traversal a :: 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
(tests :: [(InitFinPair -> IO (), (TVar Status, Path, Deps))]
tests, fins :: 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
(\(act :: InitFinPair -> IO ()
act, testInfo :: (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 tests' :: [(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)
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 opts :: OptionSet
opts name :: String
name test :: 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
(parentPath :: Path
parentPath, deps :: 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 (inits :: Seq Initializer
inits, fins :: 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 :: ResourceSpec a -> (IO a -> Tr) -> Tr
addInitAndRelease :: ResourceSpec a -> (IO a -> Tr) -> Tr
addInitAndRelease (ResourceSpec doInit :: IO a
doInit doRelease :: a -> IO ()
doRelease) a :: 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
path deps :: 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
(tests :: [(InitFinPair -> IO (), (TVar Status, Path, Deps))]
tests, fins :: 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
path deps :: 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
resolveDeps :: [(IO (), (TVar Status, Path, Deps))] -> Maybe [(Action, TVar Status)]
resolveDeps :: [(IO (), (TVar Status, Path, Deps))]
-> Maybe [(Action, TVar Status)]
resolveDeps tests :: [(IO (), (TVar Status, Path, Deps))]
tests = [((Action, TVar Status), (Path, [Path]))]
-> Maybe [(Action, TVar Status)]
forall b a. Ord b => [(a, (b, [b]))] -> Maybe [a]
checkCycles ([((Action, TVar Status), (Path, [Path]))]
-> Maybe [(Action, TVar Status)])
-> [((Action, TVar Status), (Path, [Path]))]
-> Maybe [(Action, TVar Status)]
forall a b. (a -> b) -> a -> b
$ do
(run_test :: IO ()
run_test, (statusVar :: TVar Status
statusVar, path0 :: Path
path0, deps :: Deps
deps)) <- [(IO (), (TVar Status, Path, Deps))]
tests
let
deps' :: [(DependencyType, TVar Status, Path)]
deps' :: [(DependencyType, TVar Status, Path)]
deps' = do
(deptype :: DependencyType
deptype, depexpr :: Expr
depexpr) <- Deps
deps
(_, (statusVar1 :: TVar Status
statusVar1, path :: Path
path, _)) <- [(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
(\(deptype :: DependencyType
deptype, statusvar :: TVar Status
statusvar, _) k :: 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
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
_ -> 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 (\(_, _, path :: 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 -> Result
Result
{ resultOutcome :: Outcome
resultOutcome = FailureReason -> Outcome
Failure FailureReason
TestDepFailed
, resultDescription :: String
resultDescription = ""
, resultShortDescription :: String
resultShortDescription = "SKIP"
, resultTime :: Time
resultTime = 0
}
}
((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 tests :: [(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) | (v :: b
v, vs :: [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 ()
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
getResource :: TVar (Resource r) -> IO r
getResource :: TVar (Resource r) -> IO r
getResource var :: 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 -> r -> STM r
forall (m :: * -> *) a. Monad m => a -> m a
return r
r
Destroyed -> ResourceError -> STM r
forall e a. Exception e => e -> STM a
throwSTM ResourceError
UseOutsideOfTest
_ -> 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 "getResource" Resource r
rState
destroyResource :: (forall a . IO a -> IO a) -> Finalizer -> IO (Maybe SomeException)
destroyResource :: (forall a. IO a -> IO a) -> Finalizer -> IO (Maybe SomeException)
destroyResource restore :: forall a. IO a -> IO a
restore (Finalizer doRelease :: res -> IO ()
doRelease stateVar :: TVar (Resource res)
stateVar _) = 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
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)
BeingCreated -> STM (IO (Maybe SomeException))
forall a. STM a
retry
BeingDestroyed -> STM (IO (Maybe SomeException))
forall a. STM a
retry
NotCreated -> do
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
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
launchTestTree
:: OptionSet
-> TestTree
-> (StatusMap -> IO (Time -> IO a))
-> IO a
launchTestTree :: OptionSet -> TestTree -> (StatusMap -> IO (Time -> IO a)) -> IO a
launchTestTree opts :: OptionSet
opts tree :: TestTree
tree k0 :: StatusMap -> IO (Time -> IO a)
k0 = do
(testActions :: [(Action, TVar Status)]
testActions, fins :: Seq Finalizer
fins) <- OptionSet
-> TestTree -> IO ([(Action, TVar Status)], Seq Finalizer)
createTestActions OptionSet
opts TestTree
tree
let NumThreads numTheads :: Int
numTheads = OptionSet -> NumThreads
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts
(t :: Time
t,k1 :: 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 [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` \restore :: forall a. IO a -> IO a
restore -> do
IO ()
abortTests
(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
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 r :: Resource r
r = case Resource r
r of
NotCreated -> Bool
False
BeingCreated -> Bool
True
FailedToCreate {} -> Bool
False
Created {} -> Bool
True
BeingDestroyed -> Bool
True
Destroyed -> Bool
False
waitForResources :: t Finalizer -> IO ()
waitForResources fins :: 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 _ rvar :: TVar (Resource res)
rvar _) -> 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 where_ :: String
where_ r :: 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 (10Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^(7::Int))
finallyRestore
:: IO a
-> ((forall c . IO c -> IO c) -> IO b)
-> IO a
a :: IO a
a finallyRestore :: IO a -> ((forall a. IO a -> IO a) -> IO b) -> IO a
`finallyRestore` sequel :: (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
$ \restore :: 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