{-# LANGUAGE DeriveAnyClass     #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE NamedFieldPuns     #-}
{-# LANGUAGE OverloadedStrings  #-}
{-# LANGUAGE RecordWildCards    #-}
{-# LANGUAGE TemplateHaskell    #-}
{-# OPTIONS_GHC -Wno-orphans #-}
-- | The set of parameters, like protocol parameters and slot configuration.
module Cardano.Node.Emulator.Params(
  Params(..),
  paramsWithProtocolsParameters,
  slotConfigL,
  emulatorPParamsL,
  pParamsFromProtocolParams,
  pProtocolParams,
  protocolParamsL,
  networkIdL,
  increaseTransactionLimits,
  increaseTransactionLimits',
  genesisDefaultsFromParams,
  -- * cardano-ledger specific types and conversion functions
  EmulatorEra,
  PParams,
  slotLength,
  testnet,
  emulatorEpochSize,
  emulatorGlobals,
  emulatorEraHistory
) where

import Cardano.Api (CardanoMode, ConsensusMode (..), EraHistory (EraHistory))
import Cardano.Api qualified as C
import Cardano.Api.Shelley (AnyPlutusScriptVersion (..), CostModel (..), EpochNo (..), ExecutionUnitPrices (..),
                            ExecutionUnits (..), Lovelace (..), NetworkId (..), NetworkMagic (..),
                            PlutusScriptVersion (..), ProtocolParameters (..), shelleyGenesisDefaults)
import Cardano.Ledger.Babbage (BabbageEra)
import Cardano.Ledger.Babbage.PParams (retractPP)
import Cardano.Ledger.Babbage.PParams qualified as C
import Cardano.Ledger.BaseTypes (boundRational)
import Cardano.Ledger.Crypto (StandardCrypto)
import Cardano.Ledger.Shelley.API (Coin (..), Globals, ShelleyGenesis (..), mkShelleyGlobals)
import Cardano.Ledger.Shelley.API qualified as C.Ledger
import Cardano.Ledger.Slot (EpochSize (..))
import Cardano.Node.Emulator.TimeSlot (SlotConfig (..), posixTimeToNominalDiffTime, posixTimeToUTCTime)
import Cardano.Slotting.EpochInfo (fixedEpochInfo)
import Cardano.Slotting.Time (SlotLength, mkSlotLength)
import Control.Lens (Lens', lens, makeLensesFor, over, (&), (.~))
import Data.Aeson (FromJSON (parseJSON), ToJSON (toJSON), Value (Object), (.:), (.=))
import Data.Aeson qualified as JSON
import Data.Default (Default (def))
import Data.Map (fromList)
import Data.Maybe (fromMaybe)
import Data.Ratio ((%))
import Data.SOP.Strict (K (K), NP (..))
import GHC.Generics (Generic)
import GHC.Natural (Natural)
import Ouroboros.Consensus.HardFork.History qualified as Ouroboros
import Ouroboros.Consensus.Util.Counting qualified as Ouroboros
import Plutus.V1.Ledger.Api (POSIXTime (..))
import PlutusCore (defaultCostModelParams)
import Prettyprinter (Pretty (pretty), viaShow, vsep, (<+>))

-- | The default era for the emulator
type EmulatorEra = BabbageEra StandardCrypto

type PParams = C.PParams EmulatorEra

data Params = Params
  { Params -> SlotConfig
pSlotConfig     :: SlotConfig
  -- | Convert `Params` to cardano-ledger `PParams`
  , Params -> PParams
emulatorPParams :: PParams
  , Params -> NetworkId
pNetworkId      :: NetworkId
  }
  deriving (Params -> Params -> Bool
(Params -> Params -> Bool)
-> (Params -> Params -> Bool) -> Eq Params
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Params -> Params -> Bool
$c/= :: Params -> Params -> Bool
== :: Params -> Params -> Bool
$c== :: Params -> Params -> Bool
Eq, Int -> Params -> ShowS
[Params] -> ShowS
Params -> String
(Int -> Params -> ShowS)
-> (Params -> String) -> ([Params] -> ShowS) -> Show Params
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Params] -> ShowS
$cshowList :: [Params] -> ShowS
show :: Params -> String
$cshow :: Params -> String
showsPrec :: Int -> Params -> ShowS
$cshowsPrec :: Int -> Params -> ShowS
Show, (forall x. Params -> Rep Params x)
-> (forall x. Rep Params x -> Params) -> Generic Params
forall x. Rep Params x -> Params
forall x. Params -> Rep Params x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Params x -> Params
$cfrom :: forall x. Params -> Rep Params x
Generic)

deriving instance ToJSON NetworkId
instance FromJSON NetworkId

deriving newtype instance ToJSON NetworkMagic
deriving newtype instance FromJSON NetworkMagic

makeLensesFor
  [ ("pSlotConfig", "slotConfigL")
  , ("emulatorPParams", "emulatorPParamsL")
  , ("pNetworkId", "networkIdL") ]
  ''Params

pProtocolParams :: Params -> ProtocolParameters
pProtocolParams :: Params -> ProtocolParameters
pProtocolParams Params
p = ShelleyBasedEra BabbageEra
-> PParams (ShelleyLedgerEra BabbageEra) -> ProtocolParameters
forall era.
ShelleyBasedEra era
-> PParams (ShelleyLedgerEra era) -> ProtocolParameters
C.fromLedgerPParams ShelleyBasedEra BabbageEra
C.ShelleyBasedEraBabbage (PParams (ShelleyLedgerEra BabbageEra) -> ProtocolParameters)
-> PParams (ShelleyLedgerEra BabbageEra) -> ProtocolParameters
forall a b. (a -> b) -> a -> b
$ Params -> PParams
emulatorPParams Params
p

pParamsFromProtocolParams :: ProtocolParameters -> PParams
pParamsFromProtocolParams :: ProtocolParameters -> PParams
pParamsFromProtocolParams = ShelleyBasedEra BabbageEra
-> ProtocolParameters -> PParams (ShelleyLedgerEra BabbageEra)
forall era.
ShelleyBasedEra era
-> ProtocolParameters -> PParams (ShelleyLedgerEra era)
C.toLedgerPParams ShelleyBasedEra BabbageEra
C.ShelleyBasedEraBabbage

paramsWithProtocolsParameters :: SlotConfig -> ProtocolParameters -> NetworkId -> Params
paramsWithProtocolsParameters :: SlotConfig -> ProtocolParameters -> NetworkId -> Params
paramsWithProtocolsParameters SlotConfig
sc ProtocolParameters
p = SlotConfig -> PParams -> NetworkId -> Params
Params SlotConfig
sc (ProtocolParameters -> PParams
pParamsFromProtocolParams ProtocolParameters
p)

protocolParamsL :: Lens' Params ProtocolParameters
protocolParamsL :: (ProtocolParameters -> f ProtocolParameters) -> Params -> f Params
protocolParamsL = let
  set :: Params -> ProtocolParameters -> Params
set Params
p ProtocolParameters
pParam = Params
p Params -> (Params -> Params) -> Params
forall a b. a -> (a -> b) -> b
& (PParams -> Identity PParams) -> Params -> Identity Params
Lens' Params PParams
emulatorPParamsL ((PParams -> Identity PParams) -> Params -> Identity Params)
-> PParams -> Params -> Params
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ProtocolParameters -> PParams
pParamsFromProtocolParams ProtocolParameters
pParam
  in (Params -> ProtocolParameters)
-> (Params -> ProtocolParameters -> Params)
-> Lens Params Params ProtocolParameters ProtocolParameters
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens Params -> ProtocolParameters
pProtocolParams Params -> ProtocolParameters -> Params
set

instance ToJSON Params where
  toJSON :: Params -> Value
toJSON Params
p = [Pair] -> Value
JSON.object
    [ Key
"pSlotConfig" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= SlotConfig -> Value
forall a. ToJSON a => a -> Value
toJSON (Params -> SlotConfig
pSlotConfig Params
p)
    , Key
"pProtocolParams" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= ProtocolParameters -> Value
forall a. ToJSON a => a -> Value
toJSON (Params -> ProtocolParameters
pProtocolParams Params
p)
    , Key
"pNetworkId" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= NetworkId -> Value
forall a. ToJSON a => a -> Value
toJSON (Params -> NetworkId
pNetworkId Params
p)
    ]

instance FromJSON Params where
  parseJSON :: Value -> Parser Params
parseJSON (Object Object
v) = SlotConfig -> PParams -> NetworkId -> Params
Params
    (SlotConfig -> PParams -> NetworkId -> Params)
-> Parser SlotConfig -> Parser (PParams -> NetworkId -> Params)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object
v Object -> Key -> Parser Value
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"pSlotConfig" Parser Value -> (Value -> Parser SlotConfig) -> Parser SlotConfig
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> Parser SlotConfig
forall a. FromJSON a => Value -> Parser a
parseJSON)
    Parser (PParams -> NetworkId -> Params)
-> Parser PParams -> Parser (NetworkId -> Params)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (ShelleyBasedEra BabbageEra
-> ProtocolParameters -> PParams (ShelleyLedgerEra BabbageEra)
forall era.
ShelleyBasedEra era
-> ProtocolParameters -> PParams (ShelleyLedgerEra era)
C.toLedgerPParams ShelleyBasedEra BabbageEra
C.ShelleyBasedEraBabbage (ProtocolParameters -> PParams)
-> Parser ProtocolParameters -> Parser PParams
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object
v Object -> Key -> Parser Value
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"pProtocolParams" Parser Value
-> (Value -> Parser ProtocolParameters)
-> Parser ProtocolParameters
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> Parser ProtocolParameters
forall a. FromJSON a => Value -> Parser a
parseJSON))
    Parser (NetworkId -> Params) -> Parser NetworkId -> Parser Params
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Object
v Object -> Key -> Parser Value
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"pNetworkId" Parser Value -> (Value -> Parser NetworkId) -> Parser NetworkId
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> Parser NetworkId
forall a. FromJSON a => Value -> Parser a
parseJSON)
  parseJSON Value
_ = String -> Parser Params
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Can't parse a Param"

instance Pretty Params where
  pretty :: Params -> Doc ann
pretty p :: Params
p@Params{NetworkId
PParams
SlotConfig
pNetworkId :: NetworkId
emulatorPParams :: PParams
pSlotConfig :: SlotConfig
pNetworkId :: Params -> NetworkId
emulatorPParams :: Params -> PParams
pSlotConfig :: Params -> SlotConfig
..} =
    [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep [ Doc ann
"Slot config:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> SlotConfig -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty SlotConfig
pSlotConfig
         , Doc ann
"Network ID:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> NetworkId -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow NetworkId
pNetworkId
         , Doc ann
"Protocol Parameters:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> ProtocolParameters -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow (Params -> ProtocolParameters
pProtocolParams Params
p)
         ]

-- | Set higher limits on transaction size and execution units.
-- This can be used to work around @MaxTxSizeUTxO@ and @ExUnitsTooBigUTxO@ errors.
-- Note that if you need this your Plutus script will probably not validate on Mainnet.
increaseTransactionLimits :: Params -> Params
increaseTransactionLimits :: Params -> Params
increaseTransactionLimits = Natural -> Natural -> Natural -> Params -> Params
increaseTransactionLimits' Natural
2 Natural
10 Natural
10

increaseTransactionLimits' :: Natural -> Natural -> Natural -> Params -> Params
increaseTransactionLimits' :: Natural -> Natural -> Natural -> Params -> Params
increaseTransactionLimits' Natural
size Natural
steps Natural
mem = ASetter Params Params ProtocolParameters ProtocolParameters
-> (ProtocolParameters -> ProtocolParameters) -> Params -> Params
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter Params Params ProtocolParameters ProtocolParameters
Lens Params Params ProtocolParameters ProtocolParameters
protocolParamsL ProtocolParameters -> ProtocolParameters
fixParams
  where
    fixParams :: ProtocolParameters -> ProtocolParameters
fixParams ProtocolParameters
pp = ProtocolParameters
pp
      { protocolParamMaxTxSize :: Natural
protocolParamMaxTxSize = Natural
size Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
* ProtocolParameters -> Natural
protocolParamMaxTxSize ProtocolParameters
pp
      , protocolParamMaxTxExUnits :: Maybe ExecutionUnits
protocolParamMaxTxExUnits = ProtocolParameters -> Maybe ExecutionUnits
protocolParamMaxTxExUnits ProtocolParameters
pp Maybe ExecutionUnits
-> (ExecutionUnits -> Maybe ExecutionUnits) -> Maybe ExecutionUnits
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\ExecutionUnits {Natural
executionSteps :: ExecutionUnits -> Natural
executionSteps :: Natural
executionSteps, Natural
executionMemory :: ExecutionUnits -> Natural
executionMemory :: Natural
executionMemory} -> ExecutionUnits -> Maybe ExecutionUnits
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ExecutionUnits -> Maybe ExecutionUnits)
-> ExecutionUnits -> Maybe ExecutionUnits
forall a b. (a -> b) -> a -> b
$ ExecutionUnits :: Natural -> Natural -> ExecutionUnits
ExecutionUnits {executionSteps :: Natural
executionSteps = Natural
steps Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
* Natural
executionSteps, executionMemory :: Natural
executionMemory = Natural
mem Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
* Natural
executionMemory})
      }


