Merge pull request #77 from input-output-hk/newhoggy/unified-shelley-…

…based-era-constraint-summoning

Unified `ShelleyBasedEra` constraint summoning

cardano-api/internal/Cardano/Api/Block.hs

@@ -171,7 +171,7 @@ getBlockTxs (ByronBlock Consensus.ByronBlock { Consensus.byronBlockRaw }) =
             }
         } -> map ByronTx txs
 getBlockTxs (ShelleyBlock era Consensus.ShelleyBlock{Consensus.shelleyBlockRaw}) =
-    obtainConsensusShelleyCompatibleEra era $
+    withShelleyBasedEraConstraintForConsensus era $
       getShelleyBlockTxs era shelleyBlockRaw
 
 
@@ -186,19 +186,6 @@ getShelleyBlockTxs era (Ledger.Block _header txs) =
   [ ShelleyTx era txinblock
   | txinblock <- toList (Ledger.fromTxSeq txs) ]
 
-obtainConsensusShelleyCompatibleEra
-  :: forall era ledgerera a.
-     ShelleyLedgerEra era ~ ledgerera
-  => ShelleyBasedEra era
-  -> (Consensus.ShelleyCompatible (ConsensusProtocol era) ledgerera => a)
-  -> a
-obtainConsensusShelleyCompatibleEra ShelleyBasedEraShelley f = f
-obtainConsensusShelleyCompatibleEra ShelleyBasedEraAllegra f = f
-obtainConsensusShelleyCompatibleEra ShelleyBasedEraMary    f = f
-obtainConsensusShelleyCompatibleEra ShelleyBasedEraAlonzo  f = f
-obtainConsensusShelleyCompatibleEra ShelleyBasedEraBabbage f = f
-obtainConsensusShelleyCompatibleEra ShelleyBasedEraConway f = f
-
 -- ----------------------------------------------------------------------------
 -- Block in a consensus mode
 --

cardano-api/internal/Cardano/Api/Eras.hs

@@ -1,7 +1,9 @@
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeApplications #-}
@@ -52,6 +54,8 @@ module Cardano.Api.Eras
 
     -- * Assertions on era
   , requireShelleyBasedEra
+
+  , withShelleyBasedEraConstraintsForLedger
   ) where
 
 import           Cardano.Api.HasTypeProxy
@@ -535,3 +539,22 @@ requireShelleyBasedEra era =
   case cardanoEraStyle era of
     LegacyByronEra -> pure Nothing
     ShelleyBasedEra sbe -> pure (Just sbe)
+
+withShelleyBasedEraConstraintsForLedger :: ()
+  => ShelleyLedgerEra era ~ ledgerera
+  => ShelleyBasedEra era
+  ->  ( ()
+      => L.EraCrypto ledgerera ~ L.StandardCrypto
+      => L.EraTx ledgerera
+      => L.EraTxBody ledgerera
+      => L.Era ledgerera
+      => a
+      )
+  -> a
+withShelleyBasedEraConstraintsForLedger = \case
+  ShelleyBasedEraShelley -> id
+  ShelleyBasedEraAllegra -> id
+  ShelleyBasedEraMary    -> id
+  ShelleyBasedEraAlonzo  -> id
+  ShelleyBasedEraBabbage -> id
+  ShelleyBasedEraConway  -> id

cardano-api/internal/Cardano/Api/Fees.hs

@@ -8,6 +8,7 @@
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeApplications #-}
 
 {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}
 
@@ -111,22 +112,12 @@ transactionFee txFeeFixed txFeePerByte tx =
   let a = toInteger txFeePerByte
       b = toInteger txFeeFixed
   in case tx of
-       ShelleyTx _ tx' -> let x = obtainEraTx shelleyBasedEra $ tx' ^. L.sizeTxF
-                          in Lovelace (a * x + b)
+       ShelleyTx _ tx' ->
+        let x = withShelleyBasedEraConstraintsForLedger (shelleyBasedEra @era) $ tx' ^. L.sizeTxF
+        in Lovelace (a * x + b)
        --TODO: This can be made to work for Byron txs too. Do that: fill in this case
        -- and remove the IsShelleyBasedEra constraint.
