Merge pull request #334 from input-output-hk/newhoggy/switch-to-use-n…

…ewtype-wrapper

Switch to use lens and eons for txbody construction

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

@@ -79,7 +79,6 @@ type AlonzoEraOnwardsConstraints era =
   , L.AlonzoEraTx (ShelleyLedgerEra era)
   , L.AlonzoEraTxBody (ShelleyLedgerEra era)
   , L.AlonzoEraTxOut (ShelleyLedgerEra era)
-  , L.AlonzoEraTxOut (ShelleyLedgerEra era)
   , L.AlonzoEraTxWits (ShelleyLedgerEra era)
   , L.Crypto (L.EraCrypto (ShelleyLedgerEra era))
   , L.Era (ShelleyLedgerEra era)

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

@@ -63,8 +63,7 @@ instance ToCardanoEra BabbageEraOnly where
     BabbageEraOnlyBabbage  -> BabbageEra
 
 type BabbageEraOnlyConstraints era =
-  ( L.AlonzoEraTxOut (ShelleyLedgerEra era)
-  , C.HashAlgorithm (L.HASH (L.EraCrypto (ShelleyLedgerEra era)))
+  ( C.HashAlgorithm (L.HASH (L.EraCrypto (ShelleyLedgerEra era)))
   , C.Signable (L.VRF (L.EraCrypto (ShelleyLedgerEra era))) L.Seed
   , Consensus.PraosProtocolSupportsNode (ConsensusProtocol era)
   , Consensus.ShelleyCompatible (ConsensusProtocol era) (ShelleyLedgerEra era)

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

@@ -31,6 +31,7 @@ import qualified Cardano.Ledger.Alonzo.Scripts as L
 import qualified Cardano.Ledger.Alonzo.TxInfo as L
 import qualified Cardano.Ledger.Alonzo.UTxO as L
 import qualified Cardano.Ledger.Api as L
+import qualified Cardano.Ledger.Babbage.TxOut as L
 import qualified Cardano.Ledger.BaseTypes as L
 import qualified Cardano.Ledger.Core as L
 import qualified Cardano.Ledger.Mary.Value as L
@@ -90,6 +91,7 @@ type BabbageEraOnwardsConstraints era =
   , L.ScriptsNeeded (ShelleyLedgerEra era) ~ L.AlonzoScriptsNeeded (ShelleyLedgerEra era)
   , L.ShelleyEraTxBody (ShelleyLedgerEra era)
   , L.ShelleyEraTxCert (ShelleyLedgerEra era)
+  , L.TxOut (ShelleyLedgerEra era) ~ L.BabbageTxOut (ShelleyLedgerEra era)
   , L.Value (ShelleyLedgerEra era) ~ L.MaryValue L.StandardCrypto
 
   , FromCBOR (Consensus.ChainDepState (ConsensusProtocol era))

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

@@ -30,6 +30,8 @@ module Cardano.Api.Eras
   , forEraInEonMaybe
   , forEraMaybeEon
   , maybeEon
+  , monoidForEraInEon
+  , monoidForEraInEonA
 
     -- * Data family instances
   , AsType(AsByronEra, AsShelleyEra, AsAllegraEra, AsMaryEra, AsAlonzoEra, AsBabbageEra, AsConwayEra)

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

@@ -38,6 +38,8 @@ module Cardano.Api.Eras.Core
   , forEraInEonMaybe
   , forEraMaybeEon
   , maybeEon
+  , monoidForEraInEon
+  , monoidForEraInEonA
 
     -- * Data family instances
   , AsType(AsByronEra, AsShelleyEra, AsAllegraEra, AsMaryEra, AsAlonzoEra, AsBabbageEra, AsConwayEra)
@@ -164,6 +166,23 @@ maybeEon :: ()
 maybeEon =
   inEonForEra Nothing Just cardanoEra
 
+monoidForEraInEon :: ()
+  => Eon eon
+  => Monoid a
+  => CardanoEra era
+  -> (eon era -> a)
+  -> a
+monoidForEraInEon sbe = forEraInEon sbe mempty
+
+monoidForEraInEonA :: ()
+  => Applicative f
+  => Eon eon
+  => Monoid a
+  => CardanoEra era
+  -> (eon era -> f a)
+  -> f a
+monoidForEraInEonA sbe = forEraInEon sbe (pure mempty)
+
 -- ----------------------------------------------------------------------------
 -- Era and eon existential types
 

cardano-api/internal/Cardano/Api/Ledger/Lens.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE RankNTypes #-}
 
 {- HLINT ignore "Eta reduce" -}
@@ -11,22 +12,51 @@ module Cardano.Api.Ledger.Lens
   , invalidBeforeTxBodyL
   , invalidHereAfterTxBodyL
   , ttlAsInvalidHereAfterTxBodyL
-  , apiUpdateTxBodyL
+  , updateTxBodyL
+
+  , TxBody(..)
+  , txBodyL
+  , mintTxBodyL
+  , scriptIntegrityHashTxBodyL
+  , collateralInputsTxBodyL
+  , reqSignerHashesTxBodyL
+  , referenceInputsTxBodyL
+  , collateralReturnTxBodyL
+  , totalCollateralTxBodyL
+  , certsTxBodyL
+  , votingProceduresTxBodyL
+  , proposalProceduresTxBodyL
   ) where
 
 import           Cardano.Api.Eon.AllegraEraOnwards
+import           Cardano.Api.Eon.AlonzoEraOnwards
+import           Cardano.Api.Eon.BabbageEraOnwards
+import           Cardano.Api.Eon.ConwayEraOnwards
+import           Cardano.Api.Eon.MaryEraOnwards
 import           Cardano.Api.Eon.ShelleyBasedEra
 import           Cardano.Api.Eon.ShelleyEraOnly
 import           Cardano.Api.Eon.ShelleyToBabbageEra
 import           Cardano.Api.Eras.Case
 
 import qualified Cardano.Ledger.Allegra.Core as L
+import qualified Cardano.Ledger.Alonzo.Core as L
 import qualified Cardano.Ledger.Api as L
 import           Cardano.Ledger.BaseTypes (SlotNo, StrictMaybe (..))
+import qualified Cardano.Ledger.Coin as L
+import qualified Cardano.Ledger.Keys as L
+import qualified Cardano.Ledger.Mary.Value as L
 import qualified Cardano.Ledger.Shelley.PParams as L
+import qualified Cardano.Ledger.TxIn as L
 
+import qualified Data.OSet.Strict as L
+import qualified Data.Sequence.Strict as L
+import           Data.Set (Set)
 import           Lens.Micro
 
+newtype TxBody era = TxBody
+  { unTxBody :: L.TxBody (ShelleyLedgerEra era)
+  }
+
 strictMaybeL :: Lens' (StrictMaybe a) (Maybe a)
 strictMaybeL = lens g s
   where
@@ -37,8 +67,11 @@ strictMaybeL = lens g s
     s :: StrictMaybe a -> Maybe a -> StrictMaybe a
     s _ = maybe SNothing SJust
 
-invalidBeforeTxBodyL :: AllegraEraOnwards era -> Lens' (L.TxBody (ShelleyLedgerEra era)) (Maybe SlotNo)
-invalidBeforeTxBodyL w = allegraEraOnwardsConstraints w $ L.vldtTxBodyL . L.invalidBeforeL
+txBodyL :: Lens' (TxBody era) (L.TxBody (ShelleyLedgerEra era))
+txBodyL = lens unTxBody (\_ x -> TxBody x)
+
+invalidBeforeTxBodyL :: AllegraEraOnwards era -> Lens' (TxBody era) (Maybe SlotNo)
+invalidBeforeTxBodyL w = allegraEraOnwardsConstraints w $ txBodyL . L.vldtTxBodyL . L.invalidBeforeL
 
 -- | Compatibility lens that provides a consistent interface over 'ttlTxBodyL' and
 -- 'vldtTxBodyL . invalidHereAfterStrictL' across all shelley based eras.
@@ -55,27 +88,27 @@ invalidBeforeTxBodyL w = allegraEraOnwardsConstraints w $ L.vldtTxBodyL . L.inva
 --
 -- 'invalidHereAfterTxBodyL' lens over both with a 'Maybe SlotNo' type representation.  Withing the
 -- Shelley era, setting Nothing will set the ttl to 'maxBound' in the underlying ledger type.
-invalidHereAfterTxBodyL :: ShelleyBasedEra era -> Lens' (L.TxBody (ShelleyLedgerEra era)) (Maybe SlotNo)
+invalidHereAfterTxBodyL :: ShelleyBasedEra era -> Lens' (TxBody era) (Maybe SlotNo)
 invalidHereAfterTxBodyL =
   caseShelleyEraOnlyOrAllegraEraOnwards
     ttlAsInvalidHereAfterTxBodyL
-    (const $ L.vldtTxBodyL . L.invalidHereAfterL)
+    (const $ txBodyL . L.vldtTxBodyL . L.invalidHereAfterL)
 
 -- | Compatibility lens over 'ttlTxBodyL' which represents 'maxBound' as Nothing and all other values as 'Just'.
-ttlAsInvalidHereAfterTxBodyL :: ShelleyEraOnly era -> Lens' (L.TxBody (ShelleyLedgerEra era)) (Maybe SlotNo)
+ttlAsInvalidHereAfterTxBodyL :: ShelleyEraOnly era -> Lens' (TxBody era) (Maybe SlotNo)
 ttlAsInvalidHereAfterTxBodyL w = lens (g w) (s w)
   where
-    g :: ShelleyEraOnly era -> L.TxBody (ShelleyLedgerEra era) -> Maybe SlotNo
+    g :: ShelleyEraOnly era -> TxBody era -> Maybe SlotNo
     g w' txBody =
       shelleyEraOnlyConstraints w' $
-        let ttl = txBody ^. L.ttlTxBodyL in if ttl == maxBound then Nothing else Just ttl
+        let ttl = txBody ^. txBodyL . L.ttlTxBodyL in if ttl == maxBound then Nothing else Just ttl
 
-    s :: ShelleyEraOnly era -> L.TxBody (ShelleyLedgerEra era) -> Maybe SlotNo -> L.TxBody (ShelleyLedgerEra era)
+    s :: ShelleyEraOnly era -> TxBody era -> Maybe SlotNo -> TxBody era
     s w' txBody mSlotNo =
       shelleyEraOnlyConstraints w' $
         case mSlotNo of
-          Nothing -> txBody & L.ttlTxBodyL .~ maxBound
-          Just ttl -> txBody & L.ttlTxBodyL .~ ttl
+          Nothing -> txBody & txBodyL . L.ttlTxBodyL .~ maxBound
+          Just ttl -> txBody & txBodyL . L.ttlTxBodyL .~ ttl
 
 -- | Lens to access the 'invalidBefore' field of a 'ValidityInterval' as a 'StrictMaybe SlotNo'.
 -- Ideally this should be defined in cardano-ledger
@@ -99,5 +132,36 @@ invalidHereAfterStrictL = lens g s
     s :: L.ValidityInterval -> StrictMaybe SlotNo -> L.ValidityInterval
     s (L.ValidityInterval a _) b = L.ValidityInterval a b
 
-apiUpdateTxBodyL :: ShelleyToBabbageEra era -> Lens' (L.TxBody (ShelleyLedgerEra era)) (StrictMaybe (L.Update (ShelleyLedgerEra era)))
-apiUpdateTxBodyL w = shelleyToBabbageEraConstraints w L.updateTxBodyL
+updateTxBodyL :: ShelleyToBabbageEra era -> Lens' (TxBody era) (StrictMaybe (L.Update (ShelleyLedgerEra era)))
+updateTxBodyL w = shelleyToBabbageEraConstraints w $ txBodyL . L.updateTxBodyL
+
+mintTxBodyL :: MaryEraOnwards era -> Lens' (TxBody era) (L.MultiAsset L.StandardCrypto)
+mintTxBodyL w = maryEraOnwardsConstraints w $ txBodyL . L.mintTxBodyL
+
+scriptIntegrityHashTxBodyL :: AlonzoEraOnwards era -> Lens' (TxBody era) (StrictMaybe (L.ScriptIntegrityHash L.StandardCrypto))
+scriptIntegrityHashTxBodyL w = alonzoEraOnwardsConstraints w $ txBodyL . L.scriptIntegrityHashTxBodyL
+
+collateralInputsTxBodyL :: AlonzoEraOnwards era -> Lens' (TxBody era) (Set (L.TxIn L.StandardCrypto))
+collateralInputsTxBodyL w = alonzoEraOnwardsConstraints w $ txBodyL . L.collateralInputsTxBodyL
+
+reqSignerHashesTxBodyL :: AlonzoEraOnwards era -> Lens' (TxBody era) (Set (L.KeyHash L.Witness L.StandardCrypto))
+reqSignerHashesTxBodyL w = alonzoEraOnwardsConstraints w $ txBodyL . L.reqSignerHashesTxBodyL
+
+referenceInputsTxBodyL :: BabbageEraOnwards era -> Lens' (TxBody era) (Set (L.TxIn L.StandardCrypto))
+referenceInputsTxBodyL w = babbageEraOnwardsConstraints w $ txBodyL . L.referenceInputsTxBodyL
+
+collateralReturnTxBodyL :: BabbageEraOnwards era -> Lens' (TxBody era) (StrictMaybe (L.TxOut (ShelleyLedgerEra era)))
+collateralReturnTxBodyL w = babbageEraOnwardsConstraints w $ txBodyL . L.collateralReturnTxBodyL
+
+totalCollateralTxBodyL :: BabbageEraOnwards era -> Lens' (TxBody era) (StrictMaybe L.Coin)
+totalCollateralTxBodyL w = babbageEraOnwardsConstraints w $ txBodyL . L.totalCollateralTxBodyL
+
+certsTxBodyL :: ShelleyBasedEra era -> Lens' (TxBody era) (L.StrictSeq (L.TxCert (ShelleyLedgerEra era)))
+certsTxBodyL w = shelleyBasedEraConstraints w $ txBodyL . L.certsTxBodyL
+
+votingProceduresTxBodyL :: ConwayEraOnwards era -> Lens' (TxBody era) (L.VotingProcedures (ShelleyLedgerEra era))
+votingProceduresTxBodyL w = conwayEraOnwardsConstraints w $ txBodyL . L.votingProceduresTxBodyL
+
+proposalProceduresTxBodyL :: ConwayEraOnwards era -> Lens' (TxBody era) (L.OSet (L.ProposalProcedure (ShelleyLedgerEra era)))
+proposalProceduresTxBodyL w = conwayEraOnwardsConstraints w $ txBodyL . L.proposalProceduresTxBodyL
+