{-# 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RewardType -> RewardType -> Bool
$c/= :: RewardType -> RewardType -> Bool
== :: RewardType -> RewardType -> Bool
$c== :: RewardType -> RewardType -> Bool
Eq, Int -> RewardType -> ShowS
[RewardType] -> ShowS
RewardType -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RewardType] -> ShowS
$cshowList :: [RewardType] -> ShowS
show :: RewardType -> String
$cshow :: RewardType -> String
showsPrec :: Int -> RewardType -> ShowS
$cshowsPrec :: Int -> RewardType -> ShowS
Show, Eq 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
min :: RewardType -> RewardType -> RewardType
$cmin :: RewardType -> RewardType -> RewardType
max :: RewardType -> RewardType -> RewardType
$cmax :: RewardType -> RewardType -> RewardType
>= :: RewardType -> RewardType -> Bool
$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
compare :: RewardType -> RewardType -> Ordering
$ccompare :: RewardType -> RewardType -> Ordering
Ord, RewardType
forall a. a -> a -> Bounded a
maxBound :: RewardType
$cmaxBound :: RewardType
minBound :: RewardType
$cminBound :: RewardType
Bounded, Int -> RewardType
RewardType -> Int
RewardType -> [RewardType]
RewardType -> RewardType
RewardType -> RewardType -> [RewardType]
RewardType -> RewardType -> RewardType -> [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
enumFromThenTo :: RewardType -> RewardType -> RewardType -> [RewardType]
$cenumFromThenTo :: RewardType -> RewardType -> RewardType -> [RewardType]
enumFromTo :: RewardType -> RewardType -> [RewardType]
$cenumFromTo :: RewardType -> RewardType -> [RewardType]
enumFromThen :: RewardType -> RewardType -> [RewardType]
$cenumFromThen :: RewardType -> RewardType -> [RewardType]
enumFrom :: RewardType -> [RewardType]
$cenumFrom :: RewardType -> [RewardType]
fromEnum :: RewardType -> Int
$cfromEnum :: RewardType -> Int
toEnum :: Int -> RewardType
$ctoEnum :: Int -> RewardType
pred :: RewardType -> RewardType
$cpred :: RewardType -> RewardType
succ :: RewardType -> RewardType
$csucc :: RewardType -> RewardType
Enum, 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
$cto :: forall x. Rep RewardType x -> RewardType
$cfrom :: forall x. RewardType -> Rep RewardType x
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 =
    forall s. Decoder s Word
decodeWord forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Word
0 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure RewardType
MemberReward
      Word
1 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure RewardType
LeaderReward
      Word
n -> forall (m :: * -> *) 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Reward -> Reward -> Bool
$c/= :: Reward -> Reward -> Bool
== :: Reward -> Reward -> Bool
$c== :: Reward -> Reward -> Bool
Eq, Int -> Reward -> ShowS
[Reward] -> ShowS
Reward -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Reward] -> ShowS
$cshowList :: [Reward] -> ShowS
show :: Reward -> String
$cshow :: Reward -> String
showsPrec :: Int -> Reward -> ShowS
$cshowsPrec :: Int -> Reward -> ShowS
Show, 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
$cto :: forall x. Rep Reward x -> Reward
$cfrom :: forall x. Reward -> Rep Reward x
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
_) = 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) =
    forall (w :: Wrapped) t. Encode w t -> Encoding
encode forall a b. (a -> b) -> a -> b
$ forall t. t -> Encode ('Closed 'Dense) t
Rec RewardType -> KeyHash 'StakePool -> Coin -> Reward
Reward forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To RewardType
rt forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To KeyHash 'StakePool
pool forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To Coin
c

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

instance ToJSON Reward where
  toJSON :: Reward -> Value
toJSON = [Pair] -> Value
object forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. KeyValue e a => Reward -> [a]
toRewardPair
  toEncoding :: Reward -> Encoding
toEncoding = Series -> Encoding
pairs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
rewardAmount :: Coin
rewardPool :: KeyHash 'StakePool
rewardType :: RewardType
rewardAmount :: Reward -> Coin
rewardPool :: Reward -> KeyHash 'StakePool
rewardType :: Reward -> RewardType
..} = Reward
r
   in [ Key
"rewardType" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= RewardType
rewardType
      , Key
"rewardPool" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= KeyHash 'StakePool
rewardPool
      , Key
"rewardAmount" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Coin
rewardAmount
      ]