Switch AlonzoTxAuxData to use NativeScript

Author: Soupstraw

eras/allegra/impl/src/Cardano/Ledger/Allegra/Scripts.hs

@@ -1,5 +1,7 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DefaultSignatures #-}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DerivingVia #-}
@@ -73,7 +75,7 @@ import Cardano.Ledger.Binary.Coders (
   (<*!),
  )
 import Cardano.Ledger.Core
-import Cardano.Ledger.Internal.Era (AlonzoEra, BabbageEra, ConwayEra, MaryEra)
+import Cardano.Ledger.Internal.Era (AlonzoEra, BabbageEra, ConwayEra, MaryEra, ShelleyEra)
 import Cardano.Ledger.MemoBytes (
   EqRaw (..),
   MemoBytes (Memo),
@@ -99,6 +101,7 @@ import Data.Aeson (ToJSON (..), (.=))
 import qualified Data.Aeson as Aeson
 import Data.ByteString.Lazy (fromStrict)
 import Data.ByteString.Short (fromShort)
+import Data.Coerce (Coercible, coerce)
 import Data.Foldable as F (foldl')
 import Data.MemPack
 import Data.Sequence.Strict as Seq (StrictSeq (Empty, (:<|)))
@@ -156,6 +159,12 @@ class ShelleyEraScript era => AllegraEraScript era where
   mkTimeExpire :: SlotNo -> NativeScript era
   getTimeExpire :: NativeScript era -> Maybe SlotNo
 
+  upgradeNativeScript :: NativeScript (PreviousEra era) -> NativeScript era
+  default upgradeNativeScript ::
+    Coercible (NativeScript (PreviousEra era)) (NativeScript era) =>
+    NativeScript (PreviousEra era) -> NativeScript era
+  upgradeNativeScript = coerce
+
 deriving instance Era era => NoThunks (TimelockRaw era)
 
 deriving instance Show (TimelockRaw era)
@@ -244,19 +253,22 @@ deriving instance Show (Timelock era)
 instance EqRaw (Timelock era) where
   eqRaw = eqTimelockRaw
 
+upgradeMultiSig :: NativeScript ShelleyEra -> NativeScript AllegraEra
+upgradeMultiSig = \case
+  RequireSignature keyHash -> RequireSignature keyHash
+  RequireAllOf sigs -> RequireAllOf $ upgradeScript <$> sigs
+  RequireAnyOf sigs -> RequireAnyOf $ upgradeScript <$> sigs
+  RequireMOf n sigs -> RequireMOf n $ upgradeScript <$> sigs
+  _ -> error "Impossible: All NativeScripts should have been accounted for"
+
 -- | Since Timelock scripts are a strictly backwards compatible extension of
 -- MultiSig scripts, we can use the same 'scriptPrefixTag' tag here as we did
 -- for the ValidateScript instance in MultiSig
 instance EraScript AllegraEra where
   type Script AllegraEra = Timelock AllegraEra
   type NativeScript AllegraEra = Timelock AllegraEra
 
-  upgradeScript = \case
-    RequireSignature keyHash -> RequireSignature keyHash
-    RequireAllOf sigs -> RequireAllOf $ upgradeScript <$> sigs
-    RequireAnyOf sigs -> RequireAnyOf $ upgradeScript <$> sigs
-    RequireMOf n sigs -> RequireMOf n $ upgradeScript <$> sigs
-    _ -> error "Impossible: All NativeScripts should have been accounted for"
+  upgradeScript = upgradeMultiSig
 
   scriptPrefixTag _script = nativeMultiSigTag -- "\x00"
 
@@ -284,6 +296,8 @@ instance AllegraEraScript AllegraEra where
   mkTimeExpire = mkTimeExpireTimelock
   getTimeExpire = getTimeExpireTimelock
 
+  upgradeNativeScript = upgradeMultiSig
+
 pattern RequireTimeExpire :: AllegraEraScript era => SlotNo -> NativeScript era
 pattern RequireTimeExpire mslot <- (getTimeExpire -> Just mslot)
   where
@@ -448,8 +462,6 @@ showTimelock (RequireMOf m xs) = "(MOf " ++ show m ++ " " ++ F.foldl' accum ")"
 showTimelock (RequireSignature hash) = "(Signature " ++ show hash ++ ")"
 showTimelock _ = error "Impossible: All NativeScripts should have been accounted for"
 
--- | Check the equality of two underlying types, while ignoring their binary
--- representation, which `Eq` instance normally does. This is used for testing.
 eqTimelockRaw :: Timelock era -> Timelock era -> Bool
 eqTimelockRaw t1 t2 = go (getMemoRawType t1) (getMemoRawType t2)
   where

eras/allegra/impl/src/Cardano/Ledger/Allegra/TxAuxData.hs

@@ -74,7 +74,7 @@ import NoThunks.Class (NoThunks)
 data AllegraTxAuxDataRaw era = AllegraTxAuxDataRaw
   { atadrMetadata :: !(Map Word64 Metadatum)
   -- ^ Structured transaction metadata
-  , atadrTimelock :: !(StrictSeq (Timelock era))
+  , atadrNativeScripts :: !(StrictSeq (Timelock era))
   -- ^ Pre-images of script hashes found within the TxBody, but which are not
   -- required as witnesses. Examples include:
   -- - Token policy IDs appearing in transaction outputs
@@ -108,8 +108,8 @@ timelockScriptsAllegraTxAuxDataL ::
   Era era =>
   Lens' (AllegraTxAuxData era) (StrictSeq (Timelock era))
 timelockScriptsAllegraTxAuxDataL =
-  lensMemoRawType @era atadrTimelock $
-    \txAuxDataRaw ts -> txAuxDataRaw {atadrTimelock = ts}
+  lensMemoRawType @era atadrNativeScripts $
+    \txAuxDataRaw ts -> txAuxDataRaw {atadrNativeScripts = ts}
 
 deriving instance Show (AllegraTxAuxDataRaw era)
 

eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Scripts.hs

@@ -24,7 +24,7 @@
 
 module Cardano.Ledger.Alonzo.Scripts (
   PlutusBinary (..),
-  AlonzoScript (TimelockScript, PlutusScript),
+  AlonzoScript (NativeScript, PlutusScript),
   Script,
   isPlutusScript,
   validScript,
@@ -426,44 +426,52 @@ pattern RewardingPurpose c <- (toRewardingPurpose -> Just c)
 
 -- Alonzo Script ===============================================================
 
--- | Scripts in the Alonzo Era, Either a Timelock script or a Plutus script.
+-- | Scripts in the Alonzo Era, Either a nativve script or a Plutus script.
 data AlonzoScript era
-  = TimelockScript !(Timelock era)
+  = NativeScript !(NativeScript era)
   | PlutusScript !(PlutusScript era)
   deriving (Generic)
 
-instance (Era era, MemPack (PlutusScript era)) => MemPack (AlonzoScript era) where
+instance
+  ( Era era
+  , MemPack (PlutusScript era)
+  , MemPack (NativeScript era)
+  ) =>
+  MemPack (AlonzoScript era)
+  where
   packedByteCount = \case
-    TimelockScript script -> packedTagByteCount + packedByteCount script
+    NativeScript script -> packedTagByteCount + packedByteCount script
     PlutusScript script -> packedTagByteCount + packedByteCount script
   packM = \case
-    TimelockScript script -> packTagM 0 >> packM script
+    NativeScript script -> packTagM 0 >> packM script
     PlutusScript script -> packTagM 1 >> packM script
   {-# INLINE packM #-}
   unpackM =
     unpackTagM >>= \case
-      0 -> TimelockScript <$> unpackM
+      0 -> NativeScript <$> unpackM
       1 -> PlutusScript <$> unpackM
       n -> unknownTagM @(AlonzoScript era) n
   {-# INLINE unpackM #-}
 
-deriving instance Eq (PlutusScript era) => Eq (AlonzoScript era)
+deriving instance (Eq (PlutusScript era), Eq (NativeScript era)) => Eq (AlonzoScript era)
 
-instance (Era era, NoThunks (PlutusScript era)) => NoThunks (AlonzoScript era)
+instance
+  (Era era, NoThunks (PlutusScript era), NoThunks (NativeScript era)) =>
+  NoThunks (AlonzoScript era)
 
-instance NFData (PlutusScript era) => NFData (AlonzoScript era) where
+instance (NFData (PlutusScript era), NFData (NativeScript era)) => NFData (AlonzoScript era) where
   rnf = \case
-    TimelockScript ts -> rnf ts
+    NativeScript ts -> rnf ts
     PlutusScript ps -> rnf ps
 
 instance (AlonzoEraScript era, Script era ~ AlonzoScript era) => Show (AlonzoScript era) where
-  show (TimelockScript x) = "TimelockScript " ++ show x
+  show (NativeScript x) = "NativeScript " ++ show x
   show s@(PlutusScript plutus) =
     "PlutusScript " ++ show (plutusScriptLanguage plutus) ++ " " ++ show (hashScript @era s)
 
 -- | Both constructors know their original bytes
-instance SafeToHash (PlutusScript era) => SafeToHash (AlonzoScript era) where
-  originalBytes (TimelockScript t) = originalBytes t
+instance (SafeToHash (PlutusScript era), SafeToHash (NativeScript era)) => SafeToHash (AlonzoScript era) where
+  originalBytes (NativeScript t) = originalBytes t
   originalBytes (PlutusScript plutus) = originalBytes plutus
 
 isPlutusScript :: AlonzoEraScript era => Script era -> Bool
@@ -473,22 +481,22 @@ instance EraScript AlonzoEra where
   type Script AlonzoEra = AlonzoScript AlonzoEra
   type NativeScript AlonzoEra = Timelock AlonzoEra
 
-  upgradeScript = TimelockScript . translateTimelock
+  upgradeScript = NativeScript . translateTimelock
 
   scriptPrefixTag = alonzoScriptPrefixTag
 
   getNativeScript = \case
-    TimelockScript ts -> Just ts
+    NativeScript ts -> Just ts
     _ -> Nothing
 
-  fromNativeScript = TimelockScript
+  fromNativeScript = NativeScript
 
 alonzoScriptPrefixTag ::
   (AlonzoEraScript era, AlonzoScript era ~ Script era) =>
   Script era ->
   BS.ByteString
 alonzoScriptPrefixTag = \case
-  TimelockScript _ -> nativeMultiSigTag -- "\x00"
+  NativeScript _ -> nativeMultiSigTag -- "\x00"
   PlutusScript plutusScript -> BS.singleton (withPlutusScript plutusScript plutusLanguageTag)
 
 instance ShelleyEraScript AlonzoEra where
@@ -555,7 +563,12 @@ instance AlonzoEraScript AlonzoEra where
   upgradePlutusPurposeAsIx =
     error "Impossible: No `PlutusScript` and `AlonzoEraScript` instances in the previous era"
 
-instance Eq (PlutusScript era) => EqRaw (AlonzoScript era) where
+instance
+  ( Eq (PlutusScript era)
+  , EqRaw (NativeScript era)
+  ) =>
+  EqRaw (AlonzoScript era)
+  where
   eqRaw = eqAlonzoScriptRaw
 
 instance AlonzoEraScript era => ToJSON (AlonzoScript era) where
@@ -598,7 +611,7 @@ instance AlonzoEraScript era => ToCBOR (AlonzoScript era) where
 
 encodeScript :: AlonzoEraScript era => AlonzoScript era -> Encode 'Open (AlonzoScript era)
 encodeScript = \case
-  TimelockScript i -> Sum TimelockScript 0 !> To i
+  NativeScript i -> Sum NativeScript 0 !> To i
   PlutusScript plutusScript -> withPlutusScript plutusScript $ \plutus@(Plutus pb) ->
     case plutusSLanguage plutus of
       SPlutusV1 -> Sum (PlutusScript . fromJust . mkPlutusScript . Plutus @'PlutusV1) 1 !> To pb
@@ -614,7 +627,7 @@ instance AlonzoEraScript era => DecCBOR (Annotator (AlonzoScript era)) where
       {-# INLINE decodeAnnPlutus #-}
       decodeScript :: Word -> Decode 'Open (Annotator (AlonzoScript era))
       decodeScript = \case
-        0 -> Ann (SumD TimelockScript) <*! From
+        0 -> Ann (SumD NativeScript) <*! From
         1 -> decodeAnnPlutus SPlutusV1
         2 -> decodeAnnPlutus SPlutusV2
         3 -> decodeAnnPlutus SPlutusV3
@@ -636,8 +649,12 @@ validScript pv script =
 
 -- | Check the equality of two underlying types, while ignoring their binary
 -- representation, which `Eq` instance normally does. This is used for testing.
-eqAlonzoScriptRaw :: Eq (PlutusScript era) => AlonzoScript era -> AlonzoScript era -> Bool
-eqAlonzoScriptRaw (TimelockScript t1) (TimelockScript t2) = eqTimelockRaw t1 t2
+eqAlonzoScriptRaw ::
+  ( Eq (PlutusScript era)
+  , EqRaw (NativeScript era)
+  ) =>
+  AlonzoScript era -> AlonzoScript era -> Bool
+eqAlonzoScriptRaw (NativeScript t1) (NativeScript t2) = eqRaw t1 t2
 eqAlonzoScriptRaw (PlutusScript ps1) (PlutusScript ps2) = ps1 == ps2
 eqAlonzoScriptRaw _ _ = False