Skip to content

Commit 7f48957

Browse files
SoupstrawSoupstraw
committed
Added instances
1 parent 82f0920 commit 7f48957

File tree

10 files changed

+375
-63
lines changed

10 files changed

+375
-63
lines changed

‎eras/conway/impl/CHANGELOG.md

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -2,6 +2,7 @@
22

33
## 1.20.0.0
44

5+
* Rename `transScriptPurpose` to `transPlutusPurposeV3`
56
* Make `transValidityInterval` implicit to eras instead of protocol versions.
67
* Implement `transValidityInterval` for Conway.
78
* Add `NFData` for `ConwayGenesis`

‎eras/conway/impl/src/Cardano/Ledger/Conway/TxInfo.hs

Lines changed: 10 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -25,7 +25,6 @@ module Cardano.Ledger.Conway.TxInfo (
2525
transHotCommitteeCred,
2626
transDelegatee,
2727
transDRep,
28-
transScriptPurpose,
2928
transMap,
3029
transTxInInfoV1,
3130
transTxOutV1,
@@ -37,6 +36,7 @@ module Cardano.Ledger.Conway.TxInfo (
3736
toPlutusV3Args,
3837
transTxCertV1V2,
3938
transPlutusPurposeV1V2,
39+
transPlutusPurposeV3,
4040
guardConwayFeaturesForPlutusV1V2,
4141
transTxInInfoV3,
4242
scriptPurposeToScriptInfo,
@@ -471,7 +471,7 @@ instance EraPlutusTxInfo 'PlutusV2 ConwayEra where
471471
instance EraPlutusTxInfo 'PlutusV3 ConwayEra where
472472
toPlutusTxCert _ pv = pure . transTxCert pv
473473

474-
toPlutusScriptPurpose = transScriptPurpose
474+
toPlutusScriptPurpose = transPlutusPurposeV3
475475

476476
toPlutusTxInfo proxy LedgerTxInfo {ltiProtVer, ltiEpochInfo, ltiSystemStart, ltiUTxO, ltiTx} = do
477477
timeRange <-
@@ -612,13 +612,15 @@ transDRep = \case
612612
-- and `PV3.Proposing` also have an index. Moreover, other script purposes rely on Ledger
613613
-- `Ord` instances for types that dictate the order, so it might not be a good idea to pass
614614
-- that information to Plutus for those purposes.
615-
transScriptPurpose ::
616-
(ConwayEraPlutusTxInfo l era, PlutusTxCert l ~ PV3.TxCert) =>
615+
transPlutusPurposeV3 ::
616+
( ConwayEraPlutusTxInfo l era
617+
, PlutusTxCert l ~ PV3.TxCert
618+
) =>
617619
proxy l ->
618620
ProtVer ->
619621
ConwayPlutusPurpose AsIxItem era ->
620622
Either (ContextError era) PV3.ScriptPurpose
621-
transScriptPurpose proxy pv = \case
623+
transPlutusPurposeV3 proxy pv = \case
622624
ConwaySpending (AsIxItem _ txIn) -> pure $ PV3.Spending (transTxIn txIn)
623625
ConwayMinting (AsIxItem _ policyId) -> pure $ PV3.Minting (Alonzo.transPolicyID policyId)
624626
ConwayCertifying (AsIxItem ix txCert) ->
@@ -706,10 +708,11 @@ transProposal proxy ProposalProcedure {pProcDeposit, pProcReturnAddr, pProcGovAc
706708
}
707709

708710
transPlutusPurposeV1V2 ::
711+
forall l era proxy.
709712
( PlutusTxCert l ~ PV2.DCert
710-
, PlutusPurpose AsItem era ~ ConwayPlutusPurpose AsItem era
711713
, EraPlutusTxInfo l era
712714
, Inject (ConwayContextError era) (ContextError era)
715+
, Inject (ConwayPlutusPurpose AsItem era) (PlutusPurpose AsItem era)
713716
) =>
714717
proxy l ->
715718
ProtVer ->
@@ -720,7 +723,7 @@ transPlutusPurposeV1V2 proxy pv = \case
720723
ConwayMinting policyId -> Alonzo.transPlutusPurpose proxy pv $ AlonzoMinting policyId
721724
ConwayCertifying txCert -> Alonzo.transPlutusPurpose proxy pv $ AlonzoCertifying txCert
722725
ConwayRewarding rewardAccount -> Alonzo.transPlutusPurpose proxy pv $ AlonzoRewarding rewardAccount
723-
purpose -> Left $ inject $ PlutusPurposeNotSupported purpose
726+
purpose -> Left $ inject $ PlutusPurposeNotSupported @era $ inject purpose
724727

725728
transProtVer :: ProtVer -> PV3.ProtocolVersion
726729
transProtVer (ProtVer major minor) =

‎eras/dijkstra/src/Cardano/Ledger/Dijkstra/Scripts.hs

Lines changed: 203 additions & 36 deletions
Original file line numberDiff line numberDiff line change
@@ -1,14 +1,26 @@
11
{-# LANGUAGE DataKinds #-}
22
{-# LANGUAGE DeriveGeneric #-}
3-
{-# LANGUAGE DerivingStrategies #-}
3+
{-# LANGUAGE DerivingVia #-}
4+
{-# LANGUAGE FlexibleContexts #-}
45
{-# LANGUAGE FlexibleInstances #-}
56
{-# LANGUAGE LambdaCase #-}
7+
{-# LANGUAGE MultiParamTypeClasses #-}
8+
{-# LANGUAGE OverloadedStrings #-}
9+
{-# LANGUAGE PatternSynonyms #-}
10+
{-# LANGUAGE QuantifiedConstraints #-}
11+
{-# LANGUAGE RankNTypes #-}
12+
{-# LANGUAGE StandaloneDeriving #-}
613
{-# LANGUAGE TypeApplications #-}
714
{-# LANGUAGE TypeFamilies #-}
815
{-# LANGUAGE UndecidableInstances #-}
16+
{-# LANGUAGE ViewPatterns #-}
917
{-# OPTIONS_GHC -Wno-orphans #-}
1018

11-
module Cardano.Ledger.Dijkstra.Scripts (PlutusScript (..)) where
19+
module Cardano.Ledger.Dijkstra.Scripts (
20+
PlutusScript (..),
21+
DijkstraPlutusPurpose (..),
22+
pattern GuardingPurpose,
23+
) where
1224

1325
import Cardano.Ledger.Address (RewardAccount)
1426
import Cardano.Ledger.Allegra.Scripts (
@@ -32,16 +44,34 @@ import Cardano.Ledger.Alonzo (AlonzoScript)
3244
import Cardano.Ledger.Alonzo.Scripts (
3345
AlonzoEraScript (..),
3446
AlonzoScript (..),
47+
AsItem,
3548
AsIx (..),
49+
AsIxItem,
3650
alonzoScriptPrefixTag,
3751
)
52+
import Cardano.Ledger.BaseTypes (Inject (..), kindObject)
53+
import Cardano.Ledger.Binary (
54+
CBORGroup (..),
55+
DecCBOR (..),
56+
DecCBORGroup (..),
57+
EncCBOR (..),
58+
EncCBORGroup (..),
59+
decodeWord8,
60+
encodeWord8,
61+
)
3862
import Cardano.Ledger.Conway.Governance (ProposalProcedure, Voter)
3963
import Cardano.Ledger.Conway.Scripts (
4064
ConwayEraScript (..),
4165
ConwayPlutusPurpose (..),
4266
PlutusScript (..),
4367
)
44-
import Cardano.Ledger.Core (EraScript (..), EraTxCert (..), SafeToHash (..), ScriptHash)
68+
import Cardano.Ledger.Core (
69+
EraPParams,
70+
EraScript (..),
71+
EraTxCert (..),
72+
SafeToHash (..),
73+
ScriptHash,
74+
)
4575
import Cardano.Ledger.Dijkstra.Era (DijkstraEra)
4676
import Cardano.Ledger.Dijkstra.PParams ()
4777
import Cardano.Ledger.Dijkstra.TxCert ()
@@ -50,8 +80,10 @@ import Cardano.Ledger.Plutus (Language (..), Plutus, SLanguage (..), plutusSLang
5080
import Cardano.Ledger.Shelley.Scripts (ShelleyEraScript (..))
5181
import Cardano.Ledger.TxIn (TxIn)
5282
import Control.DeepSeq (NFData (..), rwhnf)
83+
import Data.Aeson (KeyValue (..), ToJSON (..))
5384
import Data.MemPack (MemPack (..), packTagM, packedTagByteCount, unknownTagM, unpackTagM)
54-
import Data.Word (Word32)
85+
import Data.Typeable (Proxy (..), Typeable)
86+
import Data.Word (Word16, Word32, Word8)
5587
import GHC.Generics (Generic)
5688
import NoThunks.Class (NoThunks)
5789

@@ -65,6 +97,124 @@ data DijkstraPlutusPurpose f era
6597
| DijkstraGuarding !(f Word32 ScriptHash)
6698
deriving (Generic)
6799

100+
instance Inject (ConwayPlutusPurpose f era) (DijkstraPlutusPurpose f era) where
101+
inject = \case
102+
ConwaySpending p -> DijkstraSpending p
103+
ConwayMinting p -> DijkstraMinting p
104+
ConwayCertifying p -> DijkstraCertifying p
105+
ConwayRewarding p -> DijkstraRewarding p
106+
ConwayVoting p -> DijkstraVoting p
107+
ConwayProposing p -> DijkstraProposing p
108+
109+
deriving via
110+
CBORGroup (DijkstraPlutusPurpose f era)
111+
instance
112+
( Typeable f
113+
, EraPParams era
114+
, forall a b. (DecCBOR a, DecCBOR b) => DecCBOR (f a b)
115+
, forall a b. (EncCBOR a, EncCBOR b) => EncCBOR (f a b)
116+
, EraTxCert era
117+
) =>
118+
DecCBOR (DijkstraPlutusPurpose f era)
119+
120+
deriving via
121+
CBORGroup (DijkstraPlutusPurpose f era)
122+
instance
123+
( Typeable f
124+
, EraPParams era
125+
, forall a b. (EncCBOR a, EncCBOR b) => EncCBOR (f a b)
126+
, EraTxCert era
127+
) =>
128+
EncCBOR (DijkstraPlutusPurpose f era)
129+
130+
instance
131+
( Typeable f
132+
, EraPParams era
133+
, forall a b. (DecCBOR a, DecCBOR b) => DecCBOR (f a b)
134+
, DecCBOR (TxCert era)
135+
) =>
136+
DecCBORGroup (DijkstraPlutusPurpose f era)
137+
where
138+
decCBORGroup =
139+
decodeWord8 >>= \case
140+
0 -> DijkstraSpending <$> decCBOR
141+
1 -> DijkstraMinting <$> decCBOR
142+
2 -> DijkstraCertifying <$> decCBOR
143+
3 -> DijkstraRewarding <$> decCBOR
144+
4 -> DijkstraVoting <$> decCBOR
145+
5 -> DijkstraProposing <$> decCBOR
146+
6 -> DijkstraGuarding <$> decCBOR
147+
n -> fail $ "Unexpected tag for DijkstraPlutusPurpose: " <> show n
148+
149+
instance
150+
( Typeable f
151+
, EraPParams era
152+
, forall a b. (EncCBOR a, EncCBOR b) => EncCBOR (f a b)
153+
, EncCBOR (TxCert era)
154+
) =>
155+
EncCBORGroup (DijkstraPlutusPurpose f era)
156+
where
157+
listLen _ = 2
158+
listLenBound _ = 2
159+
encCBORGroup = \case
160+
DijkstraSpending p -> encodeWord8 0 <> encCBOR p
161+
DijkstraMinting p -> encodeWord8 1 <> encCBOR p
162+
DijkstraCertifying p -> encodeWord8 2 <> encCBOR p
163+
DijkstraRewarding p -> encodeWord8 3 <> encCBOR p
164+
DijkstraVoting p -> encodeWord8 4 <> encCBOR p
165+
DijkstraProposing p -> encodeWord8 5 <> encCBOR p
166+
DijkstraGuarding p -> encodeWord8 6 <> encCBOR p
167+
encodedGroupSizeExpr size_ _proxy =
168+
encodedSizeExpr size_ (Proxy @Word8) + encodedSizeExpr size_ (Proxy @Word16)
169+
170+
instance
171+
( forall a b. (ToJSON a, ToJSON b) => ToJSON (f a b)
172+
, ToJSON (TxCert era)
173+
, EraPParams era
174+
) =>
175+
ToJSON (DijkstraPlutusPurpose f era)
176+
where
177+
toJSON = \case
178+
DijkstraSpending n -> kindObjectWithValue "DijkstraSpending" n
179+
DijkstraMinting n -> kindObjectWithValue "DijkstraMinting" n
180+
DijkstraCertifying n -> kindObjectWithValue "DijkstraCertifying" n
181+
DijkstraRewarding n -> kindObjectWithValue "DijkstraRewarding" n
182+
DijkstraVoting n -> kindObjectWithValue "DijkstraVoting" n
183+
DijkstraProposing n -> kindObjectWithValue "DijkstraProposing" n
184+
DijkstraGuarding n -> kindObjectWithValue "DijkstraGuarding" n
185+
where
186+
kindObjectWithValue name n = kindObject name ["value" .= n]
187+
188+
deriving instance (EraTxCert era, EraPParams era) => Eq (DijkstraPlutusPurpose AsItem era)
189+
190+
deriving instance (EraTxCert era, EraPParams era) => Eq (DijkstraPlutusPurpose AsIx era)
191+
192+
deriving instance (EraTxCert era, EraPParams era) => Eq (DijkstraPlutusPurpose AsIxItem era)
193+
194+
instance (EraPParams era, NFData (TxCert era)) => NFData (DijkstraPlutusPurpose AsItem era)
195+
196+
instance (EraPParams era, NFData (TxCert era)) => NFData (DijkstraPlutusPurpose AsIx era)
197+
198+
instance (EraPParams era, NFData (TxCert era)) => NFData (DijkstraPlutusPurpose AsIxItem era)
199+
200+
instance (EraPParams era, NoThunks (TxCert era)) => NoThunks (DijkstraPlutusPurpose AsItem era)
201+
202+
instance (EraPParams era, NoThunks (TxCert era)) => NoThunks (DijkstraPlutusPurpose AsIx era)
203+
204+
instance (EraPParams era, NoThunks (TxCert era)) => NoThunks (DijkstraPlutusPurpose AsIxItem era)
205+
206+
deriving instance (EraPParams era, EraTxCert era) => Ord (DijkstraPlutusPurpose AsItem era)
207+
208+
deriving instance (EraPParams era, EraTxCert era) => Ord (DijkstraPlutusPurpose AsIx era)
209+
210+
deriving instance (EraPParams era, EraTxCert era) => Ord (DijkstraPlutusPurpose AsIxItem era)
211+
212+
deriving instance (EraPParams era, EraTxCert era) => Show (DijkstraPlutusPurpose AsItem era)
213+
214+
deriving instance (EraPParams era, EraTxCert era) => Show (DijkstraPlutusPurpose AsIx era)
215+
216+
deriving instance (EraPParams era, EraTxCert era) => Show (DijkstraPlutusPurpose AsIxItem era)
217+
68218
instance EraScript DijkstraEra where
69219
type Script DijkstraEra = AlonzoScript DijkstraEra
70220
type NativeScript DijkstraEra = Timelock DijkstraEra
@@ -119,7 +269,7 @@ instance AlonzoEraScript DijkstraEra where
119269
| DijkstraPlutusV4 !(Plutus 'PlutusV4)
120270
deriving (Eq, Ord, Show, Generic)
121271

122-
type PlutusPurpose f DijkstraEra = ConwayPlutusPurpose f DijkstraEra
272+
type PlutusPurpose f DijkstraEra = DijkstraPlutusPurpose f DijkstraEra
123273

124274
eraMaxLanguage = PlutusV3
125275

@@ -136,51 +286,41 @@ instance AlonzoEraScript DijkstraEra where
136286
withPlutusScript (DijkstraPlutusV4 plutus) f = f plutus
137287

138288
hoistPlutusPurpose f = \case
139-
ConwaySpending x -> ConwaySpending $ f x
140-
ConwayMinting x -> ConwayMinting $ f x
141-
ConwayCertifying x -> ConwayCertifying $ f x
142-
ConwayRewarding x -> ConwayRewarding $ f x
143-
ConwayVoting x -> ConwayVoting $ f x
144-
ConwayProposing x -> ConwayProposing $ f x
289+
DijkstraSpending x -> DijkstraSpending $ f x
290+
DijkstraMinting x -> DijkstraMinting $ f x
291+
DijkstraCertifying x -> DijkstraCertifying $ f x
292+
DijkstraRewarding x -> DijkstraRewarding $ f x
293+
DijkstraVoting x -> DijkstraVoting $ f x
294+
DijkstraProposing x -> DijkstraProposing $ f x
295+
DijkstraGuarding x -> DijkstraGuarding $ f x
145296

146-
mkSpendingPurpose = ConwaySpending
297+
mkSpendingPurpose = DijkstraSpending
147298

148-
toSpendingPurpose (ConwaySpending i) = Just i
299+
toSpendingPurpose (DijkstraSpending i) = Just i
149300
toSpendingPurpose _ = Nothing
150301

151-
mkMintingPurpose = ConwayMinting
302+
mkMintingPurpose = DijkstraMinting
152303

153-
toMintingPurpose (ConwayMinting i) = Just i
304+
toMintingPurpose (DijkstraMinting i) = Just i
154305
toMintingPurpose _ = Nothing
155306

156-
mkCertifyingPurpose = ConwayCertifying
307+
mkCertifyingPurpose = DijkstraCertifying
157308

158-
toCertifyingPurpose (ConwayCertifying i) = Just i
309+
toCertifyingPurpose (DijkstraCertifying i) = Just i
159310
toCertifyingPurpose _ = Nothing
160311

161-
mkRewardingPurpose = ConwayRewarding
312+
mkRewardingPurpose = DijkstraRewarding
162313

163-
toRewardingPurpose (ConwayRewarding i) = Just i
314+
toRewardingPurpose (DijkstraRewarding i) = Just i
164315
toRewardingPurpose _ = Nothing
165316

166317
upgradePlutusPurposeAsIx = \case
167-
ConwaySpending (AsIx ix) -> ConwaySpending (AsIx ix)
168-
ConwayMinting (AsIx ix) -> ConwayMinting (AsIx ix)
169-
ConwayCertifying (AsIx ix) -> ConwayCertifying (AsIx ix)
170-
ConwayRewarding (AsIx ix) -> ConwayRewarding (AsIx ix)
171-
ConwayVoting (AsIx ix) -> ConwayVoting (AsIx ix)
172-
ConwayProposing (AsIx ix) -> ConwayProposing (AsIx ix)
173-
174-
instance ConwayEraScript DijkstraEra where
175-
mkVotingPurpose = ConwayVoting
176-
177-
toVotingPurpose (ConwayVoting i) = Just i
178-
toVotingPurpose _ = Nothing
179-
180-
mkProposingPurpose = ConwayProposing
181-
182-
toProposingPurpose (ConwayProposing i) = Just i
183-
toProposingPurpose _ = Nothing
318+
ConwaySpending (AsIx ix) -> DijkstraSpending (AsIx ix)
319+
ConwayMinting (AsIx ix) -> DijkstraMinting (AsIx ix)
320+
ConwayCertifying (AsIx ix) -> DijkstraCertifying (AsIx ix)
321+
ConwayRewarding (AsIx ix) -> DijkstraRewarding (AsIx ix)
322+
ConwayVoting (AsIx ix) -> DijkstraVoting (AsIx ix)
323+
ConwayProposing (AsIx ix) -> DijkstraProposing (AsIx ix)
184324

185325
instance ShelleyEraScript DijkstraEra where
186326
mkRequireSignature = mkRequireSignatureTimelock
@@ -201,3 +341,30 @@ instance AllegraEraScript DijkstraEra where
201341

202342
mkTimeExpire = mkTimeExpireTimelock
203343
getTimeExpire = getTimeExpireTimelock
344+
345+
instance ConwayEraScript DijkstraEra where
346+
mkVotingPurpose = DijkstraVoting
347+
348+
toVotingPurpose (DijkstraVoting i) = Just i
349+
toVotingPurpose _ = Nothing
350+
351+
mkProposingPurpose = DijkstraProposing
352+
353+
toProposingPurpose (DijkstraProposing i) = Just i
354+
toProposingPurpose _ = Nothing
355+
356+
class DijkstraEraScript era where
357+
mkGuardingPurpose :: f Word32 ScriptHash -> PlutusPurpose f era
358+
toGuardingPurpose :: PlutusPurpose f era -> Maybe (f Word32 ScriptHash)
359+
360+
instance DijkstraEraScript DijkstraEra where
361+
mkGuardingPurpose = DijkstraGuarding
362+
363+
toGuardingPurpose (DijkstraGuarding i) = Just i
364+
toGuardingPurpose _ = Nothing
365+
366+
pattern GuardingPurpose ::
367+
DijkstraEraScript era => f Word32 ScriptHash -> PlutusPurpose f era
368+
pattern GuardingPurpose c <- (toGuardingPurpose -> Just c)
369+
where
370+
GuardingPurpose c = mkGuardingPurpose c

0 commit comments

Comments
 (0)