Merge pull request #5099 from IntersectMBO/ldan/complete-patterns

Fix `COMPLETE` pragmas for `TxCert` and `NativeScript`

Resolves #4613

Author: Lucsanszky

eras/allegra/impl/CHANGELOG.md

@@ -2,6 +2,8 @@
 
 ## 1.8.0.0
 
+* Added `COMPLETE` pragma for `TxCert AllegraEra`
+* Added `COMPLETE` pragma for `NativeScript AllegraEra`
 * Move to `testlib` `DecCBOR` instances for: `TxBody AllegraEra`, `AllegraTxAuxDataRaw`, `AllegraTxAuxData`, `TimelockRaw`, `Timelock`
 * Remove `AllegraTxBody`
 * Removed `era` parameter from `AllegraTxBodyRaw`

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

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric #-}
@@ -14,10 +15,14 @@
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE UndecidableSuperClasses #-}
 {-# LANGUAGE ViewPatterns #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
+#if __GLASGOW_HASKELL__ >= 908
+{-# OPTIONS_GHC -Wno-x-unsafe-ledger-internal #-}
+#endif
 
 module Cardano.Ledger.Allegra.Scripts (
   AllegraEraScript (..),
@@ -68,6 +73,7 @@ import Cardano.Ledger.Binary.Coders (
   (<*!),
  )
 import Cardano.Ledger.Core
+import Cardano.Ledger.Internal.Era (AlonzoEra, BabbageEra, ConwayEra, MaryEra)
 import Cardano.Ledger.MemoBytes (
   EqRaw (..),
   MemoBytes (Memo),
@@ -294,7 +300,48 @@ pattern RequireTimeStart mslot <- (getTimeStart -> Just mslot)
   , RequireAnyOf
   , RequireMOf
   , RequireTimeExpire
-  , RequireTimeStart
+  , RequireTimeStart ::
+    AllegraEra
+  #-}
+
+{-# COMPLETE
+  RequireSignature
+  , RequireAllOf
+  , RequireAnyOf
+  , RequireMOf
+  , RequireTimeExpire
+  , RequireTimeStart ::
+    MaryEra
+  #-}
+
+{-# COMPLETE
+  RequireSignature
+  , RequireAllOf
+  , RequireAnyOf
+  , RequireMOf
+  , RequireTimeExpire
+  , RequireTimeStart ::
+    AlonzoEra
+  #-}
+
+{-# COMPLETE
+  RequireSignature
+  , RequireAllOf
+  , RequireAnyOf
+  , RequireMOf
+  , RequireTimeExpire
+  , RequireTimeStart ::
+    BabbageEra
+  #-}
+
+{-# COMPLETE
+  RequireSignature
+  , RequireAllOf
+  , RequireAnyOf
+  , RequireMOf
+  , RequireTimeExpire
+  , RequireTimeStart ::
+    ConwayEra
   #-}
 
 mkRequireSignatureTimelock :: forall era. Era era => KeyHash 'Witness -> Timelock era
@@ -353,7 +400,7 @@ ltePosInfty SNothing _ = False -- ∞ > j
 ltePosInfty (SJust i) j = i <= j
 
 evalTimelock ::
-  AllegraEraScript era =>
+  (AllegraEraScript era, NativeScript era ~ Timelock era) =>
   Set.Set (KeyHash 'Witness) ->
   ValidityInterval ->
   NativeScript era ->
@@ -372,6 +419,7 @@ evalTimelock vhks (ValidityInterval txStart txExp) = go
       RequireAllOf xs -> all go xs
       RequireAnyOf xs -> any go xs
       RequireMOf m xs -> isValidMOf m xs
+      _ -> error "Impossible: All NativeScripts should have been accounted for"
 
 -- =========================================================
 -- Operations on Timelock scripts
@@ -398,6 +446,7 @@ showTimelock (RequireMOf m xs) = "(MOf " ++ show m ++ " " ++ F.foldl' accum ")"
   where
     accum ans x = showTimelock x ++ " " ++ ans
 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.

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

@@ -3,6 +3,7 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
 
@@ -12,7 +13,7 @@ module Cardano.Ledger.Allegra.Tx (
 
 import Cardano.Ledger.Allegra.Era (AllegraEra)
 import Cardano.Ledger.Allegra.PParams ()
-import Cardano.Ledger.Allegra.Scripts (AllegraEraScript (..), evalTimelock)
+import Cardano.Ledger.Allegra.Scripts (AllegraEraScript (..), Timelock, evalTimelock)
 import Cardano.Ledger.Allegra.TxAuxData ()
 import Cardano.Ledger.Allegra.TxBody (AllegraEraTxBody (..))
 import Cardano.Ledger.Allegra.TxWits ()
@@ -72,7 +73,8 @@ instance EraTx AllegraEra where
 -- We still need to correctly compute the witness set for TxBody as well.
 
 validateTimelock ::
-  (EraTx era, AllegraEraTxBody era, AllegraEraScript era) => Tx era -> NativeScript era -> Bool
+  (EraTx era, AllegraEraTxBody era, AllegraEraScript era, NativeScript era ~ Timelock era) =>
+  Tx era -> NativeScript era -> Bool
 validateTimelock tx timelock = evalTimelock vhks (tx ^. bodyTxL . vldtTxBodyL) timelock
   where
     vhks = Set.map witVKeyHash (tx ^. witsTxL . addrTxWitsL)

eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/ImpTest.hs

@@ -16,6 +16,7 @@ import Cardano.Ledger.Allegra (AllegraEra)
 import Cardano.Ledger.Allegra.Core
 import Cardano.Ledger.Allegra.Scripts (
   AllegraEraScript,
+  Timelock,
   evalTimelock,
   pattern RequireTimeExpire,
   pattern RequireTimeStart,
@@ -45,6 +46,7 @@ instance ShelleyEraImp AllegraEra where
 impAllegraSatisfyNativeScript ::
   ( AllegraEraScript era
   , AllegraEraTxBody era
+  , NativeScript era ~ Timelock era
   ) =>
   Set.Set (KeyHash 'Witness) ->
   TxBody era ->
@@ -79,4 +81,5 @@ impAllegraSatisfyNativeScript providedVKeyHashes txBody script = do
       lock@(RequireTimeExpire _)
         | evalTimelock mempty vi lock -> Just mempty
         | otherwise -> Nothing
+      _ -> error "Impossible: All NativeScripts should have been accounted for"
   pure $ satisfyScript script

eras/alonzo/impl/CHANGELOG.md

@@ -2,6 +2,8 @@
 
 ## 1.14.0.0
 
+* Added `COMPLETE` pragma for `TxCert AlonzoEra`
+* Added `COMPLETE` pragma for `NativeScript AlonzoEra`
 * Deprecated `toAlonzoGenesisPairs`
 * Removed `MissingRequiredSigners` from `AlonzoUtxowPredFailure`
 * Renamed fields of `AlonzoTx`

eras/babbage/impl/CHANGELOG.md

@@ -2,6 +2,8 @@
 
 ## 1.12.0.0
 
+* Added `COMPLETE` pragma for `TxCert BabbageEra`
+* Added `COMPLETE` pragma for `NativeScript BabbageEra`
 * Move to `testlib` the `DecCBOR` instance for `TxBody BabbageEra`
 * Remove `BabbageNonDisjointRefInputs` for protocol versions >10
 * Added `ppCoinsPerUTxOByte` to `PParams`

eras/conway/impl/CHANGELOG.md

@@ -2,6 +2,7 @@
 
 ## 1.20.0.0
 
+* Added `COMPLETE` pragma for `NativeScript ConwayEra`
 * Add default implementation for `tcConwayGenesisL`
 * Remove `tcDelegsL` and `tcInitialDRepsL`
 * Export `registerDRepsThenDelegs`

eras/conway/impl/src/Cardano/Ledger/Conway/TxCert.hs

@@ -342,7 +342,8 @@ pattern UpdateDRepTxCert cred mAnchor <- (getUpdateDRepTxCert -> Just (cred, mAn
   , ResignCommitteeColdTxCert
   , RegDRepTxCert
   , UnRegDRepTxCert
-  , UpdateDRepTxCert
+  , UpdateDRepTxCert ::
+    ConwayEra
   #-}
 
 getDelegateeTxCert :: ConwayEraTxCert era => TxCert era -> Maybe Delegatee

eras/conway/impl/src/Cardano/Ledger/Conway/TxInfo.hs

@@ -539,7 +539,8 @@ transTxBodyWithdrawals txBody =
 -- omitting the deposit in these cases. It has been confirmed that this buggy behavior for protocol
 -- version 9 has been exercised on Mainnet, therefore this conditional translation can never be
 -- removed for Conway era (#4863)
-transTxCert :: ConwayEraTxCert era => ProtVer -> TxCert era -> PV3.TxCert
+transTxCert ::
+  (ConwayEraTxCert era, TxCert era ~ ConwayTxCert era) => ProtVer -> TxCert era -> PV3.TxCert
 transTxCert pv = \case
   RegPoolTxCert PoolParams {ppId, ppVrf} ->
     PV3.TxCertPoolRegister
@@ -575,6 +576,7 @@ transTxCert pv = \case
     PV3.TxCertUnRegDRep (transDRepCred drepCred) (transCoinToLovelace refund)
   UpdateDRepTxCert drepCred _anchor ->
     PV3.TxCertUpdateDRep (transDRepCred drepCred)
+  _ -> error "Impossible: All TxCerts should have been accounted for"
 
 transDRepCred :: Credential 'DRepRole -> PV3.DRepCredential
 transDRepCred = PV3.DRepCredential . transCred

eras/mary/impl/CHANGELOG.md

@@ -2,6 +2,8 @@
 
 ## 1.9.0.0
 
+* Added `COMPLETE` pragma for `TxCert MaryEra`
+* Added `COMPLETE` pragma for `NativeScript MaryEra`
 * Move to `testlib` the `DecCBOR` instance for `TxBody MaryEra`
 * Remove `MaryTxBody`
 * Converted `MaryTxBodyRaw` into a type synonym

eras/shelley/impl/src/Cardano/Ledger/Shelley/TxCert.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric #-}
@@ -19,6 +20,9 @@
 {-# LANGUAGE UndecidableSuperClasses #-}
 {-# LANGUAGE ViewPatterns #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
+#if __GLASGOW_HASKELL__ >= 908
+{-# OPTIONS_GHC -Wno-x-unsafe-ledger-internal #-}
+#endif
 
 module Cardano.Ledger.Shelley.TxCert (
   ShelleyEraTxCert (..),
@@ -97,6 +101,7 @@ import Cardano.Ledger.Credential (
   credKeyHashWitness,
   credScriptHash,
  )
+import Cardano.Ledger.Internal.Era (AllegraEra, AlonzoEra, BabbageEra, MaryEra)
 import Cardano.Ledger.Keys (asWitness)
 import Cardano.Ledger.PoolParams (PoolParams (..))
 import Cardano.Ledger.Shelley.Era (ShelleyEra)
@@ -231,7 +236,52 @@ pattern GenesisDelegTxCert genKey genDelegKey vrfKeyHash <-
   , UnRegTxCert
   , DelegStakeTxCert
   , MirTxCert
-  , GenesisDelegTxCert
+  , GenesisDelegTxCert ::
+    ShelleyEra
+  #-}
+
+{-# COMPLETE
+  RegPoolTxCert
+  , RetirePoolTxCert
+  , RegTxCert
+  , UnRegTxCert
+  , DelegStakeTxCert
+  , MirTxCert
+  , GenesisDelegTxCert ::
+    AllegraEra
+  #-}
+
+{-# COMPLETE
+  RegPoolTxCert
+  , RetirePoolTxCert
+  , RegTxCert
+  , UnRegTxCert
+  , DelegStakeTxCert
+  , MirTxCert
+  , GenesisDelegTxCert ::
+    MaryEra
+  #-}
+
+{-# COMPLETE
+  RegPoolTxCert
+  , RetirePoolTxCert
+  , RegTxCert
+  , UnRegTxCert
+  , DelegStakeTxCert
+  , MirTxCert
+  , GenesisDelegTxCert ::
+    AlonzoEra
+  #-}
+
+{-# COMPLETE
+  RegPoolTxCert
+  , RetirePoolTxCert
+  , RegTxCert
+  , UnRegTxCert
+  , DelegStakeTxCert
+  , MirTxCert
+  , GenesisDelegTxCert ::
+    BabbageEra
   #-}
 
 -- | Genesis key delegation certificate

libs/cardano-ledger-conformance/src/Test/Cardano/Ledger/Conformance/SpecTranslate/Conway/Base.hs

@@ -225,6 +225,7 @@ instance
             pure . Agda.RequireMOf (toInteger m) $ toList tls
           RequireTimeExpire slot -> Agda.RequireTimeExpire <$> toSpecRep slot
           RequireTimeStart slot -> Agda.RequireTimeStart <$> toSpecRep slot
+          _ -> error "Impossible: All NativeScripts should have been accounted for"
 
 instance
   ( AlonzoEraScript era

libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/TxGen.hs

@@ -302,6 +302,7 @@ mkTimelockWit era mTag =
       F.fold <$> mapM (mkTimelockWit era mTag) ts
     RequireTimeStart _ -> pure (const [])
     RequireTimeExpire _ -> pure (const [])
+    _ -> error "Impossible: All NativeScripts should have been accounted for"
 
 -- | Same as `genCredKeyWit`, but for `TxOuts`
 genTxOutKeyWitness ::