From 0624a53220ec932378e41df844e0ebc394628f71 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/cardano-api.cabal | 6 +++ .../Api/Class/HasScriptLanguageInEra.hs | 29 +++++++++++ .../Cardano/Api/Class/IsAllegraEraOnwards.hs | 24 +++++++++ .../Cardano/Api/Class/IsAlonzoEraOnwards.hs | 18 +++++++ .../Cardano/Api/Class/IsBabbageEraOnwards.hs | 15 ++++++ .../Cardano/Api/Class/IsMaryEraOnwards.hs | 21 ++++++++ .../Cardano/Api/Class/ToAlonzoScript.hs | 40 +++++++++++++++ .../Cardano/Api/Eon/AllegraEraOnwards.hs | 20 ++++++++ .../Cardano/Api/Eon/AlonzoEraOnwards.hs | 13 +++++ .../Cardano/Api/Eon/MaryEraOnwards.hs | 16 ++++++ cardano-api/internal/Cardano/Api/Script.hs | 51 +++++++++++++++++++ 11 files changed, 253 insertions(+) create mode 100644 cardano-api/internal/Cardano/Api/Class/HasScriptLanguageInEra.hs create mode 100644 cardano-api/internal/Cardano/Api/Class/IsAllegraEraOnwards.hs create mode 100644 cardano-api/internal/Cardano/Api/Class/IsAlonzoEraOnwards.hs create mode 100644 cardano-api/internal/Cardano/Api/Class/IsBabbageEraOnwards.hs create mode 100644 cardano-api/internal/Cardano/Api/Class/IsMaryEraOnwards.hs create mode 100644 cardano-api/internal/Cardano/Api/Class/ToAlonzoScript.hs diff --git a/cardano-api/cardano-api.cabal b/cardano-api/cardano-api.cabal index 2fbd3c7c4c..b864385b38 100644 --- a/cardano-api/cardano-api.cabal +++ b/cardano-api/cardano-api.cabal @@ -63,6 +63,12 @@ library internal Cardano.Api.Anchor Cardano.Api.Block Cardano.Api.Certificate + Cardano.Api.Class.HasScriptLanguageInEra + Cardano.Api.Class.IsAllegraEraOnwards + Cardano.Api.Class.IsAlonzoEraOnwards + Cardano.Api.Class.IsBabbageEraOnwards + Cardano.Api.Class.IsMaryEraOnwards + Cardano.Api.Class.ToAlonzoScript Cardano.Api.Convenience.Construction Cardano.Api.Convenience.Query Cardano.Api.DRepMetadata diff --git a/cardano-api/internal/Cardano/Api/Class/HasScriptLanguageInEra.hs b/cardano-api/internal/Cardano/Api/Class/HasScriptLanguageInEra.hs new file mode 100644 index 0000000000..1dd6311e7a --- /dev/null +++ b/cardano-api/internal/Cardano/Api/Class/HasScriptLanguageInEra.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE MultiParamTypeClasses #-} + +module Cardano.Api.Class.HasScriptLanguageInEra where + +import Cardano.Api.Eras (AlonzoEra, BabbageEra, ConwayEra) +import Cardano.Api.Script (PlutusScriptV1, PlutusScriptV2, PlutusScriptV3, ScriptLanguageInEra (..)) + +-- | 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 diff --git a/cardano-api/internal/Cardano/Api/Class/IsAllegraEraOnwards.hs b/cardano-api/internal/Cardano/Api/Class/IsAllegraEraOnwards.hs new file mode 100644 index 0000000000..e0ec7ee491 --- /dev/null +++ b/cardano-api/internal/Cardano/Api/Class/IsAllegraEraOnwards.hs @@ -0,0 +1,24 @@ +module Cardano.Api.Class.IsAllegraEraOnwards where + +import Cardano.Api.Eon.AllegraEraOnwards (AllegraEraOnwards (..)) +import Cardano.Api.Eras (AllegraEra, AlonzoEra, BabbageEra, ConwayEra, MaryEra) + +-- | Type class to produce 'AllegraEraOnwards' witness values while staying +-- parameterized by era. +class IsAllegraEraOnwards era where + allegraEraOnwards :: AllegraEraOnwards era + +instance IsAllegraEraOnwards AllegraEra where + allegraEraOnwards = AllegraEraOnwardsAllegra + +instance IsAllegraEraOnwards MaryEra where + allegraEraOnwards = AllegraEraOnwardsMary + +instance IsAllegraEraOnwards AlonzoEra where + allegraEraOnwards = AllegraEraOnwardsAlonzo + +instance IsAllegraEraOnwards BabbageEra where + allegraEraOnwards = AllegraEraOnwardsBabbage + +instance IsAllegraEraOnwards ConwayEra where + allegraEraOnwards = AllegraEraOnwardsConway diff --git a/cardano-api/internal/Cardano/Api/Class/IsAlonzoEraOnwards.hs b/cardano-api/internal/Cardano/Api/Class/IsAlonzoEraOnwards.hs new file mode 100644 index 0000000000..d13ddf2f2d --- /dev/null +++ b/cardano-api/internal/Cardano/Api/Class/IsAlonzoEraOnwards.hs @@ -0,0 +1,18 @@ +module Cardano.Api.Class.IsAlonzoEraOnwards where + +import Cardano.Api.Eon.AlonzoEraOnwards (AlonzoEraOnwards (..)) +import Cardano.Api.Eras (AlonzoEra, BabbageEra, ConwayEra) + +-- | Type class to produce 'AlonzoEraOnwards' witness values while staying +-- parameterized by era. +class IsAlonzoEraOnwards era where + alonzoEraOnwards :: AlonzoEraOnwards era + +instance IsAlonzoEraOnwards AlonzoEra where + alonzoEraOnwards = AlonzoEraOnwardsAlonzo + +instance IsAlonzoEraOnwards BabbageEra where + alonzoEraOnwards = AlonzoEraOnwardsBabbage + +instance IsAlonzoEraOnwards ConwayEra where + alonzoEraOnwards = AlonzoEraOnwardsConway diff --git a/cardano-api/internal/Cardano/Api/Class/IsBabbageEraOnwards.hs b/cardano-api/internal/Cardano/Api/Class/IsBabbageEraOnwards.hs new file mode 100644 index 0000000000..91f754be89 --- /dev/null +++ b/cardano-api/internal/Cardano/Api/Class/IsBabbageEraOnwards.hs @@ -0,0 +1,15 @@ +module Cardano.Api.Class.IsBabbageEraOnwards where + +import Cardano.Api.Eon.BabbageEraOnwards (BabbageEraOnwards (..)) +import Cardano.Api.Eras (BabbageEra, ConwayEra) + +-- | Type class to produce 'BabbageEraOnwards' witness values while staying +-- parameterized by era. +class IsBabbageEraOnwards era where + babbageEraOnwards :: BabbageEraOnwards era + +instance IsBabbageEraOnwards BabbageEra where + babbageEraOnwards = BabbageEraOnwardsBabbage + +instance IsBabbageEraOnwards ConwayEra where + babbageEraOnwards = BabbageEraOnwardsConway diff --git a/cardano-api/internal/Cardano/Api/Class/IsMaryEraOnwards.hs b/cardano-api/internal/Cardano/Api/Class/IsMaryEraOnwards.hs new file mode 100644 index 0000000000..8c5e1ff408 --- /dev/null +++ b/cardano-api/internal/Cardano/Api/Class/IsMaryEraOnwards.hs @@ -0,0 +1,21 @@ +module Cardano.Api.Class.IsMaryEraOnwards where + +import Cardano.Api.Eon.MaryEraOnwards (MaryEraOnwards (..)) +import Cardano.Api.Eras (AlonzoEra, BabbageEra, ConwayEra, MaryEra) + +-- | Type class to produce 'MaryEraOnwards' witness values while staying +-- parameterized by era. +class IsMaryEraOnwards era where + maryEraOnwards :: MaryEraOnwards era + +instance IsMaryEraOnwards MaryEra where + maryEraOnwards = MaryEraOnwardsMary + +instance IsMaryEraOnwards AlonzoEra where + maryEraOnwards = MaryEraOnwardsAlonzo + +instance IsMaryEraOnwards BabbageEra where + maryEraOnwards = MaryEraOnwardsBabbage + +instance IsMaryEraOnwards ConwayEra where + maryEraOnwards = MaryEraOnwardsConway diff --git a/cardano-api/internal/Cardano/Api/Class/ToAlonzoScript.hs b/cardano-api/internal/Cardano/Api/Class/ToAlonzoScript.hs new file mode 100644 index 0000000000..177fb0de9a --- /dev/null +++ b/cardano-api/internal/Cardano/Api/Class/ToAlonzoScript.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE MultiParamTypeClasses #-} + +module Cardano.Api.Class.ToAlonzoScript where + +import Cardano.Api.Eon.ShelleyBasedEra (ShelleyLedgerEra) +import Cardano.Api.Eras (BabbageEra, ConwayEra) +import Cardano.Api.Script as Script + ( PlutusScript (..) + , PlutusScriptV1 + , PlutusScriptV2 + , PlutusScriptV3 + ) +import Cardano.Ledger.Alonzo.Scripts (AlonzoScript (..)) +import Cardano.Ledger.Conway.Scripts (PlutusScript (..)) +import Cardano.Ledger.Plutus.Language (Plutus (..), PlutusBinary (..)) + +class ToAlonzoScript lang era where + toLedgerScript + :: Script.PlutusScript lang + -> AlonzoScript (ShelleyLedgerEra era) + +instance ToAlonzoScript PlutusScriptV1 BabbageEra where + toLedgerScript (PlutusScriptSerialised bytes) = + PlutusScript $ BabbagePlutusV1 $ Plutus $ PlutusBinary bytes + +instance ToAlonzoScript PlutusScriptV2 BabbageEra where + toLedgerScript (PlutusScriptSerialised bytes) = + PlutusScript $ BabbagePlutusV2 $ Plutus $ PlutusBinary bytes + +instance ToAlonzoScript PlutusScriptV1 ConwayEra where + toLedgerScript (PlutusScriptSerialised bytes) = + PlutusScript $ ConwayPlutusV1 $ Plutus $ PlutusBinary bytes + +instance ToAlonzoScript PlutusScriptV2 ConwayEra where + toLedgerScript (PlutusScriptSerialised bytes) = + PlutusScript $ ConwayPlutusV2 $ Plutus $ PlutusBinary bytes + +instance ToAlonzoScript PlutusScriptV3 ConwayEra where + toLedgerScript (PlutusScriptSerialised bytes) = + PlutusScript $ ConwayPlutusV3 $ Plutus $ PlutusBinary bytes diff --git a/cardano-api/internal/Cardano/Api/Eon/AllegraEraOnwards.hs b/cardano-api/internal/Cardano/Api/Eon/AllegraEraOnwards.hs index ddd7870e06..2a6fe44a5d 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 @@ -107,3 +108,22 @@ 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 bd67019114..9006e5ee0c 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 @@ -115,3 +116,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/MaryEraOnwards.hs b/cardano-api/internal/Cardano/Api/Eon/MaryEraOnwards.hs index b79a5e36ed..bea9d6c8ef 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 @@ -107,3 +108,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 93768dbfc4..b82763b4a4 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 (..) @@ -1019,6 +1022,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