{-# LANGUAGE InstanceSigs #-}
module Test.Cleveland.Tasty.Internal
(
clevelandMain
, clevelandMainWithIngredients
, clevelandIngredients
, loadTastyEnv
, testScenario
, testScenarioOnEmulator
, testScenarioOnNetwork
, whenNetworkEnabled
, modifyNetworkEnv
, setAliasPrefix
, RunOnNetwork(..)
, RunOnEmulator(..)
, tastyEnvFromOpts
, onNetworkTag
, TastyEnvOpt(..)
, TastyEnv(..)
, mkTastyEnv
, mapTastyEnv
, memoize
, loadOptionSwitcher
) where
import Control.Concurrent (modifyMVar, withMVar)
import Data.Char qualified as C
import Data.Tagged (Tagged(Tagged))
import Fmt (pretty)
import System.Environment (lookupEnv)
import System.IO.Unsafe qualified as Unsafe
import Test.Tasty
(TestName, adjustOption, askOption, defaultIngredients, defaultMainWithIngredients,
includingOptions, localOption, testGroup)
import Test.Tasty.Ingredients (Ingredient)
import Test.Tasty.Options (IsOption(..), OptionSet, lookupOption)
import Test.Tasty.Patterns.Types as Tasty (Expr(..))
import Test.Tasty.Providers (IsTest(..), Progress, singleTest, testFailed, testPassed)
import Test.Tasty.Runners (Result(..), TestPattern(..), TestTree(AskOptions))
import Morley.Client (MorleyClientConfig(..), mceTezosClientL, mkMorleyClientEnv)
import Morley.Client.TezosClient.Types (tceAliasPrefixL)
import Test.Cleveland.Internal.Client as Client
(ClientM, NetworkEnv(..), neMorleyClientEnvL, runClevelandT)
import Test.Cleveland.Internal.Exceptions (WithCallStack(WithCallStack))
import Test.Cleveland.Internal.Pure as Pure (PureM, runClevelandT, runEmulatedT)
import Test.Cleveland.Internal.Scenario
import Test.Cleveland.Tasty.Internal.Options
(AliasPrefixOpt(..), ContextLinesOpt(..), DataDirOpt(..), EndpointOpt(..), MoneybagAliasOpt(..),
PathOpt(..), RunModeOpt(..), SecretKeyOpt(..), VerboseOpt(..), clevelandOptions)
import Test.Cleveland.Tasty.Internal.Report (formatError)
onNetworkTag :: TestName
onNetworkTag :: TestName
onNetworkTag = TestName
"On network"
testScenario :: TestName -> (forall m. MonadFail m => Scenario m) -> TestTree
testScenario :: TestName
-> (forall (m :: * -> *). MonadFail m => Scenario m) -> TestTree
testScenario TestName
testName forall (m :: * -> *). MonadFail m => Scenario m
scenario' =
TestName -> [TestTree] -> TestTree
testGroup TestName
testName
[ TestName -> RunOnEmulator -> TestTree
forall t. IsTest t => TestName -> t -> TestTree
singleTest TestName
"On emulator" (Scenario PureM -> RunOnEmulator
RunOnEmulator Scenario PureM
forall (m :: * -> *). MonadFail m => Scenario m
scenario')
, TestName -> RunOnNetwork -> TestTree
forall t. IsTest t => TestName -> t -> TestTree
singleTest TestName
onNetworkTag (Scenario ClientM -> RunOnNetwork
RunOnNetwork Scenario ClientM
forall (m :: * -> *). MonadFail m => Scenario m
scenario')
]
testScenarioOnEmulator :: TestName -> Scenario PureM -> TestTree
testScenarioOnEmulator :: TestName -> Scenario PureM -> TestTree
testScenarioOnEmulator TestName
testname Scenario PureM
scenario' =
TestName -> [TestTree] -> TestTree
testGroup TestName
testname
[ TestName -> RunOnEmulator -> TestTree
forall t. IsTest t => TestName -> t -> TestTree
singleTest TestName
"On emulator" (Scenario PureM -> RunOnEmulator
RunOnEmulator Scenario PureM
scenario') ]
testScenarioOnNetwork :: TestName -> Scenario ClientM -> TestTree
testScenarioOnNetwork :: TestName -> Scenario ClientM -> TestTree
testScenarioOnNetwork TestName
testname Scenario ClientM
scenario' =
TestName -> [TestTree] -> TestTree
testGroup TestName
testname
[ TestName -> RunOnNetwork -> TestTree
forall t. IsTest t => TestName -> t -> TestTree
singleTest TestName
onNetworkTag (Scenario ClientM -> RunOnNetwork
RunOnNetwork Scenario ClientM
scenario') ]
newtype RunOnEmulator = RunOnEmulator (Scenario PureM)
instance IsTest RunOnEmulator where
run :: OptionSet -> RunOnEmulator -> (Progress -> IO ()) -> IO Result
run :: OptionSet -> RunOnEmulator -> (Progress -> IO ()) -> IO Result
run OptionSet
opts (RunOnEmulator Scenario PureM
scenario') Progress -> IO ()
_ = do
let
MoneybagAliasOpt Alias
moneybagAlias = OptionSet -> MoneybagAliasOpt
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts
io :: IO ()
io = case Scenario PureM
scenario' of
ScenarioCleveland ClevelandT PureM ()
s -> Alias -> ClevelandT PureM () -> IO ()
forall a. Alias -> ClevelandT PureM a -> IO a
Pure.runClevelandT Alias
moneybagAlias ClevelandT PureM ()
s
ScenarioEmulated EmulatedT PureM ()
s -> Alias -> EmulatedT PureM () -> IO ()
forall a. Alias -> EmulatedT PureM a -> IO a
Pure.runEmulatedT Alias
moneybagAlias EmulatedT PureM ()
s
(IO ()
io IO () -> Result -> IO Result
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> TestName -> Result
testPassed TestName
"") IO Result -> (SomeException -> IO Result) -> IO Result
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` OptionSet -> SomeException -> IO Result
printFormattedException OptionSet
opts
testOptions :: Tagged RunOnEmulator [OptionDescription]
testOptions = [OptionDescription] -> Tagged RunOnEmulator [OptionDescription]
forall k (s :: k) b. b -> Tagged s b
Tagged [OptionDescription]
clevelandOptions
newtype RunOnNetwork = RunOnNetwork (Scenario ClientM)
instance IsTest RunOnNetwork where
run :: OptionSet -> RunOnNetwork -> (Progress -> IO ()) -> IO Result
run :: OptionSet -> RunOnNetwork -> (Progress -> IO ()) -> IO Result
run OptionSet
opts (RunOnNetwork (ScenarioCleveland ClevelandT ClientM ()
clevelandT)) Progress -> IO ()
_ = do
let
tastyEnv :: TastyEnv
tastyEnv = OptionSet -> TastyEnv
tastyEnvFromOpts OptionSet
opts
TastyEnv -> forall a. (NetworkEnv -> IO a) -> IO a
useNetworkEnv TastyEnv
tastyEnv ((NetworkEnv -> IO Result) -> IO Result)
-> (NetworkEnv -> IO Result) -> IO Result
forall a b. (a -> b) -> a -> b
$ \NetworkEnv
networkEnv -> do
let io :: IO ()
io = NetworkEnv -> ClevelandT ClientM () -> IO ()
forall a. NetworkEnv -> ClevelandT ClientM a -> IO a
Client.runClevelandT NetworkEnv
networkEnv ClevelandT ClientM ()
clevelandT
(IO ()
io IO () -> Result -> IO Result
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> TestName -> Result
testPassed TestName
"") IO Result -> (SomeException -> IO Result) -> IO Result
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` OptionSet -> SomeException -> IO Result
printFormattedException OptionSet
opts
testOptions :: Tagged RunOnNetwork [OptionDescription]
testOptions = [OptionDescription] -> Tagged RunOnNetwork [OptionDescription]
forall k (s :: k) b. b -> Tagged s b
Tagged [OptionDescription]
clevelandOptions
printFormattedException :: OptionSet -> SomeException -> IO Result
printFormattedException :: OptionSet -> SomeException -> IO Result
printFormattedException OptionSet
opts SomeException
se =
case SomeException -> Maybe WithCallStack
forall e. Exception e => SomeException -> Maybe e
fromException @WithCallStack SomeException
se of
Maybe WithCallStack
Nothing ->
Result -> IO Result
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TestName -> Result
testFailed (TestName -> Result) -> TestName -> Result
forall a b. (a -> b) -> a -> b
$ SomeException -> TestName
forall e. Exception e => e -> TestName
displayException SomeException
se)
Just (WithCallStack CallStack
cs SomeException
ex) -> do
Builder
msg <- Natural -> CallStack -> TestName -> IO Builder
formatError Natural
contextLines CallStack
cs (SomeException -> TestName
forall e. Exception e => e -> TestName
displayException SomeException
ex)
pure (TestName -> Result
testFailed (Builder -> TestName
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty Builder
msg))
where
ContextLinesOpt Natural
contextLines = OptionSet -> ContextLinesOpt
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts
lock :: MVar ()
lock :: MVar ()
lock = IO (MVar ()) -> MVar ()
forall a. IO a -> a
Unsafe.unsafePerformIO (() -> IO (MVar ())
forall (m :: * -> *) a. MonadIO m => a -> m (MVar a)
newMVar ())
{-# NOINLINE lock #-}
clevelandMain :: TestTree -> IO ()
clevelandMain :: TestTree -> IO ()
clevelandMain = [Ingredient] -> TestTree -> IO ()
clevelandMainWithIngredients [Ingredient]
defaultIngredients (TestTree -> IO ()) -> (TestTree -> TestTree) -> TestTree -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestTree -> TestTree
loadTastyEnv
clevelandMainWithIngredients :: [Ingredient] -> TestTree -> IO ()
clevelandMainWithIngredients :: [Ingredient] -> TestTree -> IO ()
clevelandMainWithIngredients [Ingredient]
ingredients TestTree
tree = do
Bool
ciSwitch <- IO Bool
withinCI
[Ingredient] -> TestTree -> IO ()
defaultMainWithIngredients
([Ingredient]
clevelandIngredients [Ingredient] -> [Ingredient] -> [Ingredient]
forall a. Semigroup a => a -> a -> a
<> [Ingredient]
ingredients)
(Bool -> TestTree -> TestTree
loadOptionSwitcher Bool
ciSwitch (TestTree -> TestTree)
-> (TestTree -> TestTree) -> TestTree -> TestTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestTree -> TestTree
loadTastyEnv (TestTree -> TestTree) -> TestTree -> TestTree
forall a b. (a -> b) -> a -> b
$ TestTree
tree)
clevelandIngredients :: [Ingredient]
clevelandIngredients :: [Ingredient]
clevelandIngredients =
[ [OptionDescription] -> Ingredient
includingOptions [OptionDescription]
clevelandOptions
]
tastyEnvFromOpts :: OptionSet -> TastyEnv
tastyEnvFromOpts :: OptionSet -> TastyEnv
tastyEnvFromOpts OptionSet
optionSet =
let
AliasPrefixOpt Maybe Text
aliasPrefix = OptionSet -> AliasPrefixOpt
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
optionSet
EndpointOpt Maybe BaseUrl
endpoint = OptionSet -> EndpointOpt
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
optionSet
PathOpt TestName
path = OptionSet -> PathOpt
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
optionSet
DataDirOpt Maybe TestName
dataDir = OptionSet -> DataDirOpt
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
optionSet
VerboseOpt Word
verbosity = OptionSet -> VerboseOpt
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
optionSet
SecretKeyOpt Maybe SecretKey
sk = OptionSet -> SecretKeyOpt
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
optionSet
MoneybagAliasOpt Alias
origAlias = OptionSet -> MoneybagAliasOpt
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
optionSet
in
case OptionSet -> TastyEnvOpt
forall v. IsOption v => OptionSet -> v
lookupOption @TastyEnvOpt OptionSet
optionSet of
TastyEnvOpt (Just TastyEnv
tastyEnv) -> TastyEnv
tastyEnv
TastyEnvOpt Maybe TastyEnv
Nothing -> IO NetworkEnv -> TastyEnv
mkTastyEnv (IO NetworkEnv -> TastyEnv) -> IO NetworkEnv -> TastyEnv
forall a b. (a -> b) -> a -> b
$ do
MorleyClientEnv' MorleyClientM
morleyClientEnv <- MorleyClientConfig -> IO (MorleyClientEnv' MorleyClientM)
forall (m :: * -> *).
MonadIO m =>
MorleyClientConfig -> IO (MorleyClientEnv' m)
mkMorleyClientEnv MorleyClientConfig :: Maybe Text
-> Maybe BaseUrl
-> TestName
-> Maybe TestName
-> Word
-> Maybe SecretKey
-> MorleyClientConfig
MorleyClientConfig
{ mccAliasPrefix :: Maybe Text
mccAliasPrefix = Maybe Text
aliasPrefix
, mccEndpointUrl :: Maybe BaseUrl
mccEndpointUrl = Maybe BaseUrl
endpoint
, mccTezosClientPath :: TestName
mccTezosClientPath = TestName
path
, mccMbTezosClientDataDir :: Maybe TestName
mccMbTezosClientDataDir = Maybe TestName
dataDir
, mccVerbosity :: Word
mccVerbosity = Word
verbosity
, mccSecretKey :: Maybe SecretKey
mccSecretKey = Maybe SecretKey
forall a. Maybe a
Nothing
}
pure NetworkEnv :: MorleyClientEnv' MorleyClientM
-> Maybe SecretKey -> Alias -> NetworkEnv
NetworkEnv
{ neMorleyClientEnv :: MorleyClientEnv' MorleyClientM
neMorleyClientEnv = MorleyClientEnv' MorleyClientM
morleyClientEnv
, neSecretKey :: Maybe SecretKey
neSecretKey = Maybe SecretKey
sk
, neMoneybagAlias :: Alias
neMoneybagAlias = Alias
origAlias
}
withinCI :: IO Bool
withinCI :: IO Bool
withinCI = TestName -> IO (Maybe TestName)
lookupEnv TestName
"CI" IO (Maybe TestName) -> (Maybe TestName -> Bool) -> IO Bool
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
Just TestName
"1" -> Bool
True
Just ((Char -> Char) -> TestName -> TestName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Char -> Char
C.toLower -> TestName
"true") -> Bool
True
Maybe TestName
_ -> Bool
False
{-# NOINLINE withinCI #-}
whenNetworkEnabled :: ((forall a. (NetworkEnv -> IO a) -> IO a) -> TestTree) -> TestTree
whenNetworkEnabled :: ((forall a. (NetworkEnv -> IO a) -> IO a) -> TestTree) -> TestTree
whenNetworkEnabled (forall a. (NetworkEnv -> IO a) -> IO a) -> TestTree
mkTestTree =
(OptionSet -> TestTree) -> TestTree
AskOptions \OptionSet
optionSet ->
let TastyEnv forall a. (NetworkEnv -> IO a) -> IO a
useNetworkEnv = OptionSet -> TastyEnv
tastyEnvFromOpts OptionSet
optionSet
in TestName -> [TestTree] -> TestTree
testGroup TestName
onNetworkTag [ (forall a. (NetworkEnv -> IO a) -> IO a) -> TestTree
mkTestTree forall a. (NetworkEnv -> IO a) -> IO a
useNetworkEnv ]
modifyNetworkEnv :: (NetworkEnv -> NetworkEnv) -> TestTree -> TestTree
modifyNetworkEnv :: (NetworkEnv -> NetworkEnv) -> TestTree -> TestTree
modifyNetworkEnv NetworkEnv -> NetworkEnv
f TestTree
tree =
(OptionSet -> TestTree) -> TestTree
AskOptions \OptionSet
optionSet ->
let tastyEnv :: TastyEnv
tastyEnv = OptionSet -> TastyEnv
tastyEnvFromOpts OptionSet
optionSet
in TastyEnvOpt -> TestTree -> TestTree
forall v. IsOption v => v -> TestTree -> TestTree
localOption (Maybe TastyEnv -> TastyEnvOpt
TastyEnvOpt (Maybe TastyEnv -> TastyEnvOpt) -> Maybe TastyEnv -> TastyEnvOpt
forall a b. (a -> b) -> a -> b
$ TastyEnv -> Maybe TastyEnv
forall a. a -> Maybe a
Just ((NetworkEnv -> NetworkEnv) -> TastyEnv -> TastyEnv
mapTastyEnv NetworkEnv -> NetworkEnv
f TastyEnv
tastyEnv)) (TestTree -> TestTree) -> TestTree -> TestTree
forall a b. (a -> b) -> a -> b
$
TestTree
tree
setAliasPrefix :: Text -> TestTree -> TestTree
setAliasPrefix :: Text -> TestTree -> TestTree
setAliasPrefix Text
aliasPrefix TestTree
tree =
(NetworkEnv -> NetworkEnv) -> TestTree -> TestTree
modifyNetworkEnv ((MorleyClientEnv' MorleyClientM
-> Identity (MorleyClientEnv' MorleyClientM))
-> NetworkEnv -> Identity NetworkEnv
Lens' NetworkEnv (MorleyClientEnv' MorleyClientM)
neMorleyClientEnvL((MorleyClientEnv' MorleyClientM
-> Identity (MorleyClientEnv' MorleyClientM))
-> NetworkEnv -> Identity NetworkEnv)
-> ((Maybe Text -> Identity (Maybe Text))
-> MorleyClientEnv' MorleyClientM
-> Identity (MorleyClientEnv' MorleyClientM))
-> (Maybe Text -> Identity (Maybe Text))
-> NetworkEnv
-> Identity NetworkEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(TezosClientEnv -> Identity TezosClientEnv)
-> MorleyClientEnv' MorleyClientM
-> Identity (MorleyClientEnv' MorleyClientM)
forall (m :: * -> *). Lens' (MorleyClientEnv' m) TezosClientEnv
mceTezosClientL((TezosClientEnv -> Identity TezosClientEnv)
-> MorleyClientEnv' MorleyClientM
-> Identity (MorleyClientEnv' MorleyClientM))
-> ((Maybe Text -> Identity (Maybe Text))
-> TezosClientEnv -> Identity TezosClientEnv)
-> (Maybe Text -> Identity (Maybe Text))
-> MorleyClientEnv' MorleyClientM
-> Identity (MorleyClientEnv' MorleyClientM)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Maybe Text -> Identity (Maybe Text))
-> TezosClientEnv -> Identity TezosClientEnv
Lens' TezosClientEnv (Maybe Text)
tceAliasPrefixL ((Maybe Text -> Identity (Maybe Text))
-> NetworkEnv -> Identity NetworkEnv)
-> Maybe Text -> NetworkEnv -> NetworkEnv
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Text -> Maybe Text
forall a. a -> Maybe a
Just Text
aliasPrefix) (TestTree -> TestTree) -> TestTree -> TestTree
forall a b. (a -> b) -> a -> b
$
TestTree
tree
newtype TastyEnvOpt = TastyEnvOpt (Maybe TastyEnv)
instance IsOption TastyEnvOpt where
defaultValue :: TastyEnvOpt
defaultValue = Maybe TastyEnv -> TastyEnvOpt
TastyEnvOpt Maybe TastyEnv
forall a. Maybe a
Nothing
optionName :: Tagged TastyEnvOpt TestName
optionName = Tagged TastyEnvOpt TestName
""
optionHelp :: Tagged TastyEnvOpt TestName
optionHelp = Tagged TastyEnvOpt TestName
""
parseValue :: TestName -> Maybe TastyEnvOpt
parseValue = \TestName
_ -> Maybe TastyEnvOpt
forall a. Maybe a
Nothing
loadTastyEnv :: TestTree -> TestTree
loadTastyEnv :: TestTree -> TestTree
loadTastyEnv TestTree
tree =
(OptionSet -> TestTree) -> TestTree
AskOptions \OptionSet
optionSet ->
let tastyEnv :: TastyEnv
tastyEnv = OptionSet -> TastyEnv
tastyEnvFromOpts OptionSet
optionSet
in TastyEnvOpt -> TestTree -> TestTree
forall v. IsOption v => v -> TestTree -> TestTree
localOption (Maybe TastyEnv -> TastyEnvOpt
TastyEnvOpt (Maybe TastyEnv -> TastyEnvOpt) -> Maybe TastyEnv -> TastyEnvOpt
forall a b. (a -> b) -> a -> b
$ TastyEnv -> Maybe TastyEnv
forall a. a -> Maybe a
Just TastyEnv
tastyEnv)
TestTree
tree
newtype TastyEnv = TastyEnv
{ TastyEnv -> forall a. (NetworkEnv -> IO a) -> IO a
useNetworkEnv :: forall a. (NetworkEnv -> IO a) -> IO a
}
mkTastyEnv :: IO NetworkEnv -> TastyEnv
mkTastyEnv :: IO NetworkEnv -> TastyEnv
mkTastyEnv IO NetworkEnv
mkEnv =
TastyEnv :: (forall a. (NetworkEnv -> IO a) -> IO a) -> TastyEnv
TastyEnv
{ useNetworkEnv :: forall a. (NetworkEnv -> IO a) -> IO a
useNetworkEnv = \NetworkEnv -> IO a
cont ->
MVar () -> (() -> IO a) -> IO a
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar ()
lock ((() -> IO a) -> IO a) -> (() -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \() -> do
NetworkEnv
env <- IO NetworkEnv
memoMkEnv
NetworkEnv -> IO a
cont NetworkEnv
env
}
where
memoMkEnv :: IO NetworkEnv
memoMkEnv = IO (IO NetworkEnv) -> IO NetworkEnv
forall a. IO a -> a
Unsafe.unsafePerformIO (IO (IO NetworkEnv) -> IO NetworkEnv)
-> IO (IO NetworkEnv) -> IO NetworkEnv
forall a b. (a -> b) -> a -> b
$ IO NetworkEnv -> IO (IO NetworkEnv)
forall a. IO a -> IO (IO a)
memoize IO NetworkEnv
mkEnv
mapTastyEnv :: (NetworkEnv -> NetworkEnv) -> (TastyEnv -> TastyEnv)
mapTastyEnv :: (NetworkEnv -> NetworkEnv) -> TastyEnv -> TastyEnv
mapTastyEnv NetworkEnv -> NetworkEnv
g (TastyEnv forall a. (NetworkEnv -> IO a) -> IO a
f) =
(forall a. (NetworkEnv -> IO a) -> IO a) -> TastyEnv
TastyEnv ((forall a. (NetworkEnv -> IO a) -> IO a) -> TastyEnv)
-> (forall a. (NetworkEnv -> IO a) -> IO a) -> TastyEnv
forall a b. (a -> b) -> a -> b
$ \NetworkEnv -> IO a
cont ->
(NetworkEnv -> IO a) -> IO a
forall a. (NetworkEnv -> IO a) -> IO a
f (\NetworkEnv
networkEnv -> NetworkEnv -> IO a
cont (NetworkEnv -> NetworkEnv
g NetworkEnv
networkEnv))
memoize :: forall a. IO a -> IO (IO a)
memoize :: IO a -> IO (IO a)
memoize IO a
action = do
MVar (Maybe a)
cache <- Maybe a -> IO (MVar (Maybe a))
forall (m :: * -> *) a. MonadIO m => a -> m (MVar a)
newMVar Maybe a
forall a. Maybe a
Nothing
let
readCache :: IO a
readCache :: IO a
readCache =
MVar (Maybe a) -> IO (Maybe a)
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
readMVar MVar (Maybe a)
cache IO (Maybe a) -> (Maybe a -> IO a) -> IO a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just a
a -> a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
Maybe a
Nothing ->
MVar (Maybe a) -> (Maybe a -> IO (Maybe a, a)) -> IO a
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar (Maybe a)
cache ((Maybe a -> IO (Maybe a, a)) -> IO a)
-> (Maybe a -> IO (Maybe a, a)) -> IO a
forall a b. (a -> b) -> a -> b
$ \case
Just a
a -> (Maybe a, a) -> IO (Maybe a, a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Maybe a
forall a. a -> Maybe a
Just a
a, a
a)
Maybe a
Nothing -> do
a
a <- IO a
action
pure (a -> Maybe a
forall a. a -> Maybe a
Just a
a, a
a)
IO a -> IO (IO a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure IO a
readCache
loadOptionSwitcher :: Bool -> TestTree -> TestTree
loadOptionSwitcher :: Bool -> TestTree -> TestTree
loadOptionSwitcher Bool
ciFlag TestTree
testTree =
IsOption RunModeOpt => (RunModeOpt -> TestTree) -> TestTree
forall v. IsOption v => (v -> TestTree) -> TestTree
askOption @RunModeOpt ((RunModeOpt -> TestTree) -> TestTree)
-> (RunModeOpt -> TestTree) -> TestTree
forall a b. (a -> b) -> a -> b
$ \RunModeOpt
mode -> case (RunModeOpt
mode, Bool
ciFlag) of
(RunModeOpt
RunAllMode, Bool
_) -> TestTree
testTree
(RunModeOpt
OnlyNetworkMode, Bool
_) -> TestTree -> TestTree
loadOnlyNetworkPattern TestTree
testTree
(RunModeOpt
DisableNetworkMode, Bool
_) -> TestTree -> TestTree
loadNoNetworkPattern TestTree
testTree
(RunModeOpt
DefaultMode, Bool
False) -> TestTree -> TestTree
loadNoNetworkPattern TestTree
testTree
(RunModeOpt
DefaultMode, Bool
True) -> TestTree
testTree
where
loadOnlyNetworkPattern :: TestTree -> TestTree
loadOnlyNetworkPattern :: TestTree -> TestTree
loadOnlyNetworkPattern = (TestPattern -> TestPattern) -> TestTree -> TestTree
forall v. IsOption v => (v -> v) -> TestTree -> TestTree
adjustOption (Expr -> TestPattern -> TestPattern
adjustExprToTestPattern Expr
runOnlyNetworkExpr)
loadNoNetworkPattern :: TestTree -> TestTree
loadNoNetworkPattern :: TestTree -> TestTree
loadNoNetworkPattern = (TestPattern -> TestPattern) -> TestTree -> TestTree
forall v. IsOption v => (v -> v) -> TestTree -> TestTree
adjustOption (Expr -> TestPattern -> TestPattern
adjustExprToTestPattern Expr
dontRunNetworkExpr)
adjustExprToTestPattern :: Expr -> TestPattern -> TestPattern
adjustExprToTestPattern :: Expr -> TestPattern -> TestPattern
adjustExprToTestPattern Expr
expr (TestPattern Maybe Expr
maybePattern) = Maybe Expr -> TestPattern
TestPattern (Maybe Expr -> TestPattern) -> Maybe Expr -> TestPattern
forall a b. (a -> b) -> a -> b
$ Expr -> Maybe Expr
forall a. a -> Maybe a
Just
case Maybe Expr
maybePattern of
Maybe Expr
Nothing -> Expr
expr
Just Expr
ptrn -> Expr -> Expr -> Expr
And Expr
ptrn Expr
expr
runOnlyNetworkExpr :: Expr
runOnlyNetworkExpr :: Expr
runOnlyNetworkExpr =
Expr -> Expr -> Expr
Or
(Expr -> Expr -> Expr
Or
(Expr -> Expr -> Expr
Tasty.EQ (Expr -> Expr
Field (Int -> Expr
IntLit Int
1)) (TestName -> Expr
StringLit TestName
"On network"))
(Expr -> Expr -> Expr
Tasty.EQ (Expr -> Expr
Field Expr
NF) (TestName -> Expr
StringLit TestName
"On network"))
)
(Expr -> TestName -> Expr
Match (Expr -> Expr
Field (Int -> Expr
IntLit Int
0)) TestName
".On network.")
dontRunNetworkExpr :: Expr
dontRunNetworkExpr :: Expr
dontRunNetworkExpr =
Expr -> Expr -> Expr
And
(Expr -> Expr -> Expr
And
(Expr -> Expr -> Expr
Tasty.NE (Expr -> Expr
Field (Int -> Expr
IntLit Int
1)) (TestName -> Expr
StringLit TestName
"On network"))
(Expr -> Expr -> Expr
Tasty.NE (Expr -> Expr
Field Expr
NF) (TestName -> Expr
StringLit TestName
"On network"))
)
(Expr -> TestName -> Expr
NoMatch (Expr -> Expr
Field (Int -> Expr
IntLit Int
0)) TestName
".On network.")