{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE RecordWildCards #-}

-- | Genesis config for the spec
--
-- Intended for qualified import
--
-- > import           Ouroboros.Consensus.ByronSpec.Ledger.Genesis (ByronSpecGenesis)
-- > import qualified Ouroboros.Consensus.ByronSpec.Ledger.Genesis as Genesis
module Ouroboros.Consensus.ByronSpec.Ledger.Genesis (
    ByronSpecGenesis (..)
  , modFeeParams
  , modPBftThreshold
  , modPParams
  , modUtxo
  , modUtxoValues
    -- * Conversions
  , fromChainEnv
  , toChainEnv
  ) where

import qualified Byron.Spec.Chain.STS.Rule.Chain as Spec
import qualified Byron.Spec.Ledger.Core as Spec
import qualified Byron.Spec.Ledger.Update as Spec
import qualified Byron.Spec.Ledger.UTxO as Spec
import qualified Control.State.Transition as Spec
import           Data.Coerce (coerce)
import           Data.Set (Set)
import           NoThunks.Class (AllowThunk (..), NoThunks)
import           Numeric.Natural (Natural)
import           Ouroboros.Consensus.ByronSpec.Ledger.Orphans ()

{-------------------------------------------------------------------------------
  Genesis config
-------------------------------------------------------------------------------}

-- | The equivalent of the genesis config for the abstract ledger
data ByronSpecGenesis = ByronSpecGenesis {
      ByronSpecGenesis -> Set VKeyGenesis
byronSpecGenesisDelegators    :: Set Spec.VKeyGenesis
    , ByronSpecGenesis -> UTxO
byronSpecGenesisInitUtxo      :: Spec.UTxO
    , ByronSpecGenesis -> PParams
byronSpecGenesisInitPParams   :: Spec.PParams
    , ByronSpecGenesis -> BlockCount
byronSpecGenesisSecurityParam :: Spec.BlockCount

      -- | Slot length
      --
      -- The Byron spec itself does not talk about slot length at all. Here we
      -- record it primarily to support the relation between the spec and the
      -- real implementation. For this reason we choose the same representation
      -- as the real PBFT does ('ppSlotDuration' in 'ProtocolParameters').
    , ByronSpecGenesis -> Natural
byronSpecGenesisSlotLength    :: Natural
    }
  deriving stock (Int -> ByronSpecGenesis -> ShowS
[ByronSpecGenesis] -> ShowS
ByronSpecGenesis -> String
(Int -> ByronSpecGenesis -> ShowS)
-> (ByronSpecGenesis -> String)
-> ([ByronSpecGenesis] -> ShowS)
-> Show ByronSpecGenesis
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ByronSpecGenesis -> ShowS
showsPrec :: Int -> ByronSpecGenesis -> ShowS
$cshow :: ByronSpecGenesis -> String
show :: ByronSpecGenesis -> String
$cshowList :: [ByronSpecGenesis] -> ShowS
showList :: [ByronSpecGenesis] -> ShowS
Show)
  deriving Context -> ByronSpecGenesis -> IO (Maybe ThunkInfo)
Proxy ByronSpecGenesis -> String
(Context -> ByronSpecGenesis -> IO (Maybe ThunkInfo))
-> (Context -> ByronSpecGenesis -> IO (Maybe ThunkInfo))
-> (Proxy ByronSpecGenesis -> String)
-> NoThunks ByronSpecGenesis
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> ByronSpecGenesis -> IO (Maybe ThunkInfo)
noThunks :: Context -> ByronSpecGenesis -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> ByronSpecGenesis -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> ByronSpecGenesis -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy ByronSpecGenesis -> String
showTypeOf :: Proxy ByronSpecGenesis -> String
NoThunks via AllowThunk ByronSpecGenesis

modPBftThreshold :: (Double -> Double)
                 -> ByronSpecGenesis -> ByronSpecGenesis
modPBftThreshold :: (Double -> Double) -> ByronSpecGenesis -> ByronSpecGenesis
modPBftThreshold = (PParams -> PParams) -> ByronSpecGenesis -> ByronSpecGenesis
modPParams ((PParams -> PParams) -> ByronSpecGenesis -> ByronSpecGenesis)
-> ((Double -> Double) -> PParams -> PParams)
-> (Double -> Double)
-> ByronSpecGenesis
-> ByronSpecGenesis
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double -> Double) -> PParams -> PParams
modPParamsPBftThreshold

