Add singletons for STxType

Author: lehins

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

@@ -205,6 +205,10 @@ instance EraTxBody ShelleyEra where
 
   mkBasicTxBody = mkMemoizedEra @ShelleyEra basicShelleyTxBodyRaw
 
+  txBodyType txBody =
+    case getMemoRawType txBody of
+      ShelleyTxBodyRaw {} -> SFullTx
+
   spendableInputsTxBodyF = inputsTxBodyL
   {-# INLINE spendableInputsTxBodyF #-}
 

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

@@ -183,15 +183,19 @@ instance EraUTxO ShelleyEra where
 
   getConsumedValue pp lookupKeyDeposit _ = getConsumedCoin pp lookupKeyDeposit
 
-  getProducedValue = shelleyProducedValue
+  getProducedValue pp isRegPoolId txBody =
+    case txBodyType txBody of
+      SFullTx -> shelleyProducedValue pp isRegPoolId txBody
 
   getScriptsProvided _ tx = ScriptsProvided (tx ^. witsTxL . scriptTxWitsL)
 
   getScriptsNeeded = getShelleyScriptsNeeded
 
   getScriptsHashesNeeded (ShelleyScriptsNeeded scriptsHashes) = scriptsHashes
 
-  getWitsVKeyNeeded certState utxo = getShelleyWitsVKeyNeeded certState utxo
+  getWitsVKeyNeeded certState utxo txBody =
+    case txBodyType txBody of
+      SFullTx -> getShelleyWitsVKeyNeeded certState utxo txBody
 
   getMinFeeTxUtxo pp tx _ = getShelleyMinFeeTxUtxo pp tx
 

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

@@ -4,6 +4,7 @@
 {-# LANGUAGE DefaultSignatures #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PolyKinds #-}
@@ -27,6 +28,7 @@
 module Cardano.Ledger.Core (
   -- * Transaction types
   TxType (..),
+  STxType (..),
   withTxType,
   applyTxType,
   applyFullTxType,
@@ -144,11 +146,11 @@ type data TxType = FullTx | SubTx
 
 withTxType ::
   forall f t a era. Typeable t => f t era -> (f FullTx era -> a) -> (f SubTx era -> a) -> a
-withTxType txType withFullTxType withSubTxType =
+withTxType anyTxType withFullTxType withSubTxType =
   case eqT @t @FullTx of
-    Just Refl -> withFullTxType txType
+    Just Refl -> withFullTxType anyTxType
     Nothing -> case eqT @t @SubTx of
-      Just Refl -> withSubTxType txType
+      Just Refl -> withSubTxType anyTxType
       Nothing -> error $ "Impossible: Unrecognized TxType: " <> show (typeRep (Proxy @t))
 
 applyTxType ::
@@ -168,6 +170,10 @@ applyFullTxType decFullTx =
     fail $
       "SubTx type is not supported for " <> show (typeRep (Proxy @f))
 
+data STxType t where
+  SFullTx :: STxType FullTx
+  SSubTx :: STxType SubTx
+
 -- | A transaction.
 class
   ( EraTxBody era
@@ -186,6 +192,8 @@ class
   where
   data Tx (t :: TxType) era
 
+  txType :: Tx t era -> STxType t
+
   mkBasicTx :: Typeable t => TxBody t era -> Tx t era
 
   bodyTxL :: Lens' (Tx t era) (TxBody t era)
@@ -238,6 +246,8 @@ class
   -- | The body of a transaction.
   data TxBody (t :: TxType) era
 
+  txBodyType :: TxBody t era -> STxType t
+
   mkBasicTxBody :: TxBody FullTx era
 
   inputsTxBodyL :: Lens' (TxBody t era) (Set TxIn)