{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}

module Cardano.Ledger.Rewards (
  RewardType (..),
  Reward (..),
) where

import Cardano.Ledger.BaseTypes (invalidKey)
import Cardano.Ledger.Binary (
  DecCBOR (..),
  EncCBOR (..),
  decodeWord,
  encodeWord,
 )
import Cardano.Ledger.Binary.Coders (Decode (..), Encode (..), decode, encode, (!>), (<!))
import Cardano.Ledger.Coin (Coin)
import Cardano.Ledger.Keys (KeyHash, KeyRole (..))
import Control.DeepSeq (NFData)
import Data.Aeson (KeyValue, ToJSON (..), object, pairs, (.=))
import GHC.Generics (Generic)
import NoThunks.Class (NoThunks (..))

-- | The staking rewards in Cardano are all either:
--
-- * member rewards - rewards given to a registered stake credential which has delegated
-- to a stake pool, or
--
-- * leader rewards - rewards given to a registered stake pool (in particular, given to the
-- stake credential in the stake pool registration certificate).
--
-- See Figure 47, "Functions used in the Reward Splitting", of the
-- <https://github.com/intersectmbo/cardano-ledger/releases/latest/download/shelley-ledger.pdf formal specification>
-- for more details.
data RewardType = MemberReward | LeaderReward
  deriving (RewardType -> RewardType -> Bool
(RewardType -> RewardType -> Bool)
-> (RewardType -> RewardType -> Bool) -> Eq RewardType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RewardType -> RewardType -> Bool
== :: RewardType -> RewardType -> Bool
$c/= :: RewardType -> RewardType -> Bool
/= :: RewardType -> RewardType -> Bool
Eq, Int -> RewardType -> ShowS
[RewardType] -> ShowS
RewardType -> String
(Int -> RewardType -> ShowS)
-> (RewardType -> String)
-> ([RewardType] -> ShowS)
-> Show RewardType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RewardType -> ShowS
showsPrec :: Int -> RewardType -> ShowS
$cshow :: RewardType -> String
show :: RewardType -> String
$cshowList :: [RewardType] -> ShowS
showList :: [RewardType] -> ShowS
Show, Eq RewardType
Eq RewardType =>
(RewardType -> RewardType -> Ordering)
-> (RewardType -> RewardType -> Bool)
-> (RewardType -> RewardType -> Bool)
-> (RewardType -> RewardType -> Bool)
-> (RewardType -> RewardType -> Bool)
-> (RewardType -> RewardType -> RewardType)
-> (RewardType -> RewardType -> RewardType)
-> Ord RewardType
RewardType -> RewardType -> Bool
RewardType -> RewardType -> Ordering
RewardType -> RewardType -> RewardType
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 :: RewardType -> RewardType -> Ordering
compare :: RewardType -> RewardType -> Ordering
$c< :: RewardType -> RewardType -> Bool
< :: RewardType -> RewardType -> Bool
$c<= :: RewardType -> RewardType -> Bool
<= :: RewardType -> RewardType -> Bool
$c> :: RewardType -> RewardType -> Bool
> :: RewardType -> RewardType -> Bool
$c>= :: RewardType -> RewardType -> Bool
>= :: RewardType -> RewardType -> Bool
$cmax :: RewardType -> RewardType -> RewardType
max :: RewardType -> RewardType -> RewardType
$cmin :: RewardType -> RewardType -> RewardType
min :: RewardType -> RewardType -> RewardType
Ord, RewardType
RewardType -> RewardType -> Bounded RewardType
forall a. a -> a -> Bounded a
$cminBound :: RewardType
minBound :: RewardType
$cmaxBound :: RewardType
maxBound :: RewardType
Bounded, Int -> RewardType
RewardType -> Int
RewardType -> [RewardType]
RewardType -> RewardType
RewardType -> RewardType -> [RewardType]
RewardType -> RewardType -> RewardType -> [RewardType]
(RewardType -> RewardType)
-> (RewardType -> RewardType)
-> (Int -> RewardType)
-> (RewardType -> Int)
-> (RewardType -> [RewardType])
-> (RewardType -> RewardType -> [RewardType])
-> (RewardType -> RewardType -> [RewardType])
-> (RewardType -> RewardType -> RewardType -> [RewardType])
-> Enum RewardType
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 :: RewardType -> RewardType
succ :: RewardType -> RewardType
$cpred :: RewardType -> RewardType
pred :: RewardType -> RewardType
$ctoEnum :: Int -> RewardType
toEnum :: Int -> RewardType
$cfromEnum :: RewardType -> Int
fromEnum :: RewardType -> Int
$cenumFrom :: RewardType -> [RewardType]
enumFrom :: RewardType -> [RewardType]
$cenumFromThen :: RewardType -> RewardType -> [RewardType]
enumFromThen :: RewardType -> RewardType -> [RewardType]
$cenumFromTo :: RewardType -> RewardType -> [RewardType]
enumFromTo :: RewardType -> RewardType -> [RewardType]
$cenumFromThenTo :: RewardType -> RewardType -> RewardType -> [RewardType]
enumFromThenTo :: RewardType -> RewardType -> RewardType -> [RewardType]
Enum, (forall x. RewardType -> Rep RewardType x)
-> (forall x. Rep RewardType x -> RewardType) -> Generic RewardType
forall x. Rep RewardType x -> RewardType
forall x. RewardType -> Rep RewardType x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. RewardType -> Rep RewardType x
from :: forall x. RewardType -> Rep RewardType x
$cto :: forall x. Rep RewardType x -> RewardType
to :: forall x. Rep RewardType x -> RewardType
Generic)