-- | The network id used by default by 'Param'
testnet :: NetworkId
testnet :: NetworkId
testnet = NetworkMagic -> NetworkId
Testnet (NetworkMagic -> NetworkId) -> NetworkMagic -> NetworkId
forall a b. (a -> b) -> a -> b
$ Word32 -> NetworkMagic
NetworkMagic Word32
1

instance Default Params where
  def :: Params
def = SlotConfig -> PParams -> NetworkId -> Params
Params SlotConfig
forall a. Default a => a
def (ProtocolParameters -> PParams
pParamsFromProtocolParams ProtocolParameters
forall a. Default a => a
def) NetworkId
testnet

instance Default ProtocolParameters where
  -- The protocol parameters as they are in the Alonzo era.
  def :: ProtocolParameters
def = ProtocolParameters :: (Natural, Natural)
-> Maybe Rational
-> Maybe PraosNonce
-> Natural
-> Natural
-> Natural
-> Natural
-> Natural
-> Maybe Lovelace
-> Lovelace
-> Lovelace
-> Lovelace
-> EpochNo
-> Natural
-> Rational
-> Rational
-> Rational
-> Maybe Lovelace
-> Map AnyPlutusScriptVersion CostModel
-> Maybe ExecutionUnitPrices
-> Maybe ExecutionUnits
-> Maybe ExecutionUnits
-> Maybe Natural
-> Maybe Natural
-> Maybe Natural
-> Maybe Lovelace
-> ProtocolParameters
ProtocolParameters
    { protocolParamProtocolVersion :: (Natural, Natural)
protocolParamProtocolVersion = (Natural
7,Natural
0)
    , protocolParamDecentralization :: Maybe Rational
protocolParamDecentralization = Maybe Rational
forall a. Maybe a
Nothing
    , protocolParamExtraPraosEntropy :: Maybe PraosNonce
protocolParamExtraPraosEntropy = Maybe PraosNonce
forall a. Maybe a
Nothing
    , protocolParamMaxBlockHeaderSize :: Natural
protocolParamMaxBlockHeaderSize = Natural
1100
    , protocolParamMaxBlockBodySize :: Natural
protocolParamMaxBlockBodySize = Natural
90112
    , protocolParamMaxTxSize :: Natural
protocolParamMaxTxSize = Natural
16384
    , protocolParamTxFeeFixed :: Natural
protocolParamTxFeeFixed = Natural
155381
    , protocolParamTxFeePerByte :: Natural
protocolParamTxFeePerByte = Natural
44
    , protocolParamMinUTxOValue :: Maybe Lovelace
protocolParamMinUTxOValue = Maybe Lovelace
forall a. Maybe a
Nothing
    , protocolParamStakeAddressDeposit :: Lovelace
protocolParamStakeAddressDeposit = Integer -> Lovelace
Lovelace Integer
2000000
    , protocolParamStakePoolDeposit :: Lovelace
protocolParamStakePoolDeposit = Integer -> Lovelace
Lovelace Integer
500000000
    , protocolParamMinPoolCost :: Lovelace
protocolParamMinPoolCost = Integer -> Lovelace
Lovelace Integer
340000000
    , protocolParamPoolRetireMaxEpoch :: EpochNo
protocolParamPoolRetireMaxEpoch = Word64 -> EpochNo
EpochNo Word64
18
    , protocolParamStakePoolTargetNum :: Natural
protocolParamStakePoolTargetNum = Natural
500
    , protocolParamPoolPledgeInfluence :: Rational
protocolParamPoolPledgeInfluence = Integer
3 Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Integer
10
    , protocolParamMonetaryExpansion :: Rational
protocolParamMonetaryExpansion = Integer
3 Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Integer
1000
    , protocolParamTreasuryCut :: Rational
protocolParamTreasuryCut = Integer
1 Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Integer
5
    , protocolParamUTxOCostPerWord :: Maybe Lovelace
protocolParamUTxOCostPerWord = Maybe Lovelace
forall a. Maybe a
Nothing -- Obsolete from babbage onwards
    , protocolParamCostModels :: Map AnyPlutusScriptVersion CostModel
protocolParamCostModels = [(AnyPlutusScriptVersion, CostModel)]
-> Map AnyPlutusScriptVersion CostModel
forall k a. Ord k => [(k, a)] -> Map k a
fromList
      [ (PlutusScriptVersion PlutusScriptV1 -> AnyPlutusScriptVersion
forall lang. PlutusScriptVersion lang -> AnyPlutusScriptVersion
AnyPlutusScriptVersion PlutusScriptVersion PlutusScriptV1
PlutusScriptV1, Map Text Integer -> CostModel
CostModel (Map Text Integer -> CostModel) -> Map Text Integer -> CostModel
forall a b. (a -> b) -> a -> b
$ Map Text Integer -> Maybe (Map Text Integer) -> Map Text Integer
forall a. a -> Maybe a -> a
fromMaybe (String -> Map Text Integer
forall a. HasCallStack => String -> a
error String
"Ledger.Params: defaultCostModelParams is broken") Maybe (Map Text Integer)
defaultCostModelParams)
      , (PlutusScriptVersion PlutusScriptV2 -> AnyPlutusScriptVersion
forall lang. PlutusScriptVersion lang -> AnyPlutusScriptVersion
AnyPlutusScriptVersion PlutusScriptVersion PlutusScriptV2
PlutusScriptV2, Map Text Integer -> CostModel
CostModel (Map Text Integer -> CostModel) -> Map Text Integer -> CostModel
forall a b. (a -> b) -> a -> b
$ Map Text Integer -> Maybe (Map Text Integer) -> Map Text Integer
forall a. a -> Maybe a -> a
fromMaybe (String -> Map Text Integer
forall a. HasCallStack => String -> a
error String
"Ledger.Params: defaultCostModelParams is broken") Maybe (Map Text Integer)
defaultCostModelParams) ]
    , protocolParamPrices :: Maybe ExecutionUnitPrices
protocolParamPrices = ExecutionUnitPrices -> Maybe ExecutionUnitPrices
forall a. a -> Maybe a
Just (ExecutionUnitPrices :: Rational -> Rational -> ExecutionUnitPrices
ExecutionUnitPrices {priceExecutionSteps :: Rational
priceExecutionSteps = Integer
721 Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Integer
10000000, priceExecutionMemory :: Rational
priceExecutionMemory = Integer
577 Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Integer
10000})
    , protocolParamMaxTxExUnits :: Maybe ExecutionUnits
protocolParamMaxTxExUnits = ExecutionUnits -> Maybe ExecutionUnits
forall a. a -> Maybe a
Just (ExecutionUnits :: Natural -> Natural -> ExecutionUnits
ExecutionUnits {executionSteps :: Natural
executionSteps = Natural
10000000000, executionMemory :: Natural
executionMemory = Natural
14000000})
    , protocolParamMaxBlockExUnits :: Maybe ExecutionUnits
protocolParamMaxBlockExUnits = ExecutionUnits -> Maybe ExecutionUnits
forall a. a -> Maybe a
Just (ExecutionUnits :: Natural -> Natural -> ExecutionUnits
ExecutionUnits {executionSteps :: Natural
executionSteps = Natural
40000000000, executionMemory :: Natural
executionMemory = Natural
62000000})
    , protocolParamMaxValueSize :: Maybe Natural
protocolParamMaxValueSize = Natural -> Maybe Natural
forall a. a -> Maybe a
Just Natural
5000
    , protocolParamCollateralPercent :: Maybe Natural
protocolParamCollateralPercent = Natural -> Maybe Natural
forall a. a -> Maybe a
Just Natural
150
    , protocolParamMaxCollateralInputs :: Maybe Natural
protocolParamMaxCollateralInputs = Natural -> Maybe Natural
forall a. a -> Maybe a
Just Natural
3
    , protocolParamUTxOCostPerByte :: Maybe Lovelace
protocolParamUTxOCostPerByte =
        let (Coin Integer
coinsPerUTxOByte) = Integer -> Coin
Coin Integer
4310
         in Lovelace -> Maybe Lovelace
forall a. a -> Maybe a
Just (Lovelace -> Maybe Lovelace) -> Lovelace -> Maybe Lovelace
forall a b. (a -> b) -> a -> b
$ Integer -> Lovelace
Lovelace Integer
coinsPerUTxOByte
    }


