sydtest-0.15.1.2: src/Test/Syd/Runner/Wrappers.hs

{-# 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.OptParse
import Test.Syd.Run
import Test.Syd.SpecDef

data Next a = Continue a | Stop a
  deriving (Functor)

extractNext :: Next a -> a
extractNext (Continue a) = a
extractNext (Stop a) = a

failFastNext :: Settings -> TDef (Timed TestRunReport) -> Next (TDef (Timed TestRunReport))
failFastNext settings td@(TDef timed _) =
  if settingFailFast settings && testRunReportFailed settings (timedValue timed)
    then Stop td
    else Continue td

applySimpleWrapper ::
  (MonadIO m) =>
  ((a -> m ()) -> (b -> m ())) ->
  (a -> m r) ->
  (b -> m r)
applySimpleWrapper takeTakeA takeA b = do
  var <- liftIO newEmptyMVar
  takeTakeA
    ( \a -> do
        r <- takeA a
        liftIO $ putMVar var r
    )
    b
  liftIO $ readMVar var

applySimpleWrapper' ::
  (MonadIO m) =>
  ((a -> m ()) -> m ()) ->
  (a -> m r) ->
  m r
applySimpleWrapper' takeTakeA takeA = do
  var <- liftIO newEmptyMVar
  takeTakeA
    ( \a -> do
        r <- takeA a
        liftIO $ putMVar var r
    )

  liftIO $ readMVar var

applySimpleWrapper'' ::
  (MonadIO m) =>
  (m () -> m ()) ->
  m r ->
  m r
applySimpleWrapper'' wrapper produceResult = do
  var <- liftIO newEmptyMVar
  wrapper $ do
    r <- produceResult
    liftIO $ putMVar var r

  liftIO $ readMVar var

applySimpleWrapper2 ::
  (MonadIO m) =>
  ((a -> b -> m ()) -> (c -> d -> m ())) ->
  (a -> b -> m r) ->
  (c -> d -> m r)
applySimpleWrapper2 takeTakeAB takeAB c d = do
  var <- liftIO newEmptyMVar
  takeTakeAB
    ( \a b -> do
        r <- takeAB a b
        liftIO $ putMVar var r
    )
    c
    d
  liftIO $ readMVar var