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

module Test.Cleveland.Internal.Scenario
  ( Scenario(..)
  , scenario
  , scenarioEmulated
  , withInitialNow
  , withInitialLevel
  ) where

import Morley.Tezos.Core qualified as TC
import Test.Cleveland.Internal.Abstract
import Test.Cleveland.Internal.Pure

-- | A type representing a finalized scenario
data Scenario m where
  ScenarioCleveland :: ClevelandT m () -> Scenario m
  ScenarioEmulated :: EmulatedT PureM () -> Scenario PureM

-- | Finalize a generic cleveland scenario.
scenario :: ClevelandT m () -> Scenario m
scenario :: ClevelandT m () -> Scenario m
scenario = ClevelandT m () -> Scenario m
forall (m :: * -> *). ClevelandT m () -> Scenario m
ScenarioCleveland

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

withModifiedState
  :: (PureState -> PureState)
  -> Scenario PureM
  -> Scenario PureM
withModifiedState :: (PureState -> PureState) -> Scenario PureM -> Scenario PureM
withModifiedState PureState -> PureState
modfn = \case
  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
  ScenarioCleveland ClevelandT PureM ()
cleveland ->
    ClevelandT PureM () -> Scenario PureM
forall (m :: * -> *). ClevelandT m () -> Scenario m
ScenarioCleveland (ClevelandT PureM () -> Scenario PureM)
-> ClevelandT PureM () -> Scenario PureM
forall a b. (a -> b) -> a -> b
$ PureM () -> ClevelandT 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) ClevelandT PureM () -> ClevelandT PureM () -> ClevelandT PureM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ClevelandT PureM ()
cleveland

-- | Use with an emulated 'Scenario' to configure the initial @now@ value in tests.
--
-- Example :
-- > withInitialNow (Timestamp 10000000) $ testScenarioOnEmulator "Testname" $ scenarioEmulated $ tests
-- > withInitialNow (Timestamp 10000000) $ testScenarioOnEmulator "Testname" $ 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