-- | Calculate the cardano-ledger `SlotLength`
slotLength :: Params -> SlotLength
slotLength :: Params -> SlotLength
slotLength Params { SlotConfig
pSlotConfig :: SlotConfig
pSlotConfig :: Params -> SlotConfig
pSlotConfig } = NominalDiffTime -> SlotLength
mkSlotLength (NominalDiffTime -> SlotLength) -> NominalDiffTime -> SlotLength
forall a b. (a -> b) -> a -> b
$ POSIXTime -> NominalDiffTime
posixTimeToNominalDiffTime (POSIXTime -> NominalDiffTime) -> POSIXTime -> NominalDiffTime
forall a b. (a -> b) -> a -> b
$ Integer -> POSIXTime
POSIXTime (Integer -> POSIXTime) -> Integer -> POSIXTime
forall a b. (a -> b) -> a -> b
$ SlotConfig -> Integer
scSlotLength SlotConfig
pSlotConfig


-- | A sensible default 'EpochSize' value for the emulator
emulatorEpochSize :: EpochSize
emulatorEpochSize :: EpochSize
emulatorEpochSize = Word64 -> EpochSize
EpochSize Word64
432000

-- | A sensible default 'Globals' value for the emulator
emulatorGlobals :: Params -> Globals
emulatorGlobals :: Params -> Globals
emulatorGlobals Params
params = ShelleyGenesis EmulatorEra
-> EpochInfo (Either Text) -> Natural -> Globals
forall era.
ShelleyGenesis era -> EpochInfo (Either Text) -> Natural -> Globals
mkShelleyGlobals
  (Params -> ShelleyGenesis EmulatorEra
genesisDefaultsFromParams Params
params)
  (EpochSize -> SlotLength -> EpochInfo (Either Text)
forall (m :: * -> *).
Monad m =>
EpochSize -> SlotLength -> EpochInfo m
fixedEpochInfo EpochSize
emulatorEpochSize (Params -> SlotLength
slotLength Params
params))
  ((Natural, Natural) -> Natural
forall a b. (a, b) -> a
fst ((Natural, Natural) -> Natural) -> (Natural, Natural) -> Natural
forall a b. (a -> b) -> a -> b
$ ProtocolParameters -> (Natural, Natural)
protocolParamProtocolVersion (ProtocolParameters -> (Natural, Natural))
-> ProtocolParameters -> (Natural, Natural)
forall a b. (a -> b) -> a -> b
$ Params -> ProtocolParameters
pProtocolParams Params
params)