-- | Modify the @a@ and @b@ fee parameters
modFeeParams :: ((Int, Int) -> (Int, Int))
             -> ByronSpecGenesis -> ByronSpecGenesis
modFeeParams :: ((Int, Int) -> (Int, Int)) -> ByronSpecGenesis -> ByronSpecGenesis
modFeeParams = (PParams -> PParams) -> ByronSpecGenesis -> ByronSpecGenesis
modPParams ((PParams -> PParams) -> ByronSpecGenesis -> ByronSpecGenesis)
-> (((Int, Int) -> (Int, Int)) -> PParams -> PParams)
-> ((Int, Int) -> (Int, Int))
-> ByronSpecGenesis
-> ByronSpecGenesis
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, Int) -> (Int, Int)) -> PParams -> PParams
modPParamsFeeParams

-- | Adjust all values in the initial UTxO equally
modUtxoValues :: (Integer -> Integer) -> ByronSpecGenesis -> ByronSpecGenesis
modUtxoValues :: (Integer -> Integer) -> ByronSpecGenesis -> ByronSpecGenesis
modUtxoValues = (UTxO -> UTxO) -> ByronSpecGenesis -> ByronSpecGenesis
modUtxo ((UTxO -> UTxO) -> ByronSpecGenesis -> ByronSpecGenesis)
-> ((Integer -> Integer) -> UTxO -> UTxO)
-> (Integer -> Integer)
-> ByronSpecGenesis
-> ByronSpecGenesis
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Lovelace -> Lovelace) -> UTxO -> UTxO
Spec.mapUTxOValues ((Lovelace -> Lovelace) -> UTxO -> UTxO)
-> ((Integer -> Integer) -> Lovelace -> Lovelace)
-> (Integer -> Integer)
-> UTxO
-> UTxO
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Integer -> Integer) -> Lovelace -> Lovelace
forall a b. Coercible a b => a -> b
coerce

modUtxo :: (Spec.UTxO -> Spec.UTxO) -> ByronSpecGenesis -> ByronSpecGenesis
modUtxo :: (UTxO -> UTxO) -> ByronSpecGenesis -> ByronSpecGenesis
modUtxo UTxO -> UTxO
f ByronSpecGenesis
genesis = ByronSpecGenesis
genesis {
      byronSpecGenesisInitUtxo = f (byronSpecGenesisInitUtxo genesis)
    }

modPParams :: (Spec.PParams -> Spec.PParams)
           -> ByronSpecGenesis -> ByronSpecGenesis
modPParams :: (PParams -> PParams) -> ByronSpecGenesis -> ByronSpecGenesis
modPParams PParams -> PParams
f ByronSpecGenesis
genesis = ByronSpecGenesis
genesis {
      byronSpecGenesisInitPParams = f (byronSpecGenesisInitPParams genesis)
    }

{-------------------------------------------------------------------------------
  Internal: accessors for the protocol parameters
-------------------------------------------------------------------------------}

modPParamsPBftThreshold :: (Double -> Double)
                        -> Spec.PParams -> Spec.PParams
modPParamsPBftThreshold :: (Double -> Double) -> PParams -> PParams
modPParamsPBftThreshold Double -> Double
f PParams
pparams = PParams
pparams {
      Spec._bkSgnCntT = Spec.BkSgnCntT (f threshold)
    }
  where
    Spec.BkSgnCntT Double
threshold = PParams -> BkSgnCntT
Spec._bkSgnCntT PParams
pparams

modPParamsFeeParams :: ((Int, Int) -> (Int, Int))
                    -> Spec.PParams -> Spec.PParams
modPParamsFeeParams :: ((Int, Int) -> (Int, Int)) -> PParams -> PParams
modPParamsFeeParams (Int, Int) -> (Int, Int)
f PParams
pparams = PParams
pparams {
      Spec._factorA = Spec.FactorA $ fst (f (a, b))
    , Spec._factorB = Spec.FactorB $ snd (f (a, b))
    }
  where
    Spec.FactorA Int
a = PParams -> FactorA
Spec._factorA PParams
pparams
    Spec.FactorB Int
b = PParams -> FactorB
Spec._factorB PParams
pparams

{-------------------------------------------------------------------------------
  Conversions
-------------------------------------------------------------------------------}

