Skip to content

Commit

Permalink
Add Inject instances for Eons
Browse files Browse the repository at this point in the history
  • Loading branch information
carbolymer committed Nov 14, 2024
1 parent d7c62a0 commit 5d03c61
Show file tree
Hide file tree
Showing 24 changed files with 234 additions and 110 deletions.
11 changes: 5 additions & 6 deletions cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs
Original file line number Diff line number Diff line change
Expand Up @@ -134,7 +134,6 @@ import qualified Cardano.Api as Api
import Cardano.Api.Byron (KeyWitness (ByronKeyWitness),
WitnessNetworkIdOrByronAddress (..))
import qualified Cardano.Api.Byron as Byron
import Cardano.Api.Eon.AllegraEraOnwards (allegraEraOnwardsToShelleyBasedEra)
import Cardano.Api.Error
import qualified Cardano.Api.Ledger as L
import qualified Cardano.Api.Ledger.Lens as A
Expand Down Expand Up @@ -392,15 +391,15 @@ genLedgerValue w genAId genQuant =
genValueDefault :: MaryEraOnwards era -> Gen (L.Value (ShelleyLedgerEra era))
genValueDefault w = genLedgerValue w genAssetId genSignedNonZeroQuantity

genValueForRole :: MaryEraOnwards era -> ParserValueRole -> Gen Value
genValueForRole :: forall era. MaryEraOnwards era -> ParserValueRole -> Gen Value
genValueForRole w =
\case
RoleMint ->
genValueForMinting
RoleUTxO ->
fromLedgerValue sbe <$> genValueForTxOut sbe
where
sbe = maryEraOnwardsToShelleyBasedEra w
sbe = inject w :: ShelleyBasedEra era

-- | Generate a 'Value' suitable for minting, i.e. non-ADA asset ID and a
-- positive or negative quantity.
Expand Down Expand Up @@ -600,7 +599,7 @@ genTxAuxScripts era =
TxAuxScripts w
<$> Gen.list
(Range.linear 0 3)
(genScriptInEra (allegraEraOnwardsToShelleyBasedEra w))
(genScriptInEra (inject w))
)

genTxWithdrawals :: CardanoEra era -> Gen (TxWithdrawals build era)
Expand Down Expand Up @@ -1163,7 +1162,7 @@ genProposals w = conwayEraOnwardsConstraints w $ do
-- We're doing it for the complete representation of possible values space of TxProposalProcedures.
-- Proposal procedures code in cardano-api should handle such invalid values just fine.
extraProposals <- Gen.list (Range.constant 0 10) (genProposal w)
let sbe = conwayEraOnwardsToShelleyBasedEra w
let sbe = inject w
proposalsWithWitnesses <-
forM (extraProposals <> proposalsToBeWitnessed) $ \proposal ->
(proposal,) <$> genScriptWitnessForStake sbe
Expand All @@ -1178,7 +1177,7 @@ genVotingProcedures :: Applicative (BuildTxWith build)
-> Gen (Api.TxVotingProcedures build era)
genVotingProcedures w = conwayEraOnwardsConstraints w $ do
voters <- Gen.list (Range.constant 0 10) Q.arbitrary
let sbe = conwayEraOnwardsToShelleyBasedEra w
let sbe = inject w
votersWithWitnesses <- fmap fromList . forM voters $ \voter ->
(voter,) <$> genScriptWitnessForStake sbe
Api.TxVotingProcedures <$> Q.arbitrary <*> pure (pure votersWithWitnesses)
Expand Down
4 changes: 2 additions & 2 deletions cardano-api/internal/Cardano/Api/Certificate.hs
Original file line number Diff line number Diff line change
Expand Up @@ -515,10 +515,10 @@ selectStakeCredentialWitness
selectStakeCredentialWitness = \case
ShelleyRelatedCertificate stbEra shelleyCert ->
shelleyToBabbageEraConstraints stbEra $
getTxCertWitness (shelleyToBabbageEraToShelleyBasedEra stbEra) shelleyCert
getTxCertWitness (inject stbEra) shelleyCert
ConwayCertificate cEra conwayCert ->
conwayEraOnwardsConstraints cEra $
getTxCertWitness (conwayEraOnwardsToShelleyBasedEra cEra) conwayCert
getTxCertWitness (inject cEra) conwayCert