genesisDefaultsFromParams :: Params -> ShelleyGenesis EmulatorEra
genesisDefaultsFromParams :: Params -> ShelleyGenesis EmulatorEra
genesisDefaultsFromParams params :: Params
params@Params { SlotConfig
pSlotConfig :: SlotConfig
pSlotConfig :: Params -> SlotConfig
pSlotConfig, NetworkId
pNetworkId :: NetworkId
pNetworkId :: Params -> NetworkId
pNetworkId } = ShelleyGenesis EmulatorEra
forall crypto. ShelleyGenesis crypto
shelleyGenesisDefaults
  { sgSystemStart :: UTCTime
sgSystemStart = POSIXTime -> UTCTime
posixTimeToUTCTime (POSIXTime -> UTCTime) -> POSIXTime -> UTCTime
forall a b. (a -> b) -> a -> b
$ SlotConfig -> POSIXTime
scSlotZeroTime SlotConfig
pSlotConfig
  , sgNetworkMagic :: Word32
sgNetworkMagic = case NetworkId
pNetworkId of Testnet (NetworkMagic Word32
nm) -> Word32
nm; NetworkId
_ -> Word32
0
  , sgNetworkId :: Network
sgNetworkId = case NetworkId
pNetworkId of Testnet NetworkMagic
_ -> Network
C.Ledger.Testnet; NetworkId
Mainnet -> Network
C.Ledger.Mainnet
  , sgProtocolParams :: PParams EmulatorEra
sgProtocolParams = HKD Identity Coin
-> HKD Identity UnitInterval
-> HKD Identity Nonce
-> PParams
-> PParams EmulatorEra
forall (f :: * -> *) era.
HKD f Coin
-> HKD f UnitInterval
-> HKD f Nonce
-> PParams' f era
-> PParams' f era
retractPP (Integer -> Coin
Coin Integer
0) UnitInterval
HKD Identity UnitInterval
d Nonce
HKD Identity Nonce
C.Ledger.NeutralNonce (PParams -> PParams EmulatorEra) -> PParams -> PParams EmulatorEra
forall a b. (a -> b) -> a -> b
$ Params -> PParams
emulatorPParams Params
params
  }
  where
    d :: UnitInterval
