{-# OPTIONS_HADDOCK not-home #-}
module Test.Cleveland.Tasty.Internal
(
clevelandMain
, clevelandMainWithIngredients
, clevelandIngredients
, loadTastyEnv
, testScenario
, testScenarioOnEmulator
, testScenarioOnNetwork
, whenNetworkEnabled
, modifyNetworkEnv
, 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.Directory (removeDirectoryRecursive)
import System.Environment (lookupEnv)
import System.IO.Temp (createTempDirectory, getCanonicalTemporaryDirectory)
import System.IO.Unsafe qualified as Unsafe
import Test.Tasty
(TestName, adjustOption, askOption, defaultIngredients, defaultMainWithIngredients,
includingOptions, localOption, testGroup, withResource)
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 (tceMbTezosClientDataDirL)
import Test.Cleveland.Internal.Abstract (NetworkEnv(..), neMorleyClientEnvL)
import Test.Cleveland.Internal.Client as Client (ClientM, runNetworkT)
import Test.Cleveland.Internal.Exceptions
import Test.Cleveland.Internal.Pure as Pure (PureM, runEmulatedT)
import Test.Cleveland.Internal.Scenario
import Test.Cleveland.Tasty.Internal.Options
(ContextLinesOpt(..), DataDirOpt(..), EndpointOpt(..), MoneybagAliasOpt(..), PathOpt(..),
RunModeOpt(..), SecretKeyOpt(..), VerboseOpt(..), clevelandOptions)
import Test.Cleveland.Tasty.Internal.Report (formatError)
onNetworkTag :: TestName
onNetworkTag :: String
onNetworkTag = String
"On network"
testScenario :: TestName -> (forall m. Scenario m) -> TestTree
testScenario :: String -> (forall (m :: * -> *). Scenario m) -> TestTree
testScenario String
testName forall (m :: * -> *). Scenario m
scenario_ =
String -> [TestTree] -> TestTree
testGroup String
testName
[ String -> RunOnEmulator -> TestTree
forall t. IsTest t => String -> t -> TestTree
singleTest String
"On emulator" (Scenario PureM -> RunOnEmulator
RunOnEmulator Scenario PureM
forall (m :: * -> *). Scenario m
scenario_)
, String -> RunOnNetwork -> TestTree
forall t. IsTest t => String -> t -> TestTree
singleTest String
onNetworkTag (Scenario ClientM -> RunOnNetwork
RunOnNetwork Scenario ClientM
forall (m :: * -> *). Scenario m
scenario_)
]
testScenarioOnEmulator :: TestName -> Scenario PureM -> TestTree
testScenarioOnEmulator :: String -> Scenario PureM -> TestTree
testScenarioOnEmulator String
testname Scenario PureM
scenario_ =
String -> [TestTree] -> TestTree
testGroup String
testname
[ String -> RunOnEmulator -> TestTree
forall t. IsTest t => String -> t -> TestTree
singleTest String
"On emulator" (Scenario PureM -> RunOnEmulator
RunOnEmulator Scenario PureM
scenario_) ]
testScenarioOnNetwork :: TestName -> Scenario ClientM -> TestTree
testScenarioOnNetwork :: String -> Scenario ClientM -> TestTree
testScenarioOnNetwork String
testname Scenario ClientM
scenario_ =
String -> [TestTree] -> TestTree
testGroup String
testname
[ String -> RunOnNetwork -> TestTree
forall t. IsTest t => String -> t -> TestTree
singleTest String
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 (ScenarioEmulated EmulatedT PureM ()
emulatedT)) Progress -> IO ()
_ = do
let
MoneybagAliasOpt ImplicitAlias
moneybagAlias = OptionSet -> MoneybagAliasOpt
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts
io :: IO ()
io = ImplicitAlias -> EmulatedT PureM () -> IO ()
forall a. ImplicitAlias -> EmulatedT PureM a -> IO a
Pure.runEmulatedT ImplicitAlias
moneybagAlias EmulatedT PureM ()
emulatedT
(IO ()
io IO () -> Result -> IO Result
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> String -> Result
testPassed String
"") 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 (ScenarioNetwork NetworkT 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 -> NetworkT ClientM () -> IO ()
forall a. NetworkEnv -> NetworkT ClientM a -> IO a
Client.runNetworkT NetworkEnv
networkEnv NetworkT ClientM ()
clevelandT
(IO ()
io IO () -> Result -> IO Result
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> String -> Result
testPassed String
"") 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 CallStackAnnotation
forall ann. ExceptionAnnotation ann => SomeException -> Maybe ann
lookupAnnEx SomeException
se of
Maybe CallStackAnnotation
Nothing -> Result -> IO Result
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result -> IO Result) -> Result -> IO Result
forall a b. (a -> b) -> a -> b
$ String -> Result
testFailed (String -> Result) -> String -> Result
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
se
Just (CallStackAnnotation CallStack
cs) -> String -> Result
testFailed (String -> Result) -> (Builder -> String) -> Builder -> Result
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> String
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty (Builder -> Result) -> IO Builder -> IO Result
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Natural -> CallStack -> String -> IO Builder
formatError Natural
contextLines CallStack
cs (
SomeException -> String
forall e. Exception e => e -> String
displayException (SomeException -> String) -> SomeException -> String
forall a b. (a -> b) -> a -> b
$ forall ann.
ExceptionAnnotation ann =>
SomeException -> SomeException
removeAnnEx @CallStackAnnotation SomeException
se
)
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
setupTempDatadirIfNeeded (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
EndpointOpt Maybe BaseUrl
endpoint = OptionSet -> EndpointOpt
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
optionSet
PathOpt String
path = OptionSet -> PathOpt
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
optionSet
DataDirOpt Maybe String
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 ImplicitAlias
origAlias = OptionSet -> MoneybagAliasOpt
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
optionSet
in
case 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
morleyClientEnv <- MorleyClientConfig -> IO MorleyClientEnv
mkMorleyClientEnv MorleyClientConfig :: Maybe BaseUrl
-> String
-> Maybe String
-> Word
-> Maybe SecretKey
-> MorleyClientConfig
MorleyClientConfig
{ mccEndpointUrl :: Maybe BaseUrl
mccEndpointUrl = Maybe BaseUrl
endpoint
, mccTezosClientPath :: String
mccTezosClientPath = String
path
, mccMbTezosClientDataDir :: Maybe String
mccMbTezosClientDataDir = Maybe String
dataDir
, mccVerbosity :: Word
mccVerbosity = Word
verbosity
, mccSecretKey :: Maybe SecretKey
mccSecretKey = Maybe SecretKey
forall a. Maybe a
Nothing
}
pure NetworkEnv :: MorleyClientEnv
-> Maybe SecretKey -> ImplicitAlias -> Bool -> Word -> NetworkEnv
NetworkEnv
{ neMorleyClientEnv :: MorleyClientEnv
neMorleyClientEnv = MorleyClientEnv
morleyClientEnv
, neSecretKey :: Maybe SecretKey
neSecretKey = Maybe SecretKey
sk
, neMoneybagAlias :: ImplicitAlias
neMoneybagAlias = ImplicitAlias
origAlias
, neExplicitDataDir :: Bool
neExplicitDataDir = Maybe String -> Bool
forall a. Maybe a -> Bool
isJust Maybe String
dataDir
, neVerbosity :: Word
neVerbosity = Word
verbosity
}
withinCI :: IO Bool
withinCI :: IO Bool
withinCI = String -> IO (Maybe String)
lookupEnv String
"CI" IO (Maybe String) -> (Maybe String -> Bool) -> IO Bool
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
Just String
"1" -> Bool
True
Just ((Char -> Char) -> String -> String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Char -> Char
C.toLower -> String
"true") -> Bool
True
Maybe String
_ -> 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 String -> [TestTree] -> TestTree
testGroup String
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
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 String
optionName = Tagged TastyEnvOpt String
""
optionHelp :: Tagged TastyEnvOpt String
optionHelp = Tagged TastyEnvOpt String
""
parseValue :: String -> Maybe TastyEnvOpt
parseValue = \String
_ -> 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
$ IO a -> () -> IO a
forall a b. a -> b -> a
const 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
setupTempDatadirIfNeeded :: TestTree -> TestTree
setupTempDatadirIfNeeded :: TestTree -> TestTree
setupTempDatadirIfNeeded TestTree
tree = (DataDirOpt -> TestTree) -> TestTree
forall v. IsOption v => (v -> TestTree) -> TestTree
askOption \case
DataDirOpt Just{} -> TestTree
tree
DataDirOpt Maybe String
Nothing ->
IO String
-> (String -> IO ()) -> (IO String -> TestTree) -> TestTree
forall a. IO a -> (a -> IO ()) -> (IO a -> TestTree) -> TestTree
withResource IO String
initTempDir String -> IO ()
removeDirectoryRecursive \IO String
iodir ->
(NetworkEnv -> NetworkEnv) -> TestTree -> TestTree
modifyNetworkEnv ((Maybe String -> Identity (Maybe String))
-> NetworkEnv -> Identity NetworkEnv
Lens' NetworkEnv (Maybe String)
neMbTezosClientDataDirL ((Maybe String -> Identity (Maybe String))
-> NetworkEnv -> Identity NetworkEnv)
-> Maybe String -> NetworkEnv -> NetworkEnv
forall s t a b. ASetter s t a b -> b -> s -> t
.~ String -> Maybe String
forall a. a -> Maybe a
Just (IO String -> String
forall a. IO a -> a
Unsafe.unsafePerformIO IO String
iodir)) TestTree
tree
where
initTempDir :: IO String
initTempDir = do
String
tmpdir <- IO String
getCanonicalTemporaryDirectory
String -> String -> IO String
createTempDirectory String
tmpdir String
"cleveland"
neMbTezosClientDataDirL :: Lens' NetworkEnv (Maybe FilePath)
neMbTezosClientDataDirL :: Lens' NetworkEnv (Maybe String)
neMbTezosClientDataDirL =
(MorleyClientEnv -> f MorleyClientEnv)
-> NetworkEnv -> f NetworkEnv
Lens' NetworkEnv MorleyClientEnv
neMorleyClientEnvL ((MorleyClientEnv -> f MorleyClientEnv)
-> NetworkEnv -> f NetworkEnv)
-> ((Maybe String -> f (Maybe String))
-> MorleyClientEnv -> f MorleyClientEnv)
-> (Maybe String -> f (Maybe String))
-> NetworkEnv
-> f NetworkEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TezosClientEnv -> f TezosClientEnv)
-> MorleyClientEnv -> f MorleyClientEnv
Lens' MorleyClientEnv TezosClientEnv
mceTezosClientL ((TezosClientEnv -> f TezosClientEnv)
-> MorleyClientEnv -> f MorleyClientEnv)
-> ((Maybe String -> f (Maybe String))
-> TezosClientEnv -> f TezosClientEnv)
-> (Maybe String -> f (Maybe String))
-> MorleyClientEnv
-> f MorleyClientEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe String -> f (Maybe String))
-> TezosClientEnv -> f TezosClientEnv
Lens' TezosClientEnv (Maybe String)
tceMbTezosClientDataDirL
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 :: forall a. 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 =
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)) (String -> Expr
StringLit String
"On network"))
(Expr -> Expr -> Expr
Tasty.EQ (Expr -> Expr
Field Expr
NF) (String -> Expr
StringLit String
"On network"))
)
(Expr -> String -> Expr
Match (Expr -> Expr
Field (Int -> Expr
IntLit Int
0)) String
".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)) (String -> Expr
StringLit String
"On network"))
(Expr -> Expr -> Expr
Tasty.NE (Expr -> Expr
Field Expr
NF) (String -> Expr
StringLit String
"On network"))
)
(Expr -> String -> Expr
NoMatch (Expr -> Expr
Field (Int -> Expr
IntLit Int
0)) String
".On network.")