Optimise translating the Byron UTxO to the Shelley UTxO

cabal.project

@@ -173,78 +173,78 @@ source-repository-package
 source-repository-package
   type: git
   location: https://github.com/input-output-hk/cardano-ledger-specs
-  tag: c453fa6fce99ed3cb09d129c829ddbf0980a642c
-  --sha256: 0f637wrdkpj4dc0fb30ak2w6rwcf6cldcpjbdgvn5smmdlssn5w9
+  tag: be1e61ad0f73c099a8b9ca1be430e3b40706f398
+  --sha256: 1pbmsv63fdad09w3c9xs7fidzhxiwq1d732ka5jdsafvz4zgsjaf
   subdir: semantics/executable-spec
 
 source-repository-package
   type: git
   location: https://github.com/input-output-hk/cardano-ledger-specs
-  tag: c453fa6fce99ed3cb09d129c829ddbf0980a642c
-  --sha256: 0f637wrdkpj4dc0fb30ak2w6rwcf6cldcpjbdgvn5smmdlssn5w9
+  tag: be1e61ad0f73c099a8b9ca1be430e3b40706f398
+  --sha256: 1pbmsv63fdad09w3c9xs7fidzhxiwq1d732ka5jdsafvz4zgsjaf
   subdir: semantics/small-steps-test
 
 source-repository-package
   type: git
   location: https://github.com/input-output-hk/cardano-ledger-specs
-  tag: c453fa6fce99ed3cb09d129c829ddbf0980a642c
-  --sha256: 0f637wrdkpj4dc0fb30ak2w6rwcf6cldcpjbdgvn5smmdlssn5w9
+  tag: be1e61ad0f73c099a8b9ca1be430e3b40706f398
+  --sha256: 1pbmsv63fdad09w3c9xs7fidzhxiwq1d732ka5jdsafvz4zgsjaf
   subdir: byron/ledger/executable-spec
 
 source-repository-package
   type: git
   location: https://github.com/input-output-hk/cardano-ledger-specs
-  tag: c453fa6fce99ed3cb09d129c829ddbf0980a642c
-  --sha256: 0f637wrdkpj4dc0fb30ak2w6rwcf6cldcpjbdgvn5smmdlssn5w9
+  tag: be1e61ad0f73c099a8b9ca1be430e3b40706f398
+  --sha256: 1pbmsv63fdad09w3c9xs7fidzhxiwq1d732ka5jdsafvz4zgsjaf
   subdir: byron/ledger/impl
 
 source-repository-package
   type: git
   location: https://github.com/input-output-hk/cardano-ledger-specs
-  tag: c453fa6fce99ed3cb09d129c829ddbf0980a642c
-  --sha256: 0f637wrdkpj4dc0fb30ak2w6rwcf6cldcpjbdgvn5smmdlssn5w9
+  tag: be1e61ad0f73c099a8b9ca1be430e3b40706f398
+  --sha256: 1pbmsv63fdad09w3c9xs7fidzhxiwq1d732ka5jdsafvz4zgsjaf
   subdir: byron/ledger/impl/test
 
 source-repository-package
   type: git
   location: https://github.com/input-output-hk/cardano-ledger-specs
-  tag: c453fa6fce99ed3cb09d129c829ddbf0980a642c
-  --sha256: 0f637wrdkpj4dc0fb30ak2w6rwcf6cldcpjbdgvn5smmdlssn5w9
+  tag: be1e61ad0f73c099a8b9ca1be430e3b40706f398
+  --sha256: 1pbmsv63fdad09w3c9xs7fidzhxiwq1d732ka5jdsafvz4zgsjaf
   subdir: byron/crypto
 
 source-repository-package
   type: git
   location: https://github.com/input-output-hk/cardano-ledger-specs
-  tag: c453fa6fce99ed3cb09d129c829ddbf0980a642c
-  --sha256: 0f637wrdkpj4dc0fb30ak2w6rwcf6cldcpjbdgvn5smmdlssn5w9
+  tag: be1e61ad0f73c099a8b9ca1be430e3b40706f398
+  --sha256: 1pbmsv63fdad09w3c9xs7fidzhxiwq1d732ka5jdsafvz4zgsjaf
   subdir: byron/crypto/test
 
 source-repository-package
   type: git
   location: https://github.com/input-output-hk/cardano-ledger-specs
-  tag: c453fa6fce99ed3cb09d129c829ddbf0980a642c
-  --sha256: 0f637wrdkpj4dc0fb30ak2w6rwcf6cldcpjbdgvn5smmdlssn5w9
+  tag: be1e61ad0f73c099a8b9ca1be430e3b40706f398
+  --sha256: 1pbmsv63fdad09w3c9xs7fidzhxiwq1d732ka5jdsafvz4zgsjaf
   subdir: byron/chain/executable-spec
 
 source-repository-package
   type: git
   location: https://github.com/input-output-hk/cardano-ledger-specs