d = UnitInterval -> Maybe UnitInterval -> UnitInterval
forall a. a -> Maybe a -> a
fromMaybe (String -> UnitInterval
forall a. HasCallStack => String -> a
error String
"3 % 5 should be valid UnitInterval") (Maybe UnitInterval -> UnitInterval)
-> Maybe UnitInterval -> UnitInterval
forall a b. (a -> b) -> a -> b
$ Rational -> Maybe UnitInterval
forall r. BoundedRational r => Rational -> Maybe r
boundRational (Integer
3 Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Integer
5)

-- | A sensible default 'EraHistory' value for the emulator
emulatorEraHistory :: Params -> EraHistory CardanoMode
emulatorEraHistory :: Params -> EraHistory CardanoMode
emulatorEraHistory Params
params = ConsensusMode CardanoMode
-> Interpreter
     '[ByronBlock,
       ShelleyBlock (TPraos StandardCrypto) (ShelleyEra StandardCrypto),
       ShelleyBlock (TPraos StandardCrypto) (AllegraEra StandardCrypto),
       ShelleyBlock (TPraos StandardCrypto) (MaryEra StandardCrypto),
       ShelleyBlock (TPraos StandardCrypto) (AlonzoEra StandardCrypto),
       ShelleyBlock (Praos StandardCrypto) EmulatorEra]