-- | Derive CHAIN rule environment
toChainEnv :: ByronSpecGenesis -> Spec.Environment Spec.CHAIN
toChainEnv :: ByronSpecGenesis -> Environment CHAIN
toChainEnv ByronSpecGenesis{Natural
Set VKeyGenesis
BlockCount
PParams
UTxO
byronSpecGenesisDelegators :: ByronSpecGenesis -> Set VKeyGenesis
byronSpecGenesisInitUtxo :: ByronSpecGenesis -> UTxO
byronSpecGenesisInitPParams :: ByronSpecGenesis -> PParams
byronSpecGenesisSecurityParam :: ByronSpecGenesis -> BlockCount
byronSpecGenesisSlotLength :: ByronSpecGenesis -> Natural
byronSpecGenesisDelegators :: Set VKeyGenesis
byronSpecGenesisInitUtxo :: UTxO
byronSpecGenesisInitPParams :: PParams
byronSpecGenesisSecurityParam :: BlockCount
byronSpecGenesisSlotLength :: Natural
..} = Environment CHAIN -> Environment CHAIN
disableConsensusChecks (
      Word64 -> Slot
Spec.Slot Word64
0 -- current slot
    , UTxO
byronSpecGenesisInitUtxo
    , Set VKeyGenesis
byronSpecGenesisDelegators
    , PParams
byronSpecGenesisInitPParams
    , BlockCount
byronSpecGenesisSecurityParam
    )
  where
    -- We are only interested in updating the /ledger state/, not the /consensus
    -- chain state/. Unfortunately, the Byron spec does not make that
    -- distinction, and so when we call the CHAIN rule, we might get some errors
    -- here that the implementation does not report (because it would only find
    -- them when we update the chain state). There are at least two possible
    -- proper solutions for this:
    --
    -- 1. Modify the spec so that we /do/ have the separation. Note that if we
    --    did, we would not use the chain state part of the spec, since the
    --    chain state part of the dual ledger is determined entirely by the
    --    concrete Byron block.
    -- 2. Turn 'applyExtLedger' and related types into a type class of their
    --    own, so that we can override it specifically for the dual ledger.
    --
    -- Either way, we are only testing the /ledger/ part of the two blocks here,
    -- not the consensus part. For now we just override some parameters in the
    -- environment to work around the problem and make sure that none of the
    -- consensus checks in the spec can fail.
    disableConsensusChecks :: Spec.Environment Spec.CHAIN
                           -> Spec.Environment Spec.CHAIN
    disableConsensusChecks :: Environment CHAIN -> Environment CHAIN
disableConsensusChecks ( Slot
_currentSlot
                           , UTxO
utx0
                           , Set VKeyGenesis
delegators
                           , PParams
pparams
                           , BlockCount
k
                           ) = (
          -- Disable 'SlotInTheFuture' failure
          Word64 -> Slot
Spec.Slot Word64
forall a. Bounded a => a
maxBound
        , UTxO
utx0
        , Set VKeyGenesis
delegators
          -- Disable 'TooManyIssuedBlocks' failure
        , PParams
pparams { Spec._bkSgnCntT = Spec.BkSgnCntT 1 }
        , BlockCount
k
        )

-- | Construct genesis config from CHAIN environment
--
-- This doesn't make an awful lot of sense, but the abstract spec doesn't /have/
-- a concept of a genesis config, and instead the CHAIN environment fulfills
-- that role. In order to be able to reuse the test generators, we therefore
-- also define a translation in the opposite direction.
fromChainEnv :: Natural -> Spec.Environment Spec.CHAIN -> ByronSpecGenesis
fromChainEnv :: Natural -> Environment CHAIN -> ByronSpecGenesis
fromChainEnv Natural
byronSpecGenesisSlotLength
             ( Slot
_currentSlot
             , UTxO
byronSpecGenesisInitUtxo
             , Set VKeyGenesis
byronSpecGenesisDelegators
             , PParams
byronSpecGenesisInitPParams
             , BlockCount
byronSpecGenesisSecurityParam
             ) = ByronSpecGenesis{Natural
Set VKeyGenesis
BlockCount
PParams
UTxO
byronSpecGenesisDelegators :: Set VKeyGenesis
byronSpecGenesisInitUtxo :: UTxO
byronSpecGenesisInitPParams :: PParams
byronSpecGenesisSecurityParam :: BlockCount
byronSpecGenesisSlotLength :: Natural
byronSpecGenesisSlotLength :: Natural
byronSpecGenesisInitUtxo :: UTxO
byronSpecGenesisDelegators :: Set VKeyGenesis
byronSpecGenesisInitPParams :: PParams
byronSpecGenesisSecurityParam :: BlockCount
..}