-
Notifications
You must be signed in to change notification settings - Fork 63
/
Utils.hs
172 lines (146 loc) · 6.88 KB
/
Utils.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
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ImplicitParams #-}
module Utils (HasTester, standardTester, eval, equal, equalBudgeted, equal', fails, expect, throws, traces, shrinkTester) where
import Control.Exception (SomeException, try)
import Data.Kind (Type)
import Data.Text (Text)
import Plutarch (ClosedTerm, PCon (pcon), Term, compile, printScript)
import Plutarch.Bool (PBool (PTrue))
import Plutarch.Evaluate (evaluateBudgetedScript, evaluateScript)
import qualified Plutus.V1.Ledger.Scripts as Scripts
import Shrink (shrinkScript)
import qualified PlutusCore.Evaluation.Machine.ExMemory as ExMemory
import PlutusCore.Evaluation.Machine.ExBudget (ExBudget(ExBudget))
import Test.Tasty.HUnit
newtype EvalImpl = EvalImpl {runEvalImpl :: forall k (a :: k -> Type). HasCallStack => ClosedTerm a -> IO Scripts.Script}
newtype EqualImpl = EqualImpl {runEqualImpl :: forall k (a :: k -> Type) (b :: k -> Type). HasCallStack => ClosedTerm a -> ClosedTerm b -> Assertion}
newtype Equal'Impl = Equal'Impl {runEqual'Impl :: forall k (a :: k -> Type). HasCallStack => ClosedTerm a -> String -> Assertion}
newtype FailsImpl = FailsImpl {runFailsImpl :: forall k (a :: k -> Type). HasCallStack => ClosedTerm a -> Assertion}
newtype ExpectImpl = ExpectImpl {runExpectImpl :: forall (k :: Type). HasCallStack => ClosedTerm @k PBool -> Assertion}
newtype ThrowsImpl = ThrowsImpl {runThrowsImpl :: forall k (a :: k -> Type). ClosedTerm a -> Assertion}
newtype TracesImpl = TracesImpl {runTracesImpl :: forall k (a :: k -> Type). ClosedTerm a -> [Text] -> Assertion}
data Tester = Tester
{ evalImpl :: EvalImpl
, equalImpl :: EqualImpl
, equal'Impl :: Equal'Impl
, failsImpl :: FailsImpl
, expectImpl :: ExpectImpl
, throwsImpl :: ThrowsImpl
, tracesImpl :: TracesImpl
}
type HasTester = (?tester :: Tester)
eval' :: HasCallStack => Scripts.Script -> IO Scripts.Script
eval' s = case evaluateScript s of
Left e -> assertFailure $ "Script evaluation failed: " <> show e
Right (_, _, x') -> pure x'
standardTester :: Tester
standardTester =
Tester
{ evalImpl = EvalImpl evalImpl
, equalImpl = EqualImpl equalImpl
, equal'Impl = Equal'Impl equal'Impl
, failsImpl = FailsImpl failsImpl
, expectImpl = ExpectImpl expectImpl
, throwsImpl = ThrowsImpl throwsImpl
, tracesImpl = TracesImpl tracesImpl
}
where
evalImpl :: HasCallStack => ClosedTerm a -> IO Scripts.Script
evalImpl x = eval' $ compile x
equalImpl :: HasCallStack => ClosedTerm a -> ClosedTerm b -> Assertion
equalImpl x y = do
x' <- evalImpl x
y' <- evalImpl y
printScript x' @?= printScript y'
equal'Impl :: HasCallStack => ClosedTerm a -> String -> Assertion
equal'Impl x y = do
x' <- evalImpl x
printScript x' @?= y
failsImpl :: HasCallStack => ClosedTerm a -> Assertion
failsImpl x =
case evaluateScript $ compile x of
Left (Scripts.EvaluationError _ _) -> mempty
Left (Scripts.EvaluationException _ _) -> mempty
Left e -> assertFailure $ "Script is malformed: " <> show e
Right (_, _, s) -> assertFailure $ "Script didn't err: " <> printScript s
expectImpl :: HasCallStack => ClosedTerm PBool -> Assertion
expectImpl = equalImpl (pcon PTrue :: Term s PBool)
throwsImpl :: HasCallStack => ClosedTerm a -> Assertion
throwsImpl x =
try @SomeException (putStrLn $ printScript $ compile x) >>= \case
Right _ -> assertFailure "Supposed to throw"
Left _ -> pure ()
tracesImpl :: HasCallStack => ClosedTerm a -> [Text] -> Assertion
tracesImpl x sl =
case evaluateScript $ compile x of
Left e -> assertFailure $ "Script evalImpluation failed: " <> show e
Right (_, traceLog, _) -> traceLog @?= sl
shrinkTester :: Tester
shrinkTester =
Tester
{ evalImpl = EvalImpl evalImpl
, equalImpl = EqualImpl equalImpl
, equal'Impl = Equal'Impl equal'Impl
, failsImpl = FailsImpl failsImpl
, expectImpl = ExpectImpl expectImpl
, throwsImpl = ThrowsImpl throwsImpl
, tracesImpl = TracesImpl tracesImpl
}
where
evalImpl :: HasCallStack => ClosedTerm a -> IO Scripts.Script
evalImpl x = eval' . shrinkScript $ compile x
equalImpl :: HasCallStack => ClosedTerm a -> ClosedTerm b -> Assertion
equalImpl x y = do
x' <- evalImpl x
y' <- evalImpl y
printScript x' @?= printScript y'
equal'Impl :: HasCallStack => ClosedTerm a -> String -> Assertion
equal'Impl x y = do
x' <- let ?tester = standardTester in eval x
printScript x' @?= y
failsImpl :: HasCallStack => ClosedTerm a -> Assertion
failsImpl x =
case evaluateScript . shrinkScript $ compile x of
Left (Scripts.EvaluationError _ _) -> mempty
Left (Scripts.EvaluationException _ _) -> mempty
Left e -> assertFailure $ "Script is malformed: " <> show e
Right (_, _, s) -> assertFailure $ "Script didn't err: " <> printScript s
expectImpl :: HasCallStack => ClosedTerm PBool -> Assertion
expectImpl = equalImpl (pcon PTrue :: Term s PBool)
throwsImpl :: HasCallStack => ClosedTerm a -> Assertion
throwsImpl x =
try @SomeException (putStrLn . printScript . shrinkScript $ compile x) >>= \case
Right _ -> assertFailure "Supposed to throw"
Left _ -> pure ()
tracesImpl :: HasCallStack => ClosedTerm a -> [Text] -> Assertion
tracesImpl x sl =
case evaluateScript . shrinkScript $ compile x of
Left e -> assertFailure $ "Script evalImpluation failed: " <> show e
Right (_, traceLog, _) -> traceLog @?= sl
eval :: (HasCallStack, HasTester) => ClosedTerm a -> IO Scripts.Script
eval = runEvalImpl (evalImpl ?tester)
equal :: forall k (a :: k -> Type) (b :: k -> Type). (HasCallStack, HasTester) => ClosedTerm @k a -> ClosedTerm @k b -> Assertion
equal x y = runEqualImpl (equalImpl ?tester) x y
equal' :: (HasCallStack, HasTester) => ClosedTerm a -> String -> Assertion
equal' = runEqual'Impl (equal'Impl ?tester)
fails :: (HasCallStack, HasTester) => ClosedTerm a -> Assertion
fails = runFailsImpl (failsImpl ?tester)
expect :: (HasCallStack, HasTester) => ClosedTerm PBool -> Assertion
expect = runExpectImpl (expectImpl ?tester)
throws :: (HasCallStack, HasTester) => ClosedTerm a -> Assertion
throws = runThrowsImpl (throwsImpl ?tester)
traces :: (HasCallStack, HasTester) => ClosedTerm a -> [Text] -> Assertion
traces = runTracesImpl (tracesImpl ?tester)
evalBudgeted :: HasCallStack => ClosedTerm a -> IO Scripts.Script
evalBudgeted x = case evaluateBudgetedScript (ExBudget maxCPU maxMemory) $ compile x of
Left e -> assertFailure $ "Script evaluation failed: " <> show e
Right (_, _, x') -> pure x'
maxCPU :: ExMemory.ExCPU
maxCPU = ExMemory.ExCPU 4000
maxMemory :: ExMemory.ExMemory
maxMemory = ExMemory.ExMemory 4000
equalBudgeted :: HasCallStack => ClosedTerm a -> ClosedTerm b -> Assertion
equalBudgeted x y = do
x' <- evalBudgeted x
y' <- evalBudgeted y
printScript x' @?= printScript y'