More progress

Author: Jimbo4350

cardano-api/src/Cardano/Api/Experimental/Plutus/Internal/Shim/LegacyScripts.hs

@@ -44,8 +44,11 @@ import Cardano.Ledger.Alonzo.Scripts qualified as L
 import Cardano.Ledger.BaseTypes (Version)
 import Cardano.Ledger.Core qualified as L
 import Cardano.Ledger.Plutus.Language qualified as L
+import PlutusLedgerApi.V1.Data.Tx (ScriptTag (Cert))
 
+import Data.Kind (Type)
 import Data.Text qualified as Text
+import Data.Typeable
 
 -- | This module is concerned with converting legacy api scripts and by extension
 -- script witnesses to the new api.
@@ -109,7 +112,7 @@ createPlutusScriptDatum
   :: Witnessable thing era
   -> Old.PlutusScriptVersion lang
   -> Old.ScriptDatum witctx
-  -> PlutusScriptDatum (Old.ToLedgerPlutusLanguage lang) SpendingScript
+  -> PlutusScriptDatum (Old.ToLedgerPlutusLanguage lang) (ThingToPurpose thing)
 createPlutusScriptDatum missingContext plutusVersion oldDatum =
   case (missingContext, oldDatum) of
     (w@WitTxIn{}, d@Old.ScriptDatumForTxIn{}) -> toPlutusScriptDatum w plutusVersion d
@@ -143,15 +146,15 @@ toPlutusScriptDatum WitTxIn{} Old.PlutusScriptV1 (Old.ScriptDatumForTxIn Nothing
 toPlutusScriptDatum WitTxIn{} Old.PlutusScriptV2 (Old.ScriptDatumForTxIn Nothing) = NoScriptDatum
 
 toNewPlutusScriptWitness
-  :: forall era lang purpose thing
+  :: forall era lang thing
    . L.PlutusLanguage (Old.ToLedgerPlutusLanguage lang)
   => AlonzoEraOnwards era
   -> Witnessable thing (ShelleyLedgerEra era)
   -> Old.PlutusScriptVersion lang
   -> Old.PlutusScriptOrReferenceInput lang
   -> ScriptRedeemer
   -> ExecutionUnits
-  -> PlutusScriptDatum (Old.ToLedgerPlutusLanguage lang) purpose
+  -> PlutusScriptDatum (Old.ToLedgerPlutusLanguage lang) (ThingToPurpose thing)
   -> Either
        CBOR.DecoderError
        ( AnyWitness
@@ -166,9 +169,8 @@ toNewPlutusScriptWitness eon w l (Old.PScript (Old.PlutusScriptSerialised script
       Left $
         CBOR.DecoderErrorCustom "PlutusLedgerApi.Common.ScriptDecodeError" (Text.pack . show $ pretty e)
     Right plutusScriptRunnable ->
-      return
-        . AnyPlutusScriptWitness
-        $ mkPlutusScriptWitness
+      return $
+        mkPlutusScriptWitness
           eon
           w
           (toPlutusSLanguage l)
@@ -180,16 +182,94 @@ toNewPlutusScriptWitness _ w l (Old.PReferenceScript refInput) scriptRedeemer ex
   return . AnyPlutusScriptWitness $
     mkReferencePlutusScriptWitness (toPlutusSLanguage l) refInput datum scriptRedeemer execUnits
 
+type family ThingToPurpose thing where
+  ThingToPurpose TxInItem = SpendingScript
+  ThingToPurpose CertItem = CertifyingScript
+  ThingToPurpose MintItem = MintingScript
+  ThingToPurpose WithdrawalItem = WithdrawingScript
+  ThingToPurpose VoterItem = VotingScript
+  ThingToPurpose ProposalItem = ProposingScript
+
 mkPlutusScriptWitness
-  :: AlonzoEraOnwards era
+  :: forall era thing plutuslang
+   . Typeable plutuslang
+  => AlonzoEraOnwards era
   -> Witnessable thing (ShelleyLedgerEra era)
   -> L.SLanguage plutuslang
   -> L.PlutusRunnable plutuslang
-  -> PlutusScriptDatum plutuslang purpose
+  -> PlutusScriptDatum plutuslang (ThingToPurpose thing)
   -> ScriptRedeemer
   -> ExecutionUnits
-  -> AnyPlutusScriptWitness plutuslang purpose (ShelleyLedgerEra era)
-mkPlutusScriptWitness _ w l plutusScriptRunnable d r e = undefined
+  -> AnyWitness (ShelleyLedgerEra era)
+mkPlutusScriptWitness eon w l plutusScriptRunnable d r e =
+  case w of
+    WitTxIn{} ->
+      let s
+            :: AlonzoEraOnwards era
+            -> L.SLanguage plutuslang
+            -> PlutusScriptWitness plutuslang SpendingScript (ShelleyLedgerEra era)
+          s _eon lang = PlutusScriptWitness lang (PScript $ PlutusScriptInEra plutusScriptRunnable) d r e
+       in AnyPlutusScriptWitness $
+            AnyPlutusSpendingScriptWitness $
+              case l of
+                L.SPlutusV1 ->
+                  PlutusSpendingScriptWitnessV1 (s eon l)
+                L.SPlutusV2 ->
+                  PlutusSpendingScriptWitnessV2 (s eon l)
+                L.SPlutusV3 ->
+                  PlutusSpendingScriptWitnessV3 (s eon l)
+                L.SPlutusV4 ->
+                  PlutusSpendingScriptWitnessV4 (s eon l)
+    WitTxCert{} ->
+      AnyPlutusScriptWitness $
+        AnyPlutusCertifyingScriptWitness
+          ( PlutusScriptWitness
+              l
+              (PScript $ PlutusScriptInEra plutusScriptRunnable)
+              d
+              r
+              e
+          )
+    WitMint{} ->
+      AnyPlutusScriptWitness $
+        AnyPlutusMintingScriptWitness
+          ( PlutusScriptWitness
+              l
+              (PScript $ PlutusScriptInEra plutusScriptRunnable)
+              d
+              r
+              e
+          )
+    WitWithdrawal{} ->
+      AnyPlutusScriptWitness $
+        AnyPlutusWithdrawingScriptWitness
+          ( PlutusScriptWitness
+              l
+              (PScript $ PlutusScriptInEra plutusScriptRunnable)
+              d
+              r
+              e
+          )
+    WitVote{} ->
+      AnyPlutusScriptWitness $
+        AnyPlutusVotingScriptWitness
+          ( PlutusScriptWitness
+              l
+              (PScript $ PlutusScriptInEra plutusScriptRunnable)
+              d
+              r
+              e
+          )
+    WitProposal{} ->
+      AnyPlutusScriptWitness $
+        AnyPlutusProposingScriptWitness
+          ( PlutusScriptWitness
+              l
+              (PScript $ PlutusScriptInEra plutusScriptRunnable)
+              d
+              r
+              e
+          )
 
 mkReferencePlutusScriptWitness
   :: L.SLanguage plutuslang