{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# 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,
 )
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 (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
  = 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 (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 TopTx era)
mbTrans :: !(StrictSeq (Tx TopTx 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 TopTx 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 TopTx era)
  , Environment (EraRule "LEDGERS" era) ~ ShelleyLedgersEnv era
  , State (EraRule "LEDGERS" era) ~ LedgerState era
  , Embed (EraRule "LEDGERS" era) (MOCKCHAIN era)
  , Signal (EraRule "LEDGER" era) ~ Tx TopTx 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 -> Rule (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 (_, MockChainState nes _ lastSlot count, MockBlock issuer slot 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
        lastSlot < slot ?! BlocksOutOfOrder lastSlot slot

        nes' <- trans @(EraRule "TICK" era) $ TRC ((), nes, slot)

        let NewEpochState _ _ (BlocksMade current) epochState _ _ _ = nes'
            EpochState account ledgerState _ _ = epochState
            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 = 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))

        newledgerState <-
          trans @(EraRule "LEDGERS" era) $
            TRC (LedgersEnv slot (epochFromSlotNo slot) pparams account, ledgerState, fromStrict txs)

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

        pure (MockChainState newNewEpochState nes' slot (count + 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 = \case {}
  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 TopTx 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 (ShelleyLedgersPredFailure era) => Show (MockChainFailure era)

deriving instance 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 TopTx era)) => MockBlock era -> Expr
ppMockBlock :: forall era.
ToExpr (StrictSeq (Tx TopTx era)) =>
MockBlock era -> Expr
ppMockBlock = MockBlock era -> Expr
forall a. ToExpr a => a -> Expr
toExpr

instance ToExpr (StrictSeq (Tx TopTx 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 ::
  ( EraTxOut era
  , NoThunks (GovState era)
  , NoThunks (CertState era)
  , NoThunks (InstantStake era)
  , NoThunks (StashedAVVMAddresses era)
  ) =>
  MockChainState era -> IO (Maybe ThunkInfo)
noThunksGen :: forall era.
(EraTxOut era, NoThunks (GovState era), NoThunks (CertState era),
 NoThunks (InstantStake era),
 NoThunks (StashedAVVMAddresses era)) =>
MockChainState era -> IO (Maybe ThunkInfo)
noThunksGen = Context -> MockChainState era -> IO (Maybe ThunkInfo)
forall a. NoThunks a => Context -> a -> IO (Maybe ThunkInfo)
noThunks []