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

module Test.Cleveland.Internal.Scenario
  ( Scenario
  , Scenario'(..)
  , MonadScenario(..)
  , scenarioEmulated
  , scenarioNetwork
  , withInitialNow
  , withInitialLevel
  , withMinBlockTime
  , withChainId
  ) 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 :: ClevelandT PureM () -> Scenario' PureM
scenario = EmulatedT PureM () -> Scenario' PureM
ScenarioEmulated (EmulatedT PureM () -> Scenario' PureM)
-> (ClevelandT PureM () -> EmulatedT PureM ())
-> ClevelandT PureM ()
-> Scenario' PureM
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EmulatedCaps PureM -> ClevelandCaps PureM)
-> ClevelandT PureM () -> EmulatedT PureM ()
forall r' r (m :: * -> *) a.
(r' -> r) -> ReaderT r m a -> ReaderT r' m a
withReaderT (Getting
  (ClevelandCaps PureM) (EmulatedCaps PureM) (ClevelandCaps PureM)
-> EmulatedCaps PureM -> ClevelandCaps PureM
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
  (ClevelandCaps PureM) (EmulatedCaps PureM) (ClevelandCaps PureM)
forall caps.
HasClevelandCaps caps =>
Lens' caps (ClevelandCaps (ClevelandBaseMonad caps))
clevelandCapsL)

instance MonadScenario ClientM where
  scenario :: ClevelandT ClientM () -> Scenario' ClientM
scenario = NetworkT ClientM () -> Scenario' ClientM
ScenarioNetwork (NetworkT ClientM () -> Scenario' ClientM)
-> (ClevelandT ClientM () -> NetworkT ClientM ())
-> ClevelandT ClientM ()
-> Scenario' ClientM
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NetworkCaps ClientM -> ClevelandCaps ClientM)
-> ClevelandT ClientM () -> NetworkT ClientM ()
forall r' r (m :: * -> *) a.
(r' -> r) -> ReaderT r m a -> ReaderT r' m a
withReaderT (Getting
  (ClevelandCaps ClientM)
  (NetworkCaps ClientM)
  (ClevelandCaps ClientM)
-> NetworkCaps ClientM -> ClevelandCaps ClientM
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
  (ClevelandCaps ClientM)
  (NetworkCaps ClientM)
  (ClevelandCaps ClientM)
forall caps.
HasClevelandCaps caps =>
Lens' caps (ClevelandCaps (ClevelandBaseMonad caps))
clevelandCapsL)

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

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

withModifiedState
  :: (PureState -> PureState)
  -> Scenario' PureM
  -> Scenario' PureM
withModifiedState :: (PureState -> PureState) -> Scenario' PureM -> Scenario' PureM
withModifiedState PureState -> PureState
modfn (ScenarioEmulated EmulatedT PureM ()
emulated) =
  EmulatedT PureM () -> Scenario' PureM
ScenarioEmulated (EmulatedT PureM () -> Scenario' PureM)
-> EmulatedT PureM () -> Scenario' PureM
forall a b. (a -> b) -> a -> b
$ PureM () -> EmulatedT PureM ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ((PureState -> PureState) -> PureM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify PureState -> PureState
modfn) EmulatedT PureM () -> EmulatedT PureM () -> EmulatedT PureM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> EmulatedT PureM ()
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 :: Timestamp -> Scenario' PureM -> Scenario' PureM
withInitialNow = (PureState -> PureState) -> Scenario' PureM -> Scenario' PureM
withModifiedState ((PureState -> PureState) -> Scenario' PureM -> Scenario' PureM)
-> (Timestamp -> PureState -> PureState)
-> Timestamp
-> Scenario' PureM
-> Scenario' PureM
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASetter PureState PureState Timestamp Timestamp
-> Timestamp -> PureState -> PureState
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter PureState PureState Timestamp Timestamp
Lens' PureState Timestamp
psNow

-- | Similar to 'withInitialNow' but for the initial level
withInitialLevel
  :: Natural
  -> Scenario' PureM
  -> Scenario' PureM
withInitialLevel :: Natural -> Scenario' PureM -> Scenario' PureM
withInitialLevel = (PureState -> PureState) -> Scenario' PureM -> Scenario' PureM
withModifiedState ((PureState -> PureState) -> Scenario' PureM -> Scenario' PureM)
-> (Natural -> PureState -> PureState)
-> Natural
-> Scenario' PureM
-> Scenario' PureM
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASetter PureState PureState Natural Natural
-> Natural -> PureState -> PureState
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter PureState PureState Natural Natural
Lens' PureState Natural
psLevel

-- | Similar to 'withInitialNow' but for the @MINIMAL_BLOCK_DELAY@ protocol constant.
withMinBlockTime
  :: Natural
  -> Scenario' PureM
  -> Scenario' PureM
withMinBlockTime :: Natural -> Scenario' PureM -> Scenario' PureM
withMinBlockTime = (PureState -> PureState) -> Scenario' PureM -> Scenario' PureM
withModifiedState ((PureState -> PureState) -> Scenario' PureM -> Scenario' PureM)
-> (Natural -> PureState -> PureState)
-> Natural
-> Scenario' PureM
-> Scenario' PureM
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASetter PureState PureState Natural Natural
-> Natural -> PureState -> PureState
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter PureState PureState Natural Natural
Lens' PureState Natural
psMinBlockTime

-- | Similar to 'withInitialNow' but for the chain id
withChainId
  :: TC.ChainId
  -> Scenario' PureM
  -> Scenario' PureM
withChainId :: ChainId -> Scenario' PureM -> Scenario' PureM
withChainId = (PureState -> PureState) -> Scenario' PureM -> Scenario' PureM
withModifiedState ((PureState -> PureState) -> Scenario' PureM -> Scenario' PureM)
-> (ChainId -> PureState -> PureState)
-> ChainId
-> Scenario' PureM
-> Scenario' PureM
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASetter PureState PureState ChainId ChainId
-> ChainId -> PureState -> PureState
forall s t a b. ASetter s t a b -> b -> s -> t
set ((GState -> Identity GState) -> PureState -> Identity PureState
Lens' PureState GState
psGState ((GState -> Identity GState) -> PureState -> Identity PureState)
-> ((ChainId -> Identity ChainId) -> GState -> Identity GState)
-> ASetter PureState PureState ChainId ChainId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ChainId -> Identity ChainId) -> GState -> Identity GState
Lens' GState ChainId
gsChainIdL)