{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Test.Cardano.Ledger.Generic.MockChain where

import Cardano.Ledger.BaseTypes (BlocksMade (..), ShelleyBase)
import Cardano.Ledger.Shelley.Core
import Cardano.Ledger.Shelley.LedgerState (
  EpochState (..),
  LedgerState (..),
  NewEpochState (..),
  StashedAVVMAddresses,
  curPParamsEpochStateL,
 )
import Cardano.Ledger.Shelley.RewardUpdate (PulsingRewUpdate)
import Cardano.Ledger.Shelley.Rules (
  LedgerEnv,
  RupdEnv,
  ShelleyLEDGERS,
  ShelleyLedgersEnv (..),
  ShelleyLedgersEvent,
  ShelleyLedgersPredFailure,
  ShelleyTICK,
  ShelleyTickEvent,
  ShelleyTickPredFailure,
 )
import Cardano.Ledger.State
import Cardano.Slotting.Slot (EpochNo, SlotNo)
import Control.State.Transition (
  Embed (..),
  STS (..),
  TRC (..),
  judgmentContext,
  trans,
  (?!),
 )
import qualified Data.Map.Strict as Map
import Data.Maybe.Strict (StrictMaybe)
import Data.Sequence.Internal (Seq)
import Data.Sequence.Strict (StrictSeq (..), fromStrict)
import Data.TreeDiff (Expr, ToExpr (toExpr))
import GHC.Generics (Generic)
import Lens.Micro ((^.))
import NoThunks.Class (NoThunks, ThunkInfo, noThunks)
import Test.Cardano.Ledger.Generic.Functions (TotalAda (..))
import Test.Cardano.Ledger.Generic.Proof (Proof (..), Reflect)
import Test.Cardano.Ledger.Shelley.Era
import Test.Cardano.Ledger.Shelley.Utils (epochFromSlotNo)

-- ================================================

data MOCKCHAIN era -- This is a Testing only STS instance

type instance EraRule "MOCKCHAIN" era = MOCKCHAIN era

data MockChainFailure era
  = MockChainFromTickFailure !(ShelleyTickPredFailure era)
  | MockChainFromLedgersFailure !(ShelleyLedgersPredFailure era)
  | BlocksOutOfOrder
      !SlotNo -- The last applied block SlotNo
      !SlotNo -- The candidate block SlotNo
  deriving ((forall x. MockChainFailure era -> Rep (MockChainFailure era) x)
-> (forall x. Rep (MockChainFailure era) x -> MockChainFailure era)
-> Generic (MockChainFailure era)
forall x. Rep (MockChainFailure era) x -> MockChainFailure era
forall x. MockChainFailure era -> Rep (MockChainFailure era) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x. Rep (MockChainFailure era) x -> MockChainFailure era
forall era x. MockChainFailure era -> Rep (MockChainFailure era) x
$cfrom :: forall era x. MockChainFailure era -> Rep (MockChainFailure era) x
from :: forall x. MockChainFailure era -> Rep (MockChainFailure era) x
$cto :: forall era x. Rep (MockChainFailure era) x -> MockChainFailure era
to :: forall x. Rep (MockChainFailure era) x -> MockChainFailure era
Generic)

instance
  ( ToExpr (ShelleyTickPredFailure era)
  , ToExpr (PredicateFailure (EraRule "LEDGER" era))
  ) =>
  ToExpr (MockChainFailure era)

data MockChainEvent era
  = MockChainFromTickEvent !(ShelleyTickEvent era)
  | MockChainFromLedgersEvent !(ShelleyLedgersEvent era)

data MockBlock era = MockBlock
  { forall era. MockBlock era -> KeyHash 'StakePool
mbIssuer :: !(KeyHash 'StakePool)
  , forall era. MockBlock era -> SlotNo
mbSlot :: !SlotNo
  , forall era. MockBlock era -> StrictSeq (Tx era)
mbTrans :: !(StrictSeq (Tx era))
  }
  deriving ((forall x. MockBlock era -> Rep (MockBlock era) x)
-> (forall x. Rep (MockBlock era) x -> MockBlock era)
-> Generic (MockBlock era)
forall x. Rep (MockBlock era) x -> MockBlock era
forall x. MockBlock era -> Rep (MockBlock era) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x. Rep (MockBlock era) x -> MockBlock era
forall era x. MockBlock era -> Rep (MockBlock era) x
$cfrom :: forall era x. MockBlock era -> Rep (MockBlock era) x
from :: forall x. MockBlock era -> Rep (MockBlock era) x
$cto :: forall era x. Rep (MockBlock era) x -> MockBlock era
to :: forall x. Rep (MockBlock era) x -> MockBlock era
Generic)

data MockChainState era = MockChainState
  { forall era. MockChainState era -> NewEpochState era
mcsNes :: !(NewEpochState era)
  , forall era. MockChainState era -> NewEpochState era
mcsTickNes :: !(NewEpochState era)
  , forall era. MockChainState era -> SlotNo
mcsLastBlock :: !SlotNo
  , forall era. MockChainState era -> Int
mcsCount :: !Int -- Counts the blocks made
  }

deriving instance
  ( EraTxOut era
  , Eq (StashedAVVMAddresses era)
  , Eq (GovState era)
  , Eq (InstantStake era)
  , EraCertState era
  ) =>
  Eq (MockChainState era)

instance Show (MockChainState era) where
  show :: MockChainState era -> String
show (MockChainState NewEpochState era
nes NewEpochState era
_ SlotNo
slot Int
count) =
    Int -> String
forall a. Show a => a -> String
show Int
count String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SlotNo -> String
forall a. Show a => a -> String
show SlotNo
slot String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n  " String -> ShowS
forall a. [a] -> [a] -> [a]
++ BlocksMade -> String
forall a. Show a => a -> String
show (NewEpochState era -> BlocksMade
forall era. NewEpochState era -> BlocksMade
nesBcur NewEpochState era
nes)

instance Show (MockBlock era) where
  show :: MockBlock era -> String
show (MockBlock KeyHash 'StakePool
is SlotNo
sl StrictSeq (Tx era)
_) = KeyHash 'StakePool -> String
forall a. Show a => a -> String
show KeyHash 'StakePool
is String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SlotNo -> String
forall a. Show a => a -> String
show SlotNo
sl

instance (Reflect era, EraCertState era) => TotalAda (MockChainState era) where
  totalAda :: MockChainState era -> Coin
totalAda (MockChainState NewEpochState era
nes NewEpochState era
_ SlotNo
_ Int
_) = NewEpochState era -> Coin
forall t. TotalAda t => t -> Coin
totalAda NewEpochState era
nes

deriving instance Generic (MockChainState era)

instance (Era era, NoThunks (NewEpochState era)) => NoThunks (MockChainState era)

-- ======================================================================

instance
  ( EraGov era
  , STS (ShelleyTICK era)
  , State (EraRule "TICK" era) ~ NewEpochState era
  , Signal (EraRule "TICK" era) ~ SlotNo
  , Environment (EraRule "TICK" era) ~ ()
  , Embed (EraRule "TICK" era) (MOCKCHAIN era)
  , Signal (EraRule "LEDGERS" era) ~ Seq (Tx era)
  , Environment (EraRule "LEDGERS" era) ~ ShelleyLedgersEnv era
  , State (EraRule "LEDGERS" era) ~ LedgerState era
  , Embed (EraRule "LEDGERS" era) (MOCKCHAIN era)
  , Signal (EraRule "LEDGER" era) ~ Tx era
  , Environment (EraRule "LEDGER" era) ~ LedgerEnv era
  , State (EraRule "LEDGER" era) ~ LedgerState era
  , Eq (PredicateFailure (EraRule "LEDGER" era))
  , Show (PredicateFailure (EraRule "LEDGER" era))
  ) =>
  STS (MOCKCHAIN era)
  where
  type State (MOCKCHAIN era) = MockChainState era
  type Signal (MOCKCHAIN era) = (MockBlock era)
  type Environment (MOCKCHAIN era) = ()
  type BaseM (MOCKCHAIN era) = ShelleyBase
  type PredicateFailure (MOCKCHAIN era) = MockChainFailure era
  type Event (MOCKCHAIN era) = MockChainEvent era
  initialRules :: [InitialRule (MOCKCHAIN era)]
initialRules = [String -> F (Clause (MOCKCHAIN era) 'Initial) (MockChainState era)
forall a. HasCallStack => String -> a
error String
"INITIAL RULE CALLED IN MOCKCHAIN"]
  transitionRules :: [TransitionRule (MOCKCHAIN era)]
transitionRules = [TransitionRule (MOCKCHAIN era)
F (Clause (MOCKCHAIN era) 'Transition) (MockChainState era)
chainTransition]
    where
      chainTransition :: F (Clause (MOCKCHAIN era) 'Transition) (MockChainState era)
chainTransition = do
        TRC (Environment (MOCKCHAIN era)
_, MockChainState NewEpochState era
nes NewEpochState era
_ SlotNo
lastSlot Int
count, MockBlock KeyHash 'StakePool
issuer SlotNo
slot StrictSeq (Tx era)
txs) <- Rule
  (MOCKCHAIN era)
  'Transition
  (RuleContext 'Transition (MOCKCHAIN era))
F (Clause (MOCKCHAIN era) 'Transition) (TRC (MOCKCHAIN era))
forall sts (rtype :: RuleType).
Rule sts rtype (RuleContext rtype sts)
judgmentContext
        SlotNo
lastSlot SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
< SlotNo
slot Bool
-> PredicateFailure (MOCKCHAIN era)
-> Rule (MOCKCHAIN era) 'Transition ()
forall sts (ctx :: RuleType).
Bool -> PredicateFailure sts -> Rule sts ctx ()
?! SlotNo -> SlotNo -> MockChainFailure era
forall era. SlotNo -> SlotNo -> MockChainFailure era
BlocksOutOfOrder SlotNo
lastSlot SlotNo
slot

        NewEpochState era
nes' <- forall sub super (rtype :: RuleType).
Embed sub super =>
RuleContext rtype sub -> Rule super rtype (State sub)
trans @(EraRule "TICK" era) (RuleContext 'Transition (EraRule "TICK" era)
 -> Rule (MOCKCHAIN era) 'Transition (State (EraRule "TICK" era)))
-> RuleContext 'Transition (EraRule "TICK" era)
-> Rule (MOCKCHAIN era) 'Transition (State (EraRule "TICK" era))
forall a b. (a -> b) -> a -> b
$ (Environment (EraRule "TICK" era), State (EraRule "TICK" era),
 Signal (EraRule "TICK" era))
-> TRC (EraRule "TICK" era)
forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC ((), NewEpochState era
State (EraRule "TICK" era)
nes, SlotNo
Signal (EraRule "TICK" era)
slot)

        let NewEpochState EpochNo
_ BlocksMade
_ (BlocksMade Map (KeyHash 'StakePool) Natural
current) EpochState era
epochState StrictMaybe PulsingRewUpdate
_ PoolDistr
_ StashedAVVMAddresses era
_ = NewEpochState era
nes'
            EpochState ChainAccountState
account LedgerState era
ledgerState SnapShots
_ NonMyopic
_ = EpochState era
epochState
            pparams :: PParams era
pparams = EpochState era
epochState EpochState era
-> Getting (PParams era) (EpochState era) (PParams era)
-> PParams era
forall s a. s -> Getting a s a -> a
^. Getting (PParams era) (EpochState era) (PParams era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
curPParamsEpochStateL

        let newblocksmade :: BlocksMade
newblocksmade = Map (KeyHash 'StakePool) Natural -> BlocksMade
BlocksMade ((Natural -> Natural -> Natural)
-> Map (KeyHash 'StakePool) Natural
-> Map (KeyHash 'StakePool) Natural
-> Map (KeyHash 'StakePool) Natural
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
(+) Map (KeyHash 'StakePool) Natural
current (KeyHash 'StakePool -> Natural -> Map (KeyHash 'StakePool) Natural
forall k a. k -> a -> Map k a
Map.singleton KeyHash 'StakePool
issuer Natural
1))

        LedgerState era
newledgerState <-
          forall sub super (rtype :: RuleType).
Embed sub super =>
RuleContext rtype sub -> Rule super rtype (State sub)
trans @(EraRule "LEDGERS" era) (RuleContext 'Transition (EraRule "LEDGERS" era)
 -> Rule
      (MOCKCHAIN era) 'Transition (State (EraRule "LEDGERS" era)))
-> RuleContext 'Transition (EraRule "LEDGERS" era)
-> Rule (MOCKCHAIN era) 'Transition (State (EraRule "LEDGERS" era))
forall a b. (a -> b) -> a -> b
$
            (Environment (EraRule "LEDGERS" era),
 State (EraRule "LEDGERS" era), Signal (EraRule "LEDGERS" era))
-> TRC (EraRule "LEDGERS" era)
forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC (SlotNo
-> EpochNo
-> PParams era
-> ChainAccountState
-> ShelleyLedgersEnv era
forall era.
SlotNo
-> EpochNo
-> PParams era
-> ChainAccountState
-> ShelleyLedgersEnv era
LedgersEnv SlotNo
slot (SlotNo -> EpochNo
epochFromSlotNo SlotNo
slot) PParams era
pparams ChainAccountState
account, State (EraRule "LEDGERS" era)
LedgerState era
ledgerState, StrictSeq (Tx era) -> Seq (Tx era)
forall a. StrictSeq a -> Seq a
fromStrict StrictSeq (Tx era)
txs)

        let newEpochstate :: EpochState era
newEpochstate = EpochState era
epochState {esLState = newledgerState}
            newNewEpochState :: NewEpochState era
newNewEpochState = NewEpochState era
nes' {nesEs = newEpochstate, nesBcur = newblocksmade}

        MockChainState era
-> F (Clause (MOCKCHAIN era) 'Transition) (MockChainState era)
forall a. a -> F (Clause (MOCKCHAIN era) 'Transition) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NewEpochState era
-> NewEpochState era -> SlotNo -> Int -> MockChainState era
forall era.
NewEpochState era
-> NewEpochState era -> SlotNo -> Int -> MockChainState era
MockChainState NewEpochState era
newNewEpochState NewEpochState era
nes' SlotNo
slot (Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1))

-- ===========================
-- Embed instances

instance
  ( STS (ShelleyTICK era)
  , Signal (EraRule "RUPD" era) ~ SlotNo
  , State (EraRule "RUPD" era) ~ StrictMaybe PulsingRewUpdate
  , Environment (EraRule "RUPD" era) ~ RupdEnv era
  , State (EraRule "NEWEPOCH" era) ~ NewEpochState era
  , Signal (EraRule "NEWEPOCH" era) ~ EpochNo
  , State (EraRule "NEWEPOCH" era) ~ NewEpochState era
  , Environment (EraRule "NEWEPOCH" era) ~ ()
  ) =>
  Embed (ShelleyTICK era) (MOCKCHAIN era)
  where
  wrapFailed :: PredicateFailure (ShelleyTICK era)
-> PredicateFailure (MOCKCHAIN era)
wrapFailed = PredicateFailure (ShelleyTICK era)
-> PredicateFailure (MOCKCHAIN era)
ShelleyTickPredFailure era -> MockChainFailure era
forall era. ShelleyTickPredFailure era -> MockChainFailure era
MockChainFromTickFailure
  wrapEvent :: Event (ShelleyTICK era) -> Event (MOCKCHAIN era)
wrapEvent = Event (ShelleyTICK era) -> Event (MOCKCHAIN era)
ShelleyTickEvent era -> MockChainEvent era
forall era. ShelleyTickEvent era -> MockChainEvent era
MockChainFromTickEvent

instance
  ( STS (ShelleyLEDGERS era)
  , State (EraRule "LEDGER" era) ~ LedgerState era
  , Environment (EraRule "LEDGER" era) ~ LedgerEnv era
  , Signal (EraRule "LEDGER" era) ~ Tx era
  ) =>
  Embed (ShelleyLEDGERS era) (MOCKCHAIN era)
  where
  wrapFailed :: PredicateFailure (ShelleyLEDGERS era)
-> PredicateFailure (MOCKCHAIN era)
wrapFailed = PredicateFailure (ShelleyLEDGERS era)
-> PredicateFailure (MOCKCHAIN era)
ShelleyLedgersPredFailure era -> MockChainFailure era
forall era. ShelleyLedgersPredFailure era -> MockChainFailure era
MockChainFromLedgersFailure
  wrapEvent :: Event (ShelleyLEDGERS era) -> Event (MOCKCHAIN era)
wrapEvent = Event (ShelleyLEDGERS era) -> Event (MOCKCHAIN era)
ShelleyLedgersEvent era -> MockChainEvent era
forall era. ShelleyLedgersEvent era -> MockChainEvent era
MockChainFromLedgersEvent

-- ================================================================

deriving instance
  (Show (ShelleyTickEvent era), Show (ShelleyLedgersEvent era)) => Show (MockChainEvent era)

deriving instance
  (Eq (ShelleyTickEvent era), Eq (ShelleyLedgersEvent era)) => Eq (MockChainEvent era)

deriving instance
  (Show (ShelleyTickPredFailure era), Show (ShelleyLedgersPredFailure era)) =>
  Show (MockChainFailure era)

deriving instance
  (Eq (ShelleyTickPredFailure era), Eq (ShelleyLedgersPredFailure era)) => Eq (MockChainFailure era)

ppMockChainState ::
  (Reflect era, ShelleyEraTest era) =>
  MockChainState era ->
  Expr
ppMockChainState :: forall era.
(Reflect era, ShelleyEraTest era) =>
MockChainState era -> Expr
ppMockChainState = MockChainState era -> Expr
forall a. ToExpr a => a -> Expr
toExpr

instance (Reflect era, ShelleyEraTest era) => ToExpr (MockChainState era)

ppMockBlock :: ToExpr (StrictSeq (Tx era)) => MockBlock era -> Expr
ppMockBlock :: forall era. ToExpr (StrictSeq (Tx era)) => MockBlock era -> Expr
ppMockBlock = MockBlock era -> Expr
forall a. ToExpr a => a -> Expr
toExpr

instance ToExpr (StrictSeq (Tx era)) => ToExpr (MockBlock era)

ppMockChainFailure :: ToExpr (MockChainFailure era) => MockChainFailure era -> Expr
ppMockChainFailure :: forall era.
ToExpr (MockChainFailure era) =>
MockChainFailure era -> Expr
ppMockChainFailure = MockChainFailure era -> Expr
forall a. ToExpr a => a -> Expr
toExpr

noThunksGen :: Proof era -> MockChainState era -> IO (Maybe ThunkInfo)
noThunksGen :: forall era. Proof era -> MockChainState era -> IO (Maybe ThunkInfo)
noThunksGen Proof era
Conway = Context -> MockChainState era -> IO (Maybe ThunkInfo)
forall a. NoThunks a => Context -> a -> IO (Maybe ThunkInfo)
noThunks []
noThunksGen Proof era
Babbage = Context -> MockChainState era -> IO (Maybe ThunkInfo)
forall a. NoThunks a => Context -> a -> IO (Maybe ThunkInfo)
noThunks []
noThunksGen Proof era
Alonzo = Context -> MockChainState era -> IO (Maybe ThunkInfo)
forall a. NoThunks a => Context -> a -> IO (Maybe ThunkInfo)
noThunks []
noThunksGen Proof era
Mary = Context -> MockChainState era -> IO (Maybe ThunkInfo)
forall a. NoThunks a => Context -> a -> IO (Maybe ThunkInfo)
noThunks []
noThunksGen Proof era
Allegra = Context -> MockChainState era -> IO (Maybe ThunkInfo)
forall a. NoThunks a => Context -> a -> IO (Maybe ThunkInfo)
noThunks []
noThunksGen Proof era
Shelley = Context -> MockChainState era -> IO (Maybe ThunkInfo)
forall a. NoThunks a => Context -> a -> IO (Maybe ThunkInfo)
noThunks []