{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UndecidableSuperClasses #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Cardano.Ledger.Shelley.TxCert (
  ShelleyEraTxCert (..),
  pattern MirTxCert,
  pattern GenesisDelegTxCert,
  pattern RegTxCert,
  pattern UnRegTxCert,
  pattern DelegStakeTxCert,
  ShelleyDelegCert (..),
  getVKeyWitnessShelleyTxCert,
  getScriptWitnessShelleyTxCert,
  ShelleyTxCert (..),
  upgradeShelleyTxCert,

  -- ** GenesisDelegCert
  GenesisDelegCert (..),
  genesisCWitness,
  genesisKeyHashWitness,

  -- ** MIRCert
  MIRCert (..),
  MIRPot (..),
  MIRTarget (..),
  isDelegation,
  isRegPool,
  isRetirePool,
  isGenesisDelegation,
  isInstantaneousRewards,
  isReservesMIRCert,
  isTreasuryMIRCert,

  -- ** Serialization helpers
  shelleyTxCertDelegDecoder,
  poolTxCertDecoder,
  encodeShelleyDelegCert,
  encodePoolCert,
  encodeGenesisDelegCert,

  -- ** Deposits and Refunds
  shelleyTotalDepositsTxCerts,
  shelleyTotalRefundsTxCerts,

  -- * Re-exports
  EraTxCert (..),
  pattern RegPoolTxCert,
  pattern RetirePoolTxCert,
  PoolCert (..),
  isRegStakeTxCert,
  isUnRegStakeTxCert,
) where

import Cardano.Ledger.BaseTypes (invalidKey, kindObject)
import Cardano.Ledger.Binary (
  DecCBOR (decCBOR),
  DecCBORGroup (..),
  Decoder,
  EncCBOR (..),
  EncCBORGroup (..),
  Encoding,
  FromCBOR (..),
  ToCBOR (..),
  TokenType (TypeMapLen, TypeMapLen64, TypeMapLenIndef),
  decodeRecordNamed,
  decodeRecordSum,
  decodeWord,
  encodeListLen,
  encodeWord8,
  listLenInt,
  peekTokenType,
 )
import Cardano.Ledger.Coin (Coin (..), DeltaCoin)
import Cardano.Ledger.Core
import Cardano.Ledger.Credential (
  Credential (..),
  StakeCredential,
  credKeyHashWitness,
  credScriptHash,
 )
import Cardano.Ledger.Keys (asWitness)
import Cardano.Ledger.PoolParams (PoolParams (..))
import Cardano.Ledger.Shelley.Era (ShelleyEra)
import Cardano.Ledger.Shelley.PParams ()
import Cardano.Ledger.Val ((<+>), (<×>))
import Control.DeepSeq (NFData (..), rwhnf)
import Data.Aeson (ToJSON (..), (.=))
import Data.Foldable as F (Foldable (..), foldMap', foldl')
import Data.Map.Strict (Map)
import Data.Maybe (isJust)
import Data.Monoid (Sum (..))
import qualified Data.Set as Set
import GHC.Generics (Generic)
import Lens.Micro
import NoThunks.Class (NoThunks (..))

instance EraTxCert ShelleyEra where
  type TxCert ShelleyEra = ShelleyTxCert ShelleyEra

  -- Calling this partial function will result in compilation error, since ByronEra has
  -- no instance for EraTxOut type class.
  upgradeTxCert :: EraTxCert (PreviousEra ShelleyEra) =>
