From f87b4fa70f39b18609d40e909945a55ebc3ac1b8 Mon Sep 17 00:00:00 2001 From: Las Safin Date: Mon, 17 Jan 2022 22:59:18 +0000 Subject: [PATCH] Rework PLift, add type role to Term, and remove bogus derivations --- Plutarch/Api/V1.hs | 108 ++++++++++++++++++++++++----------------- Plutarch/Bool.hs | 7 +-- Plutarch/Builtin.hs | 47 +++++++++++------- Plutarch/ByteString.hs | 7 ++- Plutarch/DataRepr.hs | 14 ++---- Plutarch/Integer.hs | 7 ++- Plutarch/Internal.hs | 4 ++ Plutarch/Lift.hs | 87 +++++++++++++++++---------------- Plutarch/String.hs | 7 ++- Plutarch/Unit.hs | 6 ++- examples/Main.hs | 26 +++++----- 11 files changed, 182 insertions(+), 138 deletions(-) diff --git a/Plutarch/Api/V1.hs b/Plutarch/Api/V1.hs index 0b2738d01..22efb32b3 100644 --- a/Plutarch/Api/V1.hs +++ b/Plutarch/Api/V1.hs @@ -1,4 +1,5 @@ {-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} module Plutarch.Api.V1 ( -- * V1 Specific types @@ -60,7 +61,7 @@ module Plutarch.Api.V1 ( -------------------------------------------------------------------------------- import Plutarch (PMatch) -import Plutarch.Bool (PBool, PEq, POrd) +import Plutarch.Bool (PBool) import Plutarch.Builtin (PAsData, PBuiltinList, PData, PIsData, type PBuiltinMap) import Plutarch.ByteString (PByteString) import Plutarch.DataRepr ( @@ -73,12 +74,12 @@ import Plutarch.DataRepr ( pmatchRepr, ) import Plutarch.Integer (PInteger, PIntegral) -import Plutarch.Lift (PLifted, PUnsafeLiftDecl) +import Plutarch.Lift (DerivePConstantViaData (DerivePConstantViaData), DerivePConstantViaNewtype (DerivePConstantViaNewtype), PConstant, PLifted, PUnsafeLiftDecl) -- ctor in-scope for deriving import Plutarch.Prelude import qualified Plutus.V1.Ledger.Api as Plutus -import qualified PlutusTx.Prelude as PlutusTx +import qualified PlutusTx.Builtins.Internal as PT -------------------------------------------------------------------------------- @@ -105,8 +106,11 @@ newtype PTxInfo (s :: S) ) ) deriving - (PMatch, PIsData, PUnsafeLiftDecl Plutus.TxInfo) - via PIsDataReprInstances PTxInfo Plutus.TxInfo + (PMatch, PIsData) + via PIsDataReprInstances PTxInfo + +instance PUnsafeLiftDecl PTxInfo where type PLifted PTxInfo = Plutus.TxInfo +deriving via (DerivePConstantViaData Plutus.TxInfo PTxInfo) instance (PConstant Plutus.TxInfo) instance PIsDataRepr PTxInfo where type @@ -129,8 +133,11 @@ instance PIsDataRepr PTxInfo where newtype PScriptContext (s :: S) = PScriptContext (Term s (PDataList '[PTxInfo, PScriptPurpose])) deriving - (PMatch, PIsData, PUnsafeLiftDecl Plutus.ScriptContext) - via PIsDataReprInstances PScriptContext Plutus.ScriptContext + (PMatch, PIsData) + via PIsDataReprInstances PScriptContext + +instance PUnsafeLiftDecl PScriptContext where type PLifted PScriptContext = Plutus.ScriptContext +deriving via (DerivePConstantViaData Plutus.ScriptContext PScriptContext) instance (PConstant Plutus.ScriptContext) instance PIsDataRepr PScriptContext where type @@ -150,8 +157,11 @@ data PScriptPurpose (s :: S) | PRewarding (Term s (PDataList '[PStakingCredential])) | PCertifying (Term s (PDataList '[PDCert])) deriving - (PMatch, PIsData, PUnsafeLiftDecl Plutus.ScriptPurpose) - via (PIsDataReprInstances PScriptPurpose Plutus.ScriptPurpose) + (PMatch, PIsData) + via (PIsDataReprInstances PScriptPurpose) + +instance PUnsafeLiftDecl PScriptPurpose where type PLifted PScriptPurpose = Plutus.ScriptPurpose +deriving via (DerivePConstantViaData Plutus.ScriptPurpose PScriptPurpose) instance (PConstant Plutus.ScriptPurpose) instance PIsDataRepr PScriptPurpose where type @@ -174,61 +184,59 @@ instance PIsDataRepr PScriptPurpose where ---------- Scripts newtype PDatum (s :: S) = PDatum (Term s PData) - deriving (PIsData, PEq) via PData newtype PRedeemer (s :: S) = PRedeemer (Term s PData) - deriving (PIsData, PEq) via PData newtype PDatumHash (s :: S) = PDatumHash (Term s PByteString) - deriving (PEq, POrd, PIsData) via PByteString newtype PStakeValidatorHash (s :: S) = PStakeValidatorHash (Term s PByteString) - deriving (PEq, POrd, PIsData) via PByteString newtype PRedeemerHash (s :: S) = PRedeemerHash (Term s PByteString) - deriving (PEq, POrd, PIsData) via PByteString newtype PValidatorHash (s :: S) = PValidatorHash (Term s PByteString) - deriving (PEq, POrd, PIsData) via PByteString ---------- Value newtype PTokenName (s :: S) = PTokenName (Term s PByteString) - deriving (PEq, POrd, PIsData) via (PByteString) deriving newtype (Semigroup, Monoid) +instance PUnsafeLiftDecl PTokenName where type PLifted PTokenName = Plutus.TokenName +deriving via + (DerivePConstantViaNewtype Plutus.TokenName PTokenName PByteString) + instance + (PConstant Plutus.TokenName) newtype PValue (s :: S) = PValue (Term s (PMap PCurrencySymbol (PMap PTokenName PInteger))) - deriving (PIsData) via (PMap PCurrencySymbol (PMap PTokenName PInteger)) newtype PCurrencySymbol (s :: S) = PCurrencySymbol (Term s PByteString) - deriving (PEq, POrd, PIsData) via PByteString +instance PUnsafeLiftDecl PCurrencySymbol where type PLifted PCurrencySymbol = Plutus.CurrencySymbol +deriving via + (DerivePConstantViaNewtype Plutus.CurrencySymbol PCurrencySymbol PByteString) + instance + (PConstant Plutus.CurrencySymbol) ---------- Crypto newtype PPubKeyHash (s :: S) = PPubKeyHash (Term s PByteString) - deriving (PEq, POrd, PIsData) via PByteString newtype PPubKey (s :: S) = PPubKey (Term s PByteString) - deriving (PEq, POrd, PIsData) via PByteString newtype PSignature (s :: S) = PSignature (Term s PByteString) - deriving (PEq, POrd, PIsData) via PByteString ---------- Time newtype PPOSIXTime (s :: S) = PPOSIXTime (Term s PInteger) - deriving (POrd, PEq, PIntegral, PIsData) via (PInteger) + deriving (PIntegral) via (PInteger) deriving newtype (Num) type PPOSIXTimeRange = PInterval PPOSIXTime @@ -253,7 +261,6 @@ newtype PInterval a (s :: S) ) via PIsDataReprInstances (PInterval a) - (Plutus.Interval (PLifted a)) instance PIsDataRepr (PInterval a) where type @@ -275,7 +282,6 @@ newtype PLowerBound a (s :: S) ) via ( PIsDataReprInstances (PLowerBound a) - (Plutus.LowerBound (PLifted a)) ) instance PIsDataRepr (PLowerBound a) where @@ -298,7 +304,6 @@ newtype PUpperBound a (s :: S) ) via ( PIsDataReprInstances (PUpperBound a) - (Plutus.UpperBound (PLifted a)) ) instance PIsDataRepr (PUpperBound a) where @@ -322,7 +327,6 @@ data PExtended a (s :: S) ) via ( PIsDataReprInstances (PExtended a) - (Plutus.Extended (PLifted a)) ) instance PIsDataRepr (PExtended a) where @@ -339,8 +343,11 @@ data PCredential (s :: S) = PPubKeyCredential (Term s (PDataList '[PPubKeyHash])) | PScriptCredential (Term s (PDataList '[PValidatorHash])) deriving - (PMatch, PIsData, PUnsafeLiftDecl Plutus.Credential) - via (PIsDataReprInstances PCredential Plutus.Credential) + (PMatch, PIsData) + via (PIsDataReprInstances PCredential) + +instance PUnsafeLiftDecl PDatum where type PLifted PDatum = Plutus.Datum +deriving via (DerivePConstantViaData Plutus.Datum PDatum) instance (PConstant Plutus.Datum) instance PIsDataRepr PCredential where type @@ -362,9 +369,8 @@ data PStakingCredential (s :: S) deriving ( PMatch , PIsData - , PUnsafeLiftDecl Plutus.StakingCredential ) - via PIsDataReprInstances PStakingCredential Plutus.StakingCredential + via PIsDataReprInstances PStakingCredential instance PIsDataRepr PStakingCredential where type @@ -388,8 +394,11 @@ newtype PAddress (s :: S) ) ) deriving - (PMatch, PIsData, PUnsafeLiftDecl Plutus.Address) - via PIsDataReprInstances PAddress Plutus.Address + (PMatch, PIsData) + via PIsDataReprInstances PAddress + +instance PUnsafeLiftDecl PRedeemer where type PLifted PRedeemer = Plutus.Redeemer +deriving via (DerivePConstantViaData Plutus.Redeemer PRedeemer) instance (PConstant Plutus.Redeemer) instance PIsDataRepr PAddress where type @@ -408,8 +417,11 @@ instance PIsDataRepr PAddress where newtype PTxId (s :: S) = PTxId (Term s (PDataList '[PByteString])) deriving - (PMatch, PIsData, PUnsafeLiftDecl Plutus.TxId) - via PIsDataReprInstances PTxId Plutus.TxId + (PMatch, PIsData) + via PIsDataReprInstances PTxId + +instance PUnsafeLiftDecl PDatumHash where type PLifted PDatumHash = Plutus.DatumHash +deriving via (DerivePConstantViaData Plutus.DatumHash PDatumHash) instance (PConstant Plutus.DatumHash) instance PIsDataRepr PTxId where type PIsDataReprRepr PTxId = '[ '[PByteString]] @@ -421,8 +433,11 @@ instance PIsDataRepr PTxId where newtype PTxOutRef (s :: S) = PTxOutRef (Term s (PDataList '[PTxId, PInteger])) deriving - (PMatch, PIsData, PUnsafeLiftDecl Plutus.TxOutRef) - via PIsDataReprInstances PTxOutRef Plutus.TxOutRef + (PMatch, PIsData) + via PIsDataReprInstances PTxOutRef + +instance PUnsafeLiftDecl PStakeValidatorHash where type PLifted PStakeValidatorHash = Plutus.StakeValidatorHash +deriving via (DerivePConstantViaData Plutus.StakeValidatorHash PStakeValidatorHash) instance (PConstant Plutus.StakeValidatorHash) instance PIsDataRepr PTxOutRef where type PIsDataReprRepr PTxOutRef = '[ '[PTxId, PInteger]] @@ -434,8 +449,11 @@ instance PIsDataRepr PTxOutRef where newtype PTxInInfo (s :: S) = PTxInInfo (Term s (PDataList '[PTxOutRef, PTxOut])) deriving - (PMatch, PIsData, PUnsafeLiftDecl Plutus.TxInfo) - via PIsDataReprInstances PTxInInfo Plutus.TxInfo + (PMatch, PIsData) + via PIsDataReprInstances PTxInInfo + +instance PUnsafeLiftDecl PRedeemerHash where type PLifted PRedeemerHash = Plutus.RedeemerHash +deriving via (DerivePConstantViaData Plutus.RedeemerHash PRedeemerHash) instance (PConstant Plutus.RedeemerHash) instance PIsDataRepr PTxInInfo where type PIsDataReprRepr PTxInInfo = '[ '[PTxOutRef, PTxOut]] @@ -456,8 +474,11 @@ newtype PTxOut (s :: S) ) ) deriving - (PMatch, PIsData, PUnsafeLiftDecl Plutus.TxOut) - via (PIsDataReprInstances PTxOut Plutus.TxOut) + (PMatch, PIsData) + via (PIsDataReprInstances PTxOut) + +instance PUnsafeLiftDecl PValidatorHash where type PLifted PValidatorHash = Plutus.ValidatorHash +deriving via (DerivePConstantViaData Plutus.ValidatorHash PValidatorHash) instance (PConstant Plutus.ValidatorHash) instance PIsDataRepr PTxOut where type @@ -481,8 +502,8 @@ data PDCert (s :: S) | PDCertGenesis (Term s (PDataList '[])) | PDCertMir (Term s (PDataList '[])) deriving - (PMatch, PIsData, PUnsafeLiftDecl Plutus.DCert) - via (PIsDataReprInstances PDCert Plutus.DCert) + (PMatch, PIsData) + via (PIsDataReprInstances PDCert) instance PIsDataRepr PDCert where type @@ -510,7 +531,6 @@ instance PIsDataRepr PDCert where newtype PMap (a :: PType) (b :: PType) (s :: S) = PMap (Term s (PBuiltinMap a b)) - deriving (PIsData) via (PBuiltinMap a b) ---------- Others @@ -521,7 +541,6 @@ data PMaybe a (s :: S) (PMatch, PIsData) via PIsDataReprInstances (PMaybe a) - (PlutusTx.Maybe (PLifted a)) instance PIsDataRepr (PMaybe a) where type PIsDataReprRepr (PMaybe a) = '[ '[], '[a]] @@ -540,7 +559,6 @@ data PEither a b (s :: S) ) via PIsDataReprInstances (PEither a b) - (PlutusTx.Either (PLifted a) (PLifted b)) instance PIsDataRepr (PEither a b) where type diff --git a/Plutarch/Bool.hs b/Plutarch/Bool.hs index 5488e5425..0d83d1a84 100644 --- a/Plutarch/Bool.hs +++ b/Plutarch/Bool.hs @@ -1,4 +1,5 @@ {-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} module Plutarch.Bool ( PBool (..), @@ -16,15 +17,15 @@ module Plutarch.Bool ( ) where import Plutarch (PlutusType (PInner, pcon', pmatch'), punsafeBuiltin) -import Plutarch.Lift (DerivePConstant, DerivePLiftViaCoercible, PConstant, PConstanted, PLifted, PLiftedRepr, PUnsafeLiftDecl, pconstant, pliftFromRepr, pliftToRepr) +import Plutarch.Lift (DerivePConstantViaCoercible (DerivePConstantViaCoercible), PConstant, PLifted, PUnsafeLiftDecl, pconstant) import Plutarch.Prelude import qualified PlutusCore as PLC -- | Plutus 'BuiltinBool' data PBool (s :: S) = PTrue | PFalse - deriving (PUnsafeLiftDecl) via (DerivePLiftViaCoercible Bool PBool Bool) -deriving via (DerivePConstant Bool) PBool instance (PConstant Bool) +instance PUnsafeLiftDecl PBool where type PLifted PBool = Bool +deriving via (DerivePConstantViaCoercible Bool PBool Bool) instance (PConstant Bool) instance PlutusType PBool where type PInner PBool _ = PBool diff --git a/Plutarch/Builtin.hs b/Plutarch/Builtin.hs index 36673926d..e9f112e69 100644 --- a/Plutarch/Builtin.hs +++ b/Plutarch/Builtin.hs @@ -1,6 +1,7 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} -- This should have been called Plutarch.Data... module Plutarch.Builtin ( @@ -26,7 +27,7 @@ import Plutarch (PlutusType (..), punsafeBuiltin, punsafeCoerce) import Plutarch.Bool (PBool (..), PEq, (#==)) import Plutarch.ByteString (PByteString) import Plutarch.Integer (PInteger) -import Plutarch.Lift (DerivePLiftViaCoercible, PLift, PLifted, PLiftedRepr, PUnsafeLiftDecl, pconstant, pliftFromRepr, pliftToRepr) +import Plutarch.Lift (DerivePConstantViaCoercible (DerivePConstantViaCoercible), PConstant, PConstantRepr, PConstanted, PLift, PLifted, PUnsafeLiftDecl, pconstant, pconstantFromRepr, pconstantToRepr) import Plutarch.List (PListLike (..), plistEquals) import Plutarch.Prelude import qualified PlutusCore as PLC @@ -35,14 +36,17 @@ import PlutusTx (Data) -- | Plutus 'BuiltinPair' data PBuiltinPair (a :: PType) (b :: PType) (s :: S) --- FIXME: figure out good way of deriving this -instance (PUnsafeLiftDecl ah a, PUnsafeLiftDecl bh b) => PUnsafeLiftDecl (ah, bh) (PBuiltinPair a b) where - type PLiftedRepr (PBuiltinPair a b) = (PLiftedRepr a, PLiftedRepr b) +instance (PLift a, PLift b) => PUnsafeLiftDecl (PBuiltinPair a b) where type PLifted (PBuiltinPair a b) = (PLifted a, PLifted b) - pliftToRepr (x, y) = (pliftToRepr @_ @a x, pliftToRepr @_ @b y) - pliftFromRepr (x, y) = do - x' <- pliftFromRepr @_ @a x - y' <- pliftFromRepr @_ @b y + +-- FIXME: figure out good way of deriving this +instance (PConstant a, PConstant b) => PConstant (a, b) where + type PConstantRepr (a, b) = (PConstantRepr a, PConstantRepr b) + type PConstanted (a, b) = PBuiltinPair (PConstanted a) (PConstanted b) + pconstantToRepr (x, y) = (pconstantToRepr x, pconstantToRepr y) + pconstantFromRepr (x, y) = do + x' <- pconstantFromRepr @a x + y' <- pconstantFromRepr @b y Just (x', y') pfstBuiltin :: Term s (PBuiltinPair a b :--> a) @@ -78,11 +82,14 @@ pnullBuiltin = phoistAcyclic $ pforce $ punsafeBuiltin PLC.NullList pconsBuiltin :: Term s (a :--> PBuiltinList a :--> PBuiltinList a) pconsBuiltin = phoistAcyclic $ pforce $ punsafeBuiltin PLC.MkCons -instance PUnsafeLiftDecl ah a => PUnsafeLiftDecl [ah] (PBuiltinList a) where +instance PConstant a => PConstant [a] where + type PConstantRepr [a] = [PConstantRepr a] + type PConstanted [a] = PBuiltinList (PConstanted a) + pconstantToRepr x = pconstantToRepr <$> x + pconstantFromRepr x = traverse (pconstantFromRepr @a) x + +instance PUnsafeLiftDecl a => PUnsafeLiftDecl (PBuiltinList a) where type PLifted (PBuiltinList a) = [PLifted a] - type PLiftedRepr (PBuiltinList a) = [PLiftedRepr a] - pliftToRepr x = pliftToRepr @_ @a <$> x - pliftFromRepr x = traverse (pliftFromRepr @_ @a) x instance PLift a => PlutusType (PBuiltinList a) where type PInner (PBuiltinList a) _ = PBuiltinList a @@ -116,7 +123,9 @@ data PData s | PDataList (Term s (PBuiltinList PData)) | PDataInteger (Term s PInteger) | PDataByteString (Term s PByteString) - deriving (PUnsafeLiftDecl Data) via (DerivePLiftViaCoercible Data PData Data) + +instance PUnsafeLiftDecl PData where type PLifted PData = Data +deriving via (DerivePConstantViaCoercible Data PData Data) instance (PConstant Data) instance PEq PData where x #== y = punsafeBuiltin PLC.EqualsData # x # y @@ -154,11 +163,13 @@ data PAsData (a :: PType) (s :: S) data PAsDataLifted (a :: PType) -instance PUnsafeLiftDecl (PAsDataLifted a) (PAsData a) where - type PLifted (PAsData a) = PAsDataLifted a - type PLiftedRepr (PAsData a) = Data - pliftToRepr = \case - pliftFromRepr _ = Nothing +instance PConstant (PAsDataLifted a) where + type PConstantRepr (PAsDataLifted a) = Data + type PConstanted (PAsDataLifted a) = PAsData a + pconstantToRepr = \case + pconstantFromRepr _ = Nothing + +instance PUnsafeLiftDecl (PAsData a) where type PLifted (PAsData a) = PAsDataLifted a pforgetData :: Term s (PAsData a) -> Term s PData pforgetData = punsafeCoerce diff --git a/Plutarch/ByteString.hs b/Plutarch/ByteString.hs index 603d0a81f..281f763e9 100644 --- a/Plutarch/ByteString.hs +++ b/Plutarch/ByteString.hs @@ -1,4 +1,5 @@ {-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} module Plutarch.ByteString ( PByteString, @@ -18,13 +19,15 @@ import GHC.Stack (HasCallStack) import Plutarch (punsafeBuiltin) import Plutarch.Bool (PEq, POrd, (#<), (#<=), (#==)) import Plutarch.Integer (PInteger) -import Plutarch.Lift (DerivePLiftViaCoercible, PUnsafeLiftDecl, pconstant) +import Plutarch.Lift (DerivePConstantViaCoercible (DerivePConstantViaCoercible), PConstant, PLifted, PUnsafeLiftDecl, pconstant) import Plutarch.Prelude import qualified PlutusCore as PLC -- | Plutus 'BuiltinByteString' data PByteString s - deriving (PUnsafeLiftDecl ByteString) via (DerivePLiftViaCoercible ByteString PByteString ByteString) + +instance PUnsafeLiftDecl PByteString where type PLifted PByteString = ByteString +deriving via (DerivePConstantViaCoercible ByteString PByteString ByteString) instance (PConstant ByteString) instance PEq PByteString where x #== y = punsafeBuiltin PLC.EqualsByteString # x # y diff --git a/Plutarch/DataRepr.hs b/Plutarch/DataRepr.hs index 8d863064d..d7cf050cc 100644 --- a/Plutarch/DataRepr.hs +++ b/Plutarch/DataRepr.hs @@ -22,10 +22,8 @@ import Plutarch.Builtin ( psndBuiltin, ) import Plutarch.Integer (PInteger) -import Plutarch.Lift (PLifted, PLiftedRepr, PUnsafeLiftDecl, pliftFromRepr, pliftToRepr) import Plutarch.List (punsafeIndex) import Plutarch.Prelude -import qualified Plutus.V1.Ledger.Api as Ledger import qualified PlutusCore as PLC data PDataList (as :: [PType]) (s :: S) @@ -122,21 +120,15 @@ pmatchDataRepr d handlers = handler $ go common (idx + 1) rest constr -newtype PIsDataReprInstances (a :: PType) (h :: Type) (s :: S) = PIsDataReprInstances (a s) +newtype PIsDataReprInstances (a :: PType) (s :: S) = PIsDataReprInstances (a s) class (PMatch a, PIsData a) => PIsDataRepr (a :: PType) where type PIsDataReprRepr a :: [[PType]] pmatchRepr :: forall s b. Term s (PDataRepr (PIsDataReprRepr a)) -> (a s -> Term s b) -> Term s b -instance PIsDataRepr a => PIsData (PIsDataReprInstances a h) where +instance PIsDataRepr a => PIsData (PIsDataReprInstances a) where pdata = punsafeCoerce pfromData = punsafeCoerce -instance PIsDataRepr a => PMatch (PIsDataReprInstances a h) where +instance PIsDataRepr a => PMatch (PIsDataReprInstances a) where pmatch x f = pmatchRepr (punsafeCoerce x) (f . PIsDataReprInstances) - -instance {-# OVERLAPPABLE #-} (Ledger.FromData h, Ledger.ToData h, PIsData p) => PUnsafeLiftDecl h (PIsDataReprInstances p h) where - type PLifted (PIsDataReprInstances p h) = h - type PLiftedRepr (PIsDataReprInstances p h) = Ledger.Data - pliftToRepr = Ledger.toData - pliftFromRepr = Ledger.fromData diff --git a/Plutarch/Integer.hs b/Plutarch/Integer.hs index 39f254e9b..710d7e4d2 100644 --- a/Plutarch/Integer.hs +++ b/Plutarch/Integer.hs @@ -1,16 +1,19 @@ {-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} module Plutarch.Integer (PInteger, PIntegral (..)) where import Plutarch (punsafeBuiltin) import Plutarch.Bool (PEq, POrd, pif, (#<), (#<=), (#==)) -import Plutarch.Lift (DerivePLiftViaCoercible, PUnsafeLiftDecl, pconstant) +import Plutarch.Lift (DerivePConstantViaCoercible (DerivePConstantViaCoercible), PConstant, PLifted, PUnsafeLiftDecl, pconstant) import Plutarch.Prelude import qualified PlutusCore as PLC -- | Plutus BuiltinInteger data PInteger s - deriving (PUnsafeLiftDecl Integer) via (DerivePLiftViaCoercible Integer PInteger Integer) + +instance PUnsafeLiftDecl PInteger where type PLifted PInteger = Integer +deriving via (DerivePConstantViaCoercible Integer PInteger Integer) instance (PConstant Integer) class PIntegral a where pdiv :: Term s (a :--> a :--> a) diff --git a/Plutarch/Internal.hs b/Plutarch/Internal.hs index 268ab79f6..15fb95ad5 100644 --- a/Plutarch/Internal.hs +++ b/Plutarch/Internal.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE RoleAnnotations #-} + module Plutarch.Internal ( -- | $hoisted (:-->), @@ -109,6 +111,8 @@ data S -- | Shorthand for Plutarch types. type PType = S -> Type +type role Term phantom representational + {- $term Source: Unembedding Domain-Specific Languages by Robert Atkey, Sam Lindley, Jeremy Yallop Thanks! diff --git a/Plutarch/Lift.hs b/Plutarch/Lift.hs index 7ae402832..7a433306f 100644 --- a/Plutarch/Lift.hs +++ b/Plutarch/Lift.hs @@ -3,72 +3,77 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableSuperClasses #-} -module Plutarch.Lift (PConstant (..), PUnsafeLiftDecl (..), PLift, pconstant, plift, plift', LiftError, DerivePLiftViaCoercible (..), DerivePConstant) where +module Plutarch.Lift (PConstant (..), PUnsafeLiftDecl (..), PLift, pconstant, plift, plift', LiftError, DerivePConstantViaCoercible (..), DerivePConstantViaData (..), DerivePConstantViaNewtype (..)) where import Data.Coerce import Data.Kind (Type) import GHC.Stack (HasCallStack) import Plutarch.Evaluate (evaluateScript) -import Plutarch.Internal (ClosedTerm, PType, S, Term, compile, punsafeConstantInternal) +import Plutarch.Internal (ClosedTerm, PType, Term, compile, punsafeConstantInternal) +import qualified Plutus.V1.Ledger.Api as Ledger import qualified Plutus.V1.Ledger.Scripts as Scripts import qualified PlutusCore as PLC import PlutusCore.Constant (readKnownConstant) -import PlutusCore.Evaluation.Machine.Exception (MachineError) +import PlutusCore.Evaluation.Machine.Exception (ErrorWithCause, MachineError) import qualified UntypedPlutusCore as UPLC -class (PConstant (PLifted p), PConstanted (PLifted p) ~ p, PLC.DefaultUni `PLC.Includes` PLiftedRepr p) => PUnsafeLiftDecl (p :: PType) where - type PLiftedRepr p :: Type +class (PConstant (PLifted p), PConstanted (PLifted p) ~ p) => PUnsafeLiftDecl (p :: PType) where type PLifted p :: Type - pliftToRepr :: PLifted p -> PLiftedRepr p - pliftFromRepr :: PLiftedRepr p -> Maybe (PLifted p) -class (PLift (PConstanted h), PLifted (PConstanted h) ~ h) => PConstant (h :: Type) where +class (PUnsafeLiftDecl (PConstanted h), PLC.DefaultUni `PLC.Includes` PConstantRepr h) => PConstant (h :: Type) where + type PConstantRepr h :: Type type PConstanted h :: PType + pconstantToRepr :: h -> PConstantRepr h + pconstantFromRepr :: PConstantRepr h -> Maybe h type PLift = PUnsafeLiftDecl -newtype DerivePLiftViaCoercible (h :: Type) (p :: PType) (r :: Type) (s :: S) = DerivePLiftViaCoercible (p s) -newtype DerivePConstant (h :: Type) (p :: PType) = DerivePConstant h - -instance (PConstant h, PConstanted h ~ DerivePLiftViaCoercible h p r, Coercible h r, PLC.DefaultUni `PLC.Includes` r) => PUnsafeLiftDecl (DerivePLiftViaCoercible h p r) where - type PLiftedRepr (DerivePLiftViaCoercible h p r) = r - type PLifted (DerivePLiftViaCoercible h p r) = h - pliftToRepr = coerce - pliftFromRepr = Just . coerce - -instance (PLift p, PLifted p ~ DerivePConstant h p) => PConstant (DerivePConstant h p) where - type PConstanted (DerivePConstant h p) = p - -pconstant :: forall p s. PUnsafeLiftDecl p => PLifted p -> Term s p -pconstant x = punsafeConstantInternal $ PLC.someValue @(PLiftedRepr p) @PLC.DefaultUni $ pliftToRepr x +pconstant :: forall p s. PLift p => PLifted p -> Term s p +pconstant x = punsafeConstantInternal $ PLC.someValue @(PConstantRepr (PLifted p)) @PLC.DefaultUni $ pconstantToRepr x -- | Error during script evaluation. -data LiftError = LiftError deriving stock (Eq, Show) +data LiftError + = LiftError_ScriptError Scripts.ScriptError + | LiftError_EvalException (ErrorWithCause (MachineError PLC.DefaultFun) ()) + | LiftError_FromRepr + | LiftError_WrongRepr + deriving stock (Eq, Show) plift' :: forall p. PUnsafeLiftDecl p => ClosedTerm p -> Either LiftError (PLifted p) plift' prog = case evaluateScript (compile prog) of Right (_, _, Scripts.unScript -> UPLC.Program _ _ term) -> - case readKnownConstant @_ @(PLiftedRepr p) @(MachineError PLC.DefaultFun) Nothing term of - Right r -> case pliftFromRepr r of + case readKnownConstant @_ @(PConstantRepr (PLifted p)) @(MachineError PLC.DefaultFun) Nothing term of + Right r -> case pconstantFromRepr r of Just h -> Right h - Nothing -> Left LiftError - Left _ -> Left LiftError - Left _ -> Left LiftError + Nothing -> Left LiftError_FromRepr + Left e -> Left $ LiftError_EvalException e + Left e -> Left $ LiftError_ScriptError e -plift :: forall p. (HasCallStack, PUnsafeLiftDecl p) => ClosedTerm p -> (PLifted p) +plift :: forall p. (HasCallStack, PLift p) => ClosedTerm p -> (PLifted p) plift prog = case plift' prog of Right x -> x - Left _ -> error "plift failed" + Left e -> error $ "plift failed: " <> show e + +newtype DerivePConstantViaCoercible (h :: Type) (p :: PType) (r :: Type) = DerivePConstantViaCoercible h + +instance (PLift p, Coercible h r, PLC.DefaultUni `PLC.Includes` r) => PConstant (DerivePConstantViaCoercible h p r) where + type PConstantRepr (DerivePConstantViaCoercible h p r) = r + type PConstanted (DerivePConstantViaCoercible h p r) = p + pconstantToRepr = coerce + pconstantFromRepr = Just . coerce + +newtype DerivePConstantViaData (h :: Type) (p :: PType) = DerivePConstantViaData h + +instance (PLift p, Ledger.FromData h, Ledger.ToData h) => PConstant (DerivePConstantViaData h p) where + type PConstantRepr (DerivePConstantViaData h p) = Ledger.Data + type PConstanted (DerivePConstantViaData h p) = p + pconstantToRepr (DerivePConstantViaData x) = Ledger.toData x + pconstantFromRepr x = DerivePConstantViaData <$> Ledger.fromData x --- FIXME: improve error messages using below code -{- - plift' prog = - case evaluateScript (compile prog) of - Left e -> Left $ LiftError_ScriptError e - Right (_, _, Scripts.unScript -> UPLC.Program _ _ term) -> - first (LiftError_EvalException . showEvalException) $ - readKnownSelf term +newtype DerivePConstantViaNewtype (h :: Type) (p :: PType) (p' :: PType) = DerivePConstantViaNewtype h -showEvalException :: EvaluationException CekUserError (MachineError PLC.DefaultFun) (UPLC.Term UPLC.DeBruijn PLC.DefaultUni PLC.DefaultFun ()) -> Text -showEvalException = T.pack . show --} +instance (PLift p, PLift p', Coercible h (PLifted p')) => PConstant (DerivePConstantViaNewtype h p p') where + type PConstantRepr (DerivePConstantViaNewtype h p p') = PConstantRepr (PLifted p') + type PConstanted (DerivePConstantViaNewtype h p p') = p + pconstantToRepr x = pconstantToRepr @(PLifted p') $ coerce x + pconstantFromRepr x = coerce $ pconstantFromRepr @(PLifted p') x diff --git a/Plutarch/String.hs b/Plutarch/String.hs index 773cb73c7..ff4d36edd 100644 --- a/Plutarch/String.hs +++ b/Plutarch/String.hs @@ -1,4 +1,5 @@ {-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} module Plutarch.String (PString, pfromText, pencodeUtf8, pdecodeUtf8) where @@ -8,13 +9,15 @@ import qualified Data.Text as Txt import Plutarch (punsafeBuiltin) import Plutarch.Bool (PEq, (#==)) import Plutarch.ByteString (PByteString) -import Plutarch.Lift (DerivePLiftViaCoercible, PUnsafeLiftDecl, pconstant) +import Plutarch.Lift (DerivePConstantViaCoercible (DerivePConstantViaCoercible), PConstant, PLifted, PUnsafeLiftDecl, pconstant) import Plutarch.Prelude import qualified PlutusCore as PLC -- | Plutus 'BuiltinString' values data PString s - deriving (PUnsafeLiftDecl Text) via (DerivePLiftViaCoercible Text PString Text) + +instance PUnsafeLiftDecl PString where type PLifted PString = Text +deriving via (DerivePConstantViaCoercible Text PString Text) instance (PConstant Text) {-# DEPRECATED pfromText "Use `pconstant` instead." #-} diff --git a/Plutarch/Unit.hs b/Plutarch/Unit.hs index e4fc44505..0a254668d 100644 --- a/Plutarch/Unit.hs +++ b/Plutarch/Unit.hs @@ -1,13 +1,15 @@ {-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} module Plutarch.Unit (PUnit (..)) where import Plutarch (PlutusType (PInner, pcon', pmatch'), Term, pcon) import Plutarch.Bool (PBool (PFalse, PTrue), PEq, POrd, (#<), (#<=), (#==)) -import Plutarch.Lift (DerivePLiftViaCoercible, PUnsafeLiftDecl, pconstant) +import Plutarch.Lift (DerivePConstantViaCoercible (DerivePConstantViaCoercible), PConstant, PLifted, PUnsafeLiftDecl, pconstant) data PUnit s = PUnit - deriving (PUnsafeLiftDecl ()) via (DerivePLiftViaCoercible () PUnit ()) +instance PUnsafeLiftDecl PUnit where type PLifted PUnit = () +deriving via (DerivePConstantViaCoercible () PUnit ()) instance (PConstant ()) instance PlutusType PUnit where type PInner PUnit _ = PUnit diff --git a/examples/Main.hs b/examples/Main.hs index f55f3685f..9ff187fbb 100644 --- a/examples/Main.hs +++ b/examples/Main.hs @@ -19,7 +19,7 @@ import Plutarch.ByteString (PByteString, pconsBS, phexByteStr, pindexBS, plength import Plutarch.Either (PEither (PLeft, PRight)) import Plutarch.Integer (PInteger) import Plutarch.Internal (punsafeConstantInternal) -import Plutarch.Lift (pconstant, plift') +import Plutarch.Lift (pconstant, plift) import Plutarch.Prelude import Plutarch.String (PString) import Plutarch.Unit (PUnit (..)) @@ -35,6 +35,8 @@ import qualified Examples.Rationals as Rationals import qualified Examples.Recursion as Recursion import Utils +import Data.Text (Text) + main :: IO () main = defaultMain $ testGroup "all tests" [standardTests] -- , shrinkTests ] @@ -233,25 +235,25 @@ plutarchTests = , testGroup "Lifting of constants" [ testCase "plift on primitive types" $ do - plift' (pcon PTrue) @?= Right True - plift' (pcon PFalse) @?= Right False + plift (pcon PTrue) @?= True + plift (pcon PFalse) @?= False , testCase "pconstant on primitive types" $ do - plift' (pconstant @PBool False) @?= Right False - plift' (pconstant @PBool True) @?= Right True + plift (pconstant @PBool False) @?= False + plift (pconstant @PBool True) @?= True , testCase "plift on list and pair" $ do - plift' (pconstant @(PBuiltinList PInteger) [1, 2, 3]) @?= Right [1, 2, 3] - plift' (pconstant @(PBuiltinPair PString PInteger) ("IOHK", 42)) @?= Right ("IOHK", 42) + plift (pconstant ([1, 2, 3] :: [Integer])) @?= [1, 2, 3] + plift (pconstant ("IOHK" :: Text, 42 :: Integer)) @?= ("IOHK", 42) , testCase "plift on data" $ do let d :: PlutusTx.Data d = PlutusTx.toData @(Either Bool Bool) $ Right False - plift' (pconstant @(PData) d) @?= Right d + plift (pconstant d) @?= d , testCase "plift on nested containers" $ do -- List of pairs - let v1 = [("IOHK", 42), ("Plutus", 31)] - plift' (pconstant @(PBuiltinList (PBuiltinPair PString PInteger)) v1) @?= Right v1 + let v1 = [("IOHK", 42), ("Plutus", 31)] :: [(Text, Integer)] + plift (pconstant v1) @?= v1 -- List of pair of lists - let v2 = [("IOHK", [1, 2, 3]), ("Plutus", [9, 8, 7])] - plift' (pconstant @(PBuiltinList (PBuiltinPair PString (PBuiltinList PInteger))) v2) @?= Right v2 + let v2 = [("IOHK", [1, 2, 3]), ("Plutus", [9, 8, 7])] :: [(Text, [Integer])] + plift (pconstant v2) @?= v2 ] , testGroup "Boolean operations"