-
Notifications
You must be signed in to change notification settings - Fork 463
/
Apply.hs
258 lines (248 loc) · 9.73 KB
/
Apply.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
-- | Computing constant application.
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Language.PlutusCore.Constant.Apply
( ConstAppResult (..)
, nonZeroArg
, integerToInt64
, applyTypeSchemed
, applyBuiltinName
) where
import Language.PlutusCore.Constant.Name
import Language.PlutusCore.Constant.Typed
import Language.PlutusCore.Core
import Language.PlutusCore.Evaluation.Machine.ExBudgeting
import Language.PlutusCore.Evaluation.Machine.Exception
import Language.PlutusCore.Evaluation.Result
import Language.PlutusCore.Universe
import Control.Monad.Except
import Crypto
import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString.Lazy.Hash as Hash
import Data.Coerce
import Data.Int
import Data.Proxy
-- | The result of evaluation of a builtin applied to some arguments.
data ConstAppResult term
= ConstAppSuccess term
-- ^ Successfully computed a value.
| ConstAppStuck
-- ^ Not enough arguments.
deriving (Show, Eq, Functor)
-- | Turn a function into another function that returns 'EvaluationFailure' when its second argument
-- is 0 or calls the original function otherwise and wraps the result in 'EvaluationSuccess'.
-- Useful for correctly handling `div`, `mod`, etc.
nonZeroArg :: (Integer -> Integer -> Integer) -> Integer -> Integer -> EvaluationResult Integer
nonZeroArg _ _ 0 = EvaluationFailure
nonZeroArg f x y = EvaluationSuccess $ f x y
integerToInt64 :: Integer -> Int64
integerToInt64 = fromIntegral
-- | Apply a function with a known 'TypeScheme' to a list of 'Constant's (unwrapped from 'Value's).
-- Checks that the constants are of expected types.
applyTypeSchemed
:: forall err m args term res.
( MonadError (ErrorWithCause err term) m, AsUnliftingError err, AsConstAppError err term
, SpendBudget m term
)
=> StagedBuiltinName
-> TypeScheme term args res
-> FoldArgs args res
-> FoldArgsEx args
-> [term]
-> m (ConstAppResult term)
applyTypeSchemed name = go where
go
:: forall args'.
TypeScheme term args' res
-> FoldArgs args' res
-> FoldArgsEx args'
-> [term]
-> m (ConstAppResult term)
go (TypeSchemeResult _) y _ args =
-- TODO: The costing function is NOT run here. Might cause problems if there's never a TypeSchemeArrow.
case args of
[] -> pure . ConstAppSuccess $ makeKnown y -- Computed the result.
_ -> throwingWithCause _ConstAppError -- Too many arguments.
(ExcessArgumentsConstAppError args)
Nothing
go (TypeSchemeAllType _ schK) f exF args =
go (schK Proxy) f exF args
go (TypeSchemeArrow _ schB) f exF args = case args of
[] -> pure ConstAppStuck -- Not enough arguments to compute.
arg : args' -> do -- Peel off one argument.
-- Coerce the argument to a Haskell value.
x <- readKnown arg
exF' <- feedBudgeter exF arg
-- Apply the function to the coerced argument and proceed recursively.
case schB of
(TypeSchemeResult _) -> do
-- Note that that if this fails, then the cause is reported to be @arg@, i.e.
-- the last argument in the builtin application being processed, not the whole
-- application. It would probably make sense to recreate the application here.
spendBudget (BBuiltin name) arg exF'
go schB (f x) exF' args'
_ -> go schB (f x) exF' args'
-- | Apply a 'TypedBuiltinName' to a list of 'Constant's (unwrapped from 'Value's)
-- Checks that the constants are of expected types.
applyTypedBuiltinName
:: ( MonadError (ErrorWithCause err term) m, AsUnliftingError err, AsConstAppError err term
, SpendBudget m term
)
=> TypedBuiltinName term args res
-> FoldArgs args res
-> FoldArgsEx args
-> [term]
-> m (ConstAppResult term)
applyTypedBuiltinName (TypedBuiltinName name schema) =
applyTypeSchemed (StaticStagedBuiltinName name) schema
-- | Apply a 'TypedBuiltinName' to a list of 'Value's.
-- Checks that the values are of expected types.
applyBuiltinName
:: forall m err uni term
. ( MonadError (ErrorWithCause err term) m, AsUnliftingError err, AsConstAppError err term
, SpendBudget m term, HasConstantIn uni term, GShow uni, GEq uni, DefaultUni <: uni
)
=> BuiltinName -> [term] -> m (ConstAppResult term)
applyBuiltinName name args = do
params <- builtinCostParams
case name of
AddInteger ->
applyTypedBuiltinName
typedAddInteger
(+)
(runCostingFunTwoArguments $ paramAddInteger params)
args
SubtractInteger ->
applyTypedBuiltinName
typedSubtractInteger
(-)
(runCostingFunTwoArguments $ paramSubtractInteger params)
args
MultiplyInteger ->
applyTypedBuiltinName
typedMultiplyInteger
(*)
(runCostingFunTwoArguments $ paramMultiplyInteger params)
args
DivideInteger ->
applyTypedBuiltinName
typedDivideInteger
(nonZeroArg div)
(runCostingFunTwoArguments $ paramDivideInteger params)
args
QuotientInteger ->
applyTypedBuiltinName
typedQuotientInteger
(nonZeroArg quot)
(runCostingFunTwoArguments $ paramQuotientInteger params)
args
RemainderInteger ->
applyTypedBuiltinName
typedRemainderInteger
(nonZeroArg rem)
(runCostingFunTwoArguments $ paramRemainderInteger params)
args
ModInteger ->
applyTypedBuiltinName
typedModInteger
(nonZeroArg mod)
(runCostingFunTwoArguments $ paramModInteger params)
args
LessThanInteger ->
applyTypedBuiltinName
typedLessThanInteger
(<)
(runCostingFunTwoArguments $ paramLessThanInteger params)
args
LessThanEqInteger ->
applyTypedBuiltinName
typedLessThanEqInteger
(<=)
(runCostingFunTwoArguments $ paramLessThanEqInteger params)
args
GreaterThanInteger ->
applyTypedBuiltinName
typedGreaterThanInteger
(>)
(runCostingFunTwoArguments $ paramGreaterThanInteger params)
args
GreaterThanEqInteger ->
applyTypedBuiltinName
typedGreaterThanInteger
(>=)
(runCostingFunTwoArguments $ paramGreaterThanEqInteger params)
args
EqInteger ->
applyTypedBuiltinName
typedEqInteger
(==)
(runCostingFunTwoArguments $ paramEqInteger params)
args
Concatenate ->
applyTypedBuiltinName
typedConcatenate
(<>)
(runCostingFunTwoArguments $ paramConcatenate params)
args
TakeByteString ->
applyTypedBuiltinName
typedTakeByteString
(coerce BSL.take . integerToInt64)
(runCostingFunTwoArguments $ paramTakeByteString params)
args
DropByteString ->
applyTypedBuiltinName
typedDropByteString
(coerce BSL.drop . integerToInt64)
(runCostingFunTwoArguments $ paramDropByteString params)
args
SHA2 ->
applyTypedBuiltinName
typedSHA2
(coerce Hash.sha2)
(runCostingFunOneArgument $ paramSHA2 params)
args
SHA3 ->
applyTypedBuiltinName
typedSHA3
(coerce Hash.sha3)
(runCostingFunOneArgument $ paramSHA3 params)
args
VerifySignature ->
applyTypedBuiltinName
typedVerifySignature
(coerce $ verifySignature @EvaluationResult)
(runCostingFunThreeArguments $ paramVerifySignature params)
args
EqByteString ->
applyTypedBuiltinName
typedEqByteString
(==)
(runCostingFunTwoArguments $ paramEqByteString params)
args
LtByteString ->
applyTypedBuiltinName
typedLtByteString
(<)
(runCostingFunTwoArguments $ paramLtByteString params)
args
GtByteString ->
applyTypedBuiltinName
typedGtByteString
(>)
(runCostingFunTwoArguments $ paramGtByteString params)
args
IfThenElse ->
applyTypedBuiltinName
typedIfThenElse
(\b x y -> if b then x else y)
(runCostingFunThreeArguments $ paramIfThenElse params)
args