Scenario.hs

-- SPDX-FileCopyrightText: 2021 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA

{-# OPTIONS_HADDOCK not-home #-}

module Test.Cleveland.Internal.Scenario
  ( module Test.Cleveland.Internal.Scenario
  ) where

import Control.Monad.Reader (withReaderT)

import Morley.Michelson.Runtime.GState (gsChainIdL)
import Morley.Tezos.Core qualified as TC
import Test.Cleveland.Internal.Abstract
import Test.Cleveland.Internal.Client
import Test.Cleveland.Internal.Pure

-- | A convenience type synonym for `Scenario'` that has 'MonadScenario'
-- constraint baked in.
type Scenario m = MonadScenario m => Scenario' m

-- | A type representing a finalized scenario. Usually, when using this type
-- with a polymorphic argument, an additional 'MonadScenario' constraint on the
-- argument is required.
--
-- To avoid annotating with 'MonadScenario' everywhere, consider using
-- 'Scenario' instead when possible.
data Scenario' m where
  ScenarioEmulated :: EmulatedT PureM () -> Scenario' PureM
  ScenarioNetwork :: NetworkT ClientM () -> Scenario' ClientM

-- | Typeclass for base monads that can implement a scenario.
class MonadFail m => MonadScenario m where
  -- | Finalize a generic cleveland scenario.
  scenario :: ClevelandT m () -> Scenario' m

instance MonadScenario PureM where
  scenario = ScenarioEmulated . withReaderT (view clevelandCapsL)

instance MonadScenario ClientM where
  scenario = ScenarioNetwork . withReaderT (view clevelandCapsL)

-- | Finalize a scenario that needs emulator-only features.
scenarioEmulated :: EmulatedT PureM () -> Scenario' PureM
scenarioEmulated = ScenarioEmulated

-- | Finalize a scenario that needs network-only features.
scenarioNetwork :: NetworkT ClientM () -> Scenario' ClientM
scenarioNetwork = ScenarioNetwork

withModifiedState
  :: (PureState -> PureState)
  -> Scenario' PureM
  -> Scenario' PureM
withModifiedState modfn (ScenarioEmulated emulated) =
  ScenarioEmulated $ lift (modify modfn) >> emulated

-- | Use with an emulated 'Scenario' to configure the initial @now@ value in tests.
--
-- Example :
-- > testScenarioOnEmulator "Testname" $ withInitialNow (Timestamp 10000000) $ scenarioEmulated $ tests
-- > testScenarioOnEmulator "Testname" $ withInitialNow (Timestamp 10000000) $ scenario $ tests
withInitialNow
  :: TC.Timestamp
  -> Scenario' PureM
  -> Scenario' PureM
withInitialNow = withModifiedState . set psNow

-- | Similar to 'withInitialNow' but for the initial level
withInitialLevel
  :: Natural
  -> Scenario' PureM
  -> Scenario' PureM
withInitialLevel = withModifiedState . set psLevel

-- | Similar to 'withInitialNow' but for the @MINIMAL_BLOCK_DELAY@ protocol constant.
withMinBlockTime
  :: Natural
  -> Scenario' PureM
  -> Scenario' PureM
withMinBlockTime = withModifiedState . set psMinBlockTime

-- | Similar to 'withInitialNow' but for the chain id
withChainId
  :: TC.ChainId
  -> Scenario' PureM
  -> Scenario' PureM
withChainId = withModifiedState . set (psGState . gsChainIdL)