filterUnRegCreds
:: Certificate era -> Maybe StakeCredential
Expand Down
20 changes: 14 additions & 6 deletions cardano-api/internal/Cardano/Api/Eon/AllegraEraOnwards.hs
Original file line number Diff line number Diff line change
Expand Up @@ -3,6 +3,7 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
Expand Down Expand Up @@ -66,6 +67,17 @@ instance ToCardanoEra AllegraEraOnwards where
AllegraEraOnwardsBabbage -> BabbageEra
AllegraEraOnwardsConway -> ConwayEra

instance Inject (AllegraEraOnwards era) (CardanoEra era) where
inject = toCardanoEra

instance Inject (AllegraEraOnwards era) (ShelleyBasedEra era) where
inject = \case
AllegraEraOnwardsAllegra -> ShelleyBasedEraAllegra
AllegraEraOnwardsMary -> ShelleyBasedEraMary
AllegraEraOnwardsAlonzo -> ShelleyBasedEraAlonzo
AllegraEraOnwardsBabbage -> ShelleyBasedEraBabbage
AllegraEraOnwardsConway -> ShelleyBasedEraConway

type AllegraEraOnwardsConstraints era =
( C.HashAlgorithm (L.HASH (L.EraCrypto (ShelleyLedgerEra era)))
, C.Signable (L.VRF (L.EraCrypto (ShelleyLedgerEra era))) L.Seed
Expand Down Expand Up @@ -103,13 +115,9 @@ allegraEraOnwardsConstraints = \case
AllegraEraOnwardsBabbage -> id
AllegraEraOnwardsConway -> id

{-# DEPRECATED allegraEraOnwardsToShelleyBasedEra "Use 'inject' instead." #-}
allegraEraOnwardsToShelleyBasedEra :: AllegraEraOnwards era -> ShelleyBasedEra era
allegraEraOnwardsToShelleyBasedEra = \case
AllegraEraOnwardsAllegra -> ShelleyBasedEraAllegra
AllegraEraOnwardsMary -> ShelleyBasedEraMary
AllegraEraOnwardsAlonzo -> ShelleyBasedEraAlonzo
AllegraEraOnwardsBabbage -> ShelleyBasedEraBabbage
AllegraEraOnwardsConway -> ShelleyBasedEraConway
allegraEraOnwardsToShelleyBasedEra = inject

class IsShelleyBasedEra era => IsAllegraBasedEra era where
allegraBasedEra :: AllegraEraOnwards era
Expand Down
16 changes: 12 additions & 4 deletions cardano-api/internal/Cardano/Api/Eon/AlonzoEraOnwards.hs
Original file line number Diff line number Diff line change
Expand Up @@ -3,6 +3,7 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
Expand Down Expand Up @@ -70,6 +71,15 @@ instance ToCardanoEra AlonzoEraOnwards where
AlonzoEraOnwardsBabbage -> BabbageEra
AlonzoEraOnwardsConway -> ConwayEra

instance Inject (AlonzoEraOnwards era) (CardanoEra era) where
inject = toCardanoEra

instance Inject (AlonzoEraOnwards era) (ShelleyBasedEra era) where
inject = \case
AlonzoEraOnwardsAlonzo -> ShelleyBasedEraAlonzo
AlonzoEraOnwardsBabbage -> ShelleyBasedEraBabbage
AlonzoEraOnwardsConway -> ShelleyBasedEraConway

type AlonzoEraOnwardsConstraints era =
( C.HashAlgorithm (L.HASH (L.EraCrypto (ShelleyLedgerEra era)))
, C.Signable (L.VRF (L.EraCrypto (ShelleyLedgerEra era))) L.Seed
Expand Down Expand Up @@ -114,11 +124,9 @@ alonzoEraOnwardsConstraints = \case
AlonzoEraOnwardsBabbage -> id
AlonzoEraOnwardsConway -> id

{-# DEPRECATED alonzoEraOnwardsToShelleyBasedEra "Use 'inject' instead." #-}
alonzoEraOnwardsToShelleyBasedEra :: AlonzoEraOnwards era -> ShelleyBasedEra era
alonzoEraOnwardsToShelleyBasedEra = \case
AlonzoEraOnwardsAlonzo -> ShelleyBasedEraAlonzo
AlonzoEraOnwardsBabbage -> ShelleyBasedEraBabbage
AlonzoEraOnwardsConway -> ShelleyBasedEraConway
alonzoEraOnwardsToShelleyBasedEra = inject

class IsMaryBasedEra era => IsAlonzoBasedEra era where
alonzoBasedEra :: AlonzoEraOnwards era
Expand Down
20 changes: 17 additions & 3 deletions cardano-api/internal/Cardano/Api/Eon/BabbageEraOnwards.hs
Original file line number Diff line number Diff line change
Expand Up @@ -3,8 +3,11 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

Expand All @@ -18,6 +21,7 @@ module Cardano.Api.Eon.BabbageEraOnwards
where

import Cardano.Api.Eon.AlonzoEraOnwards
import Cardano.Api.Eon.MaryEraOnwards
import Cardano.Api.Eon.ShelleyBasedEra
import Cardano.Api.Eras.Core
import Cardano.Api.Modes
Expand Down Expand Up @@ -66,6 +70,17 @@ instance ToCardanoEra BabbageEraOnwards where
BabbageEraOnwardsBabbage -> BabbageEra
BabbageEraOnwardsConway -> ConwayEra

instance Inject (BabbageEraOnwards era) (CardanoEra era) where
inject = toCardanoEra

instance Inject (BabbageEraOnwards era) (ShelleyBasedEra era) where
inject = inject @(MaryEraOnwards era) . inject

instance Inject (BabbageEraOnwards era) (MaryEraOnwards era) where
inject = \case
BabbageEraOnwardsBabbage -> MaryEraOnwardsBabbage
BabbageEraOnwardsConway -> MaryEraOnwardsConway

type BabbageEraOnwardsConstraints era =
( C.HashAlgorithm (L.HASH (L.EraCrypto (ShelleyLedgerEra era)))
, C.Signable (L.VRF (L.EraCrypto (ShelleyLedgerEra era))) L.Seed
Expand Down Expand Up @@ -109,10 +124,9 @@ babbageEraOnwardsConstraints = \case
BabbageEraOnwardsBabbage -> id
BabbageEraOnwardsConway -> id

{-# DEPRECATED babbageEraOnwardsToShelleyBasedEra "Use 'inject' instead." #-}
babbageEraOnwardsToShelleyBasedEra :: BabbageEraOnwards era -> ShelleyBasedEra era
babbageEraOnwardsToShelleyBasedEra = \case
BabbageEraOnwardsBabbage -> ShelleyBasedEraBabbage
BabbageEraOnwardsConway -> ShelleyBasedEraConway
babbageEraOnwardsToShelleyBasedEra = inject

class IsAlonzoBasedEra era => IsBabbageBasedEra era where
babbageBasedEra :: BabbageEraOnwards era
Expand Down
4 changes: 4 additions & 0 deletions cardano-api/internal/Cardano/Api/Eon/ByronToAlonzoEra.hs
Original file line number Diff line number Diff line change
Expand Up @@ -3,6 +3,7 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
Expand Down Expand Up @@ -47,6 +48,9 @@ instance ToCardanoEra ByronToAlonzoEra where
ByronToAlonzoEraMary -> MaryEra
ByronToAlonzoEraAlonzo -> AlonzoEra

instance Inject (ByronToAlonzoEra era) (CardanoEra era) where
inject = toCardanoEra

type ByronToAlonzoEraConstraints era =
( IsCardanoEra era
, Typeable era
Expand Down
20 changes: 16 additions & 4 deletions cardano-api/internal/Cardano/Api/Eon/ConwayEraOnwards.hs
Original file line number Diff line number Diff line change
Expand Up @@ -3,6 +3,7 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
Expand Down Expand Up @@ -66,6 +67,17 @@ instance ToCardanoEra ConwayEraOnwards where
toCardanoEra = \case
ConwayEraOnwardsConway -> ConwayEra

instance Inject (ConwayEraOnwards era) (CardanoEra era) where
inject = toCardanoEra

instance Inject (ConwayEraOnwards era) (ShelleyBasedEra era) where
inject = \case
ConwayEraOnwardsConway -> ShelleyBasedEraConway

instance Inject (ConwayEraOnwards era) (BabbageEraOnwards era) where
inject = \case
ConwayEraOnwardsConway -> BabbageEraOnwardsConway

type ConwayEraOnwardsConstraints era =
( C.HashAlgorithm (L.HASH (L.EraCrypto (ShelleyLedgerEra era)))
, C.Signable (L.VRF (L.EraCrypto (ShelleyLedgerEra era))) L.Seed
Expand Down Expand Up @@ -113,13 +125,13 @@ conwayEraOnwardsConstraints
conwayEraOnwardsConstraints = \case
ConwayEraOnwardsConway -> id

{-# DEPRECATED conwayEraOnwardsToShelleyBasedEra "Use 'inject' instead." #-}
conwayEraOnwardsToShelleyBasedEra :: ConwayEraOnwards era -> ShelleyBasedEra era
conwayEraOnwardsToShelleyBasedEra = \case
ConwayEraOnwardsConway -> ShelleyBasedEraConway
conwayEraOnwardsToShelleyBasedEra = inject

{-# DEPRECATED conwayEraOnwardsToBabbageEraOnwards "Use 'inject' instead." #-}
conwayEraOnwardsToBabbageEraOnwards :: ConwayEraOnwards era -> BabbageEraOnwards era
conwayEraOnwardsToBabbageEraOnwards = \case
ConwayEraOnwardsConway -> BabbageEraOnwardsConway
conwayEraOnwardsToBabbageEraOnwards = inject

class IsBabbageBasedEra era => IsConwayBasedEra era where
conwayBasedEra :: ConwayEraOnwards era
Expand Down
18 changes: 13 additions & 5 deletions cardano-api/internal/Cardano/Api/Eon/MaryEraOnwards.hs
Original file line number Diff line number Diff line change
Expand Up @@ -3,6 +3,7 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
Expand Down Expand Up @@ -67,6 +68,16 @@ instance ToCardanoEra MaryEraOnwards where
MaryEraOnwardsBabbage -> BabbageEra
MaryEraOnwardsConway -> ConwayEra

instance Inject (MaryEraOnwards era) (CardanoEra era) where
inject = toCardanoEra

instance Inject (MaryEraOnwards era) (ShelleyBasedEra era) where
inject = \case
MaryEraOnwardsMary -> ShelleyBasedEraMary
MaryEraOnwardsAlonzo -> ShelleyBasedEraAlonzo
MaryEraOnwardsBabbage -> ShelleyBasedEraBabbage
MaryEraOnwardsConway -> ShelleyBasedEraConway

type MaryEraOnwardsConstraints era =
( C.HashAlgorithm (L.HASH (L.EraCrypto (ShelleyLedgerEra era)))
, C.Signable (L.VRF (L.EraCrypto (ShelleyLedgerEra era))) L.Seed
Expand Down Expand Up @@ -105,12 +116,9 @@ maryEraOnwardsConstraints = \case
MaryEraOnwardsBabbage -> id
MaryEraOnwardsConway -> id

{-# DEPRECATED maryEraOnwardsToShelleyBasedEra "Use 'inject' instead." #-}
maryEraOnwardsToShelleyBasedEra :: MaryEraOnwards era -> ShelleyBasedEra era
maryEraOnwardsToShelleyBasedEra = \case
MaryEraOnwardsMary -> ShelleyBasedEraMary
MaryEraOnwardsAlonzo -> ShelleyBasedEraAlonzo
MaryEraOnwardsBabbage -> ShelleyBasedEraBabbage
MaryEraOnwardsConway -> ShelleyBasedEraConway
maryEraOnwardsToShelleyBasedEra = inject

class IsAllegraBasedEra era => IsMaryBasedEra era where
maryBasedEra :: MaryEraOnwards era
Expand Down
5 changes: 5 additions & 0 deletions cardano-api/internal/Cardano/Api/Eon/ShelleyBasedEra.hs
Original file line number Diff line number Diff line change
@@ -1,8 +1,10 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
Expand Down Expand Up @@ -177,6 +179,9 @@ instance ToCardanoEra ShelleyBasedEra where
ShelleyBasedEraBabbage -> BabbageEra
ShelleyBasedEraConway -> ConwayEra

instance Inject (ShelleyBasedEra era) (CardanoEra era) where
inject = toCardanoEra

-- | The class of eras that are based on Shelley. This allows uniform handling
-- of Shelley-based eras, but also non-uniform by making case distinctions on
-- the 'ShelleyBasedEra' constructors.
Expand Down
12 changes: 10 additions & 2 deletions cardano-api/internal/Cardano/Api/Eon/ShelleyEraOnly.hs
Original file line number Diff line number Diff line change
Expand Up @@ -3,6 +3,7 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
Expand Down Expand Up @@ -59,6 +60,13 @@ instance ToCardanoEra ShelleyEraOnly where
toCardanoEra = \case
ShelleyEraOnlyShelley -> ShelleyEra

instance Inject (ShelleyEraOnly era) (CardanoEra era) where
inject = toCardanoEra

instance Inject (ShelleyEraOnly era) (ShelleyBasedEra era) where
inject = \case
ShelleyEraOnlyShelley -> ShelleyBasedEraShelley

type ShelleyEraOnlyConstraints era =
( C.HashAlgorithm (L.HASH (L.EraCrypto (ShelleyLedgerEra era)))
, C.Signable (L.VRF (L.EraCrypto (ShelleyLedgerEra era))) L.Seed
Expand Down Expand Up @@ -99,6 +107,6 @@ shelleyEraOnlyConstraints
shelleyEraOnlyConstraints = \case
ShelleyEraOnlyShelley -> id

{-# DEPRECATED shelleyEraOnlyToShelleyBasedEra "Use 'inject' instead." #-}
shelleyEraOnlyToShelleyBasedEra :: ShelleyEraOnly era -> ShelleyBasedEra era
shelleyEraOnlyToShelleyBasedEra = \case
ShelleyEraOnlyShelley -> ShelleyBasedEraShelley
shelleyEraOnlyToShelleyBasedEra = inject
14 changes: 11 additions & 3 deletions cardano-api/internal/Cardano/Api/Eon/ShelleyToAllegraEra.hs
Original file line number Diff line number Diff line change
Expand Up @@ -3,6 +3,7 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
Expand Down Expand Up @@ -62,6 +63,14 @@ instance ToCardanoEra ShelleyToAllegraEra where
ShelleyToAllegraEraShelley -> ShelleyEra
ShelleyToAllegraEraAllegra -> AllegraEra

instance Inject (ShelleyToAllegraEra era) (CardanoEra era) where
inject = toCardanoEra

instance Inject (ShelleyToAllegraEra era) (ShelleyBasedEra era) where
inject = \case
ShelleyToAllegraEraShelley -> ShelleyBasedEraShelley
ShelleyToAllegraEraAllegra -> ShelleyBasedEraAllegra

type ShelleyToAllegraEraConstraints era =
( C.HashAlgorithm (L.HASH (L.EraCrypto (ShelleyLedgerEra era)))
, C.Signable (L.VRF (L.EraCrypto (ShelleyLedgerEra era))) L.Seed
Expand Down Expand Up @@ -102,7 +111,6 @@ shelleyToAllegraEraConstraints = \case
ShelleyToAllegraEraShelley -> id
ShelleyToAllegraEraAllegra -> id

{-# DEPRECATED shelleyToAllegraEraToShelleyBasedEra "Use 'inject' instead." #-}
shelleyToAllegraEraToShelleyBasedEra :: ShelleyToAllegraEra era -> ShelleyBasedEra era
shelleyToAllegraEraToShelleyBasedEra = \case
ShelleyToAllegraEraShelley -> ShelleyBasedEraShelley
ShelleyToAllegraEraAllegra -> ShelleyBasedEraAllegra
shelleyToAllegraEraToShelleyBasedEra = inject
Loading

0 comments on commit 5d03c61

Please sign in to comment.