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
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Language.Futhark.SyntaxTests (tests) where
import Control.Applicative hiding (many, some)
import Data.Bifunctor
import Data.Char (isAlpha)
import Data.Functor
import Data.Map qualified as M
import Data.String
import Data.Text qualified as T
import Data.Void
import Language.Futhark
import Language.Futhark.Parser (SyntaxError (syntaxErrorMsg), parseExp, parseType)
import Language.Futhark.Primitive.Parse (constituent, keyword, lexeme)
import Language.Futhark.PrimitiveTests ()
import Test.QuickCheck
import Test.Tasty
import Text.Megaparsec
import Text.Megaparsec.Char.Lexer qualified as L
import Prelude
tests :: TestTree
tests = testGroup "Source SyntaxTests" []
instance Arbitrary BinOp where
arbitrary = elements [minBound .. maxBound]
instance Arbitrary Uniqueness where
arbitrary = elements [Unique, Nonunique]
instance Arbitrary PrimType where
arbitrary =
oneof
[ Signed <$> arbitrary,
Unsigned <$> arbitrary,
FloatType <$> arbitrary,
pure Bool
]
instance Arbitrary PrimValue where
arbitrary =
oneof
[ SignedValue <$> arbitrary,
UnsignedValue <$> arbitrary,
FloatValue <$> arbitrary,
BoolValue <$> arbitrary
]
-- The following dirty instances make it slightly nicer to write unit tests.
instance IsString VName where
fromString s =
let (s', '_' : tag) = span (/= '_') s
in VName (fromString s') (read tag)
instance (IsString v) => IsString (QualName v) where
fromString = QualName [] . fromString
instance IsString UncheckedTypeExp where
fromString =
either (error . T.unpack . syntaxErrorMsg) id
. parseType "IsString UncheckedTypeExp"
. fromString
type Parser = Parsec Void T.Text
braces, brackets, parens :: Parser a -> Parser a
braces = between (lexeme "{") (lexeme "}")
brackets = between (lexeme "[") (lexeme "]")
parens = between (lexeme "(") (lexeme ")")
pName :: Parser Name
pName =
lexeme . fmap nameFromString $
(:) <$> satisfy isAlpha <*> many (satisfy constituent)
pVName :: Parser VName
pVName = lexeme $ do
(s, tag) <-
satisfy constituent
`manyTill_` try pTag
<?> "variable name"
pure $ VName (nameFromString s) tag
where
pTag =
"_" *> L.decimal <* notFollowedBy (satisfy constituent)
pQualName :: Parser (QualName VName)
pQualName = QualName [] <$> pVName
pPrimType :: Parser PrimType
pPrimType =
choice $
map
f
[ Bool,
Signed Int8,
Signed Int16,
Signed Int32,
Signed Int64,
Unsigned Int8,
Unsigned Int16,
Unsigned Int32,
Unsigned Int64,
FloatType Float32,
FloatType Float64
]
where
f t = keyword (prettyText t) $> t
pUniqueness :: Parser Uniqueness
pUniqueness = choice [lexeme "*" $> Unique, pure Nonunique]
pSize :: Parser Size
pSize =
brackets $
choice
[ flip sizeFromInteger mempty <$> lexeme L.decimal,
flip sizeFromName mempty <$> pQualName
]
pScalarNonFun :: Parser (ScalarTypeBase Size Uniqueness)
pScalarNonFun =
choice
[ Prim <$> pPrimType,
pTypeVar,
tupleRecord <$> parens (pType `sepBy` lexeme ","),
Record . M.fromList <$> braces (pField `sepBy1` lexeme ",")
]
where
pField = (,) <$> pName <* lexeme ":" <*> pType
pTypeVar = TypeVar <$> pUniqueness <*> pQualName <*> many pTypeArg
pTypeArg =
choice
[ TypeArgDim <$> pSize,
TypeArgType . second (const NoUniqueness) <$> pTypeArgType
]
pTypeArgType =
choice
[ Scalar . Prim <$> pPrimType,
parens pType
]
pArrayType :: Parser ResType
pArrayType =
Array
<$> pUniqueness
<*> (Shape <$> some pSize)
<*> (second (const NoUniqueness) <$> pScalarNonFun)
pNonFunType :: Parser ResType
pNonFunType =
choice
[ try pArrayType,
try $ parens pType,
Scalar <$> pScalarNonFun
]
pScalarType :: Parser (ScalarTypeBase Size Uniqueness)
pScalarType = choice [try pFun, pScalarNonFun]
where
pFun =
pParam <* lexeme "->" <*> pRetType
pParam =
choice
[ try pNamedParam,
do
t <- pNonFunType
pure $ Arrow Nonunique Unnamed (diet $ resToParam t) (toStruct t)
]
pNamedParam = parens $ do
v <- pVName <* lexeme ":"
t <- pType
pure $ Arrow Nonunique (Named v) (diet $ resToParam t) (toStruct t)
pRetType :: Parser ResRetType
pRetType =
choice
[ lexeme "?" *> (RetType <$> some (brackets pVName) <* lexeme "." <*> pType),
RetType [] <$> pType
]
pType :: Parser ResType
pType =
choice [try $ Scalar <$> pScalarType, pArrayType, parens pType]
fromStringParse :: Parser a -> String -> String -> a
fromStringParse p what s =
either onError id $ parse (p <* eof) "" (T.pack s)
where
onError e =
error $ "not a " <> what <> ": " <> s <> "\n" <> errorBundlePretty e
instance IsString (ScalarTypeBase Size NoUniqueness) where
fromString =
fromStringParse (second (const NoUniqueness) <$> pScalarType) "ScalarType"
instance IsString StructType where
fromString =
fromStringParse (second (const NoUniqueness) <$> pType) "StructType"
instance IsString StructRetType where
fromString =
fromStringParse (second (pure NoUniqueness) <$> pRetType) "StructRetType"
instance IsString ResRetType where
fromString = fromStringParse pRetType "ResRetType"
instance IsString UncheckedExp where
fromString = either (error . T.unpack . syntaxErrorMsg) id . parseExp "string literal" . T.pack
|
