Add transAddressShelley in PlutusLedger

cabal.project

@@ -20,6 +20,12 @@ index-state:
 
 multi-repl: true
 
+-- You never, ever, want this.
+write-ghc-environment-files: never
+
+test-show-details: direct
+tests: True
+
 packages:
   src/base
   src/coin-selection

src/base/convex-base.cabal

@@ -1,4 +1,4 @@
-cabal-version: 3.0
+cabal-version: 3.4
 name:          convex-base
 version:       0.3.0.0
 synopsis:      Base classes and types for working with cardano-api transactions
@@ -81,3 +81,28 @@ library
       dlist,
       either-result,
       strict-sop-core
+
+test-suite convex-base-test
+  import: lang
+  type: exitcode-stdio-1.0
+  hs-source-dirs:     test
+  main-is:
+    Spec.hs
+  other-modules:
+    Convex.PlutusLedgerSpec
+  build-tool-depends:
+    tasty-discover:tasty-discover
+  -- Local dependencies
+  build-depends:
+    , convex-base
+  -- CHaP dependencies
+  build-depends:
+    , cardano-api
+    , cardano-api:gen
+  -- Hackage dependencies
+  build-depends:
+    , base >= 4.14.0
+    , tasty
+    , tasty-quickcheck
+    , QuickCheck
+    , hedgehog-quickcheck

src/base/lib/Convex/PlutusLedger.hs

@@ -46,6 +46,9 @@ module Convex.PlutusLedger(
   unTransAddressInEra,
   transAddressInEra,
 
+  unTransAddressShelley,
+  transAddressShelley,
+
   -- * Tx IDs
   unTransTxOutRef,
   transTxOutRef,
@@ -183,22 +186,30 @@ unTransStakeAddressReference (Just (PV1.StakingPtr slotNo txIx ptrIx)) =
   Right (C.StakeAddressByPointer (C.StakeAddressPointer (Ptr (C.SlotNo $ fromIntegral slotNo) (TxIx $ fromIntegral txIx) (CertIx $ fromIntegral ptrIx))))
 
 unTransAddressInEra :: C.NetworkId -> PV1.Address -> Either C.SerialiseAsRawBytesError (C.AddressInEra C.ConwayEra)
-unTransAddressInEra networkId (PV1.Address cred staking) =
+unTransAddressInEra networkId addr =
   C.AddressInEra (C.ShelleyAddressInEra C.ShelleyBasedEraConway) <$>
-    (C.makeShelleyAddress networkId
-      <$> unTransCredential cred
-      <*> unTransStakeAddressReference staking
-      )
+    unTransAddressShelley networkId addr
 
 -- | @cardano-api@ address to @plutus@ address. Returns 'Nothing' for
 -- | byron addresses.
 transAddressInEra :: C.AddressInEra C.ConwayEra -> Maybe PV1.Address
 transAddressInEra = \case
-  C.AddressInEra (C.ShelleyAddressInEra C.ShelleyBasedEraConway) (C.ShelleyAddress _ p s) ->
-    Just $ PV1.Address
+  C.AddressInEra (C.ShelleyAddressInEra C.ShelleyBasedEraConway) shelleyAddr ->
+    Just $ transAddressShelley shelleyAddr
+  C.AddressInEra C.ByronAddressInAnyEra _ -> Nothing
+
+transAddressShelley :: C.Address C.ShelleyAddr -> PV1.Address
+transAddressShelley = \case
+  (C.ShelleyAddress _ p s) ->
+    PV1.Address
       (transCredential $ C.fromShelleyPaymentCredential p)
       (transStakeAddressReference $ C.fromShelleyStakeReference s)
-  C.AddressInEra C.ByronAddressInAnyEra _ -> Nothing
+
+unTransAddressShelley :: C.NetworkId -> PV1.Address -> Either C.SerialiseAsRawBytesError (C.Address C.ShelleyAddr)
+unTransAddressShelley networkId (PV1.Address cred staking) =
+  C.makeShelleyAddress networkId
+    <$> unTransCredential cred
+    <*> unTransStakeAddressReference staking
 
 unTransTxOutRef :: PV1.TxOutRef -> Either C.SerialiseAsRawBytesError C.TxIn
 unTransTxOutRef PV1.TxOutRef{PV1.txOutRefId=PV1.TxId bs, PV1.txOutRefIdx} =

src/base/test/Convex/PlutusLedgerSpec.hs

@@ -0,0 +1,33 @@
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE GADTs #-}
+
+module Convex.PlutusLedgerSpec where
+
+import qualified Cardano.Api.Shelley as C
+import Test.Gen.Cardano.Api.Typed qualified as CGen
+import Convex.PlutusLedger (transAddressShelley, unTransAddressShelley)
+import Test.QuickCheck qualified as QC
+import Test.QuickCheck.Hedgehog qualified as QC
+import qualified Cardano.Api.Ledger as Shelley
+
+newtype ArbitraryNetworkMagic = ArbitraryNetworkMagic C.NetworkMagic
+  deriving stock (Show)
+
+instance QC.Arbitrary ArbitraryNetworkMagic where
+  arbitrary = fmap ArbitraryNetworkMagic $ QC.hedgehog CGen.genNetworkMagic
+
+newtype ArbitraryAddressShelley = ArbitraryAddressShelley (C.Address C.ShelleyAddr)
+  deriving stock (Show)
+
+instance QC.Arbitrary ArbitraryAddressShelley where
+  arbitrary = fmap ArbitraryAddressShelley $ QC.hedgehog CGen.genAddressShelley
+
+prop_rountripAddressShelleyPlutusTranslation :: ArbitraryNetworkMagic -> ArbitraryAddressShelley -> Bool
+prop_rountripAddressShelleyPlutusTranslation
+  (ArbitraryNetworkMagic nm)
+  (ArbitraryAddressShelley addr@(C.ShelleyAddress n _ _))
+  = do
+  let nid = case n of Shelley.Mainnet -> C.Mainnet; Shelley.Testnet -> C.Testnet nm
+  case unTransAddressShelley nid (transAddressShelley addr) of
+    Left _err -> False
+    Right addr' -> addr' == addr

src/base/test/Spec.hs

@@ -0,0 +1 @@
+{-# OPTIONS_GHC -F -pgmF tasty-discover #-}