-  tag: c453fa6fce99ed3cb09d129c829ddbf0980a642c
-  --sha256: 0f637wrdkpj4dc0fb30ak2w6rwcf6cldcpjbdgvn5smmdlssn5w9
+  tag: be1e61ad0f73c099a8b9ca1be430e3b40706f398
+  --sha256: 1pbmsv63fdad09w3c9xs7fidzhxiwq1d732ka5jdsafvz4zgsjaf
   subdir: shelley/chain-and-ledger/dependencies/non-integer
 
 source-repository-package
   type: git
   location: https://github.com/input-output-hk/cardano-ledger-specs
-  tag: c453fa6fce99ed3cb09d129c829ddbf0980a642c
-  --sha256: 0f637wrdkpj4dc0fb30ak2w6rwcf6cldcpjbdgvn5smmdlssn5w9
+  tag: be1e61ad0f73c099a8b9ca1be430e3b40706f398
+  --sha256: 1pbmsv63fdad09w3c9xs7fidzhxiwq1d732ka5jdsafvz4zgsjaf
   subdir: shelley/chain-and-ledger/executable-spec
 
 source-repository-package
   type: git
   location: https://github.com/input-output-hk/cardano-ledger-specs
-  tag: c453fa6fce99ed3cb09d129c829ddbf0980a642c
-  --sha256: 0f637wrdkpj4dc0fb30ak2w6rwcf6cldcpjbdgvn5smmdlssn5w9
+  tag: be1e61ad0f73c099a8b9ca1be430e3b40706f398
+  --sha256: 1pbmsv63fdad09w3c9xs7fidzhxiwq1d732ka5jdsafvz4zgsjaf
   subdir: shelley/chain-and-ledger/executable-spec/test
 
 source-repository-package

ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal

@@ -79,6 +79,7 @@ test-suite test
                        Test.Consensus.Cardano.Golden
                        Test.Consensus.Cardano.Examples
                        Test.Consensus.Cardano.Serialisation
+                       Test.Consensus.Cardano.Translation
                        Test.ThreadNet.Cardano
                        Test.ThreadNet.TxGen.Cardano
 
@@ -94,6 +95,7 @@ test-suite test
                      , cardano-prelude
                      , cborg             >=0.2.2 && <0.3
                      , containers
+                     , hedgehog-quickcheck
                      , mtl
                      , QuickCheck
                      , sop-core

ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano/CanHardFork.hs

@@ -15,6 +15,9 @@ module Ouroboros.Consensus.Cardano.CanHardFork (
     TriggerHardFork (..)
   , ByronPartialLedgerConfig (..)
   , ShelleyPartialLedgerConfig (..)
+    -- * Exported for testing purposes
+  , translateTxIdByronToShelley
+  , translateCompactTxOutByronToShelley
   ) where
 
 import           Control.Monad.Reader (runReader)
@@ -60,7 +63,6 @@ import qualified Ouroboros.Consensus.Shelley.Protocol.State as TPraosState
 
 import           Ouroboros.Consensus.Util (hashFromBytesE)
 
-import qualified Shelley.Spec.Ledger.Address as SL
 import qualified Shelley.Spec.Ledger.API as SL
 import qualified Shelley.Spec.Ledger.BaseTypes as SL
 import qualified Shelley.Spec.Ledger.Coin as SL
@@ -271,35 +273,34 @@ translatePointByronToShelley = \case
     GenesisPoint   -> GenesisPoint
     BlockPoint s h -> BlockPoint s (translateHeaderHashByronToShelley h)
 
+
+-- | We use the same hashing algorithm so we can unwrap and rewrap the bytes.
+-- We don't care about the type that is hashed, which will differ going from
+-- Byron to Shelley, we just use the hashes as IDs.
+translateTxIdByronToShelley :: Crypto sc => CC.TxId -> SL.TxId sc
+translateTxIdByronToShelley =
+    SL.TxId . hashFromBytesE . Hashing.hashToBytes
+
+translateCompactTxInByronToShelley :: Crypto sc => CC.CompactTxIn -> SL.TxIn sc
+translateCompactTxInByronToShelley (CC.CompactTxInUtxo compactTxId idx) =
+    SL.TxInCompact
+      (translateTxIdByronToShelley (CC.fromCompactTxId compactTxId))
+      (fromIntegral idx)
+
+translateCompactTxOutByronToShelley :: CC.CompactTxOut -> SL.TxOut sc
+translateCompactTxOutByronToShelley (CC.CompactTxOut compactAddr amount) =
+    SL.TxOutCompact
+      (CC.unsafeGetCompactAddress compactAddr)
+      (CC.unsafeGetLovelace amount)
+
 translateUTxOByronToShelley :: forall sc. Crypto sc => CC.UTxO -> SL.UTxO sc
 translateUTxOByronToShelley (CC.UTxO utxoByron) =
     SL.UTxO $ Map.fromList
       [ (txInShelley, txOutShelley)
       | (txInByron, txOutByron) <- Map.toList utxoByron
-      , let txInShelley  = translateTxIn  $ CC.fromCompactTxIn  txInByron
-            txOutShelley = translateTxOut $ CC.fromCompactTxOut txOutByron
+      , let txInShelley  = translateCompactTxInByronToShelley  txInByron
+            txOutShelley = translateCompactTxOutByronToShelley txOutByron
       ]
