{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeApplications #-}

module Cardano.Ledger.Shelley.HardForks
  ( aggregatedRewards,
    allowMIRTransfer,
    validatePoolRewardAccountNetID,
    allowScriptStakeCredsToEarnRewards,
    translateTimeForPlutusScripts,
    missingScriptsSymmetricDifference,
    forgoRewardPrefilter,
    allowOutsideForecastTTL,
  )
where

import Cardano.Ledger.BaseTypes (ProtVer (..))
import GHC.Records

aggregatedRewards ::
  (HasField "_protocolVersion" pp ProtVer) =>
  pp ->
  Bool
aggregatedRewards :: pp -> Bool
aggregatedRewards pp
pp = ProtVer -> Natural
pvMajor (pp -> ProtVer
forall k (x :: k) r a. HasField x r a => r -> a
getField @"_protocolVersion" pp
pp) Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
> Natural
2

-- | Starting with protocol version 5, the MIR certs will also be
-- able to transfer funds between the reserves and the treasury.
-- Additionally, the semantics for the pervious functionality will
-- change a bit. Before version 5 redundancies in the instantaneous
-- reward mapping were handled by overriding. Now they are handled
-- by adding the values and allowing for negatives updates, provided
-- the sum for each key remains positive.
allowMIRTransfer ::
  (HasField "_protocolVersion" pp ProtVer) =>
  pp ->
  Bool
allowMIRTransfer :: pp -> Bool
allowMIRTransfer pp
pp = ProtVer -> Natural
pvMajor (pp -> ProtVer
forall k (x :: k) r a. HasField x r a => r -> a
getField @"_protocolVersion" pp
pp) Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
> Natural
4

-- | Starting with protocol version 5, we will validate the network ID
-- for the reward account listed in stake pool registration certificates.
validatePoolRewardAccountNetID ::
  (HasField "_protocolVersion" pp ProtVer) =>
  pp ->
  Bool
validatePoolRewardAccountNetID :: pp -> Bool
validatePoolRewardAccountNetID pp
pp = ProtVer -> Natural
pvMajor (pp -> ProtVer
forall k (x :: k) r a. HasField x r a => r -> a
getField @"_protocolVersion" pp
pp) Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
> Natural
4

-- | Starting with protocol version 5, Stake Credentials bound by scripts
-- will be eligibile for staking rewards.
allowScriptStakeCredsToEarnRewards ::
  (HasField "_protocolVersion" pp ProtVer) =>
  pp ->
  Bool
allowScriptStakeCredsToEarnRewards :: pp -> Bool
allowScriptStakeCredsToEarnRewards pp
pp = ProtVer -> Natural
pvMajor (pp -> ProtVer
forall k (x :: k) r a. HasField x r a => r -> a
getField @"_protocolVersion" pp
pp) Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
> Natural
4

-- | Starting with protocol version 6, we translate slots to time correctly for
-- Plutus scripts.
translateTimeForPlutusScripts ::
  (HasField "_protocolVersion" pp ProtVer) =>
  pp ->
  Bool
translateTimeForPlutusScripts :: pp -> Bool
translateTimeForPlutusScripts pp
pp = ProtVer -> Natural
pvMajor (pp -> ProtVer
forall k (x :: k) r a. HasField x r a => r -> a
getField @"_protocolVersion" pp
pp) Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
> Natural
5

-- | Starting with protocol version 7, the UTXO rule predicate failure
-- MissingScriptWitnessesUTXOW will not be used for extraneous scripts
missingScriptsSymmetricDifference ::
  (HasField "_protocolVersion" pp ProtVer) =>
  pp ->
  Bool
missingScriptsSymmetricDifference :: pp -> Bool
missingScriptsSymmetricDifference pp
pp = ProtVer -> Natural
pvMajor (pp -> ProtVer
forall k (x :: k) r a. HasField x r a => r -> a
getField @"_protocolVersion" pp
pp) Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
> Natural
6

-- | Starting with protocol version 7, the reward calculation no longer
-- filters out unregistered stake addresses at the moment the calculation begins.
-- See the Shelley Ledger Errata 17.2.
forgoRewardPrefilter ::
  (HasField "_protocolVersion" pp ProtVer) =>
  pp ->
  Bool
forgoRewardPrefilter :: pp -> Bool
forgoRewardPrefilter pp
pp = ProtVer -> Natural
pvMajor (pp -> ProtVer
forall k (x :: k) r a. HasField x r a => r -> a
getField @"_protocolVersion" pp
pp) Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
> Natural
6

-- | In versions 5 and 6, we allow the ttl field to lie outside the stability
-- window.
allowOutsideForecastTTL ::
  (HasField "_protocolVersion" pp ProtVer) =>
  pp ->
  Bool
allowOutsideForecastTTL :: pp -> Bool
allowOutsideForecastTTL pp
pp =
  let mv :: Natural
mv = ProtVer -> Natural
pvMajor (pp -> ProtVer
forall k (x :: k) r a. HasField x r a => r -> a
getField @"_protocolVersion" pp
pp)
   in Natural
mv Natural -> Natural -> Bool
forall a. Eq a => a -> a -> Bool
== Natural
5 Bool -> Bool -> Bool
|| Natural
mv Natural -> Natural -> Bool
forall a. Eq a => a -> a -> Bool
== Natural
6