-
Notifications
You must be signed in to change notification settings - Fork 463
/
Spec.hs
221 lines (191 loc) · 9.48 KB
/
Spec.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
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Main
( main
) where
import PlutusPrelude
import Check.Spec qualified as Check
import CostModelInterface.Spec
import Evaluation.Spec (test_evaluation)
import Names.Spec
import Normalization.Check
import Normalization.Type
import Pretty.Readable
import TypeSynthesis.Spec (test_typecheck)
import PlutusCore
import PlutusCore.Generators
import PlutusCore.Generators.AST as AST
import PlutusCore.Generators.NEAT.Spec qualified as NEAT
import PlutusCore.MkPlc
import PlutusCore.Pretty
import Data.ByteString.Lazy qualified as BSL
import Data.Text qualified as T
import Data.Text.Encoding (encodeUtf8)
import Flat (flat)
import Flat qualified
import Hedgehog hiding (Var)
import Hedgehog.Gen qualified as Gen
import Hedgehog.Range qualified as Range
import Test.Tasty
import Test.Tasty.Golden
import Test.Tasty.HUnit
import Test.Tasty.Hedgehog
main :: IO ()
main = do
plcFiles <- findByExtension [".plc"] "plutus-core/test/data"
rwFiles <- findByExtension [".plc"] "plutus-core/test/scopes"
typeFiles <- findByExtension [".plc"] "plutus-core/test/types"
typeErrorFiles <- findByExtension [".plc"] "plutus-core/test/type-errors"
defaultMain (allTests plcFiles rwFiles typeFiles typeErrorFiles)
compareName :: Name -> Name -> Bool
compareName = (==) `on` nameString
compareTyName :: TyName -> TyName -> Bool
compareTyName (TyName n) (TyName n') = compareName n n'
compareTerm
:: (GEq uni, Closed uni, uni `Everywhere` Eq, Eq fun, Eq a)
=> Term TyName Name uni fun a -> Term TyName Name uni fun a -> Bool
compareTerm (Var _ n) (Var _ n') = compareName n n'
compareTerm (TyAbs _ n k t) (TyAbs _ n' k' t') = compareTyName n n' && k == k' && compareTerm t t'
compareTerm (LamAbs _ n ty t) (LamAbs _ n' ty' t') = compareName n n' && compareType ty ty' && compareTerm t t'
compareTerm (Apply _ t t'') (Apply _ t' t''') = compareTerm t t' && compareTerm t'' t'''
compareTerm (Constant _ x) (Constant _ y) = x == y
compareTerm (Builtin _ bi) (Builtin _ bi') = bi == bi'
compareTerm (TyInst _ t ty) (TyInst _ t' ty') = compareTerm t t' && compareType ty ty'
compareTerm (Unwrap _ t) (Unwrap _ t') = compareTerm t t'
compareTerm (IWrap _ pat1 arg1 t1) (IWrap _ pat2 arg2 t2) =
compareType pat1 pat2 && compareType arg1 arg2 && compareTerm t1 t2
compareTerm (Error _ ty) (Error _ ty') = compareType ty ty'
compareTerm _ _ = False
compareType
:: (GEq uni, Closed uni, uni `Everywhere` Eq, Eq a)
=> Type TyName uni a -> Type TyName uni a -> Bool
compareType (TyVar _ n) (TyVar _ n') = compareTyName n n'
compareType (TyFun _ t s) (TyFun _ t' s') = compareType t t' && compareType s s'
compareType (TyIFix _ pat1 arg1) (TyIFix _ pat2 arg2) = compareType pat1 pat2 && compareType arg1 arg2
compareType (TyForall _ n k t) (TyForall _ n' k' t') = compareTyName n n' && k == k' && compareType t t'
compareType (TyBuiltin _ x) (TyBuiltin _ y) = x == y
compareType (TyLam _ n k t) (TyLam _ n' k' t') = compareTyName n n' && k == k' && compareType t t'
compareType (TyApp _ t t') (TyApp _ t'' t''') = compareType t t'' && compareType t' t'''
compareType _ _ = False
compareProgram
:: (GEq uni, Closed uni, uni `Everywhere` Eq, Eq fun, Eq a)
=> Program TyName Name uni fun a -> Program TyName Name uni fun a -> Bool
compareProgram (Program _ v t) (Program _ v' t') = v == v' && compareTerm t t'
-- | A 'Program' which we compare using textual equality of names rather than alpha-equivalence.
newtype TextualProgram a = TextualProgram { unTextualProgram :: Program TyName Name DefaultUni DefaultFun a } deriving Show
instance Eq a => Eq (TextualProgram a) where
(TextualProgram p1) == (TextualProgram p2) = compareProgram p1 p2
propFlat :: Property
propFlat = property $ do
prog <- forAllPretty $ runAstGen genProgram
Hedgehog.tripping prog Flat.flat Flat.unflat
type DefaultError = Error DefaultUni DefaultFun SourcePos
reprint :: PrettyPlc a => a -> BSL.ByteString
reprint = BSL.fromStrict . encodeUtf8 . displayPlcDef
{-| Test that the parser can successfully consume the output from the
prettyprinter for the unit and boolean types. We use a unit test here
because there are only three possibilities (@()@, @false@, and @true@). -}
testLexConstant :: Assertion
testLexConstant =
mapM_ (\t -> (fmap void . parseTerm . reprint $ t) @?= Right t) smallConsts
where
smallConsts :: [Term TyName Name DefaultUni DefaultFun ()]
smallConsts =
[ mkConstant () ()
, mkConstant () False
, mkConstant () True
]
{- Generate constant terms for each type in the default universe. The parser should
be able to consume escape sequences in characters and strings, both standard
ASCII escape sequences and Unicode ones. Hedgehog has generators for both of
these, but the Unicode one essentially never generates anything readable: all
of the output looks like '\857811'. To get good coverage of the different
possible formats we have generators for Unicode characters and ASCII
characters, and also Latin-1 ones (characters 0-255, including standard ASCII
from 0-127); there is also a generator for UTF8-encoded Unicode. -}
-- TODO: replace PlutusCore.Generators.AST.genConstant with this. We
-- can't do that at the moment because genConstant is used by the tests for the
-- plutus-ir parser, and that can't handle the full range of constants at the
-- moment.
genConstantForTest :: AstGen (Some (ValueOf DefaultUni))
genConstantForTest = Gen.frequency
[ (3, someValue <$> pure ())
, (3, someValue <$> Gen.bool)
, (5, someValue <$> Gen.integral (Range.linear (-k1) k1)) -- Smallish Integers
, (5, someValue <$> Gen.integral (Range.linear (-k2) k2)) -- Big Integers, generally not Ints
, (10, someValue <$> Gen.text (Range.linear 0 100) Gen.ascii) -- eg "\SOc_\t\GS'v\DC4FP@-pN`\na\SI\r"
, (3, someValue <$> Gen.text (Range.linear 0 100) Gen.latin1) -- eg "\246'X\b<\195]\171Y"
, (3, someValue <$> Gen.utf8 (Range.linear 0 100) Gen.unicode) -- eg "\243\190\180\141"
, (3, someValue <$> Gen.text (Range.linear 0 100) Gen.unicode) -- eg "\1108177\609033\384623"
, (10, someValue <$> Gen.bytes (Range.linear 0 100)) -- Bytestring
]
where k1 = 1000000 :: Integer
k2 = m*m
m = fromIntegral (maxBound::Int) :: Integer
{-| Check that printing followed by parsing is the identity function on
constants. This is quite fast, so we do it 1000 times to get good coverage
of the various generators. -}
propLexConstant :: Property
propLexConstant = withTests (1000 :: Hedgehog.TestLimit) . property $ do
term <- forAllPretty $ Constant () <$> runAstGen genConstantForTest
Hedgehog.tripping term reprint (fmap void . parseTerm)
-- | Generate a random 'Program', pretty-print it, and parse the pretty-printed
-- text, hopefully returning the same thing.
propParser :: Property
propParser = property $ do
prog <- TextualProgram <$> forAllPretty (runAstGen genProgram)
Hedgehog.tripping prog (reprint . unTextualProgram)
(\p -> fmap (TextualProgram . void) $ parseProgram p)
type TestFunction = BSL.ByteString -> Either DefaultError T.Text
asIO :: TestFunction -> FilePath -> IO BSL.ByteString
asIO f = fmap (either errorgen (BSL.fromStrict . encodeUtf8) . f) . BSL.readFile
errorgen :: PrettyPlc a => a -> BSL.ByteString
errorgen = BSL.fromStrict . encodeUtf8 . displayPlcDef
asGolden :: TestFunction -> TestName -> TestTree
asGolden f file = goldenVsString file (file ++ ".golden") (asIO f file)
-- TODO: evaluation tests should go under the 'Evaluation' module,
-- normalization tests -- under 'Normalization', etc.
testsType :: [FilePath] -> TestTree
testsType = testGroup "golden type synthesis tests" . fmap (asGolden printType)
testsGolden :: [FilePath] -> TestTree
testsGolden
= testGroup "golden tests"
. fmap (asGolden (format $ defPrettyConfigPlcClassic defPrettyConfigPlcOptions))
testsRewrite :: [FilePath] -> TestTree
testsRewrite
= testGroup "golden rewrite tests"
. fmap (asGolden (format $ debugPrettyConfigPlcClassic defPrettyConfigPlcOptions))
tests :: TestTree
tests = testCase "example programs" $ fold
[ fmt "(program 0.1.0 [(builtin addInteger) x y])" @?= Right "(program 0.1.0 [ [ (builtin addInteger) x ] y ])"
, fmt "(program 0.1.0 doesn't)" @?= Right "(program 0.1.0 doesn't)"
]
where
fmt :: BSL.ByteString -> Either ParseError T.Text
fmt = format cfg
cfg = defPrettyConfigPlcClassic defPrettyConfigPlcOptions
allTests :: [FilePath] -> [FilePath] -> [FilePath] -> [FilePath] -> TestTree
allTests plcFiles rwFiles typeFiles typeErrorFiles =
testGroup "all tests"
[ tests
, testCase "lexing constants from small types" testLexConstant
, testProperty "lexing constants" propLexConstant
, testProperty "parser round-trip" propParser
, testProperty "serialization round-trip (Flat)" propFlat
, testsGolden plcFiles
, testsRewrite rwFiles
, testsType typeFiles
, testsType typeErrorFiles
, test_names
, test_Pretty
, test_typeNormalization
, test_typecheck
, test_evaluation
, test_normalizationCheck
, test_costModelInterface
, Check.tests
, NEAT.tests NEAT.defaultGenOptions
]