-> EraHistory CardanoMode
forall mode (xs :: [*]).
(ConsensusBlockForMode mode ~ HardForkBlock xs) =>
ConsensusMode mode -> Interpreter xs -> EraHistory mode
EraHistory ConsensusMode CardanoMode
CardanoMode (Summary
  '[ByronBlock,
    ShelleyBlock (TPraos StandardCrypto) (ShelleyEra StandardCrypto),
    ShelleyBlock (TPraos StandardCrypto) (AllegraEra StandardCrypto),
    ShelleyBlock (TPraos StandardCrypto) (MaryEra StandardCrypto),
    ShelleyBlock (TPraos StandardCrypto) (AlonzoEra StandardCrypto),
    ShelleyBlock (Praos StandardCrypto) EmulatorEra]
-> Interpreter
     '[ByronBlock,
       ShelleyBlock (TPraos StandardCrypto) (ShelleyEra StandardCrypto),
       ShelleyBlock (TPraos StandardCrypto) (AllegraEra StandardCrypto),
       ShelleyBlock (TPraos StandardCrypto) (MaryEra StandardCrypto),
       ShelleyBlock (TPraos StandardCrypto) (AlonzoEra StandardCrypto),
       ShelleyBlock (Praos StandardCrypto) EmulatorEra]