-       ByronTx _ -> case shelleyBasedEra :: ShelleyBasedEra ByronEra of {}
- where
-  obtainEraTx
-    :: ShelleyBasedEra era
-    -> (L.EraTx (ShelleyLedgerEra era) => a)
-    -> a
-  obtainEraTx ShelleyBasedEraShelley f = f
-  obtainEraTx ShelleyBasedEraAllegra f = f
-  obtainEraTx ShelleyBasedEraMary    f = f
-  obtainEraTx ShelleyBasedEraAlonzo  f = f
-  obtainEraTx ShelleyBasedEraBabbage f = f
-  obtainEraTx ShelleyBasedEraConway  f = f
+       ByronTx _ -> case shelleyBasedEra @era of {}
 
 {-# DEPRECATED transactionFee "Use 'evaluateTransactionFee' instead" #-}
 
@@ -201,7 +192,7 @@ estimateTransactionFee nw txFeeFixed txFeePerByte (ShelleyTx era tx) =
 --TODO: This can be made to work for Byron txs too. Do that: fill in this case
 -- and remove the IsShelleyBasedEra constraint.
 estimateTransactionFee _ _ _ (ByronTx _) =
-    case shelleyBasedEra :: ShelleyBasedEra era of {}
+    case shelleyBasedEra @era of {}
 
 --TODO: also deprecate estimateTransactionFee:
 --{-# DEPRECATED estimateTransactionFee "Use 'evaluateTransactionFee' instead" #-}
@@ -228,7 +219,7 @@ evaluateTransactionFee bpparams txbody keywitcount _byronwitcount =
       ByronTx{} -> case shelleyBasedEra :: ShelleyBasedEra era of {}
       --TODO: we could actually support Byron here, it'd be different but simpler
 
-      ShelleyTx era tx -> withLedgerConstraints era (evalShelleyBasedEra tx)
+      ShelleyTx era tx -> withShelleyBasedEraConstraintsForLedger era (evalShelleyBasedEra tx)
   where
     evalShelleyBasedEra :: forall ledgerera.
                            ShelleyLedgerEra era ~ ledgerera
@@ -242,19 +233,6 @@ evaluateTransactionFee bpparams txbody keywitcount _byronwitcount =
           tx
           keywitcount
 
-    -- Conjure up all the necessary class instances and evidence
-    withLedgerConstraints
-      :: ShelleyLedgerEra era ~ ledgerera
-      => ShelleyBasedEra era
-      -> (L.EraTx ledgerera => a)
-      -> a
-    withLedgerConstraints ShelleyBasedEraShelley f = f
-    withLedgerConstraints ShelleyBasedEraAllegra f = f
-    withLedgerConstraints ShelleyBasedEraMary    f = f
-    withLedgerConstraints ShelleyBasedEraAlonzo  f = f
-    withLedgerConstraints ShelleyBasedEraBabbage f = f
-    withLedgerConstraints ShelleyBasedEraConway  f = f
-
 -- | Give an approximate count of the number of key witnesses (i.e. signatures)
 -- a transaction will need.
 --

cardano-api/internal/Cardano/Api/LedgerState.hs

@@ -1494,7 +1494,7 @@ nextEpochEligibleLeadershipSlots sbe sGen serCurrEpochState ptclState poolid (Vr
                                 decodeCurrentEpochState sbe serCurrEpochState
 
   let snapshot :: ShelleyAPI.SnapShot Shelley.StandardCrypto
-      snapshot = ShelleyAPI.ssStakeMark $ obtainIsStandardCrypto sbe $ ShelleyAPI.esSnapshots cEstate
+      snapshot = ShelleyAPI.ssStakeMark $ withShelleyBasedEraConstraintsForLedger sbe $ ShelleyAPI.esSnapshots cEstate
       markSnapshotPoolDistr :: Map (SL.KeyHash 'SL.StakePool Shelley.StandardCrypto) (SL.IndividualPoolStake Shelley.StandardCrypto)
       markSnapshotPoolDistr = ShelleyAPI.unPoolDistr . ShelleyAPI.calculatePoolDistr $ snapshot
 
@@ -1576,19 +1576,6 @@ isLeadingSlotsPraos slotRangeOfInterest poolid snapshotPoolDistr eNonce vrfSkey
 
   Right $ Set.filter isLeader slotRangeOfInterest
 
-obtainIsStandardCrypto
-  :: ShelleyLedgerEra era ~ ledgerera
-  => ShelleyBasedEra era
-  -> (Core.EraCrypto ledgerera ~ Shelley.StandardCrypto => a)
-  -> a
-obtainIsStandardCrypto ShelleyBasedEraShelley f = f
-obtainIsStandardCrypto ShelleyBasedEraAllegra f = f
-obtainIsStandardCrypto ShelleyBasedEraMary    f = f
-obtainIsStandardCrypto ShelleyBasedEraAlonzo  f = f
-obtainIsStandardCrypto ShelleyBasedEraBabbage f = f
-obtainIsStandardCrypto ShelleyBasedEraConway  f = f
-
-
 -- | Return the slots at which a particular stake pool operator is
 -- expected to mint a block.
 currentEpochEligibleLeadershipSlots :: forall era. ()

cardano-api/internal/Cardano/Api/Modes.hs

@@ -1,6 +1,9 @@
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
@@ -41,6 +44,8 @@ module Cardano.Api.Modes (
     ConsensusBlockForEra,
     toConsensusEraIndex,
     fromConsensusEraIndex,
+
+    withShelleyBasedEraConstraintForConsensus,
   ) where
 
 import           Cardano.Api.Eras
@@ -49,12 +54,13 @@ import qualified Cardano.Chain.Slotting as Byron (EpochSlots (..))
 import           Cardano.Ledger.Crypto (StandardCrypto)
 import qualified Ouroboros.Consensus.Byron.Ledger as Consensus
 import qualified Ouroboros.Consensus.Cardano.Block as Consensus
-import qualified Ouroboros.Consensus.Cardano.ByronHFC as Consensus (ByronBlockHFC)
+import qualified Ouroboros.Consensus.Cardano.ByronHFC as Consensus
 import           Ouroboros.Consensus.HardFork.Combinator as Consensus (EraIndex (..), eraIndexSucc,
                    eraIndexZero)
 import qualified Ouroboros.Consensus.Protocol.Praos as Consensus
 import qualified Ouroboros.Consensus.Protocol.TPraos as Consensus
 import qualified Ouroboros.Consensus.Shelley.HFEras as Consensus
+import qualified Ouroboros.Consensus.Shelley.Ledger as Consensus
 import qualified Ouroboros.Consensus.Shelley.ShelleyHFC as Consensus
 
 import           Data.Aeson (FromJSON (parseJSON), ToJSON (toJSON), Value)
@@ -424,3 +430,16 @@ fromConsensusEraIndex CardanoMode = fromShelleyEraIndex
     fromShelleyEraIndex (Consensus.EraIndex (S (S (S (S (S (S (Z (K ()))))))))) =
       AnyEraInMode ConwayEraInCardanoMode
 
+withShelleyBasedEraConstraintForConsensus
+  :: forall era ledgerera a. ()
+  => ShelleyLedgerEra era ~ ledgerera
+  => ShelleyBasedEra era
+  -> (Consensus.ShelleyCompatible (ConsensusProtocol era) ledgerera => a)
+  -> a
+withShelleyBasedEraConstraintForConsensus = \case
+  ShelleyBasedEraShelley  -> id
+  ShelleyBasedEraAllegra  -> id
+  ShelleyBasedEraMary     -> id
+  ShelleyBasedEraAlonzo   -> id
+  ShelleyBasedEraBabbage  -> id
+  ShelleyBasedEraConway   -> id

cardano-api/internal/Cardano/Api/TxBody.hs

@@ -2286,18 +2286,7 @@ getTxId (ByronTxBody tx) =
       error "getTxId: byron and shelley hash sizes do not match"
 
 getTxId (ShelleyTxBody era tx _ _ _ _) =
-  obtainConstraints era $ getTxIdShelley era tx
- where
-  obtainConstraints
-    :: ShelleyBasedEra era
-    -> ((Ledger.EraCrypto (ShelleyLedgerEra era) ~ StandardCrypto, Ledger.EraTxBody (ShelleyLedgerEra era)) => a)
-    -> a
-  obtainConstraints ShelleyBasedEraShelley f = f
-  obtainConstraints ShelleyBasedEraAllegra f = f
-  obtainConstraints ShelleyBasedEraMary    f = f
-  obtainConstraints ShelleyBasedEraAlonzo  f = f
-  obtainConstraints ShelleyBasedEraBabbage f = f
-  obtainConstraints ShelleyBasedEraConway  f = f
+  withShelleyBasedEraConstraintsForLedger era $ getTxIdShelley era tx
 
 getTxIdShelley
   :: Ledger.EraCrypto (ShelleyLedgerEra era) ~ StandardCrypto
@@ -2485,7 +2474,7 @@ createTransactionBody era txBodyContent =
           case sData of
             TxBodyNoScriptData -> pure SNothing
             TxBodyScriptData _sDataSupported datums redeemers ->
-              getLedgerEraConstraint era
+              withShelleyBasedEraConstraintsForLedger era
                 $ convPParamsToScriptIntegrityHash
                     era
                     apiProtocolParameters
@@ -2519,7 +2508,7 @@ createTransactionBody era txBodyContent =
           case sData of
             TxBodyNoScriptData -> pure SNothing
             TxBodyScriptData _sDataSupported datums redeemers ->
-              getLedgerEraConstraint era
+              withShelleyBasedEraConstraintsForLedger era
                 $ convPParamsToScriptIntegrityHash
                     era
                     apiProtocolParameters
@@ -3423,7 +3412,7 @@ convReturnCollateral
 convReturnCollateral era txReturnCollateral =
   case txReturnCollateral of
     TxReturnCollateralNone -> SNothing
-    TxReturnCollateral _ colTxOut -> SJust $ getCBORConstraint era $ toShelleyTxOutAny era colTxOut
+    TxReturnCollateral _ colTxOut -> SJust $ withShelleyBasedEraConstraintsForLedger era $ toShelleyTxOutAny era colTxOut
 
 convTotalCollateral :: TxTotalCollateral era -> StrictMaybe Ledger.Coin
 convTotalCollateral txTotalCollateral =
@@ -3600,28 +3589,6 @@ convReferenceInputs txInsReference =
     TxInsReferenceNone -> mempty
     TxInsReference _ refTxins -> Set.fromList $ map toShelleyTxIn refTxins
 
-getCBORConstraint
-  :: ShelleyBasedEra era
-  -> (ToCBOR (Ledger.TxOut (ShelleyLedgerEra era)) => a)
-  -> a
-getCBORConstraint ShelleyBasedEraShelley f = f
-getCBORConstraint ShelleyBasedEraAllegra f = f
-getCBORConstraint ShelleyBasedEraMary f = f
-getCBORConstraint ShelleyBasedEraAlonzo f = f
-getCBORConstraint ShelleyBasedEraBabbage f = f
-getCBORConstraint ShelleyBasedEraConway f = f
-
-getLedgerEraConstraint
-  :: ShelleyBasedEra era
-  -> (Ledger.Era (ShelleyLedgerEra era) => a)
-  -> a
-getLedgerEraConstraint ShelleyBasedEraShelley f = f
-getLedgerEraConstraint ShelleyBasedEraAllegra f = f
-getLedgerEraConstraint ShelleyBasedEraMary f = f
-getLedgerEraConstraint ShelleyBasedEraAlonzo f = f
-getLedgerEraConstraint ShelleyBasedEraBabbage f = f
-getLedgerEraConstraint ShelleyBasedEraConway f = f
-
 guardShelleyTxInsOverflow :: [TxIn] -> Either TxBodyError ()
 guardShelleyTxInsOverflow txIns = do
     for_ txIns $ \txin@(TxIn _ (TxIx txix)) ->