instance NoThunks RewardType

instance NFData RewardType

instance ToJSON RewardType

instance EncCBOR RewardType where
  encCBOR :: RewardType -> Encoding
encCBOR RewardType
MemberReward = Word -> Encoding
encodeWord Word
0
  encCBOR RewardType
LeaderReward = Word -> Encoding
encodeWord Word
1

instance DecCBOR RewardType where
  decCBOR :: forall s. Decoder s RewardType
decCBOR =
    Decoder s Word
forall s. Decoder s Word
decodeWord Decoder s Word
-> (Word -> Decoder s RewardType) -> Decoder s RewardType
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 -> RewardType -> Decoder s RewardType
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RewardType
MemberReward
      Word
1 -> RewardType -> Decoder s RewardType
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RewardType
LeaderReward
      Word
n -> Word -> Decoder s RewardType
forall a (m :: * -> *). (Typeable a, MonadFail m) => Word -> m a
invalidKey Word
n

-- | The 'Reward' type captures:
--
-- * if the reward is a member or leader reward
--
-- * the stake pool ID associated with the reward
--
-- * the number of Lovelace in the reward
data Reward = Reward
  { Reward -> RewardType
rewardType :: !RewardType
  , Reward -> KeyHash 'StakePool
rewardPool :: !(KeyHash 'StakePool)
  , Reward -> Coin
rewardAmount :: !Coin
  }
  deriving (Reward -> Reward -> Bool
(Reward -> Reward -> Bool)
-> (Reward -> Reward -> Bool) -> Eq Reward
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Reward -> Reward -> Bool
== :: Reward -> Reward -> Bool
$c/= :: Reward -> Reward -> Bool
/= :: Reward -> Reward -> Bool
Eq, Int -> Reward -> ShowS
[Reward] -> ShowS
Reward -> String
(Int -> Reward -> ShowS)
-> (Reward -> String) -> ([Reward] -> ShowS) -> Show Reward
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Reward -> ShowS
showsPrec :: Int -> Reward -> ShowS
$cshow :: Reward -> String
show :: Reward -> String
$cshowList :: [Reward] -> ShowS
showList :: [Reward] -> ShowS
Show, (forall x. Reward -> Rep Reward x)
-> (forall x. Rep Reward x -> Reward) -> Generic Reward
forall x. Rep Reward x -> Reward
forall x. Reward -> Rep Reward x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Reward -> Rep Reward x
from :: forall x. Reward -> Rep Reward x
$cto :: forall x. Rep Reward x -> Reward
to :: forall x. Rep Reward x -> Reward
Generic)

-- | Note that this Ord instance is chosen to align precisely
--  with the Allegra reward aggregation, as given by the
--  function 'aggregateRewards' so that 'Set.findMax' returns
--  the expected value.
instance Ord Reward where
  compare :: Reward -> Reward -> Ordering
compare (Reward RewardType
MemberReward KeyHash 'StakePool
_ Coin
_) (Reward RewardType
LeaderReward KeyHash 'StakePool
_ Coin
_) = Ordering
GT
  compare (Reward RewardType
LeaderReward KeyHash 'StakePool
_ Coin
_) (Reward RewardType
MemberReward KeyHash 'StakePool
_ Coin
_) = Ordering
LT
  compare (Reward RewardType
_ KeyHash 'StakePool
pool1 Coin
_) (Reward RewardType
_ KeyHash 'StakePool
pool2 Coin
_) = KeyHash 'StakePool -> KeyHash 'StakePool -> Ordering
forall a. Ord a => a -> a -> Ordering
compare KeyHash 'StakePool
pool1 KeyHash 'StakePool
pool2

instance NoThunks Reward

instance NFData Reward

instance EncCBOR Reward where
  encCBOR :: Reward -> Encoding
encCBOR (Reward RewardType
rt KeyHash 'StakePool
pool Coin
c) =
    Encode ('Closed 'Dense) Reward -> Encoding
forall (w :: Wrapped) t. Encode w t -> Encoding
encode (Encode ('Closed 'Dense) Reward -> Encoding)
-> Encode ('Closed 'Dense) Reward -> Encoding
forall a b. (a -> b) -> a -> b
$ (RewardType -> KeyHash 'StakePool -> Coin -> Reward)
-> Encode
     ('Closed 'Dense)
     (RewardType -> KeyHash 'StakePool -> Coin -> Reward)
forall t. t -> Encode ('Closed 'Dense) t
Rec RewardType -> KeyHash 'StakePool -> Coin -> Reward
Reward Encode
  ('Closed 'Dense)
  (RewardType -> KeyHash 'StakePool -> Coin -> Reward)
-> Encode ('Closed 'Dense) RewardType
-> Encode ('Closed 'Dense) (KeyHash 'StakePool -> Coin -> Reward)
forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> RewardType -> Encode ('Closed 'Dense) RewardType
forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To RewardType
rt Encode ('Closed 'Dense) (KeyHash 'StakePool -> Coin -> Reward)
-> Encode ('Closed 'Dense) (KeyHash 'StakePool)
-> Encode ('Closed 'Dense) (Coin -> Reward)
forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> KeyHash 'StakePool -> Encode ('Closed 'Dense) (KeyHash 'StakePool)
forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To KeyHash 'StakePool
pool Encode ('Closed 'Dense) (Coin -> Reward)
-> Encode ('Closed 'Dense) Coin -> Encode ('Closed 'Dense) Reward
forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> Coin -> Encode ('Closed 'Dense) Coin
forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To Coin
c

instance DecCBOR Reward where
  decCBOR :: forall s. Decoder s Reward
decCBOR =
    Decode ('Closed 'Dense) Reward -> Decoder s Reward
forall t (w :: Wrapped) s. Typeable t => Decode w t -> Decoder s t
decode (Decode ('Closed 'Dense) Reward -> Decoder s Reward)
-> Decode ('Closed 'Dense) Reward -> Decoder s Reward
forall a b. (a -> b) -> a -> b
$ (RewardType -> KeyHash 'StakePool -> Coin -> Reward)
-> Decode
     ('Closed 'Dense)
     (RewardType -> KeyHash 'StakePool -> Coin -> Reward)
forall t. t -> Decode ('Closed 'Dense) t
RecD RewardType -> KeyHash 'StakePool -> Coin -> Reward
Reward Decode
  ('Closed 'Dense)
  (RewardType -> KeyHash 'StakePool -> Coin -> Reward)
-> Decode ('Closed Any) RewardType
-> Decode ('Closed 'Dense) (KeyHash 'StakePool -> Coin -> Reward)
forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! Decode ('Closed Any) RewardType
forall t (w :: Wrapped). DecCBOR t => Decode w t
From Decode ('Closed 'Dense) (KeyHash 'StakePool -> Coin -> Reward)
-> Decode ('Closed Any) (KeyHash 'StakePool)
-> Decode ('Closed 'Dense) (Coin -> Reward)
forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! Decode ('Closed Any) (KeyHash 'StakePool)
forall t (w :: Wrapped). DecCBOR t => Decode w t
From Decode ('Closed 'Dense) (Coin -> Reward)
-> Decode ('Closed Any) Coin -> Decode ('Closed 'Dense) Reward
forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! Decode ('Closed Any) Coin
forall t (w :: Wrapped). DecCBOR t => Decode w t
From

instance ToJSON Reward where
  toJSON :: Reward -> Value
toJSON = [Pair] -> Value
object ([Pair] -> Value) -> (Reward -> [Pair]) -> Reward -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reward -> [Pair]
forall e a. KeyValue e a => Reward -> [a]
toRewardPair
  toEncoding :: Reward -> Encoding
toEncoding = Series -> Encoding
pairs (Series -> Encoding) -> (Reward -> Series) -> Reward -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Series] -> Series
forall a. Monoid a => [a] -> a
mconcat ([Series] -> Series) -> (Reward -> [Series]) -> Reward -> Series
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reward -> [Series]
forall e a. KeyValue e a => Reward -> [a]
toRewardPair

toRewardPair :: KeyValue e a => Reward -> [a]
toRewardPair :: forall e a. KeyValue e a => Reward -> [a]
toRewardPair r :: Reward
r@(Reward RewardType
_ KeyHash 'StakePool
_ Coin
_) =
  let Reward {KeyHash 'StakePool
Coin
RewardType
rewardType :: Reward -> RewardType
rewardPool :: Reward -> KeyHash 'StakePool
rewardAmount :: Reward -> Coin
rewardType :: RewardType
rewardPool :: KeyHash 'StakePool
rewardAmount :: Coin
..} = Reward
r
   in [ Key
"rewardType" Key -> RewardType -> a
forall v. ToJSON v => Key -> v -> a
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= RewardType
rewardType
      , Key
"rewardPool" Key -> KeyHash 'StakePool -> a
forall v. ToJSON v => Key -> v -> a
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= KeyHash 'StakePool
rewardPool
      , Key
"rewardAmount" Key -> Coin -> a
forall v. ToJSON v => Key -> v -> a
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Coin
rewardAmount
      ]