diff --git a/cabal.project b/cabal.project index 074cd924ea5..350e90ad9b2 100644 --- a/cabal.project +++ b/cabal.project @@ -42,8 +42,8 @@ test-show-details: streaming source-repository-package type: git location: https://github.com/input-output-hk/cardano-base - tag: 654f5b7c76f7cc57900b4ddc664a82fc3b925fb0 - --sha256: 0j4x9zbx5dkww82sqi086h39p456iq5xr476ylmrnpwcpfb4xai4 + tag: 7de552c29e8c6fb421a4df48281f145feb6c7d2c + --sha256: 0icq9y3nnl42fz536da84414av36g37894qnyw4rk3qkalksqwir subdir: base-deriving-via binary diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxInfo.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxInfo.hs index 33e66c78728..252be647d37 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxInfo.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxInfo.hs @@ -187,7 +187,7 @@ transVITime pp ei sysS (ValidityInterval (SJust i) (SJust j)) = do -- ======================================== -- translate TxIn and TxOut -txInfoIn' :: CC.Crypto c => TxIn c -> PV1.TxOutRef +txInfoIn' :: TxIn c -> PV1.TxOutRef txInfoIn' (TxIn txid nat) = PV1.TxOutRef (txInfoId txid) (fromIntegral nat) -- | Given a TxIn, look it up in the UTxO. If it exists, translate it and return @@ -321,7 +321,7 @@ exBudgetToExUnits (PV1.ExBudget (PV1.ExCPU steps) (PV1.ExMemory memory)) = -- =================================== -- translate Script Purpose -transScriptPurpose :: CC.Crypto crypto => ScriptPurpose crypto -> PV1.ScriptPurpose +transScriptPurpose :: ScriptPurpose crypto -> PV1.ScriptPurpose transScriptPurpose (Minting policyid) = PV1.Minting (transPolicyID policyid) transScriptPurpose (Spending txin) = PV1.Spending (txInfoIn' txin) transScriptPurpose (Rewarding (RewardAcnt _network cred)) = @@ -406,7 +406,6 @@ txInfo pp lang ei sysS utxo tx = do -- translates it into a 'Data', which the Plutus language knows how to interpret. -- The UTxO and the PtrMap are used to 'resolve' the TxIn and the StakeRefPtr's valContext :: - Era era => VersionedTxInfo -> ScriptPurpose (Crypto era) -> Data era diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Core.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Core.hs index 8408dae5f18..2771658bdbd 100644 --- a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Core.hs +++ b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Core.hs @@ -725,7 +725,6 @@ genesisAccountState = -- | Creates the UTxO for a new ledger with the specified -- genesis TxId and transaction outputs. genesisCoins :: - (Era era) => Ledger.TxId (Crypto era) -> [Core.TxOut era] -> UTxO era diff --git a/libs/cardano-ledger-core/cardano-ledger-core.cabal b/libs/cardano-ledger-core/cardano-ledger-core.cabal index 6a31c58c2e6..1421a0aa5fb 100644 --- a/libs/cardano-ledger-core/cardano-ledger-core.cabal +++ b/libs/cardano-ledger-core/cardano-ledger-core.cabal @@ -74,6 +74,7 @@ library cardano-ledger-byron, cardano-prelude, cardano-slotting, + compact-map, containers, data-default-class, deepseq, diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/AuxiliaryData.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/AuxiliaryData.hs index 53700b29615..14aaf34dc00 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/AuxiliaryData.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/AuxiliaryData.hs @@ -19,6 +19,7 @@ import qualified Cardano.Ledger.Crypto as CC (Crypto) import Cardano.Ledger.Hashes (EraIndependentAuxiliaryData) import Cardano.Ledger.SafeHash (SafeHash) import Control.DeepSeq (NFData (..)) +import Data.Compact.HashMap (Keyed) import NoThunks.Class (NoThunks (..)) newtype AuxiliaryDataHash crypto = AuxiliaryDataHash @@ -26,6 +27,10 @@ newtype AuxiliaryDataHash crypto = AuxiliaryDataHash } deriving (Show, Eq, Ord, NoThunks, NFData) +deriving newtype instance + CC.Crypto crypto => + Keyed (AuxiliaryDataHash crypto) + deriving instance CC.Crypto crypto => ToCBOR (AuxiliaryDataHash crypto) diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/Hashes.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/Hashes.hs index ed942258ab9..07091080593 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/Hashes.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/Hashes.hs @@ -34,6 +34,7 @@ import Cardano.Ledger.Crypto (ADDRHASH) import qualified Cardano.Ledger.Crypto as CC (Crypto) import Control.DeepSeq (NFData) import Data.Aeson +import Data.Compact.HashMap (Keyed) import GHC.Generics (Generic) import NoThunks.Class (NoThunks (..)) @@ -75,13 +76,11 @@ newtype ScriptHash crypto deriving (Show, Eq, Ord, Generic) deriving newtype (NFData, NoThunks) -deriving newtype instance - CC.Crypto crypto => - ToCBOR (ScriptHash crypto) +deriving newtype instance CC.Crypto crypto => Keyed (ScriptHash crypto) -deriving newtype instance - CC.Crypto crypto => - FromCBOR (ScriptHash crypto) +deriving newtype instance CC.Crypto crypto => ToCBOR (ScriptHash crypto) + +deriving newtype instance CC.Crypto crypto => FromCBOR (ScriptHash crypto) deriving newtype instance CC.Crypto crypto => ToJSON (ScriptHash crypto) diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/SafeHash.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/SafeHash.hs index 9fdbb318955..5f17c9d755e 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/SafeHash.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/SafeHash.hs @@ -33,6 +33,7 @@ import Cardano.Prelude (HeapWords (..)) import Control.DeepSeq (NFData) import Data.ByteString (ByteString) import Data.ByteString.Short (ShortByteString, fromShort) +import Data.Compact.HashMap (Keyed) import Data.Foldable (fold) import Data.MemoBytes (MemoBytes (..)) import Data.Typeable @@ -55,6 +56,8 @@ deriving newtype instance Hash.HashAlgorithm (CC.HASH crypto) => SafeToHash (SafeHash crypto index) +deriving newtype instance CC.Crypto crypto => Keyed (SafeHash crypto index) + deriving newtype instance HeapWords (Hash.Hash (CC.HASH c) i) => HeapWords (SafeHash c i) deriving instance (Typeable index, CC.Crypto c) => ToCBOR (SafeHash c index) diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/TxIn.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/TxIn.hs index 91f51a3a223..ebe052feb19 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/TxIn.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/TxIn.hs @@ -6,7 +6,6 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -23,30 +22,30 @@ module Cardano.Ledger.TxIn ( TxId (..), TxIn (TxIn, ..), - viewTxIn, txid, ) where -import Cardano.Binary (FromCBOR (fromCBOR), ToCBOR (..), encodeListLen) -import qualified Cardano.Crypto.Hash.Class as HS +import Cardano.Binary + ( DecoderError (DecoderErrorCustom), + FromCBOR (fromCBOR), + ToCBOR (..), + encodeListLen, + ) import Cardano.Ledger.Core (TxBody) import qualified Cardano.Ledger.Crypto as CC import Cardano.Ledger.Era (Crypto, Era) import Cardano.Ledger.Hashes (EraIndependentTxBody) -import Cardano.Ledger.SafeHash - ( SafeHash, - extractHash, - hashAnnotated, - unsafeMakeSafeHash, - ) +import Cardano.Ledger.SafeHash (SafeHash, hashAnnotated) import Cardano.Ledger.Serialization (decodeRecordNamed) -import Cardano.Prelude (HeapWords (..)) +import Cardano.Prelude (HeapWords (..), NFData, cborError) import qualified Cardano.Prelude as HW -import Control.DeepSeq (NFData (rnf)) +import Control.Monad (when) +import Data.Compact.HashMap (Keyed) +import Data.Text as T (pack) import Data.Word (Word64) import GHC.Generics (Generic) -import NoThunks.Class (NoThunks (..), noThunksInValues) +import NoThunks.Class (NoThunks (..)) import Numeric.Natural (Natural) -- | Compute the id of a transaction. @@ -72,101 +71,59 @@ newtype TxId crypto = TxId {_unTxId :: SafeHash crypto EraIndependentTxBody} deriving (Show, Eq, Ord, Generic) deriving newtype (NoThunks, HeapWords) +deriving newtype instance CC.Crypto crypto => Keyed (TxId crypto) + deriving newtype instance CC.Crypto crypto => ToCBOR (TxId crypto) deriving newtype instance CC.Crypto crypto => FromCBOR (TxId crypto) deriving newtype instance CC.Crypto crypto => NFData (TxId crypto) -instance HeapWords (TxIn crypto) where - heapWords (TxInCompact32 a _ _ _ ix) = - 6 + (4 * HW.heapWordsUnpacked a) + HW.heapWordsUnpacked ix - heapWords (TxInCompactOther tid ix) = - 3 + HW.heapWords tid + HW.heapWordsUnpacked ix +instance CC.Crypto crypto => HeapWords (TxIn crypto) where + heapWords (TxIn txId txIx) = + 2 + HW.heapWords txId + HW.heapWordsUnpacked txIx -- | The input of a UTxO. -data TxIn crypto where - TxInCompact32 :: - HS.SizeHash (CC.HASH crypto) ~ 32 => - {-# UNPACK #-} !Word64 -> -- Hash part 1/4 - {-# UNPACK #-} !Word64 -> -- Hash part 2/4 - {-# UNPACK #-} !Word64 -> -- Hash part 3/4 - {-# UNPACK #-} !Word64 -> -- Hash part 4/4 - {-# UNPACK #-} !Word64 -> -- Index - TxIn crypto - TxInCompactOther :: !(TxId crypto) -> {-# UNPACK #-} !Word64 -> TxIn crypto +data TxIn crypto = TxInCompact !(TxId crypto) {-# UNPACK #-} !Int + deriving (Generic) pattern TxIn :: - CC.Crypto crypto => TxId crypto -> - Natural -> -- TODO We might want to change this to Word64 generally + Natural -> -- TODO We might want to change this to Int generally TxIn crypto -pattern TxIn tid index <- - (viewTxIn -> (tid, index)) +pattern TxIn addr index <- + TxInCompact addr (fromIntegral -> index) where - TxIn tid@(TxId sh) index = - case HS.viewHash32 (extractHash sh) of - HS.ViewHashNot32 -> TxInCompactOther tid (fromIntegral index) - HS.ViewHash32 a b c d -> TxInCompact32 a b c d (fromIntegral index) + TxIn addr index = + TxInCompact addr (fromIntegral index) {-# COMPLETE TxIn #-} -viewTxIn :: TxIn crypto -> (TxId crypto, Natural) -viewTxIn (TxInCompactOther tid i) = (tid, fromIntegral i) -viewTxIn (TxInCompact32 a b c d i) = (tid, fromIntegral i) - where - tid = TxId (unsafeMakeSafeHash $ HS.unsafeMkHash32 a b c d) - -instance Show (TxIn crypto) where - showsPrec d (viewTxIn -> (tid, ix)) = - showParen (d > app_prec) $ - showString "TxIn " - . showsPrec (app_prec + 1) tid - . showString " " - . showsPrec (app_prec + 1) ix - where - app_prec = 10 - -instance Ord (TxIn crypto) where - compare (TxInCompact32 a1 b1 c1 d1 i1) (TxInCompact32 a2 b2 c2 d2 i2) = - compare a1 a2 <> compare b1 b2 <> compare c1 c2 <> compare d1 d2 - <> compare i1 i2 - compare (viewTxIn -> (id1, ix1)) (viewTxIn -> (id2, ix2)) = - compare id1 id2 <> compare ix1 ix2 - -instance Eq (TxIn crypto) where - (==) (TxInCompact32 a1 b1 c1 d1 i1) (TxInCompact32 a2 b2 c2 d2 i2) = - (a1 == a2) && (b1 == b2) && (c1 == c2) && (d1 == d2) && (i1 == i2) - (==) (viewTxIn -> (id1, ix1)) (viewTxIn -> (id2, ix2)) = - (id1 == id2) && (ix1 == ix2) - -instance CC.Crypto crypto => NFData (TxIn crypto) where - rnf (TxInCompactOther tid _) = seq (rnf tid) () - rnf (TxInCompact32 _ _ _ _ _) = () - -instance NoThunks (TxIn crypto) where - showTypeOf _ = "TxIn" - wNoThunks c (TxInCompactOther tid _) = noThunksInValues c [tid] - wNoThunks _ (TxInCompact32 _ _ _ _ _) = pure Nothing -- always in normal form - -instance - CC.Crypto crypto => - ToCBOR (TxIn crypto) - where - toCBOR (viewTxIn -> (txId, index)) = +deriving instance Ord (TxIn crypto) + +deriving instance Eq (TxIn crypto) + +deriving instance Show (TxIn crypto) + +deriving instance CC.Crypto crypto => NFData (TxIn crypto) + +instance NoThunks (TxIn crypto) + +instance CC.Crypto crypto => ToCBOR (TxIn crypto) where + toCBOR (TxInCompact txId index) = encodeListLen 2 <> toCBOR txId <> toCBOR index -instance - CC.Crypto crypto => - FromCBOR (TxIn crypto) - where +instance CC.Crypto crypto => FromCBOR (TxIn crypto) where fromCBOR = decodeRecordNamed "TxIn" (const 2) - (TxIn <$> fromCBOR <*> fmap natural fromCBOR) + (TxInCompact <$> fromCBOR <*> txIxFromCBOR) where - natural :: Word64 -> Natural - natural = fromIntegral + txIxFromCBOR = do + w64 :: Word64 <- fromCBOR + when (w64 > fromIntegral (maxBound :: Int)) $ + cborError $ DecoderErrorCustom "TxIn" ("Tx index is too big: " <> T.pack (show w64)) + pure $ fromIntegral w64 diff --git a/libs/cardano-ledger-pretty/src/Cardano/Ledger/Pretty.hs b/libs/cardano-ledger-pretty/src/Cardano/Ledger/Pretty.hs index 089ebf993d5..dd857177140 100644 --- a/libs/cardano-ledger-pretty/src/Cardano/Ledger/Pretty.hs +++ b/libs/cardano-ledger-pretty/src/Cardano/Ledger/Pretty.hs @@ -151,7 +151,7 @@ import Cardano.Ledger.Slot EpochSize (..), SlotNo (..), ) -import Cardano.Ledger.TxIn (TxId (..), TxIn (..), viewTxIn) +import Cardano.Ledger.TxIn (TxId (..), TxIn (..)) import Cardano.Protocol.TPraos.BHeader ( BHBody (..), BHeader (BHeader), @@ -998,7 +998,7 @@ ppTxId :: TxId c -> PDoc ppTxId (TxId x) = ppSexp "TxId" [ppSafeHash x] ppTxIn :: TxIn c -> PDoc -ppTxIn (viewTxIn -> (txid, index)) = ppSexp "TxIn" [ppTxId txid, ppNatural index] +ppTxIn (TxIn txid index) = ppSexp "TxIn" [ppTxId txid, ppNatural index] ppTxOut :: (Era era, PrettyA (Core.Value era)) => TxOut era -> PDoc ppTxOut (TxOutCompact caddr cval) = ppSexp "TxOut" [ppCompactAddr caddr, ppCompactForm prettyA cval] diff --git a/libs/compact-map/compact-map.cabal b/libs/compact-map/compact-map.cabal index 7c403a0d7ad..60585abd95c 100644 --- a/libs/compact-map/compact-map.cabal +++ b/libs/compact-map/compact-map.cabal @@ -35,6 +35,7 @@ library build-depends: base >=4.11 && <5 , array , containers + , cardano-crypto-class , deepseq , prettyprinter , primitive diff --git a/libs/compact-map/src/Data/Compact/HashMap.hs b/libs/compact-map/src/Data/Compact/HashMap.hs index cec0d079002..bc067f4b782 100644 --- a/libs/compact-map/src/Data/Compact/HashMap.hs +++ b/libs/compact-map/src/Data/Compact/HashMap.hs @@ -1,11 +1,18 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} module Data.Compact.HashMap where +import Cardano.Crypto.Hash.Class import Data.Compact.KeyMap (Key, KeyMap) import qualified Data.Compact.KeyMap as KM +import Data.Proxy import Data.Set (Set) import qualified Data.Set as Set +import Data.Typeable +import GHC.TypeLits -- ========================================================================== @@ -13,6 +20,25 @@ class Keyed t where toKey :: t -> Key fromKey :: Key -> t +instance HashAlgorithm h => Keyed (Hash h a) where + toKey h = + case hashToPackedBytes h of + PackedBytes8 a -> KM.Key a 0 0 0 + PackedBytes28 a b c d -> KM.Key a b c (fromIntegral d) + PackedBytes32 a b c d -> KM.Key a b c d + _ -> error $ "Unsupported hash size: " <> show (sizeHash (Proxy :: Proxy h)) + fromKey (KM.Key a b c d) = + hashFromPackedBytes $ + case sameNat (Proxy :: Proxy (SizeHash h)) (Proxy :: Proxy 32) of + Just Refl -> PackedBytes32 a b c d + Nothing -> + case sameNat (Proxy :: Proxy (SizeHash h)) (Proxy :: Proxy 28) of + Just Refl -> PackedBytes28 a b c (fromIntegral d) + Nothing -> + case sameNat (Proxy :: Proxy (SizeHash h)) (Proxy :: Proxy 8) of + Just Refl -> PackedBytes8 a + Nothing -> error $ "Unsupported hash size: " <> show (sizeHash (Proxy :: Proxy h)) + data HashMap k v where HashMap :: Keyed k => KeyMap v -> HashMap k v