{-# 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
extractNext :: Next a -> a
extractNext (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