From 49d47fa8ffb2aec8f31d85958149440e1d82c2a2 Mon Sep 17 00:00:00 2001 From: Daniel Firth Date: Thu, 16 May 2024 18:41:22 +0000 Subject: [PATCH] Add Classy versions of Era witness functions --- .../Cardano/Api/Eon/AllegraEraOnwards.hs | 19 +++++++ .../Cardano/Api/Eon/AlonzoEraOnwards.hs | 13 +++++ .../Cardano/Api/Eon/BabbageEraOnwards.hs | 10 ++++ .../Cardano/Api/Eon/ConwayEraOnwards.hs | 7 +++ .../Cardano/Api/Eon/MaryEraOnwards.hs | 16 ++++++ cardano-api/internal/Cardano/Api/Script.hs | 51 +++++++++++++++++++ cardano-api/src/Cardano/Api.hs | 7 +++ 7 files changed, 123 insertions(+) diff --git a/cardano-api/internal/Cardano/Api/Eon/AllegraEraOnwards.hs b/cardano-api/internal/Cardano/Api/Eon/AllegraEraOnwards.hs index aae2dd17b0..e7adbc0979 100644 --- a/cardano-api/internal/Cardano/Api/Eon/AllegraEraOnwards.hs +++ b/cardano-api/internal/Cardano/Api/Eon/AllegraEraOnwards.hs @@ -13,6 +13,7 @@ module Cardano.Api.Eon.AllegraEraOnwards , allegraEraOnwardsConstraints , allegraEraOnwardsToShelleyBasedEra , AllegraEraOnwardsConstraints + , IsAllegraBasedEra (..) ) where @@ -109,3 +110,21 @@ allegraEraOnwardsToShelleyBasedEra = \case AllegraEraOnwardsAlonzo -> ShelleyBasedEraAlonzo AllegraEraOnwardsBabbage -> ShelleyBasedEraBabbage AllegraEraOnwardsConway -> ShelleyBasedEraConway + +class IsAllegraBasedEra era where + allegraBasedEra :: AllegraEraOnwards era + +instance IsAllegraBasedEra AllegraEra where + allegraBasedEra = AllegraEraOnwardsAllegra + +instance IsAllegraBasedEra MaryEra where + allegraBasedEra = AllegraEraOnwardsMary + +instance IsAllegraBasedEra AlonzoEra where + allegraBasedEra = AllegraEraOnwardsAlonzo + +instance IsAllegraBasedEra BabbageEra where + allegraBasedEra = AllegraEraOnwardsBabbage + +instance IsAllegraBasedEra ConwayEra where + allegraBasedEra = AllegraEraOnwardsConway diff --git a/cardano-api/internal/Cardano/Api/Eon/AlonzoEraOnwards.hs b/cardano-api/internal/Cardano/Api/Eon/AlonzoEraOnwards.hs index 2a581029c3..150f9a6ca2 100644 --- a/cardano-api/internal/Cardano/Api/Eon/AlonzoEraOnwards.hs +++ b/cardano-api/internal/Cardano/Api/Eon/AlonzoEraOnwards.hs @@ -13,6 +13,7 @@ module Cardano.Api.Eon.AlonzoEraOnwards , alonzoEraOnwardsConstraints , alonzoEraOnwardsToShelleyBasedEra , AlonzoEraOnwardsConstraints + , IsAlonzoBasedEra (..) ) where @@ -117,3 +118,15 @@ alonzoEraOnwardsToShelleyBasedEra = \case AlonzoEraOnwardsAlonzo -> ShelleyBasedEraAlonzo AlonzoEraOnwardsBabbage -> ShelleyBasedEraBabbage AlonzoEraOnwardsConway -> ShelleyBasedEraConway + +class IsAlonzoBasedEra era where + alonzoBasedEra :: AlonzoEraOnwards era + +instance IsAlonzoBasedEra AlonzoEra where + alonzoBasedEra = AlonzoEraOnwardsAlonzo + +instance IsAlonzoBasedEra BabbageEra where + alonzoBasedEra = AlonzoEraOnwardsBabbage + +instance IsAlonzoBasedEra ConwayEra where + alonzoBasedEra = AlonzoEraOnwardsConway diff --git a/cardano-api/internal/Cardano/Api/Eon/BabbageEraOnwards.hs b/cardano-api/internal/Cardano/Api/Eon/BabbageEraOnwards.hs index cba37e9434..979e144f18 100644 --- a/cardano-api/internal/Cardano/Api/Eon/BabbageEraOnwards.hs +++ b/cardano-api/internal/Cardano/Api/Eon/BabbageEraOnwards.hs @@ -13,6 +13,7 @@ module Cardano.Api.Eon.BabbageEraOnwards , babbageEraOnwardsConstraints , babbageEraOnwardsToShelleyBasedEra , BabbageEraOnwardsConstraints + , IsBabbageBasedEra (..) ) where @@ -111,3 +112,12 @@ babbageEraOnwardsToShelleyBasedEra :: BabbageEraOnwards era -> ShelleyBasedEra e babbageEraOnwardsToShelleyBasedEra = \case BabbageEraOnwardsBabbage -> ShelleyBasedEraBabbage BabbageEraOnwardsConway -> ShelleyBasedEraConway + +class IsBabbageBasedEra era where + babbageBasedEra :: BabbageEraOnwards era + +instance IsBabbageBasedEra BabbageEra where + babbageBasedEra = BabbageEraOnwardsBabbage + +instance IsBabbageBasedEra ConwayEra where + babbageBasedEra = BabbageEraOnwardsConway diff --git a/cardano-api/internal/Cardano/Api/Eon/ConwayEraOnwards.hs b/cardano-api/internal/Cardano/Api/Eon/ConwayEraOnwards.hs index 6bf52ce3bd..06fa98fc0a 100644 --- a/cardano-api/internal/Cardano/Api/Eon/ConwayEraOnwards.hs +++ b/cardano-api/internal/Cardano/Api/Eon/ConwayEraOnwards.hs @@ -13,6 +13,7 @@ module Cardano.Api.Eon.ConwayEraOnwards , conwayEraOnwardsConstraints , conwayEraOnwardsToShelleyBasedEra , ConwayEraOnwardsConstraints + , IsConwayBasedEra (..) ) where @@ -112,3 +113,9 @@ conwayEraOnwardsConstraints = \case conwayEraOnwardsToShelleyBasedEra :: ConwayEraOnwards era -> ShelleyBasedEra era conwayEraOnwardsToShelleyBasedEra = \case ConwayEraOnwardsConway -> ShelleyBasedEraConway + +class IsConwayBasedEra era where + conwayBasedEra :: ConwayEraOnwards era + +instance IsConwayBasedEra ConwayEra where + conwayBasedEra = ConwayEraOnwardsConway diff --git a/cardano-api/internal/Cardano/Api/Eon/MaryEraOnwards.hs b/cardano-api/internal/Cardano/Api/Eon/MaryEraOnwards.hs index 2fe9d2ea0a..3f59847306 100644 --- a/cardano-api/internal/Cardano/Api/Eon/MaryEraOnwards.hs +++ b/cardano-api/internal/Cardano/Api/Eon/MaryEraOnwards.hs @@ -13,6 +13,7 @@ module Cardano.Api.Eon.MaryEraOnwards , maryEraOnwardsConstraints , maryEraOnwardsToShelleyBasedEra , MaryEraOnwardsConstraints + , IsMaryBasedEra (..) ) where @@ -109,3 +110,18 @@ maryEraOnwardsToShelleyBasedEra = \case MaryEraOnwardsAlonzo -> ShelleyBasedEraAlonzo MaryEraOnwardsBabbage -> ShelleyBasedEraBabbage MaryEraOnwardsConway -> ShelleyBasedEraConway + +class IsMaryBasedEra era where + maryBasedEra :: MaryEraOnwards era + +instance IsMaryBasedEra MaryEra where + maryBasedEra = MaryEraOnwardsMary + +instance IsMaryBasedEra AlonzoEra where + maryBasedEra = MaryEraOnwardsAlonzo + +instance IsMaryBasedEra BabbageEra where + maryBasedEra = MaryEraOnwardsBabbage + +instance IsMaryBasedEra ConwayEra where + maryBasedEra = MaryEraOnwardsConway diff --git a/cardano-api/internal/Cardano/Api/Script.hs b/cardano-api/internal/Cardano/Api/Script.hs index f909b89ebd..a8e21f2927 100644 --- a/cardano-api/internal/Cardano/Api/Script.hs +++ b/cardano-api/internal/Cardano/Api/Script.hs @@ -4,6 +4,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} @@ -40,6 +41,8 @@ module Cardano.Api.Script , ScriptInEra (..) , toScriptInEra , eraOfScriptInEra + , HasScriptLanguageInEra (..) + , ToAlonzoScript (..) -- * Reference scripts , ReferenceScript (..) @@ -1021,6 +1024,54 @@ instance IsPlutusScriptLanguage lang => HasTextEnvelope (PlutusScript lang) wher PlutusScriptV2 -> "PlutusScriptV2" PlutusScriptV3 -> "PlutusScriptV3" +-- | Smart-constructor for 'ScriptLanguageInEra' to write functions +-- manipulating scripts that do not commit to a particular era. +class HasScriptLanguageInEra lang era where + scriptLanguageInEra :: ScriptLanguageInEra lang era + +instance HasScriptLanguageInEra PlutusScriptV1 AlonzoEra where + scriptLanguageInEra = PlutusScriptV1InAlonzo + +instance HasScriptLanguageInEra PlutusScriptV1 BabbageEra where + scriptLanguageInEra = PlutusScriptV1InBabbage + +instance HasScriptLanguageInEra PlutusScriptV2 BabbageEra where + scriptLanguageInEra = PlutusScriptV2InBabbage + +instance HasScriptLanguageInEra PlutusScriptV1 ConwayEra where + scriptLanguageInEra = PlutusScriptV1InConway + +instance HasScriptLanguageInEra PlutusScriptV2 ConwayEra where + scriptLanguageInEra = PlutusScriptV2InConway + +instance HasScriptLanguageInEra PlutusScriptV3 ConwayEra where + scriptLanguageInEra = PlutusScriptV3InConway + +class ToAlonzoScript lang era where + toLedgerScript + :: PlutusScript lang + -> Conway.AlonzoScript (ShelleyLedgerEra era) + +instance ToAlonzoScript PlutusScriptV1 BabbageEra where + toLedgerScript (PlutusScriptSerialised bytes) = + Conway.PlutusScript $ Conway.BabbagePlutusV1 $ Plutus.Plutus $ Plutus.PlutusBinary bytes + +instance ToAlonzoScript PlutusScriptV2 BabbageEra where + toLedgerScript (PlutusScriptSerialised bytes) = + Conway.PlutusScript $ Conway.BabbagePlutusV2 $ Plutus.Plutus $ Plutus.PlutusBinary bytes + +instance ToAlonzoScript PlutusScriptV1 ConwayEra where + toLedgerScript (PlutusScriptSerialised bytes) = + Conway.PlutusScript $ Conway.ConwayPlutusV1 $ Plutus.Plutus $ Plutus.PlutusBinary bytes + +instance ToAlonzoScript PlutusScriptV2 ConwayEra where + toLedgerScript (PlutusScriptSerialised bytes) = + Conway.PlutusScript $ Conway.ConwayPlutusV2 $ Plutus.Plutus $ Plutus.PlutusBinary bytes + +instance ToAlonzoScript PlutusScriptV3 ConwayEra where + toLedgerScript (PlutusScriptSerialised bytes) = + Conway.PlutusScript $ Conway.ConwayPlutusV3 $ Plutus.Plutus $ Plutus.PlutusBinary bytes + -- | An example Plutus script that always succeeds, irrespective of inputs. -- -- For example, if one were to use this for a payment address then it would diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index 0a7b772ada..510c14bf0d 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -79,26 +79,31 @@ module Cardano.Api -- ** From Allegra , AllegraEraOnwards (..) + , IsAllegraBasedEra (..) -- ** From Mary , MaryEraOnwards (..) , maryEraOnwardsConstraints , maryEraOnwardsToShelleyBasedEra + , IsMaryBasedEra (..) -- ** From Alonzo , AlonzoEraOnwards (..) , alonzoEraOnwardsConstraints , alonzoEraOnwardsToShelleyBasedEra + , IsAlonzoBasedEra (..) -- ** From Babbage , BabbageEraOnwards (..) , babbageEraOnwardsConstraints , babbageEraOnwardsToShelleyBasedEra + , IsBabbageBasedEra (..) -- ** From Conway , ConwayEraOnwards (..) , conwayEraOnwardsConstraints , conwayEraOnwardsToShelleyBasedEra + , IsConwayBasedEra (..) -- * Era case handling @@ -501,6 +506,8 @@ module Cardano.Api , ScriptInEra (..) , toScriptInEra , eraOfScriptInEra + , HasScriptLanguageInEra (..) + , ToAlonzoScript (..) -- ** Use of a script in an era as a witness , WitCtxTxIn