Merge pull request #2530 from input-output-hk/lehins/ts-compact-integ…

…ration

Remove compacting of TxIn. Add Keyed instances for hashes

cabal.project

@@ -43,8 +43,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

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

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

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,

libs/cardano-ledger-core/src/Cardano/Ledger/AuxiliaryData.hs

@@ -19,13 +19,18 @@ 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
   { unsafeAuxiliaryDataHash :: SafeHash crypto EraIndependentAuxiliaryData
   }
   deriving (Show, Eq, Ord, NoThunks, NFData)
 
+deriving newtype instance
+  CC.Crypto crypto =>
+  Keyed (AuxiliaryDataHash crypto)
+
 deriving instance
   CC.Crypto crypto =>
   ToCBOR (AuxiliaryDataHash crypto)

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)
 

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)

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

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),
@@ -999,7 +999,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]

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

libs/compact-map/src/Data/Compact/HashMap.hs

@@ -1,18 +1,44 @@
+{-# 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
 
 -- ==========================================================================
 
 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