TxCert (PreviousEra ShelleyEra)
-> Either (TxCertUpgradeError ShelleyEra) (TxCert ShelleyEra)
upgradeTxCert = [Char] -> TxCert ByronEra -> Either Void (ShelleyTxCert ShelleyEra)
forall a. HasCallStack => [Char] -> a
error [Char]
"Byron does not have any TxCerts to upgrade with 'upgradeTxCert'"

  getVKeyWitnessTxCert :: TxCert ShelleyEra -> Maybe (KeyHash 'Witness)
getVKeyWitnessTxCert = TxCert ShelleyEra -> Maybe (KeyHash 'Witness)
ShelleyTxCert ShelleyEra -> Maybe (KeyHash 'Witness)
forall era. ShelleyTxCert era -> Maybe (KeyHash 'Witness)
getVKeyWitnessShelleyTxCert

  getScriptWitnessTxCert :: TxCert ShelleyEra -> Maybe ScriptHash
getScriptWitnessTxCert = TxCert ShelleyEra -> Maybe ScriptHash
ShelleyTxCert ShelleyEra -> Maybe ScriptHash
forall era. ShelleyTxCert era -> Maybe ScriptHash
getScriptWitnessShelleyTxCert

  mkRegPoolTxCert :: PoolParams -> TxCert ShelleyEra
mkRegPoolTxCert = PoolCert -> ShelleyTxCert ShelleyEra
forall era. PoolCert -> ShelleyTxCert era
ShelleyTxCertPool (PoolCert -> ShelleyTxCert ShelleyEra)
-> (PoolParams -> PoolCert)
-> PoolParams
-> ShelleyTxCert ShelleyEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PoolParams -> PoolCert
RegPool

  getRegPoolTxCert :: TxCert ShelleyEra -> Maybe PoolParams
getRegPoolTxCert (ShelleyTxCertPool (RegPool PoolParams
poolParams)) = PoolParams -> Maybe PoolParams
forall a. a -> Maybe a
Just PoolParams
poolParams
  getRegPoolTxCert TxCert ShelleyEra
_ = Maybe PoolParams
forall a. Maybe a
Nothing

  mkRetirePoolTxCert :: KeyHash 'StakePool -> EpochNo -> TxCert ShelleyEra
mkRetirePoolTxCert KeyHash 'StakePool
poolId EpochNo
epochNo = PoolCert -> ShelleyTxCert ShelleyEra
forall era. PoolCert -> ShelleyTxCert era
ShelleyTxCertPool (PoolCert -> ShelleyTxCert ShelleyEra)
-> PoolCert -> ShelleyTxCert ShelleyEra
forall a b. (a -> b) -> a -> b
$ KeyHash 'StakePool -> EpochNo -> PoolCert
RetirePool KeyHash 'StakePool
poolId EpochNo
epochNo

  getRetirePoolTxCert :: TxCert ShelleyEra -> Maybe (KeyHash 'StakePool, EpochNo)
getRetirePoolTxCert (ShelleyTxCertPool (RetirePool KeyHash 'StakePool
poolId EpochNo
epochNo)) = (KeyHash 'StakePool, EpochNo)
-> Maybe (KeyHash 'StakePool, EpochNo)
forall a. a -> Maybe a
Just (KeyHash 'StakePool
poolId, EpochNo
epochNo)
  getRetirePoolTxCert TxCert ShelleyEra
_ = Maybe (KeyHash 'StakePool, EpochNo)
forall a. Maybe a
Nothing

  lookupRegStakeTxCert :: TxCert ShelleyEra -> Maybe StakeCredential
lookupRegStakeTxCert = \case
    RegTxCert StakeCredential
c -> StakeCredential -> Maybe StakeCredential
forall a. a -> Maybe a
Just StakeCredential
c
    TxCert ShelleyEra
_ -> Maybe StakeCredential
forall a. Maybe a
Nothing
  lookupUnRegStakeTxCert :: TxCert ShelleyEra -> Maybe StakeCredential
lookupUnRegStakeTxCert = \case
    UnRegTxCert StakeCredential
c -> StakeCredential -> Maybe StakeCredential
forall a. a -> Maybe a
Just StakeCredential
c
    TxCert ShelleyEra
_ -> Maybe StakeCredential
forall a. Maybe a
Nothing

  getTotalDepositsTxCerts :: forall (f :: * -> *).
Foldable f =>
PParams ShelleyEra
-> (KeyHash 'StakePool -> Bool) -> f (TxCert ShelleyEra) -> Coin
getTotalDepositsTxCerts = PParams ShelleyEra
-> (KeyHash 'StakePool -> Bool) -> f (TxCert ShelleyEra) -> Coin
forall era (f :: * -> *).
(EraPParams era, Foldable f, EraTxCert era) =>
PParams era
-> (KeyHash 'StakePool -> Bool) -> f (TxCert era) -> Coin
shelleyTotalDepositsTxCerts

  getTotalRefundsTxCerts :: forall (f :: * -> *).
Foldable f =>
PParams ShelleyEra
-> (StakeCredential -> Maybe Coin)
-> (Credential 'DRepRole -> Maybe Coin)
-> f (TxCert ShelleyEra)
-> Coin
getTotalRefundsTxCerts PParams ShelleyEra
pp StakeCredential -> Maybe Coin
lookupStakeDeposit Credential 'DRepRole -> Maybe Coin
_ = PParams ShelleyEra
-> (StakeCredential -> Maybe Coin) -> f (TxCert ShelleyEra) -> Coin
forall era (f :: * -> *).
(EraPParams era, Foldable f, EraTxCert era) =>
PParams era
-> (StakeCredential -> Maybe Coin) -> f (TxCert era) -> Coin
shelleyTotalRefundsTxCerts PParams ShelleyEra
pp StakeCredential -> Maybe Coin
lookupStakeDeposit

class EraTxCert era => ShelleyEraTxCert era where
  mkRegTxCert :: StakeCredential -> TxCert era
  getRegTxCert :: TxCert era -> Maybe StakeCredential

  mkUnRegTxCert :: StakeCredential -> TxCert era
  getUnRegTxCert :: TxCert era -> Maybe StakeCredential

  mkDelegStakeTxCert :: StakeCredential -> KeyHash 'StakePool -> TxCert era
  getDelegStakeTxCert :: TxCert era -> Maybe (StakeCredential, KeyHash 'StakePool)

  mkGenesisDelegTxCert :: ProtVerAtMost era 8 => GenesisDelegCert -> TxCert era
  getGenesisDelegTxCert :: ProtVerAtMost era 8 => TxCert era -> Maybe GenesisDelegCert

  mkMirTxCert :: ProtVerAtMost era 8 => MIRCert -> TxCert era
  getMirTxCert :: ProtVerAtMost era 8 => TxCert era -> Maybe MIRCert

instance ShelleyEraTxCert ShelleyEra where
  mkRegTxCert :: StakeCredential -> TxCert ShelleyEra
mkRegTxCert = ShelleyDelegCert -> ShelleyTxCert ShelleyEra
forall era. ShelleyDelegCert -> ShelleyTxCert era
ShelleyTxCertDelegCert (ShelleyDelegCert -> ShelleyTxCert ShelleyEra)
-> (StakeCredential -> ShelleyDelegCert)
-> StakeCredential
-> ShelleyTxCert ShelleyEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StakeCredential -> ShelleyDelegCert
ShelleyRegCert

  getRegTxCert :: TxCert ShelleyEra -> Maybe StakeCredential
getRegTxCert (ShelleyTxCertDelegCert (ShelleyRegCert StakeCredential
c)) = StakeCredential -> Maybe StakeCredential
forall a. a -> Maybe a
Just StakeCredential
c
  getRegTxCert TxCert ShelleyEra
_ = Maybe StakeCredential
forall a. Maybe a
Nothing

  mkUnRegTxCert :: StakeCredential -> TxCert ShelleyEra
mkUnRegTxCert = ShelleyDelegCert -> ShelleyTxCert ShelleyEra
forall era. ShelleyDelegCert -> ShelleyTxCert era
ShelleyTxCertDelegCert (ShelleyDelegCert -> ShelleyTxCert ShelleyEra)
-> (StakeCredential -> ShelleyDelegCert)
-> StakeCredential
-> ShelleyTxCert ShelleyEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StakeCredential -> ShelleyDelegCert
ShelleyUnRegCert

  getUnRegTxCert :: TxCert ShelleyEra -> Maybe StakeCredential
getUnRegTxCert (ShelleyTxCertDelegCert (ShelleyUnRegCert StakeCredential
c)) = StakeCredential -> Maybe StakeCredential
forall a. a -> Maybe a
Just StakeCredential
c
  getUnRegTxCert TxCert ShelleyEra
_ = Maybe StakeCredential
forall a. Maybe a
Nothing

  mkDelegStakeTxCert :: StakeCredential -> KeyHash 'StakePool -> TxCert ShelleyEra
mkDelegStakeTxCert StakeCredential
c KeyHash 'StakePool
kh = ShelleyDelegCert -> ShelleyTxCert ShelleyEra
forall era. ShelleyDelegCert -> ShelleyTxCert era
ShelleyTxCertDelegCert (ShelleyDelegCert -> ShelleyTxCert ShelleyEra)
-> ShelleyDelegCert -> ShelleyTxCert ShelleyEra
forall a b. (a -> b) -> a -> b
$ StakeCredential -> KeyHash 'StakePool -> ShelleyDelegCert
ShelleyDelegCert StakeCredential
c KeyHash 'StakePool
kh

  getDelegStakeTxCert :: TxCert ShelleyEra -> Maybe (StakeCredential, KeyHash 'StakePool)
getDelegStakeTxCert (ShelleyTxCertDelegCert (ShelleyDelegCert StakeCredential
c KeyHash 'StakePool
kh)) = (StakeCredential, KeyHash 'StakePool)
-> Maybe (StakeCredential, KeyHash 'StakePool)
forall a. a -> Maybe a
Just (StakeCredential
c, KeyHash 'StakePool
kh)
  getDelegStakeTxCert TxCert ShelleyEra
_ = Maybe (StakeCredential, KeyHash 'StakePool)
forall a. Maybe a
Nothing

  mkGenesisDelegTxCert :: ProtVerAtMost ShelleyEra 8 => GenesisDelegCert -> TxCert ShelleyEra
mkGenesisDelegTxCert = GenesisDelegCert -> TxCert ShelleyEra
GenesisDelegCert -> ShelleyTxCert ShelleyEra
forall era. GenesisDelegCert -> ShelleyTxCert era
ShelleyTxCertGenesisDeleg

  getGenesisDelegTxCert :: ProtVerAtMost ShelleyEra 8 =>
TxCert ShelleyEra -> Maybe GenesisDelegCert
getGenesisDelegTxCert (ShelleyTxCertGenesisDeleg GenesisDelegCert
c) = GenesisDelegCert -> Maybe GenesisDelegCert
forall a. a -> Maybe a
Just GenesisDelegCert
c
  getGenesisDelegTxCert TxCert ShelleyEra
_ = Maybe GenesisDelegCert
forall a. Maybe a
Nothing

  mkMirTxCert :: ProtVerAtMost ShelleyEra 8 => MIRCert -> TxCert ShelleyEra
mkMirTxCert = MIRCert -> TxCert ShelleyEra
MIRCert -> ShelleyTxCert ShelleyEra
forall era. MIRCert -> ShelleyTxCert era
ShelleyTxCertMir

  getMirTxCert :: ProtVerAtMost ShelleyEra 8 => TxCert ShelleyEra -> Maybe MIRCert
getMirTxCert (ShelleyTxCertMir MIRCert
c) = MIRCert -> Maybe MIRCert
forall a. a -> Maybe a
Just MIRCert
c
  getMirTxCert TxCert ShelleyEra
_ = Maybe MIRCert
forall a. Maybe a
Nothing

pattern RegTxCert :: ShelleyEraTxCert era => StakeCredential -> TxCert era
pattern $mRegTxCert :: forall {r} {era}.
ShelleyEraTxCert era =>
TxCert era -> (StakeCredential -> r) -> ((# #) -> r) -> r
$bRegTxCert :: forall era. ShelleyEraTxCert era => StakeCredential -> TxCert era
RegTxCert c <- (getRegTxCert -> Just c)
  where
    RegTxCert StakeCredential
c = StakeCredential -> TxCert era
forall era. ShelleyEraTxCert era => StakeCredential -> TxCert era
mkRegTxCert StakeCredential
c

pattern UnRegTxCert :: ShelleyEraTxCert era => StakeCredential -> TxCert era
pattern $mUnRegTxCert :: forall {r} {era}.
ShelleyEraTxCert era =>
TxCert era -> (StakeCredential -> r) -> ((# #) -> r) -> r
$bUnRegTxCert :: forall era. ShelleyEraTxCert era => StakeCredential -> TxCert era
UnRegTxCert c <- (getUnRegTxCert -> Just c)
  where
    UnRegTxCert StakeCredential
c = StakeCredential -> TxCert era
forall era. ShelleyEraTxCert era => StakeCredential -> TxCert era
mkUnRegTxCert StakeCredential
c

pattern DelegStakeTxCert ::
  ShelleyEraTxCert era =>
  StakeCredential ->
  KeyHash 'StakePool ->
  TxCert era
pattern $mDelegStakeTxCert :: forall {r} {era}.
ShelleyEraTxCert era =>
TxCert era
-> (StakeCredential -> KeyHash 'StakePool -> r)
-> ((# #) -> r)
-> r
$bDelegStakeTxCert :: forall era.
ShelleyEraTxCert era =>
StakeCredential -> KeyHash 'StakePool -> TxCert era
DelegStakeTxCert c kh <- (getDelegStakeTxCert -> Just (c, kh))
  where
    DelegStakeTxCert StakeCredential
c KeyHash 'StakePool
kh = StakeCredential -> KeyHash 'StakePool -> TxCert era
forall era.
ShelleyEraTxCert era =>
StakeCredential -> KeyHash 'StakePool -> TxCert era
mkDelegStakeTxCert StakeCredential
c KeyHash 'StakePool
kh

pattern MirTxCert ::
  (ShelleyEraTxCert era, ProtVerAtMost era 8) => MIRCert -> TxCert era
pattern $mMirTxCert :: forall {r} {era}.
(ShelleyEraTxCert era, ProtVerAtMost era 8) =>
TxCert era -> (MIRCert -> r) -> ((# #) -> r) -> r
$bMirTxCert :: forall era.
(ShelleyEraTxCert era, ProtVerAtMost era 8) =>
MIRCert -> TxCert era
MirTxCert d <- (getMirTxCert -> Just d)
  where
    MirTxCert MIRCert
d = MIRCert -> TxCert era
forall era.
(ShelleyEraTxCert era, ProtVerAtMost era 8) =>
MIRCert -> TxCert era
mkMirTxCert MIRCert
d

pattern GenesisDelegTxCert ::
  (ShelleyEraTxCert era, ProtVerAtMost era 8) =>
  KeyHash 'Genesis ->
  KeyHash 'GenesisDelegate ->
  VRFVerKeyHash 'GenDelegVRF ->
  TxCert era
pattern $mGenesisDelegTxCert :: forall {r} {era}.
(ShelleyEraTxCert era, ProtVerAtMost era 8) =>
TxCert era
-> (KeyHash 'Genesis
    -> KeyHash 'GenesisDelegate -> VRFVerKeyHash 'GenDelegVRF -> r)
-> ((# #) -> r)
-> r
$bGenesisDelegTxCert :: forall era.
(ShelleyEraTxCert era, ProtVerAtMost era 8) =>
KeyHash 'Genesis
-> KeyHash 'GenesisDelegate
-> VRFVerKeyHash 'GenDelegVRF
-> TxCert era
GenesisDelegTxCert genKey genDelegKey vrfKeyHash <-
  (getGenesisDelegTxCert -> Just (GenesisDelegCert genKey genDelegKey vrfKeyHash))
  where
    GenesisDelegTxCert KeyHash 'Genesis
genKey KeyHash 'GenesisDelegate
genDelegKey VRFVerKeyHash 'GenDelegVRF
vrfKeyHash =
      GenesisDelegCert -> TxCert era
forall era.
(ShelleyEraTxCert era, ProtVerAtMost era 8) =>
GenesisDelegCert -> TxCert era
mkGenesisDelegTxCert (GenesisDelegCert -> TxCert era) -> GenesisDelegCert -> TxCert era
forall a b. (a -> b) -> a -> b
$ KeyHash 'Genesis
-> KeyHash 'GenesisDelegate
-> VRFVerKeyHash 'GenDelegVRF
-> GenesisDelegCert
GenesisDelegCert KeyHash 'Genesis
genKey KeyHash 'GenesisDelegate
genDelegKey VRFVerKeyHash 'GenDelegVRF
vrfKeyHash

{-# COMPLETE
  RegPoolTxCert
  , RetirePoolTxCert
  , RegTxCert
  , UnRegTxCert
  , DelegStakeTxCert
  , MirTxCert
  , GenesisDelegTxCert
  #-}

-- | Genesis key delegation certificate
data GenesisDelegCert
  = GenesisDelegCert
      !(KeyHash 'Genesis)
      !(KeyHash 'GenesisDelegate)
      !(VRFVerKeyHash 'GenDelegVRF)
  deriving (Int -> GenesisDelegCert -> ShowS
[GenesisDelegCert] -> ShowS
GenesisDelegCert -> [Char]
(Int -> GenesisDelegCert -> ShowS)
-> (GenesisDelegCert -> [Char])
-> ([GenesisDelegCert] -> ShowS)
-> Show GenesisDelegCert
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GenesisDelegCert -> ShowS
showsPrec :: Int -> GenesisDelegCert -> ShowS
$cshow :: GenesisDelegCert -> [Char]
show :: GenesisDelegCert -> [Char]
$cshowList :: [GenesisDelegCert] -> ShowS
showList :: [GenesisDelegCert] -> ShowS
Show, (forall x. GenesisDelegCert -> Rep GenesisDelegCert x)
-> (forall x. Rep GenesisDelegCert x -> GenesisDelegCert)
-> Generic GenesisDelegCert
forall x. Rep GenesisDelegCert x -> GenesisDelegCert
forall x. GenesisDelegCert -> Rep GenesisDelegCert x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. GenesisDelegCert -> Rep GenesisDelegCert x
from :: forall x. GenesisDelegCert -> Rep GenesisDelegCert x
$cto :: forall x. Rep GenesisDelegCert x -> GenesisDelegCert
to :: forall x. Rep GenesisDelegCert x -> GenesisDelegCert
Generic, GenesisDelegCert -> GenesisDelegCert -> Bool
(GenesisDelegCert -> GenesisDelegCert -> Bool)
-> (GenesisDelegCert -> GenesisDelegCert -> Bool)
-> Eq GenesisDelegCert
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: GenesisDelegCert -> GenesisDelegCert -> Bool
== :: GenesisDelegCert -> GenesisDelegCert -> Bool
$c/= :: GenesisDelegCert -> GenesisDelegCert -> Bool
/= :: GenesisDelegCert -> GenesisDelegCert -> Bool
Eq, Eq GenesisDelegCert
Eq GenesisDelegCert =>
(GenesisDelegCert -> GenesisDelegCert -> Ordering)
-> (GenesisDelegCert -> GenesisDelegCert -> Bool)
-> (GenesisDelegCert -> GenesisDelegCert -> Bool)
-> (GenesisDelegCert -> GenesisDelegCert -> Bool)
-> (GenesisDelegCert -> GenesisDelegCert -> Bool)
-> (GenesisDelegCert -> GenesisDelegCert -> GenesisDelegCert)
-> (GenesisDelegCert -> GenesisDelegCert -> GenesisDelegCert)
-> Ord GenesisDelegCert
GenesisDelegCert -> GenesisDelegCert -> Bool
GenesisDelegCert -> GenesisDelegCert -> Ordering
GenesisDelegCert -> GenesisDelegCert -> GenesisDelegCert
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: GenesisDelegCert -> GenesisDelegCert -> Ordering
compare :: GenesisDelegCert -> GenesisDelegCert -> Ordering
$c< :: GenesisDelegCert -> GenesisDelegCert -> Bool
< :: GenesisDelegCert -> GenesisDelegCert -> Bool
$c<= :: GenesisDelegCert -> GenesisDelegCert -> Bool
<= :: GenesisDelegCert -> GenesisDelegCert -> Bool
$c> :: GenesisDelegCert -> GenesisDelegCert -> Bool
> :: GenesisDelegCert -> GenesisDelegCert -> Bool
$c>= :: GenesisDelegCert -> GenesisDelegCert -> Bool
>= :: GenesisDelegCert -> GenesisDelegCert -> Bool
$cmax :: GenesisDelegCert -> GenesisDelegCert -> GenesisDelegCert
max :: GenesisDelegCert -> GenesisDelegCert -> GenesisDelegCert
$cmin :: GenesisDelegCert -> GenesisDelegCert -> GenesisDelegCert
min :: GenesisDelegCert -> GenesisDelegCert -> GenesisDelegCert
Ord)

instance NoThunks GenesisDelegCert

instance NFData GenesisDelegCert where
  rnf :: GenesisDelegCert -> ()
rnf = GenesisDelegCert -> ()
forall a. a -> ()
rwhnf

instance ToJSON GenesisDelegCert where
  toJSON :: GenesisDelegCert -> Value
toJSON (GenesisDelegCert KeyHash 'Genesis
genKeyHash KeyHash 'GenesisDelegate
genDelegKeyHash VRFVerKeyHash 'GenDelegVRF
hashVrf) =
    Text -> [Pair] -> Value
kindObject Text
"GenesisDelegCert" ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$
      [ Key
"genKeyHash" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= KeyHash 'Genesis -> Value
forall a. ToJSON a => a -> Value
toJSON KeyHash 'Genesis
genKeyHash
      , Key
"genDelegKeyHash" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= KeyHash 'GenesisDelegate -> Value
forall a. ToJSON a => a -> Value
toJSON KeyHash 'GenesisDelegate
genDelegKeyHash
      , Key
"hashVrf" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= VRFVerKeyHash 'GenDelegVRF -> Value
forall a. ToJSON a => a -> Value
toJSON VRFVerKeyHash 'GenDelegVRF
hashVrf
      ]

genesisKeyHashWitness :: GenesisDelegCert -> KeyHash 'Witness
genesisKeyHashWitness :: GenesisDelegCert -> KeyHash 'Witness
genesisKeyHashWitness (GenesisDelegCert KeyHash 'Genesis
gk KeyHash 'GenesisDelegate
_ VRFVerKeyHash 'GenDelegVRF
_) = KeyHash 'Genesis -> KeyHash 'Witness
forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness KeyHash 'Genesis
gk

genesisCWitness :: GenesisDelegCert -> KeyHash 'Genesis
genesisCWitness :: GenesisDelegCert -> KeyHash 'Genesis
genesisCWitness (GenesisDelegCert KeyHash 'Genesis
gk KeyHash 'GenesisDelegate
_ VRFVerKeyHash 'GenDelegVRF
_) = KeyHash 'Genesis
gk

data MIRPot = ReservesMIR | TreasuryMIR
  deriving (Int -> MIRPot -> ShowS
[MIRPot] -> ShowS
MIRPot -> [Char]
(Int -> MIRPot -> ShowS)
-> (MIRPot -> [Char]) -> ([MIRPot] -> ShowS) -> Show MIRPot
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MIRPot -> ShowS
showsPrec :: Int -> MIRPot -> ShowS
$cshow :: MIRPot -> [Char]
show :: MIRPot -> [Char]
$cshowList :: [MIRPot] -> ShowS
showList :: [MIRPot] -> ShowS
Show, (forall x. MIRPot -> Rep MIRPot x)
-> (forall x. Rep MIRPot x -> MIRPot) -> Generic MIRPot
forall x. Rep MIRPot x -> MIRPot
forall x. MIRPot -> Rep MIRPot x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. MIRPot -> Rep MIRPot x
from :: forall x. MIRPot -> Rep MIRPot x
$cto :: forall x. Rep MIRPot x -> MIRPot
to :: forall x. Rep MIRPot x -> MIRPot
Generic, MIRPot -> MIRPot -> Bool
(MIRPot -> MIRPot -> Bool)
-> (MIRPot -> MIRPot -> Bool) -> Eq MIRPot
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MIRPot -> MIRPot -> Bool
== :: MIRPot -> MIRPot -> Bool
$c/= :: MIRPot -> MIRPot -> Bool
/= :: MIRPot -> MIRPot -> Bool
Eq, MIRPot -> ()
(MIRPot -> ()) -> NFData MIRPot
forall a. (a -> ()) -> NFData a
$crnf :: MIRPot -> ()
rnf :: MIRPot -> ()
NFData, Eq MIRPot
Eq MIRPot =>
(MIRPot -> MIRPot -> Ordering)
-> (MIRPot -> MIRPot -> Bool)
-> (MIRPot -> MIRPot -> Bool)
-> (MIRPot -> MIRPot -> Bool)
-> (MIRPot -> MIRPot -> Bool)
-> (MIRPot -> MIRPot -> MIRPot)
-> (MIRPot -> MIRPot -> MIRPot)
-> Ord MIRPot
MIRPot -> MIRPot -> Bool
MIRPot -> MIRPot -> Ordering
MIRPot -> MIRPot -> MIRPot
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: MIRPot -> MIRPot -> Ordering
compare :: MIRPot -> MIRPot -> Ordering
$c< :: MIRPot -> MIRPot -> Bool
< :: MIRPot -> MIRPot -> Bool
$c<= :: MIRPot -> MIRPot -> Bool
<= :: MIRPot -> MIRPot -> Bool
$c> :: MIRPot -> MIRPot -> Bool
> :: MIRPot -> MIRPot -> Bool
$c>= :: MIRPot -> MIRPot -> Bool
>= :: MIRPot -> MIRPot -> Bool
$cmax :: MIRPot -> MIRPot -> MIRPot
max :: MIRPot -> MIRPot -> MIRPot
$cmin :: MIRPot -> MIRPot -> MIRPot
min :: MIRPot -> MIRPot -> MIRPot
Ord, Int -> MIRPot
MIRPot -> Int
MIRPot -> [MIRPot]
MIRPot -> MIRPot
MIRPot -> MIRPot -> [MIRPot]
MIRPot -> MIRPot -> MIRPot -> [MIRPot]
(MIRPot -> MIRPot)
-> (MIRPot -> MIRPot)
-> (Int -> MIRPot)
-> (MIRPot -> Int)
-> (MIRPot -> [MIRPot])
-> (MIRPot -> MIRPot -> [MIRPot])
-> (MIRPot -> MIRPot -> [MIRPot])
-> (MIRPot -> MIRPot -> MIRPot -> [MIRPot])
-> Enum MIRPot
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: MIRPot -> MIRPot
succ :: MIRPot -> MIRPot
$cpred :: MIRPot -> MIRPot
pred :: MIRPot -> MIRPot
$ctoEnum :: Int -> MIRPot
toEnum :: Int -> MIRPot
$cfromEnum :: MIRPot -> Int
fromEnum :: MIRPot -> Int
$cenumFrom :: MIRPot -> [MIRPot]
enumFrom :: MIRPot -> [MIRPot]
$cenumFromThen :: MIRPot -> MIRPot -> [MIRPot]
enumFromThen :: MIRPot -> MIRPot -> [MIRPot]
$cenumFromTo :: MIRPot -> MIRPot -> [MIRPot]
enumFromTo :: MIRPot -> MIRPot -> [MIRPot]
$cenumFromThenTo :: MIRPot -> MIRPot -> MIRPot -> [MIRPot]
enumFromThenTo :: MIRPot -> MIRPot -> MIRPot -> [MIRPot]
Enum, MIRPot
MIRPot -> MIRPot -> Bounded MIRPot
forall a. a -> a -> Bounded a
$cminBound :: MIRPot
minBound :: MIRPot
$cmaxBound :: MIRPot
maxBound :: MIRPot
Bounded)

deriving instance NoThunks MIRPot

instance EncCBOR MIRPot where
  encCBOR :: MIRPot -> Encoding
encCBOR MIRPot
ReservesMIR = Word8 -> Encoding
encodeWord8 Word8
0
  encCBOR MIRPot
TreasuryMIR = Word8 -> Encoding
encodeWord8 Word8
1

instance DecCBOR MIRPot where
  decCBOR :: forall s. Decoder s MIRPot
decCBOR =
    Decoder s Word
forall s. Decoder s Word
decodeWord Decoder s Word -> (Word -> Decoder s MIRPot) -> Decoder s MIRPot
forall a b. Decoder s a -> (a -> Decoder s b) -> Decoder s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Word
0 -> MIRPot -> Decoder s MIRPot
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure MIRPot
ReservesMIR
      Word
1 -> MIRPot -> Decoder s MIRPot
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure MIRPot
TreasuryMIR
      Word
k -> Word -> Decoder s MIRPot
forall a (m :: * -> *). (Typeable a, MonadFail m) => Word -> m a
invalidKey Word
k

instance ToJSON MIRPot where
  toJSON :: MIRPot -> Value
toJSON = \case
    MIRPot
ReservesMIR -> Value
"reserves"
    MIRPot
TreasuryMIR -> Value
"treasury"

-- | MIRTarget specifies if funds from either the reserves
-- or the treasury are to be handed out to a collection of
-- reward accounts or instead transfered to the opposite pot.
data MIRTarget
  = StakeAddressesMIR !(Map (Credential 'Staking) DeltaCoin)
  | SendToOppositePotMIR !Coin
  deriving (Int -> MIRTarget -> ShowS
[MIRTarget] -> ShowS
MIRTarget -> [Char]
(Int -> MIRTarget -> ShowS)
-> (MIRTarget -> [Char])
-> ([MIRTarget] -> ShowS)
-> Show MIRTarget
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MIRTarget -> ShowS
showsPrec :: Int -> MIRTarget -> ShowS
$cshow :: MIRTarget -> [Char]
show :: MIRTarget -> [Char]
$cshowList :: [MIRTarget] -> ShowS
showList :: [MIRTarget] -> ShowS
Show, (forall x. MIRTarget -> Rep MIRTarget x)
-> (forall x. Rep MIRTarget x -> MIRTarget) -> Generic MIRTarget
forall x. Rep MIRTarget x -> MIRTarget
forall x. MIRTarget -> Rep MIRTarget x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. MIRTarget -> Rep MIRTarget x
from :: forall x. MIRTarget -> Rep MIRTarget x
$cto :: forall x. Rep MIRTarget x -> MIRTarget
to :: forall x. Rep MIRTarget x -> MIRTarget
Generic, MIRTarget -> MIRTarget -> Bool
(MIRTarget -> MIRTarget -> Bool)
-> (MIRTarget -> MIRTarget -> Bool) -> Eq MIRTarget
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MIRTarget -> MIRTarget -> Bool
== :: MIRTarget -> MIRTarget -> Bool
$c/= :: MIRTarget -> MIRTarget -> Bool
/= :: MIRTarget -> MIRTarget -> Bool
Eq, Eq MIRTarget
Eq MIRTarget =>
(MIRTarget -> MIRTarget -> Ordering)
-> (MIRTarget -> MIRTarget -> Bool)
-> (MIRTarget -> MIRTarget -> Bool)
-> (MIRTarget -> MIRTarget -> Bool)
-> (MIRTarget -> MIRTarget -> Bool)
-> (MIRTarget -> MIRTarget -> MIRTarget)
-> (MIRTarget -> MIRTarget -> MIRTarget)
-> Ord MIRTarget
MIRTarget -> MIRTarget -> Bool
MIRTarget -> MIRTarget -> Ordering
MIRTarget -> MIRTarget -> MIRTarget
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: MIRTarget -> MIRTarget -> Ordering
compare :: MIRTarget -> MIRTarget -> Ordering
$c< :: MIRTarget -> MIRTarget -> Bool
< :: MIRTarget -> MIRTarget -> Bool
$c<= :: MIRTarget -> MIRTarget -> Bool
<= :: MIRTarget -> MIRTarget -> Bool
$c> :: MIRTarget -> MIRTarget -> Bool
> :: MIRTarget -> MIRTarget -> Bool
$c>= :: MIRTarget -> MIRTarget -> Bool
>= :: MIRTarget -> MIRTarget -> Bool
$cmax :: MIRTarget -> MIRTarget -> MIRTarget
max :: MIRTarget -> MIRTarget -> MIRTarget
$cmin :: MIRTarget -> MIRTarget -> MIRTarget
min :: MIRTarget -> MIRTarget -> MIRTarget
Ord, MIRTarget -> ()
(MIRTarget -> ()) -> NFData MIRTarget
forall a. (a -> ()) -> NFData a
$crnf :: MIRTarget -> ()
rnf :: MIRTarget -> ()
NFData)

deriving instance NoThunks MIRTarget

instance DecCBOR MIRTarget where
  decCBOR :: forall s. Decoder s MIRTarget
decCBOR = do
    Decoder s TokenType
forall s. Decoder s TokenType
peekTokenType Decoder s TokenType
-> (TokenType -> Decoder s MIRTarget) -> Decoder s MIRTarget
forall a b. Decoder s a -> (a -> Decoder s b) -> Decoder s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      TokenType
TypeMapLen -> Map StakeCredential DeltaCoin -> MIRTarget
StakeAddressesMIR (Map StakeCredential DeltaCoin -> MIRTarget)
-> Decoder s (Map StakeCredential DeltaCoin) -> Decoder s MIRTarget
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (Map StakeCredential DeltaCoin)
forall s. Decoder s (Map StakeCredential DeltaCoin)
forall a s. DecCBOR a => Decoder s a
decCBOR
      TokenType
TypeMapLen64 -> Map StakeCredential DeltaCoin -> MIRTarget
StakeAddressesMIR (Map StakeCredential DeltaCoin -> MIRTarget)
-> Decoder s (Map StakeCredential DeltaCoin) -> Decoder s MIRTarget
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (Map StakeCredential DeltaCoin)
forall s. Decoder s (Map StakeCredential DeltaCoin)
forall a s. DecCBOR a => Decoder s a
decCBOR
      TokenType
TypeMapLenIndef -> Map StakeCredential DeltaCoin -> MIRTarget
StakeAddressesMIR (Map StakeCredential DeltaCoin -> MIRTarget)
-> Decoder s (Map StakeCredential DeltaCoin) -> Decoder s MIRTarget
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (Map StakeCredential DeltaCoin)
forall s. Decoder s (Map StakeCredential DeltaCoin)
forall a s. DecCBOR a => Decoder s a
decCBOR
      TokenType
_ -> Coin -> MIRTarget
SendToOppositePotMIR (Coin -> MIRTarget) -> Decoder s Coin -> Decoder s MIRTarget
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Coin
forall s. Decoder s Coin
forall a s. DecCBOR a => Decoder s a
decCBOR

instance EncCBOR MIRTarget where
  encCBOR :: MIRTarget -> Encoding
encCBOR = \case
    StakeAddressesMIR Map StakeCredential DeltaCoin
m -> Map StakeCredential DeltaCoin -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR Map StakeCredential DeltaCoin
m
    SendToOppositePotMIR Coin
c -> Coin -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR Coin
c

instance ToJSON MIRTarget where
  toJSON :: MIRTarget -> Value
toJSON = \case
    StakeAddressesMIR Map StakeCredential DeltaCoin
mirAddresses ->
      Text -> [Pair] -> Value
kindObject Text
"StakeAddressesMIR" [Key
"addresses" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Map StakeCredential DeltaCoin -> Value
forall a. ToJSON a => a -> Value
toJSON Map StakeCredential DeltaCoin
mirAddresses]
    SendToOppositePotMIR Coin
c ->
      Text -> [Pair] -> Value
kindObject Text
"SendToOppositePotMIR" [Key
"coin" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Coin -> Value
forall a. ToJSON a => a -> Value
toJSON Coin
c]

-- | Move instantaneous rewards certificate
data MIRCert = MIRCert
  { MIRCert -> MIRPot
mirPot :: !MIRPot
  , MIRCert -> MIRTarget
mirRewards :: !MIRTarget
  }
  deriving (Int -> MIRCert -> ShowS
[MIRCert] -> ShowS
MIRCert -> [Char]
(Int -> MIRCert -> ShowS)
-> (MIRCert -> [Char]) -> ([MIRCert] -> ShowS) -> Show MIRCert
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MIRCert -> ShowS
showsPrec :: Int -> MIRCert -> ShowS
$cshow :: MIRCert -> [Char]
show :: MIRCert -> [Char]
$cshowList :: [MIRCert] -> ShowS
showList :: [MIRCert] -> ShowS
Show, (forall x. MIRCert -> Rep MIRCert x)
-> (forall x. Rep MIRCert x -> MIRCert) -> Generic MIRCert
forall x. Rep MIRCert x -> MIRCert
forall x. MIRCert -> Rep MIRCert x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. MIRCert -> Rep MIRCert x
from :: forall x. MIRCert -> Rep MIRCert x
$cto :: forall x. Rep MIRCert x -> MIRCert
to :: forall x. Rep MIRCert x -> MIRCert
Generic, MIRCert -> MIRCert -> Bool
(MIRCert -> MIRCert -> Bool)
-> (MIRCert -> MIRCert -> Bool) -> Eq MIRCert
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MIRCert -> MIRCert -> Bool
== :: MIRCert -> MIRCert -> Bool
$c/= :: MIRCert -> MIRCert -> Bool
/= :: MIRCert -> MIRCert -> Bool
Eq, Eq MIRCert
Eq MIRCert =>
(MIRCert -> MIRCert -> Ordering)
-> (MIRCert -> MIRCert -> Bool)
-> (MIRCert -> MIRCert -> Bool)
-> (MIRCert -> MIRCert -> Bool)
-> (MIRCert -> MIRCert -> Bool)
-> (MIRCert -> MIRCert -> MIRCert)
-> (MIRCert -> MIRCert -> MIRCert)
-> Ord MIRCert
MIRCert -> MIRCert -> Bool
MIRCert -> MIRCert -> Ordering
MIRCert -> MIRCert -> MIRCert
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: MIRCert -> MIRCert -> Ordering
compare :: MIRCert -> MIRCert -> Ordering
$c< :: MIRCert -> MIRCert -> Bool
< :: MIRCert -> MIRCert -> Bool
$c<= :: MIRCert -> MIRCert -> Bool
<= :: MIRCert -> MIRCert -> Bool
$c> :: MIRCert -> MIRCert -> Bool
> :: MIRCert -> MIRCert -> Bool
$c>= :: MIRCert -> MIRCert -> Bool
>= :: MIRCert -> MIRCert -> Bool
$cmax :: MIRCert -> MIRCert -> MIRCert
max :: MIRCert -> MIRCert -> MIRCert
$cmin :: MIRCert -> MIRCert -> MIRCert
min :: MIRCert -> MIRCert -> MIRCert
Ord, MIRCert -> ()
(MIRCert -> ()) -> NFData MIRCert
forall a. (a -> ()) -> NFData a
$crnf :: MIRCert -> ()
rnf :: MIRCert -> ()
NFData)

instance NoThunks MIRCert

instance DecCBOR MIRCert where
  decCBOR :: forall s. Decoder s MIRCert
decCBOR =
    Text -> (MIRCert -> Int) -> Decoder s MIRCert -> Decoder s MIRCert
forall a s. Text -> (a -> Int) -> Decoder s a -> Decoder s a
decodeRecordNamed Text
"MIRCert" (Int -> MIRCert -> Int
forall a b. a -> b -> a
const Int
2) (MIRPot -> MIRTarget -> MIRCert
MIRCert (MIRPot -> MIRTarget -> MIRCert)
-> Decoder s MIRPot -> Decoder s (MIRTarget -> MIRCert)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s MIRPot
forall s. Decoder s MIRPot
forall a s. DecCBOR a => Decoder s a
decCBOR Decoder s (MIRTarget -> MIRCert)
-> Decoder s MIRTarget -> Decoder s MIRCert
forall a b. Decoder s (a -> b) -> Decoder s a -> Decoder s b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s MIRTarget
forall s. Decoder s MIRTarget
forall a s. DecCBOR a => Decoder s a
decCBOR)

instance EncCBOR MIRCert where
  encCBOR :: MIRCert -> Encoding
encCBOR (MIRCert MIRPot
pot MIRTarget
targets) =
    Word -> Encoding
encodeListLen Word
2 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> MIRPot -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR MIRPot
pot Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> MIRTarget -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR MIRTarget
targets

instance ToJSON MIRCert where
  toJSON :: MIRCert -> Value
toJSON MIRCert {MIRPot
mirPot :: MIRCert -> MIRPot
mirPot :: MIRPot
mirPot, MIRTarget
mirRewards :: MIRCert -> MIRTarget
mirRewards :: MIRTarget
mirRewards} =
    Text -> [Pair] -> Value
kindObject Text
"MIRCert" ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$
      [ Key
"pot" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= MIRPot -> Value
forall a. ToJSON a => a -> Value
toJSON MIRPot
mirPot
      , Key
"rewards" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= MIRTarget -> Value
forall a. ToJSON a => a -> Value
toJSON MIRTarget
mirRewards
      ]

-- | A heavyweight certificate.
data ShelleyTxCert era
  = ShelleyTxCertDelegCert !ShelleyDelegCert
  | ShelleyTxCertPool !PoolCert
  | ShelleyTxCertGenesisDeleg !GenesisDelegCert
  | ShelleyTxCertMir !MIRCert
  deriving (Int -> ShelleyTxCert era -> ShowS
[ShelleyTxCert era] -> ShowS
ShelleyTxCert era -> [Char]
(Int -> ShelleyTxCert era -> ShowS)
-> (ShelleyTxCert era -> [Char])
-> ([ShelleyTxCert era] -> ShowS)
-> Show (ShelleyTxCert era)
forall era. Int -> ShelleyTxCert era -> ShowS
forall era. [ShelleyTxCert era] -> ShowS
forall era. ShelleyTxCert era -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall era. Int -> ShelleyTxCert era -> ShowS
showsPrec :: Int -> ShelleyTxCert era -> ShowS
$cshow :: forall era. ShelleyTxCert era -> [Char]
show :: ShelleyTxCert era -> [Char]
$cshowList :: forall era. [ShelleyTxCert era] -> ShowS
showList :: [ShelleyTxCert era] -> ShowS
Show, (forall x. ShelleyTxCert era -> Rep (ShelleyTxCert era) x)
-> (forall x. Rep (ShelleyTxCert era) x -> ShelleyTxCert era)
-> Generic (ShelleyTxCert era)
forall x. Rep (ShelleyTxCert era) x -> ShelleyTxCert era
forall x. ShelleyTxCert era -> Rep (ShelleyTxCert era) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x. Rep (ShelleyTxCert era) x -> ShelleyTxCert era
forall era x. ShelleyTxCert era -> Rep (ShelleyTxCert era) x
$cfrom :: forall era x. ShelleyTxCert era -> Rep (ShelleyTxCert era) x
from :: forall x. ShelleyTxCert era -> Rep (ShelleyTxCert era) x
$cto :: forall era x. Rep (ShelleyTxCert era) x -> ShelleyTxCert era
to :: forall x. Rep (ShelleyTxCert era) x -> ShelleyTxCert era
Generic, ShelleyTxCert era -> ShelleyTxCert era -> Bool
(ShelleyTxCert era -> ShelleyTxCert era -> Bool)
-> (ShelleyTxCert era -> ShelleyTxCert era -> Bool)
-> Eq (ShelleyTxCert era)
forall era. ShelleyTxCert era -> ShelleyTxCert era -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall era. ShelleyTxCert era -> ShelleyTxCert era -> Bool
== :: ShelleyTxCert era -> ShelleyTxCert era -> Bool
$c/= :: forall era. ShelleyTxCert era -> ShelleyTxCert era -> Bool
/= :: ShelleyTxCert era -> ShelleyTxCert era -> Bool
Eq, Eq (ShelleyTxCert era)
Eq (ShelleyTxCert era) =>
(ShelleyTxCert era -> ShelleyTxCert era -> Ordering)
-> (ShelleyTxCert era -> ShelleyTxCert era -> Bool)
-> (ShelleyTxCert era -> ShelleyTxCert era -> Bool)
-> (ShelleyTxCert era -> ShelleyTxCert era -> Bool)
-> (ShelleyTxCert era -> ShelleyTxCert era -> Bool)
-> (ShelleyTxCert era -> ShelleyTxCert era -> ShelleyTxCert era)
-> (ShelleyTxCert era -> ShelleyTxCert era -> ShelleyTxCert era)
-> Ord (ShelleyTxCert era)
ShelleyTxCert era -> ShelleyTxCert era -> Bool
ShelleyTxCert era -> ShelleyTxCert era -> Ordering
ShelleyTxCert era -> ShelleyTxCert era -> ShelleyTxCert era
forall era. Eq (ShelleyTxCert era)
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall era. ShelleyTxCert era -> ShelleyTxCert era -> Bool
forall era. ShelleyTxCert era -> ShelleyTxCert era -> Ordering
forall era.
ShelleyTxCert era -> ShelleyTxCert era -> ShelleyTxCert era
$ccompare :: forall era. ShelleyTxCert era -> ShelleyTxCert era -> Ordering
compare :: ShelleyTxCert era -> ShelleyTxCert era -> Ordering
$c< :: forall era. ShelleyTxCert era -> ShelleyTxCert era -> Bool
< :: ShelleyTxCert era -> ShelleyTxCert era -> Bool
$c<= :: forall era. ShelleyTxCert era -> ShelleyTxCert era -> Bool
<= :: ShelleyTxCert era -> ShelleyTxCert era -> Bool
$c> :: forall era. ShelleyTxCert era -> ShelleyTxCert era -> Bool
> :: ShelleyTxCert era -> ShelleyTxCert era -> Bool
$c>= :: forall era. ShelleyTxCert era -> ShelleyTxCert era -> Bool
>= :: ShelleyTxCert era -> ShelleyTxCert era -> Bool
$cmax :: forall era.
ShelleyTxCert era -> ShelleyTxCert era -> ShelleyTxCert era
max :: ShelleyTxCert era -> ShelleyTxCert era -> ShelleyTxCert era
$cmin :: forall era.
ShelleyTxCert era -> ShelleyTxCert era -> ShelleyTxCert era
min :: ShelleyTxCert era -> ShelleyTxCert era -> ShelleyTxCert era
Ord, ShelleyTxCert era -> ()
(ShelleyTxCert era -> ()) -> NFData (ShelleyTxCert era)
forall era. ShelleyTxCert era -> ()
forall a. (a -> ()) -> NFData a
$crnf :: forall era. ShelleyTxCert era -> ()
rnf :: ShelleyTxCert era -> ()
NFData)

instance NoThunks (ShelleyTxCert era)

instance Era era => ToJSON (ShelleyTxCert era) where
  toJSON :: ShelleyTxCert era -> Value
toJSON = \case
    ShelleyTxCertDelegCert ShelleyDelegCert
delegCert -> ShelleyDelegCert -> Value
forall a. ToJSON a => a -> Value
toJSON ShelleyDelegCert
delegCert
    ShelleyTxCertPool PoolCert
poolCert -> PoolCert -> Value
forall a. ToJSON a => a -> Value
toJSON PoolCert
poolCert
    ShelleyTxCertGenesisDeleg GenesisDelegCert
genDelegCert -> GenesisDelegCert -> Value
forall a. ToJSON a => a -> Value
toJSON GenesisDelegCert
genDelegCert
    ShelleyTxCertMir MIRCert
mirCert -> MIRCert -> Value
forall a. ToJSON a => a -> Value
toJSON MIRCert
mirCert

upgradeShelleyTxCert ::
  ShelleyTxCert era1 ->
  ShelleyTxCert era2
upgradeShelleyTxCert :: forall era1 era2. ShelleyTxCert era1 -> ShelleyTxCert era2
upgradeShelleyTxCert = \case
  ShelleyTxCertDelegCert ShelleyDelegCert
cert -> ShelleyDelegCert -> ShelleyTxCert era2
forall era. ShelleyDelegCert -> ShelleyTxCert era
ShelleyTxCertDelegCert ShelleyDelegCert
cert
  ShelleyTxCertPool PoolCert
cert -> PoolCert -> ShelleyTxCert era2
forall era. PoolCert -> ShelleyTxCert era
ShelleyTxCertPool PoolCert
cert
  ShelleyTxCertGenesisDeleg GenesisDelegCert
cert -> GenesisDelegCert -> ShelleyTxCert era2
forall era. GenesisDelegCert -> ShelleyTxCert era
ShelleyTxCertGenesisDeleg GenesisDelegCert
cert
  ShelleyTxCertMir MIRCert
cert -> MIRCert -> ShelleyTxCert era2
forall era. MIRCert -> ShelleyTxCert era
ShelleyTxCertMir MIRCert
cert

-- CBOR

instance Era era => EncCBOR (ShelleyTxCert era) where
  encCBOR :: ShelleyTxCert era -> Encoding
encCBOR = \case
    ShelleyTxCertDelegCert ShelleyDelegCert
delegCert -> ShelleyDelegCert -> Encoding
encodeShelleyDelegCert ShelleyDelegCert
delegCert
    ShelleyTxCertPool PoolCert
poolCert -> PoolCert -> Encoding
encodePoolCert PoolCert
poolCert
    ShelleyTxCertGenesisDeleg GenesisDelegCert
constCert -> GenesisDelegCert -> Encoding
encodeGenesisDelegCert GenesisDelegCert
constCert
    ShelleyTxCertMir MIRCert
mir ->
      Word -> Encoding
encodeListLen Word
2 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word8 -> Encoding
encodeWord8 Word8
6 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> MIRCert -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR MIRCert
mir

encodeShelleyDelegCert :: ShelleyDelegCert -> Encoding
encodeShelleyDelegCert :: ShelleyDelegCert -> Encoding
encodeShelleyDelegCert = \case
  ShelleyRegCert StakeCredential
cred ->
    Word -> Encoding
encodeListLen Word
2 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word8 -> Encoding
encodeWord8 Word8
0 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> StakeCredential -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR StakeCredential
cred
  ShelleyUnRegCert StakeCredential
cred ->
    Word -> Encoding
encodeListLen Word
2 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word8 -> Encoding
encodeWord8 Word8
1 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> StakeCredential -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR StakeCredential
cred
  ShelleyDelegCert StakeCredential
cred KeyHash 'StakePool
poolId ->
    Word -> Encoding
encodeListLen Word
3 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word8 -> Encoding
encodeWord8 Word8
2 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> StakeCredential -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR StakeCredential
cred Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> KeyHash 'StakePool -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR KeyHash 'StakePool
poolId

encodePoolCert :: PoolCert -> Encoding
encodePoolCert :: PoolCert -> Encoding
encodePoolCert = \case
  RegPool PoolParams
poolParams ->
    Word -> Encoding
encodeListLen (Word
1 Word -> Word -> Word
forall a. Num a => a -> a -> a
+ PoolParams -> Word
forall a. EncCBORGroup a => a -> Word
listLen PoolParams
poolParams)
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word8 -> Encoding
encodeWord8 Word8
3
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> PoolParams -> Encoding
forall a. EncCBORGroup a => a -> Encoding
encCBORGroup PoolParams
poolParams
  RetirePool KeyHash 'StakePool
vk EpochNo
epoch ->
    Word -> Encoding
encodeListLen Word
3
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word8 -> Encoding
encodeWord8 Word8
4
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> KeyHash 'StakePool -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR KeyHash 'StakePool
vk
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> EpochNo -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR EpochNo
epoch

encodeGenesisDelegCert :: GenesisDelegCert -> Encoding
encodeGenesisDelegCert :: GenesisDelegCert -> Encoding
encodeGenesisDelegCert (GenesisDelegCert KeyHash 'Genesis
gk KeyHash 'GenesisDelegate
kh VRFVerKeyHash 'GenDelegVRF
vrf) =
  Word -> Encoding
encodeListLen Word
4
    Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word8 -> Encoding
encodeWord8 Word8
5
    Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> KeyHash 'Genesis -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR KeyHash 'Genesis
gk
    Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> KeyHash 'GenesisDelegate -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR KeyHash 'GenesisDelegate
kh
    Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> VRFVerKeyHash 'GenDelegVRF -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR VRFVerKeyHash 'GenDelegVRF
vrf

instance Era era => ToCBOR (ShelleyTxCert era) where
  toCBOR :: ShelleyTxCert era -> Encoding
toCBOR = forall era t. (Era era, EncCBOR t) => t -> Encoding
toEraCBOR @era

instance
  ( ShelleyEraTxCert era
  , TxCert era ~ ShelleyTxCert era
  ) =>
  FromCBOR (ShelleyTxCert era)
  where
  fromCBOR :: forall s. Decoder s (ShelleyTxCert era)
fromCBOR = forall era t s. (Era era, DecCBOR t) => Decoder s t
fromEraCBOR @era

instance
  ( ShelleyEraTxCert era
  , TxCert era ~ ShelleyTxCert era
  ) =>
  DecCBOR (ShelleyTxCert era)
  where
  decCBOR :: forall s. Decoder s (ShelleyTxCert era)
decCBOR = Text
-> (Word -> Decoder s (Int, ShelleyTxCert era))
-> Decoder s (ShelleyTxCert era)
forall s a. Text -> (Word -> Decoder s (Int, a)) -> Decoder s a
decodeRecordSum Text
"ShelleyTxCert" ((Word -> Decoder s (Int, ShelleyTxCert era))
 -> Decoder s (ShelleyTxCert era))
-> (Word -> Decoder s (Int, ShelleyTxCert era))
-> Decoder s (ShelleyTxCert era)
forall a b. (a -> b) -> a -> b
$ \case
    Word
t
      | Word
0 Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
<= Word
t Bool -> Bool -> Bool
&& Word
t Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
< Word
3 -> Word -> Decoder s (Int, TxCert era)
forall era s.
ShelleyEraTxCert era =>
Word -> Decoder s (Int, TxCert era)
shelleyTxCertDelegDecoder Word
t
      | Word
3 Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
<= Word
t Bool -> Bool -> Bool
&& Word
t Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
< Word
5 -> Word -> Decoder s (Int, TxCert era)
forall era s. EraTxCert era => Word -> Decoder s (Int, TxCert era)
poolTxCertDecoder Word
t
    Word
5 -> do
      KeyHash 'Genesis
gen <- Decoder s (KeyHash 'Genesis)
forall s. Decoder s (KeyHash 'Genesis)
forall a s. DecCBOR a => Decoder s a
decCBOR
      KeyHash 'GenesisDelegate
genDeleg <- Decoder s (KeyHash 'GenesisDelegate)
forall s. Decoder s (KeyHash 'GenesisDelegate)
forall a s. DecCBOR a => Decoder s a
decCBOR
      VRFVerKeyHash 'GenDelegVRF
vrf <- Decoder s (VRFVerKeyHash 'GenDelegVRF)
forall s. Decoder s (VRFVerKeyHash 'GenDelegVRF)
forall a s. DecCBOR a => Decoder s a
decCBOR
      (Int, ShelleyTxCert era) -> Decoder s (Int, ShelleyTxCert era)
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
4, GenesisDelegCert -> ShelleyTxCert era
forall era. GenesisDelegCert -> ShelleyTxCert era
ShelleyTxCertGenesisDeleg (GenesisDelegCert -> ShelleyTxCert era)
-> GenesisDelegCert -> ShelleyTxCert era
forall a b. (a -> b) -> a -> b
$ KeyHash 'Genesis
-> KeyHash 'GenesisDelegate
-> VRFVerKeyHash 'GenDelegVRF
-> GenesisDelegCert
GenesisDelegCert KeyHash 'Genesis
gen KeyHash 'GenesisDelegate
genDeleg VRFVerKeyHash 'GenDelegVRF
vrf)
    Word
6 -> do
      MIRCert
x <- Decoder s MIRCert
forall s. Decoder s MIRCert
forall a s. DecCBOR a => Decoder s a
decCBOR
      (Int, ShelleyTxCert era) -> Decoder s (Int, ShelleyTxCert era)
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
2, MIRCert -> ShelleyTxCert era
forall era. MIRCert -> ShelleyTxCert era
ShelleyTxCertMir MIRCert
x)
    Word
x -> Word -> Decoder s (Int, ShelleyTxCert era)
forall a (m :: * -> *). (Typeable a, MonadFail m) => Word -> m a
invalidKey Word
x
  {-# INLINE decCBOR #-}

shelleyTxCertDelegDecoder ::
  ShelleyEraTxCert era =>
  Word ->
  Decoder s (Int, TxCert era)
shelleyTxCertDelegDecoder :: forall era s.
ShelleyEraTxCert era =>
Word -> Decoder s (Int, TxCert era)
shelleyTxCertDelegDecoder = \case
  Word
0 -> do
    StakeCredential
cred <- Decoder s StakeCredential
forall s. Decoder s StakeCredential
forall a s. DecCBOR a => Decoder s a
decCBOR
    (Int, TxCert era) -> Decoder s (Int, TxCert era)
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
2, StakeCredential -> TxCert era
forall era. ShelleyEraTxCert era => StakeCredential -> TxCert era
RegTxCert StakeCredential
cred)
  Word
1 -> do
    StakeCredential
cred <- Decoder s StakeCredential
forall s. Decoder s StakeCredential
forall a s. DecCBOR a => Decoder s a
decCBOR
    (Int, TxCert era) -> Decoder s (Int, TxCert era)
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
2, StakeCredential -> TxCert era
forall era. ShelleyEraTxCert era => StakeCredential -> TxCert era
UnRegTxCert StakeCredential
cred)
  Word
2 -> do
    StakeCredential
cred <- Decoder s StakeCredential
forall s. Decoder s StakeCredential
forall a s. DecCBOR a => Decoder s a
decCBOR
    KeyHash 'StakePool
stakePool <- Decoder s (KeyHash 'StakePool)
forall s. Decoder s (KeyHash 'StakePool)
forall a s. DecCBOR a => Decoder s a
decCBOR
    (Int, TxCert era) -> Decoder s (Int, TxCert era)
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
3, StakeCredential -> KeyHash 'StakePool -> TxCert era
forall era.
ShelleyEraTxCert era =>
StakeCredential -> KeyHash 'StakePool -> TxCert era
DelegStakeTxCert StakeCredential
cred KeyHash 'StakePool
stakePool)
  Word
k -> Word -> Decoder s (Int, TxCert era)
forall a (m :: * -> *). (Typeable a, MonadFail m) => Word -> m a
invalidKey Word
k
{-# INLINE shelleyTxCertDelegDecoder #-}

poolTxCertDecoder :: EraTxCert era => Word -> Decoder s (Int, TxCert era)
poolTxCertDecoder :: forall era s. EraTxCert era => Word -> Decoder s (Int, TxCert era)
poolTxCertDecoder = \case
  Word
3 -> do
    PoolParams
group <- Decoder s PoolParams
forall s. Decoder s PoolParams
forall a s. DecCBORGroup a => Decoder s a
decCBORGroup
    (Int, TxCert era) -> Decoder s (Int, TxCert era)
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ PoolParams -> Int
forall a. EncCBORGroup a => a -> Int
listLenInt PoolParams
group, PoolParams -> TxCert era
forall era. EraTxCert era => PoolParams -> TxCert era
RegPoolTxCert PoolParams
group)
  Word
4 -> do
    KeyHash 'StakePool
a <- Decoder s (KeyHash 'StakePool)
forall s. Decoder s (KeyHash 'StakePool)
forall a s. DecCBOR a => Decoder s a
decCBOR
    EpochNo
b <- Decoder s EpochNo
forall s. Decoder s EpochNo
forall a s. DecCBOR a => Decoder s a
decCBOR
    (Int, TxCert era) -> Decoder s (Int, TxCert era)
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
3, KeyHash 'StakePool -> EpochNo -> TxCert era
forall era.
EraTxCert era =>
KeyHash 'StakePool -> EpochNo -> TxCert era
RetirePoolTxCert KeyHash 'StakePool
a EpochNo
b)
  Word
k -> Word -> Decoder s (Int, TxCert era)
forall a (m :: * -> *). (Typeable a, MonadFail m) => Word -> m a
invalidKey Word
k
{-# INLINE poolTxCertDecoder #-}

data ShelleyDelegCert
  = -- | A stake credential registration certificate.
    ShelleyRegCert !StakeCredential
  | -- | A stake credential deregistration certificate.
    ShelleyUnRegCert !StakeCredential
  | -- | A stake delegation certificate.
    ShelleyDelegCert !StakeCredential !(KeyHash 'StakePool)
  deriving (Int -> ShelleyDelegCert -> ShowS
[ShelleyDelegCert] -> ShowS
ShelleyDelegCert -> [Char]
(Int -> ShelleyDelegCert -> ShowS)
-> (ShelleyDelegCert -> [Char])
-> ([ShelleyDelegCert] -> ShowS)
-> Show ShelleyDelegCert
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ShelleyDelegCert -> ShowS
showsPrec :: Int -> ShelleyDelegCert -> ShowS
$cshow :: ShelleyDelegCert -> [Char]
show :: ShelleyDelegCert -> [Char]
$cshowList :: [ShelleyDelegCert] -> ShowS
showList :: [ShelleyDelegCert] -> ShowS
Show, (forall x. ShelleyDelegCert -> Rep ShelleyDelegCert x)
-> (forall x. Rep ShelleyDelegCert x -> ShelleyDelegCert)
-> Generic ShelleyDelegCert
forall x. Rep ShelleyDelegCert x -> ShelleyDelegCert
forall x. ShelleyDelegCert -> Rep ShelleyDelegCert x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ShelleyDelegCert -> Rep ShelleyDelegCert x
from :: forall x. ShelleyDelegCert -> Rep ShelleyDelegCert x
$cto :: forall x. Rep ShelleyDelegCert x -> ShelleyDelegCert
to :: forall x. Rep ShelleyDelegCert x -> ShelleyDelegCert
Generic, ShelleyDelegCert -> ShelleyDelegCert -> Bool
(ShelleyDelegCert -> ShelleyDelegCert -> Bool)
-> (ShelleyDelegCert -> ShelleyDelegCert -> Bool)
-> Eq ShelleyDelegCert
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ShelleyDelegCert -> ShelleyDelegCert -> Bool
== :: ShelleyDelegCert -> ShelleyDelegCert -> Bool
$c/= :: ShelleyDelegCert -> ShelleyDelegCert -> Bool
/= :: ShelleyDelegCert -> ShelleyDelegCert -> Bool
Eq, Eq ShelleyDelegCert
Eq ShelleyDelegCert =>
(ShelleyDelegCert -> ShelleyDelegCert -> Ordering)
-> (ShelleyDelegCert -> ShelleyDelegCert -> Bool)
-> (ShelleyDelegCert -> ShelleyDelegCert -> Bool)
-> (ShelleyDelegCert -> ShelleyDelegCert -> Bool)
-> (ShelleyDelegCert -> ShelleyDelegCert -> Bool)
-> (ShelleyDelegCert -> ShelleyDelegCert -> ShelleyDelegCert)
-> (ShelleyDelegCert -> ShelleyDelegCert -> ShelleyDelegCert)
-> Ord ShelleyDelegCert
ShelleyDelegCert -> ShelleyDelegCert -> Bool
ShelleyDelegCert -> ShelleyDelegCert -> Ordering
ShelleyDelegCert -> ShelleyDelegCert -> ShelleyDelegCert
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: ShelleyDelegCert -> ShelleyDelegCert -> Ordering
compare :: ShelleyDelegCert -> ShelleyDelegCert -> Ordering
$c< :: ShelleyDelegCert -> ShelleyDelegCert -> Bool
< :: ShelleyDelegCert -> ShelleyDelegCert -> Bool
$c<= :: ShelleyDelegCert -> ShelleyDelegCert -> Bool
<= :: ShelleyDelegCert -> ShelleyDelegCert -> Bool
$c> :: ShelleyDelegCert -> ShelleyDelegCert -> Bool
> :: ShelleyDelegCert -> ShelleyDelegCert -> Bool
$c>= :: ShelleyDelegCert -> ShelleyDelegCert -> Bool
>= :: ShelleyDelegCert -> ShelleyDelegCert -> Bool
$cmax :: ShelleyDelegCert -> ShelleyDelegCert -> ShelleyDelegCert
max :: ShelleyDelegCert -> ShelleyDelegCert -> ShelleyDelegCert
$cmin :: ShelleyDelegCert -> ShelleyDelegCert -> ShelleyDelegCert
min :: ShelleyDelegCert -> ShelleyDelegCert -> ShelleyDelegCert
Ord)

instance ToJSON ShelleyDelegCert where
  toJSON :: ShelleyDelegCert -> Value
toJSON = \case
    ShelleyRegCert StakeCredential
cred -> Text -> [Pair] -> Value
kindObject Text
"RegCert" [Key
"credential" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= StakeCredential -> Value
forall a. ToJSON a => a -> Value
toJSON StakeCredential
cred]
    ShelleyUnRegCert StakeCredential
cred -> Text -> [Pair] -> Value
kindObject Text
"UnRegCert" [Key
"credential" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= StakeCredential -> Value
forall a. ToJSON a => a -> Value
toJSON StakeCredential
cred]
    ShelleyDelegCert StakeCredential
cred KeyHash 'StakePool
poolId ->
      Text -> [Pair] -> Value
kindObject Text
"DelegCert" ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$
        [ Key
"credential" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= StakeCredential -> Value
forall a. ToJSON a => a -> Value
toJSON StakeCredential
cred
        , Key
"poolId" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= KeyHash 'StakePool -> Value
forall a. ToJSON a => a -> Value
toJSON KeyHash 'StakePool
poolId
        ]

instance NoThunks ShelleyDelegCert

instance NFData ShelleyDelegCert where
  rnf :: ShelleyDelegCert -> ()
rnf = ShelleyDelegCert -> ()
forall a. a -> ()
rwhnf

-- | Check for 'ShelleyDelegCert' constructor
isDelegation :: ShelleyEraTxCert era => TxCert era -> Bool
isDelegation :: forall era. ShelleyEraTxCert era => TxCert era -> Bool
isDelegation (DelegStakeTxCert StakeCredential
_ KeyHash 'StakePool
_) = Bool
True
isDelegation TxCert era
_ = Bool
False

-- | Check for 'GenesisDelegate' constructor
isGenesisDelegation :: (ShelleyEraTxCert era, ProtVerAtMost era 8) => TxCert era -> Bool
isGenesisDelegation :: forall era.
(ShelleyEraTxCert era, ProtVerAtMost era 8) =>
TxCert era -> Bool
isGenesisDelegation = Maybe GenesisDelegCert -> Bool
forall a. Maybe a -> Bool
isJust (Maybe GenesisDelegCert -> Bool)
-> (TxCert era -> Maybe GenesisDelegCert) -> TxCert era -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxCert era -> Maybe GenesisDelegCert
forall era.
(ShelleyEraTxCert era, ProtVerAtMost era 8) =>
TxCert era -> Maybe GenesisDelegCert
getGenesisDelegTxCert

-- | Check for 'RegPool' constructor
isRegPool :: EraTxCert era => TxCert era -> Bool
isRegPool :: forall era. EraTxCert era => TxCert era -> Bool
isRegPool (RegPoolTxCert PoolParams
_) = Bool
True
isRegPool TxCert era
_ = Bool
False

-- | Check for 'RetirePool' constructor
isRetirePool :: EraTxCert era => TxCert era -> Bool
isRetirePool :: forall era. EraTxCert era => TxCert era -> Bool
isRetirePool (RetirePoolTxCert KeyHash 'StakePool
_ EpochNo
_) = Bool
True
isRetirePool TxCert era
_ = Bool
False

isInstantaneousRewards :: (ShelleyEraTxCert era, ProtVerAtMost era 8) => TxCert era -> Bool
isInstantaneousRewards :: forall era.
(ShelleyEraTxCert era, ProtVerAtMost era 8) =>
TxCert era -> Bool
isInstantaneousRewards = Maybe MIRCert -> Bool
forall a. Maybe a -> Bool
isJust (Maybe MIRCert -> Bool)
-> (TxCert era -> Maybe MIRCert) -> TxCert era -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxCert era -> Maybe MIRCert
forall era.
(ShelleyEraTxCert era, ProtVerAtMost era 8) =>
TxCert era -> Maybe MIRCert
getMirTxCert

isReservesMIRCert :: (ShelleyEraTxCert era, ProtVerAtMost era 8) => TxCert era -> Bool
isReservesMIRCert :: forall era.
(ShelleyEraTxCert era, ProtVerAtMost era 8) =>
TxCert era -> Bool
isReservesMIRCert TxCert era
x = case TxCert era -> Maybe MIRCert
forall era.
(ShelleyEraTxCert era, ProtVerAtMost era 8) =>
TxCert era -> Maybe MIRCert
getMirTxCert TxCert era
x of
  Just (MIRCert MIRPot
ReservesMIR MIRTarget
_) -> Bool
True
  Maybe MIRCert
_ -> Bool
False

isTreasuryMIRCert :: (ShelleyEraTxCert era, ProtVerAtMost era 8) => TxCert era -> Bool
isTreasuryMIRCert :: forall era.
(ShelleyEraTxCert era, ProtVerAtMost era 8) =>
TxCert era -> Bool
isTreasuryMIRCert TxCert era
x = case TxCert era -> Maybe MIRCert
forall era.
(ShelleyEraTxCert era, ProtVerAtMost era 8) =>
TxCert era -> Maybe MIRCert
getMirTxCert TxCert era
x of
  Just (MIRCert MIRPot
TreasuryMIR MIRTarget
_) -> Bool
True
  Maybe MIRCert
_ -> Bool
False

getScriptWitnessShelleyTxCert ::
  ShelleyTxCert era ->
  Maybe ScriptHash
getScriptWitnessShelleyTxCert :: forall era. ShelleyTxCert era -> Maybe ScriptHash
getScriptWitnessShelleyTxCert = \case
  ShelleyTxCertDelegCert ShelleyDelegCert
delegCert ->
    case ShelleyDelegCert
delegCert of
      ShelleyRegCert StakeCredential
_ -> Maybe ScriptHash
forall a. Maybe a
Nothing
      ShelleyUnRegCert StakeCredential
cred -> StakeCredential -> Maybe ScriptHash
forall (kr :: KeyRole). Credential kr -> Maybe ScriptHash
credScriptHash StakeCredential
cred
      ShelleyDelegCert StakeCredential
cred KeyHash 'StakePool
_ -> StakeCredential -> Maybe ScriptHash
forall (kr :: KeyRole). Credential kr -> Maybe ScriptHash
credScriptHash StakeCredential
cred
  ShelleyTxCert era
_ -> Maybe ScriptHash
forall a. Maybe a
Nothing

getVKeyWitnessShelleyTxCert :: ShelleyTxCert era -> Maybe (KeyHash 'Witness)
getVKeyWitnessShelleyTxCert :: forall era. ShelleyTxCert era -> Maybe (KeyHash 'Witness)
getVKeyWitnessShelleyTxCert = \case
  ShelleyTxCertDelegCert ShelleyDelegCert
delegCert ->
    case ShelleyDelegCert
delegCert of
      -- Registration certificates do not require a witness
      ShelleyRegCert StakeCredential
_ -> Maybe (KeyHash 'Witness)
forall a. Maybe a
Nothing
      ShelleyUnRegCert StakeCredential
cred -> StakeCredential -> Maybe (KeyHash 'Witness)
forall (r :: KeyRole). Credential r -> Maybe (KeyHash 'Witness)
credKeyHashWitness StakeCredential
cred
      ShelleyDelegCert StakeCredential
cred KeyHash 'StakePool
_ -> StakeCredential -> Maybe (KeyHash 'Witness)
forall (r :: KeyRole). Credential r -> Maybe (KeyHash 'Witness)
credKeyHashWitness StakeCredential
cred
  ShelleyTxCertPool PoolCert
poolCert -> KeyHash 'Witness -> Maybe (KeyHash 'Witness)
forall a. a -> Maybe a
Just (KeyHash 'Witness -> Maybe (KeyHash 'Witness))
-> KeyHash 'Witness -> Maybe (KeyHash 'Witness)
forall a b. (a -> b) -> a -> b
$ PoolCert -> KeyHash 'Witness
poolCertKeyHashWitness PoolCert
poolCert
  ShelleyTxCertGenesisDeleg GenesisDelegCert
genesisCert -> KeyHash 'Witness -> Maybe (KeyHash 'Witness)
forall a. a -> Maybe a
Just (KeyHash 'Witness -> Maybe (KeyHash 'Witness))
-> KeyHash 'Witness -> Maybe (KeyHash 'Witness)
forall a b. (a -> b) -> a -> b
$ GenesisDelegCert -> KeyHash 'Witness
genesisKeyHashWitness GenesisDelegCert
genesisCert
  ShelleyTxCertMir {} -> Maybe (KeyHash 'Witness)
forall a. Maybe a
Nothing

-- | Determine the total deposit amount needed from a TxBody.
-- The block may (legitimately) contain multiple registration certificates
-- for the same pool, where the first will be treated as a registration and
-- any subsequent ones as re-registration. As such, we must only take a
-- deposit for the first such registration. It is even possible for a single
-- transaction to have multiple pool registration for the same pool, so as
-- we process pool registrations, we must keep track of those that are already
-- registered, so we do not add a Deposit for the same pool twice.
--
-- Note that this is not an issue for key registrations since subsequent
-- registration certificates would be invalid.
shelleyTotalDepositsTxCerts ::
  (EraPParams era, Foldable f, EraTxCert era) =>
  PParams era ->
  -- | Check whether a pool with a supplied PoolStakeId is already registered.
  (KeyHash 'StakePool -> Bool) ->
  f (TxCert era) ->
  Coin
shelleyTotalDepositsTxCerts :: forall era (f :: * -> *).
(EraPParams era, Foldable f, EraTxCert era) =>
PParams era
-> (KeyHash 'StakePool -> Bool) -> f (TxCert era) -> Coin
shelleyTotalDepositsTxCerts PParams era
pp KeyHash 'StakePool -> Bool
isRegPoolRegistered f (TxCert era)
certs =
  Int
numKeys
    Int -> Coin -> Coin
forall i. Integral i => i -> Coin -> Coin
forall t i. (Val t, Integral i) => i -> t -> t
<×> (PParams era
pp PParams era -> Getting Coin (PParams era) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. Getting Coin (PParams era) Coin
forall era. EraPParams era => Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppKeyDepositL)
    Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<+> Int
numNewRegPoolCerts
    Int -> Coin -> Coin
forall i. Integral i => i -> Coin -> Coin
forall t i. (Val t, Integral i) => i -> t -> t
<×> (PParams era
pp PParams era -> Getting Coin (PParams era) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. Getting Coin (PParams era) Coin
forall era. EraPParams era => Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppPoolDepositL)
  where
    numKeys :: Int
numKeys = forall a. Sum a -> a
getSum @Int (Sum Int -> Int) -> Sum Int -> Int
forall a b. (a -> b) -> a -> b
$ (TxCert era -> Sum Int) -> f (TxCert era) -> Sum Int
forall m a. Monoid m => (a -> m) -> f a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap' (\TxCert era
x -> if TxCert era -> Bool
forall era. EraTxCert era => TxCert era -> Bool
isRegStakeTxCert TxCert era
x then Sum Int
1 else Sum Int
0) f (TxCert era)
certs
    numNewRegPoolCerts :: Int
numNewRegPoolCerts = Set (KeyHash 'StakePool) -> Int
forall a. Set a -> Int
Set.size ((Set (KeyHash 'StakePool)
 -> TxCert era -> Set (KeyHash 'StakePool))
-> Set (KeyHash 'StakePool)
-> f (TxCert era)
-> Set (KeyHash 'StakePool)
forall b a. (b -> a -> b) -> b -> f a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
F.foldl' Set (KeyHash 'StakePool) -> TxCert era -> Set (KeyHash 'StakePool)
addNewPoolIds Set (KeyHash 'StakePool)
forall a. Set a
Set.empty f (TxCert era)
certs)
    addNewPoolIds :: Set (KeyHash 'StakePool) -> TxCert era -> Set (KeyHash 'StakePool)
addNewPoolIds Set (KeyHash 'StakePool)
regPoolIds = \case
      RegPoolTxCert (PoolParams {KeyHash 'StakePool
ppId :: KeyHash 'StakePool
ppId :: PoolParams -> KeyHash 'StakePool
ppId})
        -- We don't pay a deposit on a pool that is already registered or duplicated in the certs
        | Bool -> Bool
not (KeyHash 'StakePool -> Bool
isRegPoolRegistered KeyHash 'StakePool
ppId Bool -> Bool -> Bool
|| KeyHash 'StakePool -> Set (KeyHash 'StakePool) -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member KeyHash 'StakePool
ppId Set (KeyHash 'StakePool)
regPoolIds) -> KeyHash 'StakePool
-> Set (KeyHash 'StakePool) -> Set (KeyHash 'StakePool)
forall a. Ord a => a -> Set a -> Set a
Set.insert KeyHash 'StakePool
ppId Set (KeyHash 'StakePool)
regPoolIds
      TxCert era
_ -> Set (KeyHash 'StakePool)
regPoolIds

-- | Compute the key deregistration refunds in a transaction
shelleyTotalRefundsTxCerts ::
  (EraPParams era, Foldable f, EraTxCert era) =>
  PParams era ->
  -- | Function that can lookup current deposit, in case when the stake key is registered.
  (StakeCredential -> Maybe Coin) ->
  f (TxCert era) ->
  Coin
shelleyTotalRefundsTxCerts :: forall era (f :: * -> *).
(EraPParams era, Foldable f, EraTxCert era) =>
PParams era
-> (StakeCredential -> Maybe Coin) -> f (TxCert era) -> Coin
shelleyTotalRefundsTxCerts PParams era
pp StakeCredential -> Maybe Coin
lookupDeposit = (Set StakeCredential, Coin) -> Coin
forall a b. (a, b) -> b
snd ((Set StakeCredential, Coin) -> Coin)
-> (f (TxCert era) -> (Set StakeCredential, Coin))
-> f (TxCert era)
-> Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Set StakeCredential, Coin)
 -> TxCert era -> (Set StakeCredential, Coin))
-> (Set StakeCredential, Coin)
-> f (TxCert era)
-> (Set StakeCredential, Coin)
forall b a. (b -> a -> b) -> b -> f a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
F.foldl' (Set StakeCredential, Coin)
-> TxCert era -> (Set StakeCredential, Coin)
accum (Set StakeCredential
forall a. Monoid a => a
mempty, Integer -> Coin
Coin Integer
0)
  where
    keyDeposit :: Coin
keyDeposit = PParams era
pp PParams era -> Getting Coin (PParams era) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. Getting Coin (PParams era) Coin
forall era. EraPParams era => Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppKeyDepositL
    accum :: (Set StakeCredential, Coin)
-> TxCert era -> (Set StakeCredential, Coin)
accum (!Set StakeCredential
regCreds, !Coin
totalRefunds) TxCert era
cert =
      case TxCert era -> Maybe StakeCredential
forall era. EraTxCert era => TxCert era -> Maybe StakeCredential
lookupRegStakeTxCert TxCert era
cert of
        Just StakeCredential
k ->
          -- Need to track new delegations in case that the same key is later deregistered in
          -- the same transaction.
          (StakeCredential -> Set StakeCredential -> Set StakeCredential
forall a. Ord a => a -> Set a -> Set a
Set.insert StakeCredential
k Set StakeCredential
regCreds, Coin
totalRefunds)
        Maybe StakeCredential
Nothing ->
          case TxCert era -> Maybe StakeCredential
forall era. EraTxCert era => TxCert era -> Maybe StakeCredential
lookupUnRegStakeTxCert TxCert era
cert of
            Just StakeCredential
cred
              -- We first check if there was already a registration certificate in this
              -- transaction.
              | StakeCredential -> Set StakeCredential -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member StakeCredential
cred Set StakeCredential
regCreds -> (StakeCredential -> Set StakeCredential -> Set StakeCredential
forall a. Ord a => a -> Set a -> Set a
Set.delete StakeCredential
cred Set StakeCredential
regCreds, Coin
totalRefunds Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<+> Coin
keyDeposit)
              -- Check for the deposit left during registration in some previous
              -- transaction. This de-registration check will be matched first, despite being
              -- the last case to match, because registration is not possible without
              -- de-registration.
              | Just Coin
deposit <- StakeCredential -> Maybe Coin
lookupDeposit StakeCredential
cred -> (Set StakeCredential
regCreds, Coin
totalRefunds Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<+> Coin
deposit)
            Maybe StakeCredential
_ -> (Set StakeCredential
regCreds, Coin
totalRefunds)