-  where
-    translateTxIn :: CC.TxIn -> SL.TxIn sc
-    translateTxIn (CC.TxInUtxo txId idx) =
-      SL.TxIn (translateTxId txId) (fromIntegral idx)
-
-    translateTxOut :: CC.TxOut -> SL.TxOut sc
-    translateTxOut (CC.TxOut addr amount) =
-      SL.TxOut (translateAddr addr) (translateAmount amount)
-
-    -- | We use the same hasing algorithm so we can unwrap and rewrap the
-    -- bytes. We don't care about the type that is hashed, which will differ
-    -- going from Byron to Shelley, we just use the hashes as IDs.
-    translateTxId :: CC.TxId -> SL.TxId sc
-    translateTxId =
-      SL.TxId . hashFromBytesE . Hashing.hashToBytes
-
-    translateAmount :: CC.Lovelace -> SL.Coin
-    translateAmount = SL.Coin . CC.lovelaceToInteger
-
-    translateAddr :: CC.Address -> SL.Addr sc
-    translateAddr = SL.AddrBootstrap . SL.BootstrapAddress
 
 translateLedgerStateByronToShelleyWrapper
   :: forall sc. Crypto sc

ouroboros-consensus-cardano/test/Main.hs

@@ -6,6 +6,7 @@ import           Test.Util.Nightly
 import qualified Test.Consensus.Cardano.ByronCompatibility (tests)
 import qualified Test.Consensus.Cardano.Golden (tests)
 import qualified Test.Consensus.Cardano.Serialisation (tests)
+import qualified Test.Consensus.Cardano.Translation (tests)
 import qualified Test.ThreadNet.Cardano (tests)
 
 main :: IO ()
@@ -17,5 +18,6 @@ tests =
   [ Test.Consensus.Cardano.ByronCompatibility.tests
   , Test.Consensus.Cardano.Golden.tests
   , Test.Consensus.Cardano.Serialisation.tests
+  , Test.Consensus.Cardano.Translation.tests
   , Test.ThreadNet.Cardano.tests
   ]

ouroboros-consensus-cardano/test/Test/Consensus/Cardano/Translation.hs

@@ -0,0 +1,62 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications    #-}
+
+{-# OPTIONS_GHC -Wno-orphans #-}
+module Test.Consensus.Cardano.Translation (tests) where
+
+import qualified Cardano.Chain.Common as CC
+import qualified Cardano.Chain.UTxO as CC
+
+import           Ouroboros.Consensus.Cardano.CanHardFork
+import           Ouroboros.Consensus.Shelley.Protocol
+
+import qualified Shelley.Spec.Ledger.Address as SL
+import qualified Shelley.Spec.Ledger.Coin as SL
+import qualified Shelley.Spec.Ledger.TxData as SL
+
+import           Test.QuickCheck.Hedgehog (hedgehog)
+import           Test.Tasty
+import           Test.Tasty.QuickCheck
+
+import           Test.Cardano.Chain.UTxO.Gen (genCompactTxOut)
+
+{------------------------------------------------------------------------------
+  Top-level tests
+------------------------------------------------------------------------------}
+
+tests :: TestTree
+tests = testGroup "Translation" [
+      testProperty "translateTxOut correctness" prop_translateTxOut_correctness
+    ]
+
+{------------------------------------------------------------------------------
+  Properties
+------------------------------------------------------------------------------}
+
+prop_translateTxOut_correctness :: CC.CompactTxOut -> Property
+prop_translateTxOut_correctness compactTxOut =
+        translateTxOutByronToShelley
+          @TPraosStandardCrypto
+          (CC.fromCompactTxOut compactTxOut)
+    === translateCompactTxOutByronToShelley compactTxOut
+
+{------------------------------------------------------------------------------
+  Reference implementation
+------------------------------------------------------------------------------}
+
+translateTxOutByronToShelley :: forall sc. Crypto sc => CC.TxOut -> SL.TxOut sc
+translateTxOutByronToShelley (CC.TxOut addr amount) =
+    SL.TxOut (translateAddr addr) (translateAmount amount)
+  where
+    translateAmount :: CC.Lovelace -> SL.Coin
+    translateAmount = SL.Coin . CC.lovelaceToInteger
+
+    translateAddr :: CC.Address -> SL.Addr sc
+    translateAddr = SL.AddrBootstrap . SL.BootstrapAddress
+
+{------------------------------------------------------------------------------
+  Generators
+------------------------------------------------------------------------------}
+
+instance Arbitrary CC.CompactTxOut where
+  arbitrary = hedgehog genCompactTxOut

stack.yaml

@@ -52,7 +52,7 @@ extra-deps:
       - slotting
 
   - git: https://github.com/input-output-hk/cardano-ledger-specs
-    commit: c453fa6fce99ed3cb09d129c829ddbf0980a642c
+    commit: be1e61ad0f73c099a8b9ca1be430e3b40706f398
     subdirs:
       - byron/chain/executable-spec
       - byron/ledger/executable-spec