forall (xs :: [*]). Summary xs -> Interpreter xs
Ouroboros.mkInterpreter (Summary
   '[ByronBlock,
     ShelleyBlock (TPraos StandardCrypto) (ShelleyEra StandardCrypto),
     ShelleyBlock (TPraos StandardCrypto) (AllegraEra StandardCrypto),
     ShelleyBlock (TPraos StandardCrypto) (MaryEra StandardCrypto),
     ShelleyBlock (TPraos StandardCrypto) (AlonzoEra StandardCrypto),
     ShelleyBlock (Praos StandardCrypto) EmulatorEra]
 -> Interpreter
      '[ByronBlock,
        ShelleyBlock (TPraos StandardCrypto) (ShelleyEra StandardCrypto),
        ShelleyBlock (TPraos StandardCrypto) (AllegraEra StandardCrypto),
        ShelleyBlock (TPraos StandardCrypto) (MaryEra StandardCrypto),
        ShelleyBlock (TPraos StandardCrypto) (AlonzoEra StandardCrypto),
        ShelleyBlock (Praos StandardCrypto) EmulatorEra])
-> Summary
     '[ByronBlock,
       ShelleyBlock (TPraos StandardCrypto) (ShelleyEra StandardCrypto),
       ShelleyBlock (TPraos StandardCrypto) (AllegraEra StandardCrypto),
       ShelleyBlock (TPraos StandardCrypto) (MaryEra StandardCrypto),
       ShelleyBlock (TPraos StandardCrypto) (AlonzoEra StandardCrypto),
       ShelleyBlock (Praos StandardCrypto) EmulatorEra]
-> Interpreter
     '[ByronBlock,
       ShelleyBlock (TPraos StandardCrypto) (ShelleyEra StandardCrypto),
       ShelleyBlock (TPraos StandardCrypto) (AllegraEra StandardCrypto),
       ShelleyBlock (TPraos StandardCrypto) (MaryEra StandardCrypto),
       ShelleyBlock (TPraos StandardCrypto) (AlonzoEra StandardCrypto),
       ShelleyBlock (Praos StandardCrypto) EmulatorEra]
forall a b. (a -> b) -> a -> b
$ Exactly
  '[ByronBlock,
    ShelleyBlock (TPraos StandardCrypto) (ShelleyEra StandardCrypto),
    ShelleyBlock (TPraos StandardCrypto) (AllegraEra StandardCrypto),
    ShelleyBlock (TPraos StandardCrypto) (MaryEra StandardCrypto),
    ShelleyBlock (TPraos StandardCrypto) (AlonzoEra StandardCrypto),
    ShelleyBlock (Praos StandardCrypto) EmulatorEra]
  EraSummary
-> Summary
     '[ByronBlock,
       ShelleyBlock (TPraos StandardCrypto) (ShelleyEra StandardCrypto),
       ShelleyBlock (TPraos StandardCrypto) (AllegraEra StandardCrypto),
       ShelleyBlock (TPraos StandardCrypto) (MaryEra StandardCrypto),
       ShelleyBlock (TPraos StandardCrypto) (AlonzoEra StandardCrypto),
       ShelleyBlock (Praos StandardCrypto) EmulatorEra]
