{-# 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 GHC.Generics (Generic)
import Lens.Micro ((^.))
import NoThunks.Class (NoThunks, ThunkInfo, noThunks)
import Test.Cardano.Ledger.Generic.Functions (TotalAda (..))
import Test.Cardano.Ledger.Generic.PrettyCore (
  PDoc,
  PrettyA (..),
  pcKeyHash,
  pcNewEpochState,
  pcSlotNo,
  ppInt,
  ppRecord,
  ppShelleyLedgersPredFailure,
  ppTickPredicateFailure,
 )
import Test.Cardano.Ledger.Generic.Proof (Proof (..), Reflect (reify))
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

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))
  }

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 =>
  MockChainState era ->
  PDoc
ppMockChainState :: forall era. Reflect era => MockChainState era -> PDoc
ppMockChainState (MockChainState NewEpochState era
nes NewEpochState era
_ SlotNo
sl Int
count) =
  Text -> [(Text, PDoc)] -> PDoc
ppRecord
    Text
"MockChainState"
    [ (Text
"NewEpochState", Proof era -> NewEpochState era -> PDoc
forall era. Reflect era => Proof era -> NewEpochState era -> PDoc
pcNewEpochState Proof era
forall era. Reflect era => Proof era
reify NewEpochState era
nes)
    , (Text
"LastBlock", SlotNo -> PDoc
pcSlotNo SlotNo
sl)
    , (Text
"Count", Int -> PDoc
forall a. Int -> Doc a
ppInt Int
count)
    ]

instance Reflect era => PrettyA (MockChainState era) where
  prettyA :: MockChainState era -> PDoc
prettyA = MockChainState era -> PDoc
forall era. Reflect era => MockChainState era -> PDoc
ppMockChainState

ppMockBlock :: MockBlock era -> PDoc
ppMockBlock :: forall era. MockBlock era -> PDoc
ppMockBlock (MockBlock KeyHash 'StakePool
iss SlotNo
sl StrictSeq (Tx era)
txs) =
  Text -> [(Text, PDoc)] -> PDoc
ppRecord
    Text
"MockBock"
    [ (Text
"Issuer", KeyHash 'StakePool -> PDoc
forall (discriminator :: KeyRole). KeyHash discriminator -> PDoc
pcKeyHash KeyHash 'StakePool
iss)
    , (Text
"Slot", SlotNo -> PDoc
pcSlotNo SlotNo
sl)
    , (Text
"Transactions", Int -> PDoc
forall a. Int -> Doc a
ppInt (StrictSeq (Tx era) -> Int
forall a. StrictSeq a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length StrictSeq (Tx era)
txs))
    ]

instance PrettyA (MockBlock era) where prettyA :: MockBlock era -> PDoc
prettyA = MockBlock era -> PDoc
forall era. MockBlock era -> PDoc
ppMockBlock

ppMockChainFailure :: Reflect era => Proof era -> MockChainFailure era -> PDoc
ppMockChainFailure :: forall era.
Reflect era =>
Proof era -> MockChainFailure era -> PDoc
ppMockChainFailure Proof era
proof MockChainFailure era
x = case Proof era
proof of
  Proof era
Conway -> MockChainFailure era -> PDoc
help MockChainFailure era
x
  Proof era
Babbage -> MockChainFailure era -> PDoc
help MockChainFailure era
x
  Proof era
Alonzo -> MockChainFailure era -> PDoc
help MockChainFailure era
x
  Proof era
Mary -> MockChainFailure era -> PDoc
help MockChainFailure era
x
  Proof era
Allegra -> MockChainFailure era -> PDoc
help MockChainFailure era
x
  Proof era
Shelley -> MockChainFailure era -> PDoc
help MockChainFailure era
x
  where
    help :: MockChainFailure era -> PDoc
help (MockChainFromTickFailure ShelleyTickPredFailure era
y) = ShelleyTickPredFailure era -> PDoc
forall era. Reflect era => ShelleyTickPredFailure era -> PDoc
ppTickPredicateFailure ShelleyTickPredFailure era
y
    help (MockChainFromLedgersFailure ShelleyLedgersPredFailure era
y) = Proof era -> ShelleyLedgersPredFailure era -> PDoc
forall era.
Reflect era =>
Proof era -> ShelleyLedgersPredFailure era -> PDoc
ppShelleyLedgersPredFailure Proof era
proof ShelleyLedgersPredFailure era
y
    help (BlocksOutOfOrder SlotNo
lastslot SlotNo
cand) =
      Text -> [(Text, PDoc)] -> PDoc
ppRecord
        Text
"BlocksOutOfOrder"
        [ (Text
"Last applied block", SlotNo -> PDoc
pcSlotNo SlotNo
lastslot)
        , (Text
"Candidate block", SlotNo -> PDoc
pcSlotNo SlotNo
cand)
        ]

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 []