{-# 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.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 (MockChainState era)

instance Show (MockChainState era) where
  show :: MockChainState era -> String
show (MockChainState NewEpochState era
nes NewEpochState era
_ SlotNo
slot Int
count) =
    forall a. Show a => a -> String
show Int
count forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show SlotNo
slot forall a. [a] -> [a] -> [a]
++ String
"\n  " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (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)
_) = forall a. Show a => a -> String
show KeyHash 'StakePool
is forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show SlotNo
sl

instance Reflect era => TotalAda (MockChainState era) where
  totalAda :: MockChainState era -> Coin
totalAda (MockChainState NewEpochState era
nes NewEpochState era
_ SlotNo
_ Int
_) = 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 = [forall a. HasCallStack => String -> a
error String
"INITIAL RULE CALLED IN MOCKCHAIN"]
  transitionRules :: [TransitionRule (MOCKCHAIN era)]
transitionRules = [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) <- forall sts (rtype :: RuleType).
Rule sts rtype (RuleContext rtype sts)
judgmentContext
        SlotNo
lastSlot forall a. Ord a => a -> a -> Bool
< SlotNo
slot forall sts (ctx :: RuleType).
Bool -> PredicateFailure sts -> Rule sts ctx ()
?! 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) forall a b. (a -> b) -> a -> b
$ forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC ((), NewEpochState era
nes, SlotNo
slot)

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

        let newblocksmade :: BlocksMade
newblocksmade = Map (KeyHash 'StakePool) Natural -> BlocksMade
BlocksMade (forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith forall a. Num a => a -> a -> a
(+) Map (KeyHash 'StakePool) Natural
current (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) forall a b. (a -> b) -> a -> b
$
            forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC (forall era.
SlotNo
-> EpochNo -> PParams era -> AccountState -> ShelleyLedgersEnv era
LedgersEnv SlotNo
slot (SlotNo -> EpochNo
epochFromSlotNo SlotNo
slot) PParams era
pparams AccountState
account, LedgerState era
ledgerState, forall a. StrictSeq a -> Seq a
fromStrict StrictSeq (Tx era)
txs)

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

        forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall era.
NewEpochState era
-> NewEpochState era -> SlotNo -> Int -> MockChainState era
MockChainState NewEpochState era
newNewEpochState NewEpochState era
nes' SlotNo
slot (Int
count 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 = forall era. ShelleyTickPredFailure era -> MockChainFailure era
MockChainFromTickFailure
  wrapEvent :: Event (ShelleyTICK era) -> Event (MOCKCHAIN era)
wrapEvent = 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 = forall era. ShelleyLedgersPredFailure era -> MockChainFailure era
MockChainFromLedgersFailure
  wrapEvent :: Event (ShelleyLEDGERS era) -> Event (MOCKCHAIN era)
wrapEvent = 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", forall era. Reflect era => Proof era -> NewEpochState era -> PDoc
pcNewEpochState forall era. Reflect era => Proof era
reify NewEpochState era
nes)
    , (Text
"LastBlock", SlotNo -> PDoc
pcSlotNo SlotNo
sl)
    , (Text
"Count", forall a. Int -> Doc a
ppInt Int
count)
    ]

instance Reflect era => PrettyA (MockChainState era) where
  prettyA :: MockChainState era -> PDoc
prettyA = 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", forall (discriminator :: KeyRole). KeyHash discriminator -> PDoc
pcKeyHash KeyHash 'StakePool
iss)
    , (Text
"Slot", SlotNo -> PDoc
pcSlotNo SlotNo
sl)
    , (Text
"Transactions", forall a. Int -> Doc a
ppInt (forall (t :: * -> *) a. Foldable t => t a -> Int
length StrictSeq (Tx era)
txs))
    ]

instance PrettyA (MockBlock era) where prettyA :: MockBlock era -> PDoc
prettyA = 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) = forall era. Reflect era => ShelleyTickPredFailure era -> PDoc
ppTickPredicateFailure ShelleyTickPredFailure era
y
    help (MockChainFromLedgersFailure ShelleyLedgersPredFailure era
y) = 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 = forall a. NoThunks a => Context -> a -> IO (Maybe ThunkInfo)
noThunks []
noThunksGen Proof era
Babbage = forall a. NoThunks a => Context -> a -> IO (Maybe ThunkInfo)
noThunks []
noThunksGen Proof era
Alonzo = forall a. NoThunks a => Context -> a -> IO (Maybe ThunkInfo)
noThunks []
noThunksGen Proof era
Mary = forall a. NoThunks a => Context -> a -> IO (Maybe ThunkInfo)
noThunks []
noThunksGen Proof era
Allegra = forall a. NoThunks a => Context -> a -> IO (Maybe ThunkInfo)
noThunks []
noThunksGen Proof era
Shelley = forall a. NoThunks a => Context -> a -> IO (Maybe ThunkInfo)
noThunks []