{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
module Test.Syd.Runner.Wrappers where
import Control.Concurrent
import Control.Monad.IO.Class
import Test.Syd.Run
import Test.Syd.SpecDef
data Next a = Continue a | Stop a
deriving (a -> Next b -> Next a
(a -> b) -> Next a -> Next b
(forall a b. (a -> b) -> Next a -> Next b)
-> (forall a b. a -> Next b -> Next a) -> Functor Next
forall a b. a -> Next b -> Next a
forall a b. (a -> b) -> Next a -> Next b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Next b -> Next a
$c<$ :: forall a b. a -> Next b -> Next a
fmap :: (a -> b) -> Next a -> Next b
$cfmap :: forall a b. (a -> b) -> Next a -> Next b
Functor)
extractNext :: Next a -> a
(Continue a
a) = a
a
extractNext (Stop a
a) = a
a
failFastNext :: Bool -> TDef (Timed TestRunResult) -> Next (TDef (Timed TestRunResult))
failFastNext :: Bool
-> TDef (Timed TestRunResult) -> Next (TDef (Timed TestRunResult))
failFastNext Bool
b td :: TDef (Timed TestRunResult)
td@(TDef (Timed TestRunResult
trr Word64
_) CallStack
_) =
if Bool
b Bool -> Bool -> Bool
&& TestRunResult -> TestStatus
testRunResultStatus TestRunResult
trr TestStatus -> TestStatus -> Bool
forall a. Eq a => a -> a -> Bool
== TestStatus
TestFailed
then TDef (Timed TestRunResult) -> Next (TDef (Timed TestRunResult))
forall a. a -> Next a
Stop TDef (Timed TestRunResult)
td
else TDef (Timed TestRunResult) -> Next (TDef (Timed TestRunResult))
forall a. a -> Next a
Continue TDef (Timed TestRunResult)
td
applySimpleWrapper ::
MonadIO m =>
((a -> m ()) -> (b -> m ())) ->
(a -> m r) ->
(b -> m r)
applySimpleWrapper :: ((a -> m ()) -> b -> m ()) -> (a -> m r) -> b -> m r
applySimpleWrapper (a -> m ()) -> b -> m ()
takeTakeA a -> m r
takeA b
b = do
MVar r
var <- IO (MVar r) -> m (MVar r)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (MVar r)
forall a. IO (MVar a)
newEmptyMVar
(a -> m ()) -> b -> m ()
takeTakeA
( \a
a -> do
r
r <- a -> m r
takeA a
a
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ MVar r -> r -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar r
var r
r
)
b
b
IO r -> m r
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO r -> m r) -> IO r -> m r
forall a b. (a -> b) -> a -> b
$ MVar r -> IO r
forall a. MVar a -> IO a
readMVar MVar r
var
applySimpleWrapper' ::
MonadIO m =>
((a -> m ()) -> m ()) ->
(a -> m r) ->
m r
applySimpleWrapper' :: ((a -> m ()) -> m ()) -> (a -> m r) -> m r
applySimpleWrapper' (a -> m ()) -> m ()
takeTakeA a -> m r
takeA = do
MVar r
var <- IO (MVar r) -> m (MVar r)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (MVar r)
forall a. IO (MVar a)
newEmptyMVar
(a -> m ()) -> m ()
takeTakeA
( \a
a -> do
r
r <- a -> m r
takeA a
a
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ MVar r -> r -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar r
var r
r
)
IO r -> m r
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO r -> m r) -> IO r -> m r
forall a b. (a -> b) -> a -> b
$ MVar r -> IO r
forall a. MVar a -> IO a
readMVar MVar r
var
applySimpleWrapper'' ::
MonadIO m =>
(m () -> m ()) ->
m r ->
m r
applySimpleWrapper'' :: (m () -> m ()) -> m r -> m r
applySimpleWrapper'' m () -> m ()
wrapper m r
produceResult = do
MVar r
var <- IO (MVar r) -> m (MVar r)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (MVar r)
forall a. IO (MVar a)
newEmptyMVar
m () -> m ()
wrapper (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
r
r <- m r
produceResult
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ MVar r -> r -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar r
var r
r
IO r -> m r
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO r -> m r) -> IO r -> m r
forall a b. (a -> b) -> a -> b
$ MVar r -> IO r
forall a. MVar a -> IO a
readMVar MVar r
var
applySimpleWrapper2 ::
MonadIO m =>
((a -> b -> m ()) -> (c -> d -> m ())) ->
(a -> b -> m r) ->
(c -> d -> m r)
applySimpleWrapper2 :: ((a -> b -> m ()) -> c -> d -> m ())
-> (a -> b -> m r) -> c -> d -> m r
applySimpleWrapper2 (a -> b -> m ()) -> c -> d -> m ()
takeTakeAB a -> b -> m r
takeAB c
c d
d = do
MVar r
var <- IO (MVar r) -> m (MVar r)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (MVar r)
forall a. IO (MVar a)
newEmptyMVar
(a -> b -> m ()) -> c -> d -> m ()
takeTakeAB
( \a
a b
b -> do
r
r <- a -> b -> m r
takeAB a
a b
b
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ MVar r -> r -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar r
var r
r
)
c
c
d
d
IO r -> m r
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO r -> m r) -> IO r -> m r
forall a b. (a -> b) -> a -> b
$ MVar r -> IO r
forall a. MVar a -> IO a
readMVar MVar r
var