review remarks

cardano-api/internal/Cardano/Api/Eon/ConwayEraOnwards.hs

@@ -103,8 +103,8 @@ type ConwayEraOnwardsConstraints era =
   )
 
 conwayEraOnwardsConstraints
-  :: ()
-  => ConwayEraOnwards era
+  :: forall a era
+   . ConwayEraOnwards era
   -> (ConwayEraOnwardsConstraints era => a)
   -> a
 conwayEraOnwardsConstraints = \case

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

@@ -8,7 +8,6 @@
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE TypeApplications #-}
 
 -- | Fee calculation
 module Cardano.Api.Fees
@@ -88,7 +87,6 @@ import qualified Data.List as List
 import           Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import           Data.Maybe
-import           Data.OSet.Strict (OSet)
 import qualified Data.OSet.Strict as OSet
 import           Data.Ratio
 import           Data.Set (Set)
@@ -1391,8 +1389,7 @@ maybeDummyTotalCollAndCollReturnOutput sbe TxBodyContent{txInsCollateral, txRetu
 
 substituteExecutionUnits
   :: forall era
-   . IsShelleyBasedEra era
-  => Map ScriptWitnessIndex ExecutionUnits
+   . Map ScriptWitnessIndex ExecutionUnits
   -> TxBodyContent BuildTx era
   -> Either (TxBodyErrorAutoBalance era) (TxBodyContent BuildTx era)
 substituteExecutionUnits
@@ -1578,9 +1575,7 @@ substituteExecutionUnits
     mapScriptWitnessesProposals (Just (Featured _ TxProposalProceduresNone)) = return Nothing
     mapScriptWitnessesProposals (Just (Featured _ (TxProposalProcedures _ ViewTx))) = return Nothing
     mapScriptWitnessesProposals (Just (Featured era txpp@(TxProposalProcedures osetProposalProcedures (BuildTxWith sWitMap)))) = do
-      let proposals :: OSet (L.ProposalProcedure (ShelleyLedgerEra era))
-          proposals = shelleyBasedEraConstraints (shelleyBasedEra @era) $ convProposalProcedures txpp
-          allProposalsList = toList proposals
+      let allProposalsList = toList $ convProposalProcedures txpp
           eSubstitutedExecutionUnits =
             [ (proposal, updatedWitness)
             | (proposal, scriptWitness) <- toList sWitMap

cardano-api/internal/Cardano/Api/Governance/Actions/ProposalProcedure.hs

@@ -155,9 +155,6 @@ instance IsShelleyBasedEra era => Show (Proposal era) where
 instance IsShelleyBasedEra era => Eq (Proposal era) where
   (Proposal pp1) == (Proposal pp2) = shelleyBasedEraConstraints (shelleyBasedEra @era) $ pp1 == pp2
 
-instance IsShelleyBasedEra era => Ord (Proposal era) where
-  compare (Proposal pp1) (Proposal pp2) = shelleyBasedEraConstraints (shelleyBasedEra @era) $ compare pp1 pp2
-
 instance IsShelleyBasedEra era => ToCBOR (Proposal era) where
   toCBOR (Proposal vp) = shelleyBasedEraConstraints (shelleyBasedEra @era) $ Shelley.toEraCBOR @Conway.Conway vp
 

cardano-api/internal/Cardano/Api/Governance/Actions/VotingProcedure.hs

@@ -123,8 +123,6 @@ newtype VotingProcedures era = VotingProcedures
 
 deriving instance Eq (VotingProcedures era)
 
-deriving instance Ord (VotingProcedures era)
-
 deriving instance Generic (VotingProcedures era)
 
 deriving instance Show (VotingProcedures era)

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

@@ -575,12 +575,6 @@ parsePlutusParamName t =
 
 deriving instance Show V2.ParamName
 
--- Required instance, to be able to use the type as the map key
--- TODO upstream to cardano-ledger
-deriving instance Ord (L.VotingProcedures ledgerera)
-
-deriving instance Ord (L.VotingProcedure ledgerera)
-
 -- TODO upstream to cardano-ledger
 instance IsList (ListMap k a) where
   type Item (ListMap k a) = (k, a)

cardano-api/internal/Cardano/Api/Tx/Body.hs

@@ -256,6 +256,7 @@ import qualified Data.Map.Strict as Map
 import           Data.Maybe
 import           Data.Monoid
 import           Data.OSet.Strict (OSet, (|><))
+import qualified Data.OSet.Strict as OSet
 import           Data.Scientific (toBoundedInteger)
 import qualified Data.Sequence.Strict as Seq
 import           Data.Set (Set)
@@ -835,12 +836,6 @@ instance Applicative (BuildTxWith BuildTx) where
   pure = BuildTxWith
   (BuildTxWith f) <*> (BuildTxWith a) = BuildTxWith (f a)
 
-instance Monad (BuildTxWith ViewTx) where
-  ViewTx >>= _ = ViewTx
-
-instance Monad (BuildTxWith BuildTx) where
-  (BuildTxWith a) >>= f = f a
-
 buildTxWithToMaybe :: BuildTxWith build a -> Maybe a
 buildTxWithToMaybe ViewTx = Nothing
 buildTxWithToMaybe (BuildTxWith a) = Just a
@@ -1299,7 +1294,7 @@ mkTxProposalProcedures
 mkTxProposalProcedures proposalsWithWitnessesList = do
   let (proposals, proposalsWithWitnesses) =
         bimap toList toList $
-          Foldable.foldl' partitionProposals (mempty, mempty) proposalsWithWitnessesList
+          Foldable.foldl' partitionProposals mempty proposalsWithWitnessesList
   shelleyBasedEraConstraints (shelleyBasedEra @era) $
     TxProposalProcedures (fromList proposals) (pure $ fromList proposalsWithWitnesses)
  where
@@ -1877,8 +1872,7 @@ fromLedgerTxBody sbe scriptValidity body scriptdata mAux =
   (txMetadata, txAuxScripts) = fromLedgerTxAuxiliaryData sbe mAux
 
 fromLedgerProposalProcedures
-  :: forall era
-   . ShelleyBasedEra era
+  :: ShelleyBasedEra era
   -> Ledger.TxBody (ShelleyLedgerEra era)
   -> Maybe (Featured ConwayEraOnwards era (TxProposalProcedures ViewTx era))
 fromLedgerProposalProcedures sbe body =
@@ -2466,15 +2460,11 @@ convReferenceInputs txInsReference =
 -- If 'pws' in 'TxProposalProcedures pps (BuildTxWith pws)' contained proposals not present in 'pps', the'll
 -- be sorted ascendingly and snoc-ed to 'pps' if they're not present in 'pps'.
 convProposalProcedures
-  :: forall era build
-   . IsShelleyBasedEra era
-  => TxProposalProcedures build era -> OSet (L.ProposalProcedure (ShelleyLedgerEra era))
-convProposalProcedures TxProposalProceduresNone =
-  shelleyBasedEraConstraints (shelleyBasedEra @era) mempty
-convProposalProcedures (TxProposalProcedures pp bWits) =
-  shelleyBasedEraConstraints (shelleyBasedEra @era) $ do
-    let wits = fromMaybe mempty $ buildTxWithToMaybe bWits
-    pp |>< fromList (Map.keys wits)
+  :: TxProposalProcedures build era -> OSet (L.ProposalProcedure (ShelleyLedgerEra era))
+convProposalProcedures TxProposalProceduresNone = OSet.empty
+convProposalProcedures (TxProposalProcedures pp bWits) = do
+  let wits = fromMaybe mempty $ buildTxWithToMaybe bWits
+  pp |>< fromList (Map.keys wits)
 
 convVotingProcedures :: TxVotingProcedures build era -> L.VotingProcedures (ShelleyLedgerEra era)
 convVotingProcedures txVotingProcedures =

cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/TxBody.hs

@@ -1,5 +1,7 @@
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 module Test.Cardano.Api.Typed.TxBody
   ( tests
@@ -27,25 +29,22 @@ import           Test.Tasty.Hedgehog (testProperty)
 
 {- HLINT ignore "Use camelCase" -}
 
-era :: ShelleyBasedEra BabbageEra
-era = ShelleyBasedEraBabbage
-
 -- | Check the txOuts in a TxBodyContent after a ledger roundtrip.
-prop_roundtrip_txbodycontent_txouts :: Property
-prop_roundtrip_txbodycontent_txouts = H.property $ do
-  content <- H.forAll $ genTxBodyContent era
+prop_roundtrip_txbodycontent_txouts :: forall era. ShelleyBasedEra era -> Property
+prop_roundtrip_txbodycontent_txouts era = H.property $ do
+  content <- shelleyBasedEraConstraints era $ H.forAll $ genTxBodyContent era
   -- Create the ledger body & auxiliaries
   body <- H.leftFail $ createAndValidateTransactionBody era content
   annotateShow body
   -- Convert ledger body back via 'getTxBodyContent' and 'fromLedgerTxBody'
   let (TxBody content') = body
   matchTxOuts (txOuts content) (txOuts content')
  where
-  matchTxOuts :: MonadTest m => [TxOut CtxTx BabbageEra] -> [TxOut CtxTx BabbageEra] -> m ()
+  matchTxOuts :: MonadTest m => [TxOut CtxTx era] -> [TxOut CtxTx era] -> m ()
   matchTxOuts as bs =
     mapM_ matchTxOut $ zip as bs
 
-  matchTxOut :: MonadTest m => (TxOut CtxTx BabbageEra, TxOut CtxTx BabbageEra) -> m ()
+  matchTxOut :: MonadTest m => (TxOut CtxTx era, TxOut CtxTx era) -> m ()
   matchTxOut (a, b) = do
     let TxOut aAddress aValue aDatum aRefScript = a
     let TxOut bAddress bValue bDatum bRefScript = b
@@ -65,11 +64,12 @@ prop_roundtrip_txbodycontent_txouts = H.property $ do
 
   -- NOTE: After Allegra, all eras interpret SimpleScriptV1 as SimpleScriptV2
   -- because V2 is a superset of V1. So we accept that as a valid conversion.
-  matchRefScript :: MonadTest m => (ReferenceScript BabbageEra, ReferenceScript BabbageEra) -> m ()
+  matchRefScript :: MonadTest m => (ReferenceScript era, ReferenceScript era) -> m ()
   matchRefScript (a, b)
     | isSimpleScriptV2 a && isSimpleScriptV2 b =
-        refScriptToShelleyScript ShelleyBasedEraBabbage a
-          === refScriptToShelleyScript ShelleyBasedEraBabbage b
+        shelleyBasedEraConstraints era $
+          refScriptToShelleyScript era a
+            === refScriptToShelleyScript era b
     | otherwise =
         a === b
 
@@ -83,9 +83,10 @@ prop_roundtrip_txbodycontent_txouts = H.property $ do
 
 prop_roundtrip_txbodycontent_conway_fields :: Property
 prop_roundtrip_txbodycontent_conway_fields = H.property $ do
-  content <- H.forAll $ genTxBodyContent era
+  let sbe = ShelleyBasedEraConway
+  content <- H.forAll $ genTxBodyContent sbe
   -- Create the ledger body & auxiliaries
-  body <- H.leftFail $ createAndValidateTransactionBody era content
+  body <- H.leftFail $ createAndValidateTransactionBody sbe content
   annotateShow body
   -- Convert ledger body back via 'getTxBodyContent' and 'fromLedgerTxBody'
   let (TxBody content') = body
@@ -107,8 +108,7 @@ prop_roundtrip_txbodycontent_conway_fields = H.property $ do
   getVotingProcedures TxVotingProceduresNone = Nothing
   getVotingProcedures (TxVotingProcedures vps _) = Just vps
   getProposalProcedures
-    :: IsShelleyBasedEra era
-    => TxProposalProcedures build era
+    :: TxProposalProcedures build era
     -> Maybe [L.ProposalProcedure (ShelleyLedgerEra era)]
   getProposalProcedures TxProposalProceduresNone = Nothing
   getProposalProcedures txpp@(TxProposalProcedures _ _) = Just . toList $ convProposalProcedures txpp
@@ -117,6 +117,11 @@ tests :: TestTree
 tests =
   testGroup
     "Test.Cardano.Api.Typed.TxBody"
-    [ testProperty "roundtrip txbodycontent txouts" prop_roundtrip_txbodycontent_txouts
-    , testProperty "roundtrip txbodycontent new conway fields" prop_roundtrip_txbodycontent_conway_fields
+    [ testProperty "roundtrip txbodycontent txouts Babbage" $
+        prop_roundtrip_txbodycontent_txouts ShelleyBasedEraBabbage
+    , testProperty "roundtrip txbodycontent txouts Conway" $
+        prop_roundtrip_txbodycontent_txouts ShelleyBasedEraConway
+    , testProperty
+        "roundtrip txbodycontent new conway fields"
+        prop_roundtrip_txbodycontent_conway_fields
     ]