{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}

-- | Peras state to be stored in the extended ledger state.
module Ouroboros.Consensus.Ledger.Peras
  ( PerasState (..)
  , initPerasState
  , decodePerasState
  , encodePerasState
  ) where

import Cardano.Binary (FromCBOR (..), ToCBOR (..))
import Codec.CBOR.Decoding (Decoder, decodeListLenOf)
import Codec.CBOR.Encoding (Encoding, encodeListLen)
import Data.Maybe.Strict (StrictMaybe (..))
import Data.SOP (All)
import Data.SOP.Constraint (Top)
import Data.Typeable (Typeable)
import GHC.Generics (Generic)
import NoThunks.Class (NoThunks (..))
import Ouroboros.Consensus.Block.SupportsPeras (PerasVotingCommittee)
import Ouroboros.Consensus.HardFork.Abstract (HasHardForkHistory (..))
import Ouroboros.Consensus.HeaderValidation (HeaderState)
import Ouroboros.Consensus.Ledger.Basics (LedgerCfg, LedgerState)
import Ouroboros.Consensus.Ledger.Tables (HasLedgerTables)
import Ouroboros.Consensus.Ledger.Tables.Utils (forgetLedgerTables)
import Ouroboros.Consensus.Peras.Context
  ( PerasEpochContextResolver
  , StateSupportsPerasEpochContext
  , initPerasEpochContextResolver
  )
import Ouroboros.Consensus.Peras.Types (PerasRoundNo)
import Ouroboros.Consensus.Storage.Serialisation
import Ouroboros.Consensus.Util.CBOR (decodeStrictMaybe, encodeStrictMaybe)

-- | Peras state to be stored in the extended ledger state.
data PerasState blk
  = PerasState
  { forall blk. PerasState blk -> PerasEpochContextResolver blk
perasEpochContextResolver :: !(PerasEpochContextResolver blk)
  , forall blk. PerasState blk -> StrictMaybe PerasRoundNo
latestPerasCertOnChainRound :: !(StrictMaybe PerasRoundNo)
  }

deriving instance Eq (PerasVotingCommittee blk) => Eq (PerasState blk)
deriving instance Show (PerasVotingCommittee blk) => Show (PerasState blk)
deriving instance NoThunks (PerasVotingCommittee blk) => NoThunks (PerasState blk)
deriving instance Generic (PerasState blk)

initPerasState ::
  ( All Top (HardForkIndices blk)
  , StateSupportsPerasEpochContext blk
  , HasLedgerTables LedgerState blk
  ) =>
  LedgerCfg LedgerState blk ->
  LedgerState blk mk ->
  HeaderState blk ->
  PerasState blk
initPerasState :: forall blk (mk :: MapKind).
(All Top (HardForkIndices blk), StateSupportsPerasEpochContext blk,
 HasLedgerTables LedgerState blk) =>
LedgerCfg LedgerState blk
-> LedgerState blk mk -> HeaderState blk -> PerasState blk
initPerasState LedgerCfg LedgerState blk
ledgerConfig LedgerState blk mk
ledgerState HeaderState blk
headerState =
  PerasState
    { perasEpochContextResolver :: PerasEpochContextResolver blk
perasEpochContextResolver =
        LedgerCfg LedgerState blk
-> LedgerState blk EmptyMK
-> HeaderState blk
-> PerasEpochContextResolver blk
forall blk.
(All Top (HardForkIndices blk),
 StateSupportsPerasEpochContext blk) =>
LedgerConfig blk
-> LedgerState blk EmptyMK
-> HeaderState blk
-> PerasEpochContextResolver blk
initPerasEpochContextResolver
          LedgerCfg LedgerState blk
ledgerConfig
          (LedgerState blk mk -> LedgerState blk EmptyMK
forall (l :: StateKind) blk (mk :: MapKind).
HasLedgerTables l blk =>
l blk mk -> l blk EmptyMK
forgetLedgerTables LedgerState blk mk
ledgerState)
          HeaderState blk
headerState
    , latestPerasCertOnChainRound :: StrictMaybe PerasRoundNo
latestPerasCertOnChainRound =
        StrictMaybe PerasRoundNo
forall a. StrictMaybe a
SNothing
    }

encodePerasState ::
  (PerasEpochContextResolver blk -> Encoding) ->
  PerasState blk ->
  Encoding
encodePerasState :: forall blk.
(PerasEpochContextResolver blk -> Encoding)
-> PerasState blk -> Encoding
encodePerasState
  PerasEpochContextResolver blk -> Encoding