forall x (xs :: [*]).
Exactly (x : xs) EraSummary -> Summary (x : xs)
Ouroboros.summaryWithExactly Exactly
  '[ByronBlock,
    ShelleyBlock (TPraos StandardCrypto) (ShelleyEra StandardCrypto),
    ShelleyBlock (TPraos StandardCrypto) (AllegraEra StandardCrypto),
    ShelleyBlock (TPraos StandardCrypto) (MaryEra StandardCrypto),
    ShelleyBlock (TPraos StandardCrypto) (AlonzoEra StandardCrypto),
    ShelleyBlock (Praos StandardCrypto) EmulatorEra]
  EraSummary
forall x x x x x x. Exactly '[x, x, x, x, x, x] EraSummary
list)
  where
    one :: EraSummary
one = NonEmpty '[Any] EraSummary -> EraSummary
forall (xs :: [*]) a. NonEmpty xs a -> a
Ouroboros.nonEmptyHead (NonEmpty '[Any] EraSummary -> EraSummary)
-> NonEmpty '[Any] EraSummary -> EraSummary
forall a b. (a -> b) -> a -> b
$ Summary '[Any] -> NonEmpty '[Any] EraSummary
forall (xs :: [*]). Summary xs -> NonEmpty xs EraSummary
Ouroboros.getSummary (Summary '[Any] -> NonEmpty '[Any] EraSummary)
-> Summary '[Any] -> NonEmpty '[Any] EraSummary
forall a b. (a -> b) -> a -> b
$ EpochSize -> SlotLength -> Summary '[Any]
forall x. EpochSize -> SlotLength -> Summary '[x]
Ouroboros.neverForksSummary EpochSize
emulatorEpochSize (Params -> SlotLength
slotLength Params
params)
    list :: Exactly '[x, x, x, x, x, x] EraSummary
list = NP (K EraSummary) '[x, x, x, x, x, x]
-> Exactly '[x, x, x, x, x, x] EraSummary
forall (xs :: [*]) a. NP (K a) xs -> Exactly xs a
Ouroboros.Exactly (NP (K EraSummary) '[x, x, x, x, x, x]
 -> Exactly '[x, x, x, x, x, x] EraSummary)
-> NP (K EraSummary) '[x, x, x, x, x, x]
-> Exactly '[x, x, x, x, x, x] EraSummary
forall a b. (a -> b) -> a -> b
$ EraSummary -> K EraSummary x
forall k a (b :: k). a -> K a b
K EraSummary
one K EraSummary x
-> NP (K EraSummary) '[x, x, x, x, x]
-> NP (K EraSummary) '[x, x, x, x, x, x]
forall k (a :: k -> *) (x :: k) (xs :: [k]).
a x -> NP a xs -> NP a (x : xs)
:* EraSummary -> K EraSummary x
forall k a (b :: k). a -> K a b
K EraSummary
one K EraSummary x
-> NP (K EraSummary) '[x, x, x, x]
-> NP (K EraSummary) '[x, x, x, x, x]
forall k (a :: k -> *) (x :: k) (xs :: [k]).
a x -> NP a xs -> NP a (x : xs)
:* EraSummary -> K EraSummary x
forall k a (b :: k). a -> K a b
K EraSummary
one K EraSummary x
-> NP (K EraSummary) '[x, x, x] -> NP (K EraSummary) '[x, x, x, x]
forall k (a :: k -> *) (x :: k) (xs :: [k]).
a x -> NP a xs -> NP a (x : xs)
:* EraSummary -> K EraSummary x
forall k a (b :: k). a -> K a b
K EraSummary
one K EraSummary x
-> NP (K EraSummary) '[x, x] -> NP (K EraSummary) '[x, x, x]
forall k (a :: k -> *) (x :: k) (xs :: [k]).
a x -> NP a xs -> NP a (x : xs)
:* EraSummary -> K EraSummary x
forall k a (b :: k). a -> K a b
K EraSummary
one K EraSummary x
-> NP (K EraSummary) '[x] -> NP (K EraSummary) '[x, x]
forall k (a :: k -> *) (x :: k) (xs :: [k]).
a x -> NP a xs -> NP a (x : xs)
:* EraSummary -> K EraSummary x
forall k a (b :: k). a -> K a b
K EraSummary
one K EraSummary x -> NP (K EraSummary) '[] -> NP (K EraSummary) '[x]
forall k (a :: k -> *) (x :: k) (xs :: [k]).
a x -> NP a xs -> NP a (x : xs)
:* NP (K EraSummary) '[]
forall k (a :: k -> *). NP a '[]
Nil