Skip to content

Commit 40b4c11

Browse files
author
euonymos
committed
feat: smart constructors for DSL
1 parent d592932 commit 40b4c11

File tree

8 files changed

+220
-141
lines changed

8 files changed

+220
-141
lines changed

‎example/CEM/Example/Auction.hs‎

Lines changed: 77 additions & 93 deletions
Original file line numberDiff line numberDiff line change
@@ -1,26 +1,29 @@
11
{-# LANGUAGE OverloadedLabels #-}
22
{-# LANGUAGE OverloadedRecordDot #-}
33

4-
-- | CEM Script Acution example
4+
-- | CEM Script Acution example -- simple no-deposit acutons
55
module CEM.Example.Auction where
66

77
import Cardano.CEM
88
import Data.Map qualified as Map
9-
109
import PlutusLedgerApi.V1.Crypto (PubKeyHash)
1110
import PlutusLedgerApi.V2 (Value)
1211
import PlutusTx.Prelude
1312
import Prelude qualified
1413

15-
-- | Simple no-deposit auction
14+
-- | Tag
1615
data SimpleAuction
1716

17+
-- | A bid
1818
data Bid = MkBet
1919
{ better :: PubKeyHash
2020
, betAmount :: Integer
2121
}
2222
deriving stock (Prelude.Eq, Prelude.Show)
2323

24+
{- | 'Bid' is the only type we need to derive HasPlutusSpine intance,
25+
since it's not directly referenced from 'CEMScript'.
26+
-}
2427
derivePlutusSpine ''Bid
2528

2629
data SimpleAuctionState
@@ -60,101 +63,82 @@ instance CEMScript SimpleAuction where
6063
compilationConfig = MkCompilationConfig "AUC"
6164

6265
perTransitionScriptSpec =
63-
Map.fromList
64-
[
65-
( CreateSpine
66-
,
67-
[ MainSignerCoinSelect ctxParams.seller cMinLovelace cEmptyValue
68-
, -- , TxFan Out (SameScript $ MkSameScriptArg ctxState) scriptStateValue
69-
TxFan Out (SameScript $ MkSameScriptArg $ nullarySpine @SimpleAuctionState NotStartedSpine) scriptStateValue
70-
]
71-
)
72-
,
73-
( StartSpine
74-
,
75-
[ ownInputInState NotStartedSpine
76-
, TxFan
77-
Out
78-
( SameScript
79-
$ MkSameScriptArg
80-
$ cOfSpine CurrentBidSpine [#bid ::= initialBid]
81-
)
82-
scriptStateValue
83-
, MainSignerNoValue ctxParams.seller
84-
]
85-
)
86-
,
87-
( MakeBidSpine
88-
,
89-
[ ownInputInState CurrentBidSpine
90-
, byFlagError
91-
(ctxTransition.bid.betAmount @<= ctxState.bid.betAmount)
92-
"Bid amount is less or equal to current bid"
93-
, TxFan
94-
Out
95-
( SameScript
96-
$ MkSameScriptArg
97-
$ cOfSpine
98-
CurrentBidSpine
99-
[#bid ::= ctxTransition.bid]
100-
)
101-
scriptStateValue
102-
, MainSignerNoValue ctxTransition.bid.better
103-
]
104-
)
105-
,
106-
( CloseSpine
107-
,
108-
[ ownInputInState CurrentBidSpine
109-
, TxFan
110-
Out
111-
( SameScript
112-
$ MkSameScriptArg
113-
$ cOfSpine WinnerSpine [#bid ::= ctxState.bid]
114-
)
115-
scriptStateValue
116-
, MainSignerNoValue ctxParams.seller
117-
]
118-
)
119-
,
120-
( BuyoutSpine
121-
,
122-
[ ownInputInState WinnerSpine
123-
, -- Example: In constraints redundant for on-chain
124-
offchainOnly
125-
( MainSignerCoinSelect
126-
buyoutBid.better
127-
( cMkAdaOnlyValue buyoutBid.betAmount
128-
@<> cMinLovelace
129-
)
130-
cEmptyValue
131-
)
132-
, TxFan
133-
Out
134-
(UserAddress ctxParams.seller)
135-
(cMinLovelace @<> cMkAdaOnlyValue buyoutBid.betAmount)
136-
, TxFan
137-
Out
138-
(UserAddress buyoutBid.better)
139-
(cMinLovelace @<> ctxParams.lot)
140-
]
141-
)
142-
]
143-
where
66+
let
14467
buyoutBid = ctxState.bid
68+
14569
initialBid =
14670
cOfSpine
14771
MkBetSpine
14872
[ #better ::= ctxParams.seller
14973
, #betAmount ::= lift 0
15074
]
151-
scriptStateValue = cMinLovelace @<> ctxParams.lot
15275

153-
ownInputInState :: SimpleAuctionStateSpine -> TxConstraint False SimpleAuction
154-
ownInputInState state =
155-
TxFan
156-
In
157-
(SameScript $ MkSameScriptArg $ cUpdateOfSpine' ctxState state)
158-
-- (SameScript $ MkSameScriptArg $ cOfSpine state [])
159-
-- (SameScript $ MkSameScriptArg ctxState)
160-
scriptStateValue
76+
auctionValue = cMinLovelace @<> ctxParams.lot
77+
in
78+
Map.fromList
79+
[
80+
( CreateSpine
81+
,
82+
[ spentBy ctxParams.seller cMinLovelace cEmptyValue
83+
, output (ownUtxo $ withNullaryState NotStartedSpine) auctionValue
84+
]
85+
)
86+
,
87+
( StartSpine
88+
,
89+
[ input (ownUtxo $ inState NotStartedSpine) auctionValue
90+
, output (ownUtxo $ withState CurrentBidSpine [#bid ::= initialBid]) auctionValue
91+
, signedBy ctxParams.seller
92+
]
93+
)
94+
,
95+
( MakeBidSpine
96+
,
97+
[ input (ownUtxo $ inState CurrentBidSpine) auctionValue
98+
, byFlagError
99+
(ctxTransition.bid.betAmount @<= ctxState.bid.betAmount)
100+
"Bid amount is less or equal to current bid"
101+
, output
102+
( ownUtxo
103+
$ withState
104+
CurrentBidSpine
105+
[#bid ::= ctxTransition.bid]
106+
)
107+
auctionValue
108+
, signedBy ctxTransition.bid.better
109+
]
110+
)
111+
,
112+
( CloseSpine
113+
,
114+
[ input (ownUtxo $ inState CurrentBidSpine) auctionValue
115+
, output
116+
( ownUtxo
117+
$ withState WinnerSpine [#bid ::= ctxState.bid]
118+
)
119+
auctionValue
120+
, signedBy ctxParams.seller
121+
]
122+
)
123+
,
124+
( BuyoutSpine
125+
,
126+
[ input (ownUtxo $ inState WinnerSpine) auctionValue
127+
, -- Example: In constraints redundant for on-chain
128+
offchainOnly
129+
( spentBy
130+
buyoutBid.better
131+
( cMkAdaOnlyValue buyoutBid.betAmount
132+
@<> cMinLovelace
133+
)
134+
cEmptyValue
135+
)
136+
, output
137+
(userUtxo ctxParams.seller)
138+
(cMinLovelace @<> cMkAdaOnlyValue buyoutBid.betAmount)
139+
, output
140+
(userUtxo buyoutBid.better)
141+
(cMinLovelace @<> ctxParams.lot)
142+
]
143+
)
144+
]

‎example/CEM/Example/Voting.hs‎

Lines changed: 27 additions & 38 deletions
Original file line numberDiff line numberDiff line change
@@ -11,9 +11,10 @@ import Data.Map qualified as Map
1111
import PlutusLedgerApi.V1.Crypto (PubKeyHash)
1212
import PlutusLedgerApi.V2 (Value)
1313
import PlutusTx.AssocMap qualified as PMap
14-
import PlutusTx.Prelude
15-
import Prelude qualified
14+
import PlutusTx.Prelude hiding (error)
15+
import Prelude qualified hiding (error)
1616

17+
-- | Voting example tag
1718
data SimpleVoting
1819

1920
data VoteValue = Yes | No | Abstain
@@ -73,7 +74,7 @@ countVotes params votesMap = maxDecision
7374
LT -> No
7475
EQ -> drawDecision params
7576

76-
-- Other datatypes
77+
-- CEM Script standard datatypes
7778

7879
data SimpleVotingParams = MkVotingParams
7980
{ disputeDescription :: BuiltinByteString
@@ -113,13 +114,14 @@ data SimpleVotingCalc
113114
| NoCalc
114115
deriving stock (Prelude.Eq, Prelude.Show)
115116

117+
derivePlutusSpine ''SimpleVotingCalc
118+
116119
instance CEMScriptTypes SimpleVoting where
117120
type Params SimpleVoting = SimpleVotingParams
118121
type State SimpleVoting = SimpleVotingState
119122
type Transition SimpleVoting = SimpleVotingTransition
120123
type TransitionComp SimpleVoting = SimpleVotingCalc
121124

122-
derivePlutusSpine ''SimpleVotingCalc
123125
$(deriveCEMAssociatedTypes False ''SimpleVoting)
124126

125127
instance CEMScript SimpleVoting where
@@ -155,32 +157,31 @@ instance CEMScript SimpleVoting where
155157
[
156158
( CreateSpine
157159
,
158-
[ TxFan Out (SameScript $ MkSameScriptArg $ lift NotStarted) cMinLovelace
159-
, MainSignerNoValue ctxParams.creator
160+
[ output (ownUtxo $ withNullaryState NotStartedSpine) cMinLovelace
161+
, signedBy ctxParams.creator
160162
]
161163
)
162164
,
163165
( StartSpine
164166
,
165-
[ TxFan In (SameScript $ MkSameScriptArg $ lift NotStarted) cMinLovelace
166-
, TxFan Out (SameScript $ MkSameScriptArg $ lift $ InProgress PMap.empty) cMinLovelace
167-
, MainSignerNoValue ctxParams.creator
167+
[ input (ownUtxo $ inState NotStartedSpine) cMinLovelace
168+
, -- TODO: lift here sounds slightly misleading
169+
output (ownUtxo $ lift $ InProgress PMap.empty) cMinLovelace
170+
, signedBy ctxParams.creator
168171
]
169172
)
170173
,
171174
( VoteSpine
172175
,
173-
[ sameScriptIncOfSpine InProgressSpine
174-
, MatchBySpine ctxComp.voteAddResult
176+
[ input (ownUtxo $ inState InProgressSpine) cMinLovelace
177+
, match ctxComp.voteAddResult
175178
$ Map.fromList
176-
[ (DuplicateVoteSpine, Error "You already casted vote")
179+
[ (DuplicateVoteSpine, error "You already casted vote")
177180
,
178181
( SuccessSpine
179-
, TxFan
180-
Out
181-
( SameScript
182-
$ MkSameScriptArg
183-
$ cOfSpine
182+
, output
183+
( ownUtxo
184+
$ withState
184185
InProgressSpine
185186
[ #votes
186187
::= ctxComp.voteAddResult.newVoteStorage
@@ -189,18 +190,17 @@ instance CEMScript SimpleVoting where
189190
cMinLovelace
190191
)
191192
]
192-
, MainSignerNoValue ctxTransition.votingJury
193-
, MatchBySpine ctxParams.juryPolicy
193+
, signedBy ctxTransition.votingJury
194+
, match ctxParams.juryPolicy
194195
$ Map.fromList
195196
[
196197
( WithTokenSpine
197-
, TxFan
198-
InRef
199-
(UserAddress ctxTransition.votingJury)
198+
, refInput
199+
(userUtxo ctxTransition.votingJury)
200200
ctxParams.juryPolicy.juryAuthTokenValue
201201
)
202-
, (FixedJuryListSpine, Noop)
203-
, (AnyoneSpine, Noop)
202+
, (FixedJuryListSpine, noop)
203+
, (AnyoneSpine, noop)
204204
]
205205
, byFlagError
206206
ctxComp.votingNotAllowed
@@ -215,20 +215,9 @@ instance CEMScript SimpleVoting where
215215
,
216216
( FinalizeSpine
217217
,
218-
[ sameScriptIncOfSpine InProgressSpine
219-
, TxFan
220-
Out
221-
( SameScript
222-
$ MkSameScriptArg
223-
$ cOfSpine
224-
FinalizedSpine
225-
[#votingResult ::= ctxComp.result]
226-
)
227-
cMinLovelace
228-
, MainSignerNoValue ctxParams.creator
218+
[ input (ownUtxo $ inState InProgressSpine) cMinLovelace
219+
, output (ownUtxo $ withState FinalizedSpine [#votingResult ::= ctxComp.result]) cMinLovelace
220+
, signedBy ctxParams.creator
229221
]
230222
)
231223
]
232-
where
233-
sameScriptIncOfSpine spine =
234-
TxFan In (SameScript $ MkSameScriptArg $ cUpdateOfSpine ctxState spine []) cMinLovelace

‎src/Cardano/CEM.hs‎

Lines changed: 8 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -6,7 +6,14 @@ module Cardano.CEM (
66

77
import Cardano.CEM.Address as X (scriptCredential)
88
import Cardano.CEM.Compile as X
9-
import Cardano.CEM.DSL as X
9+
import Cardano.CEM.DSL as X (
10+
CEMScript (..),
11+
CEMScriptDatum,
12+
CEMScriptTypes (..),
13+
CompilationConfig (..),
14+
RecordSetter ((::=)),
15+
TxConstraint,
16+
)
1017
import Cardano.CEM.DSLSmart as X
1118
import Cardano.CEM.Monads as X
1219
import Cardano.CEM.Monads.CLB as X

‎src/Cardano/CEM/DSL.hs‎

Lines changed: 1 addition & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -343,8 +343,7 @@ class
343343
) =>
344344
CEMScript script
345345
where
346-
-- | This map defines constraints for each transition via DSL
347-
-- FIXME: name
346+
-- | The crux part - a map that defines constraints for each transition via DSL
348347
perTransitionScriptSpec :: CEMScriptSpec False script
349348

350349
-- | Optional Plutus script to calculate things, for the cases when

0 commit comments

Comments
 (0)