encodeResolver
  PerasState
    { PerasEpochContextResolver blk
perasEpochContextResolver :: forall blk. PerasState blk -> PerasEpochContextResolver blk
perasEpochContextResolver :: PerasEpochContextResolver blk
perasEpochContextResolver
    , StrictMaybe PerasRoundNo
latestPerasCertOnChainRound :: forall blk. PerasState blk -> StrictMaybe PerasRoundNo
latestPerasCertOnChainRound :: StrictMaybe PerasRoundNo
latestPerasCertOnChainRound
    } =
    Word -> Encoding
encodeListLen Word
2
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> PerasEpochContextResolver blk -> Encoding
encodeResolver PerasEpochContextResolver blk
perasEpochContextResolver
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> (PerasRoundNo -> Encoding) -> StrictMaybe PerasRoundNo -> Encoding
forall a. (a -> Encoding) -> StrictMaybe a -> Encoding
encodeStrictMaybe PerasRoundNo -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR StrictMaybe PerasRoundNo
latestPerasCertOnChainRound

decodePerasState ::
  (forall s. Decoder s (PerasEpochContextResolver blk)) ->
  forall s. Decoder s (PerasState blk)
decodePerasState :: forall blk.
(forall s. Decoder s (PerasEpochContextResolver blk))
-> forall s. Decoder s (PerasState blk)
decodePerasState forall s. Decoder s (PerasEpochContextResolver blk)
decodeResolver = do
  Int -> Decoder s ()
forall s. Int -> Decoder s ()
decodeListLenOf Int
2
  perasEpochContextResolver <- Decoder s (PerasEpochContextResolver blk)
forall s. Decoder s (PerasEpochContextResolver blk)
decodeResolver
  latestPerasCertOnChainRound <- decodeStrictMaybe fromCBOR
  pure
    PerasState
      { perasEpochContextResolver
      , latestPerasCertOnChainRound
      }

instance
  ( Typeable blk
  , FromCBOR (PerasVotingCommittee blk)
  ) =>
  FromCBOR (PerasState blk)
  where
  fromCBOR :: forall s. Decoder s (PerasState blk)
fromCBOR = (forall s. Decoder s (PerasEpochContextResolver blk))
-> forall s. Decoder s (PerasState blk)
forall blk.
(forall s. Decoder s (PerasEpochContextResolver blk))
-> forall s. Decoder s (PerasState blk)
decodePerasState Decoder s (PerasEpochContextResolver blk)
forall s. Decoder s (PerasEpochContextResolver blk)
forall a s. FromCBOR a => Decoder s a
fromCBOR

instance
  ( Typeable blk
  , ToCBOR (PerasVotingCommittee blk)
  ) =>
  ToCBOR (PerasState blk)
  where
  toCBOR :: PerasState blk -> Encoding
toCBOR = (PerasEpochContextResolver blk -> Encoding)
-> PerasState blk -> Encoding
forall blk.
(PerasEpochContextResolver blk -> Encoding)
-> PerasState blk -> Encoding
encodePerasState PerasEpochContextResolver blk -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR

instance
  ( Typeable blk
  , FromCBOR (PerasVotingCommittee blk)
  ) =>
  DecodeDisk blk (PerasState blk)
  where
  decodeDisk :: CodecConfig blk -> forall s. Decoder s (PerasState blk)
decodeDisk CodecConfig blk
cfg = (forall s. Decoder s (PerasEpochContextResolver blk))
-> forall s. Decoder s (PerasState blk)
forall blk.
(forall s. Decoder s (PerasEpochContextResolver blk))
-> forall s. Decoder s (PerasState blk)
decodePerasState (CodecConfig blk
-> forall s. Decoder s (PerasEpochContextResolver blk)
forall blk a.
DecodeDisk blk a =>
CodecConfig blk -> forall s. Decoder s a
decodeDisk CodecConfig blk
cfg)

instance
  ( Typeable blk
  , ToCBOR (PerasVotingCommittee blk)
  ) =>
  EncodeDisk blk (PerasState blk)
  where
  encodeDisk :: CodecConfig blk -> PerasState blk -> Encoding
encodeDisk CodecConfig blk
cfg = (PerasEpochContextResolver blk -> Encoding)
-> PerasState blk -> Encoding
forall blk.
(PerasEpochContextResolver blk -> Encoding)
-> PerasState blk -> Encoding
encodePerasState (CodecConfig blk -> PerasEpochContextResolver blk -> Encoding
forall blk a. EncodeDisk blk a => CodecConfig blk -> a -> Encoding
encodeDisk CodecConfig blk
cfg)