-
Notifications
You must be signed in to change notification settings - Fork 463
/
PlcTestUtils.hs
101 lines (82 loc) · 3.67 KB
/
PlcTestUtils.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
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module PlcTestUtils (
GetProgram(..),
pureTry,
catchAll,
rethrow,
trivialProgram,
runPlc,
goldenPlc,
goldenPlcCatch,
goldenEval,
goldenEvalCatch) where
import PlutusPrelude
import Common
import Language.PlutusCore
import Language.PlutusCore.DeBruijn
import Language.PlutusCore.Evaluation.Machine.Cek
import Language.PlutusCore.Evaluation.Machine.ExBudgetingDefaults
import Language.PlutusCore.Evaluation.Machine.ExMemory
import Language.PlutusCore.Pretty
import Control.Exception
import Control.Monad.Except
import qualified Data.Text.Prettyprint.Doc as PP
import System.IO.Unsafe
-- | Class for ad-hoc overloading of things which can be turned into a PLC program. Any errors
-- from the process should be caught.
class GetProgram a uni | a -> uni where
getProgram :: a -> ExceptT SomeException IO (Program TyName Name uni ())
instance GetProgram a uni => GetProgram (ExceptT SomeException IO a) uni where
getProgram a = a >>= getProgram
instance GetProgram (Program TyName Name uni ()) uni where
getProgram = pure
pureTry :: Exception e => a -> Either e a
pureTry = unsafePerformIO . try . evaluate
catchAll :: a -> ExceptT SomeException IO a
catchAll value = ExceptT $ try @SomeException (evaluate value)
rethrow :: ExceptT SomeException IO a -> IO a
rethrow = fmap (either throw id) . runExceptT
trivialProgram :: Term TyName Name uni () -> Program TyName Name uni ()
trivialProgram = Program () (defaultVersion ())
runPlc
:: ( GetProgram a uni, GShow uni, GEq uni, DefaultUni <: uni
, Closed uni, uni `Everywhere` ExMemoryUsage, uni `Everywhere` PrettyConst, Typeable uni
)
=> [a] -> ExceptT SomeException IO (EvaluationResult (Plain Term uni))
runPlc values = do
ps <- traverse getProgram values
let p = foldl1 applyProgram ps
liftEither . first toException . extractEvaluationResult . evaluateCek mempty defaultCostModel $ toTerm p
ppCatch :: PrettyPlc a => ExceptT SomeException IO a -> IO (Doc ann)
ppCatch value = either (PP.pretty . show) prettyPlcClassicDebug <$> runExceptT value
ppThrow :: PrettyPlc a => ExceptT SomeException IO a -> IO (Doc ann)
ppThrow value = rethrow $ prettyPlcClassicDebug <$> value
goldenPlc
:: (GetProgram a uni, GShow uni, Closed uni, uni `Everywhere` PrettyConst)
=> String -> a -> TestNested
goldenPlc name value = nestedGoldenVsDocM name $ ppThrow $ do
p <- getProgram value
withExceptT toException $ deBruijnProgram p
goldenPlcCatch
:: (GetProgram a uni, GShow uni, Closed uni, uni `Everywhere` PrettyConst)
=> String -> a -> TestNested
goldenPlcCatch name value = nestedGoldenVsDocM name $ ppCatch $ do
p <- getProgram value
withExceptT toException $ deBruijnProgram p
goldenEval
:: ( GetProgram a uni, GShow uni, GEq uni, DefaultUni <: uni
, Closed uni, uni `Everywhere` ExMemoryUsage, uni `Everywhere` PrettyConst, Typeable uni
)
=> String -> [a] -> TestNested
goldenEval name values = nestedGoldenVsDocM name $ prettyPlcClassicDebug <$> (rethrow $ runPlc values)
goldenEvalCatch
:: ( GetProgram a uni, GShow uni, GEq uni, DefaultUni <: uni
, Closed uni, uni `Everywhere` ExMemoryUsage, uni `Everywhere` PrettyConst, Typeable uni
)
=> String -> [a] -> TestNested
goldenEvalCatch name values = nestedGoldenVsDocM name $ ppCatch $ runPlc values