-- SPDX-FileCopyrightText: 2021 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA
{-# LANGUAGE InstanceSigs #-}

-- | This module is the internal implementation of "Test.Cleveland.Tasty".
module Test.Cleveland.Tasty.Internal
  (
  -- * Main
    clevelandMain
  , clevelandMainWithIngredients
  , clevelandIngredients
  , loadTastyEnv

  -- * Test cases
  , testScenario
  , testScenarioOnEmulator
  , testScenarioOnNetwork

  , whenNetworkEnabled

  -- * Reading/setting options
  , modifyNetworkEnv
  , setAliasPrefix

  -- * Internals
  , 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)

-- | A name that we use to tag all tests that run on the network.
--
-- We use this in a tasty @--pattern@ in .gitlab-ci.yml to run only network tests.
onNetworkTag :: TestName
onNetworkTag :: TestName
onNetworkTag = TestName
"On network"

-- | Create a tasty test case from a 'Scenario'.
--
-- This will create a test tree with 2 tests:
-- one that runs the 'Scenario' on the "Morley.Michelson.Runtime" emulator,
-- and another that runs it on a real Tezos network.
--
-- The network config is read from the command line/environment variables.
-- Use @--help@ to see the available options.
--
-- If a 'TestTree' contains many tests scheduled to run on a real Tezos network,
-- those tests will be run sequentially.
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')
    ]

-- | Create a tasty test case from an emulated 'Scenario'.
--
-- This will create a test tree with 1 test,
-- which will run the 'Scenario' on the "Morley.Michelson.Runtime" emulator.
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') ]

-- | Create a tasty test case from a 'Scenario'.
--
-- This will create a test tree with 1 test,
-- which will run the 'Scenario' on real Tezos network.
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

  -- If a 'RunOnNetwork' test is created somewhere in a suite,
  -- these options will be automatically added to tasty's @--help@.
  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

-- | A global mutex to ensure only one cleveland test is executed at a time.
--
-- TODO [#399]: Remove this when is done.
-- https://gitlab.com/morley-framework/morley/-/issues/399
--
-- See also: https://wiki.haskell.org/Top_level_mutable_state
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 #-}

----------------------------------------------------------------------------
-- Main
----------------------------------------------------------------------------

-- | Similar to @tasty@ @defaultMain@, but also preloads 'TastyEnv' and
-- registers the necessary command line options/environment variables to configure
-- "Test.Cleveland".
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

-- | Similar to 'defaultMainWithIngredients', but also preloads 'TastyEnv' and
-- registers the necessary command line options/environment variables to configure
-- "Test.Cleveland".
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)

-- | A list with all the ingredients necessary to configure "Test.Cleveland".
--
-- Note: If a test suite uses 'Scenario', the relevant command line options
-- will be automatically added to tasty's @--help@.
--
-- However, if a test suite intends to not use those functions, and use 'whenNetworkEnabled'
-- only, then the CLI options need to be registered manually by using this ingredient
-- (or 'clevelandMain'/'clevelandMainWithIngredients').
clevelandIngredients :: [Ingredient]
clevelandIngredients :: [Ingredient]
clevelandIngredients =
  [ [OptionDescription] -> Ingredient
includingOptions [OptionDescription]
clevelandOptions
  ]

----------------------------------------------------------------------------
-- Reading/setting options
----------------------------------------------------------------------------

-- | Creates a 'TastyEnv' from the passed command line/environment options.
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
      -- If 'TastyEnv' has been already loaded and cached, use it.
      TastyEnvOpt (Just TastyEnv
tastyEnv) -> TastyEnv
tastyEnv
      -- Otherwise, load it.
      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
            }

-- | Heuristics to check whether we are running within CI.
-- Check the respective env variable which is usually set in all CIs.
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 #-}

-- | Runs some tests only when network tests are enabled
-- (i.e., when running in the CI or when @--cleveland-mode all@).
--
-- Do not use this with a cleveland test (e.g. with 'testScenario'), as it will
-- lead to a [deadlock](https://gitlab.com/morley-framework/morley/-/issues/728).
-- This is only suitable for HUnit/Hspec/Hedgehog/etc tests.
--
-- Example usage:
--
-- > test :: TestTree
-- > test =
-- >   whenNetworkEnabled $ \withEnv ->
-- >     testCase "a test name" $
-- >       withEnv $ \env ->
-- >         runMorleyClientM (neMorleyClientEnv env) $ do
-- >           ...
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 ]

-- | Modifies the 'NetworkEnv' for all the tests in the given test tree.
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

-- | Overrides the alias prefix (parsed from @--cleveland-alias-prefix@ or @TASTY_CLEVELAND_ALIAS_PREFIX@)
-- for all the tests in the given test 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

----------------------------------------------------------------------------
-- Preload TastyEnv
----------------------------------------------------------------------------

-- | A pre-loaded 'TastyEnv'.
--
-- It's not an actual command line option, we use it
-- so we can load a 'TastyEnv' once, and then cache it
-- alongside the other options in tasty's 'OptionSet'.
--
-- Kiiiind of a hack, but it works :D
--
-- It is purposefully never registered as a CLI option
-- (e.g. using 'Test.Tasty.Providers.testOptions' or 'Test.Tasty.includingOptions')
-- to make sure it doesn't appear in tasty's @--help@.
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

-- | Pre-load 'TastyEnv' from the passed command line/environment options,
-- and store it in tasty's 'OptionSet' to make it available to
-- all tests within the test tree.
--
-- Creating a 'NetworkEnv' is a relatively expensive operation, when executed hundreds of times.
-- This function guarantees that only one 'TastyEnv' is created for this test tree, and
-- 'TastyEnv' will, in turn, guarantee that only one 'NetworkEnv' is created while the tests are running.
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

----------------------------------------------------------------------------
-- TastyEnv
----------------------------------------------------------------------------

-- | This action will:
--
-- 1. Enter a critical section
-- 2. Either:
--
--     * Create a 'NetworkEnv' and cache it, if it's the first time being evaluated.
--     * Or reuse an existing cached 'NetworkEnv' otherwise.
--
-- 3. Pass it to the given @networkEnv -> IO a@ function.
-- 4. Exit the critical section
--
-- This ensures:
--
-- * 'NetworkEnv' is only created once (it's a relatively expensive operation).
-- * tests that use 'NetworkEnv' are run sequentially
--    (see #399, https://gitlab.com/morley-framework/morley/-/issues/399)
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
    -- Note: Using `unsafePerformIO` here is the recommended workaround for
    -- not being able to use IO inside `askOption`/`AskOptions`.
    -- https://github.com/feuerbach/tasty/issues/228
    --
    -- We're only using it here to initialize an 'MVar', so it /should/ be safe 🤞
    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))

-- | A thread-safe, lazy, write-once cache.
--
-- >>> action <- memoize (putStrLn "hello" $> 3)
-- >>> action
-- hello
-- 3
-- >>> action
-- 3
memoize :: forall a. IO a -> IO (IO a)
memoize :: IO a -> IO (IO a)
memoize IO a
action = do
  -- The implementation is very similar to 'once' from @io-memoize@.
  -- https://hackage.haskell.org/package/io-memoize-1.1.1.0/docs/System-IO-Memoize.html
  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

----------------------------------------------------------------------------
-- Custom @TestPattern@s
----------------------------------------------------------------------------

-- | Helper that checks which environment variables / command line options are set,
-- and filters TestTree to run tests according to the decision table
-- at the top of this module.
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

-- | Pattern that enables only network tests, all emulator tests will be disabled.
--
-- Tasty pattern eDSL version of
-- "$1 == \"On network\" || $NF == \"On network\" || $0 ~ /.On network./"
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.")

-- | Pattern that disables all network tests, all other tests will be enabled.
--
-- Tasty pattern eDSL version of
-- "$1 != \"On network\" && $NF != \"On network\" && $0 !~ /.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.")