git.iko.soy/elk
on 8d8afda help sign in
elk/src/Validate.hs
463 lines 11 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module Validate (declarations) where
4import Control.Monad (foldM)
5import qualified Data.Map as Map
6import qualified Data.Set as Set
7import qualified Data.Foldable as F
8import qualified Data.Traversable as T
10import AST.Expression.General as Expr
11import qualified AST.Expression.Source as Source
12import qualified AST.Expression.Valid as Valid
13import qualified AST.Declaration as D
14import qualified AST.Pattern as Pattern
15import qualified AST.Type as Type
16import Elm.Utils ((|>))
17import qualified Reporting.Annotation as A
18import qualified Reporting.Error.Syntax as Error
19import qualified Reporting.Region as R
20import qualified Reporting.Result as Result
24-- COLLAPSE COMMENTS
27type Commented a =
28 A.Annotated (R.Region, Maybe (A.Located String)) a
31collapseComments
32 :: [D.CommentOr (A.Located a)]
33 -> Result.Result wrn Error.Error [Commented a]
34collapseComments listWithComments =
35 case listWithComments of
36 [] ->
37 Result.ok []
39 D.Comment msg : D.Whatever (A.A region a) : rest ->
40 let
41 entry =
42 A.A (region, Just msg) a
43 in
44 fmap (entry:) (collapseComments rest)
46 D.Comment (A.A region _) : D.Comment _ : _ ->
47 Result.throw region Error.CommentOnComment
49 [D.Comment (A.A region _)] ->
50 Result.throw region Error.CommentOnNothing
52 D.Whatever (A.A region a) : rest ->
53 let
54 entry =
55 A.A (region, Nothing) a
56 in
57 fmap (entry:) (collapseComments rest)
61-- VALIDATE STRUCTURED SOURCE
64declarations :: [D.Source] -> Result.Result wrn Error.Error [D.Valid]
65declarations sourceDecls =
66 do decls <-
67 collapseComments sourceDecls
69 validDecls <-
70 validateDecls decls
72 F.traverse_ id
73 (declDuplicates validDecls : map findBadTypeVars validDecls)
75 return validDecls
79-- VALIDATE DECLARATIONS
82validateDecls
83 :: [Commented D.Source']
84 -> Result.Result wrn Error.Error [D.Valid]
85validateDecls commentedDecls =
86 case commentedDecls of
87 [] ->
88 Result.ok []
90 A.A (region, maybeComment) decl : rest ->
91 let
92 addRest validDecl =
93 let
94 entry =
95 A.A (region, fmap A.drop maybeComment) validDecl
96 in
97 fmap (entry:) (validateDecls rest)
98 in
99 case decl of
100 D.Union name tvars ctors ->
101 addRest (D.Union name tvars ctors)
103 D.Alias name tvars alias ->
104 addRest (D.Alias name tvars alias)
106 D.Fixity assoc prec op ->
107 addRest (D.Fixity assoc prec op)
109 D.Def def ->
110 validateDeclsHelp maybeComment def rest
113validateDeclsHelp
114 :: Maybe (A.Located String)
115 -> Source.Def
116 -> [Commented D.Source']
117 -> Result.Result wrn Error.Error [D.Valid]
118validateDeclsHelp maybeComment (A.A region def) decls =
119 let
120 ann =
121 (region, fmap A.drop maybeComment)
123 makeDef pat expr maybeType =
124 D.Def (Valid.Definition pat expr maybeType)
125 in
126 case def of
127 Source.Definition pat expr ->
128 (:)
129 <$> validateDef makeDef ann pat expr Nothing
130 <*> validateDecls decls
132 Source.Annotation name tipe ->
133 case decls of
134 A.A (_, Just (A.A commentRegion _)) _ : _ ->
135 Result.throw commentRegion (Error.CommentAfterAnnotation name)
137 A.A _ (D.Def (A.A _ (Source.Definition pat expr))) : rest
138 | Pattern.isVar name pat ->
139 (:)
140 <$> validateDef makeDef ann pat expr (Just tipe)
141 <*> validateDecls rest
143 _ ->
144 Result.throw region (Error.TypeWithoutDefinition name)
148-- VALIDATE DEFINITIONS
151definitions :: [Source.Def] -> Result.Result wrn Error.Error [Valid.Def]
152definitions sourceDefs =
153 do validDefs <- definitionsHelp sourceDefs
154 let patterns = map (\(Valid.Definition p _ _) -> p) validDefs
155 defDuplicates patterns
156 return validDefs
159definitionsHelp :: [Source.Def] -> Result.Result wrn Error.Error [Valid.Def]
160definitionsHelp sourceDefs =
161 case sourceDefs of
162 [] ->
163 return []
165 A.A region (Source.Definition pat expr) : rest ->
166 (:)
167 <$> fmap A.drop (validateDef Valid.Definition region pat expr Nothing)
168 <*> definitionsHelp rest
170 A.A r1 (Source.Annotation name tipe) : rest ->
171 case rest of
172 A.A r2 (Source.Definition pat expr) : rest'
173 | Pattern.isVar name pat ->
174 (:)
175 <$> fmap A.drop (validateDef Valid.Definition (R.merge r1 r2) pat expr (Just tipe))
176 <*> definitionsHelp rest'
178 _ ->
179 Result.throw r1 (Error.TypeWithoutDefinition name)
182validateDef
183 :: (Pattern.Raw -> Valid.Expr -> Maybe Type.Raw -> def)
184 -> annotation
185 -> Pattern.Raw
186 -> Source.Expr
187 -> Maybe Type.Raw
188 -> Result.Result wrn Error.Error (A.Annotated annotation def)
189validateDef makeDef annotation pat expr maybeType =
190 do validExpr <- expression expr
191 validateDefPattern pat validExpr
192 return $ A.A annotation (makeDef pat validExpr maybeType)
195validateDefPattern :: Pattern.Raw -> Valid.Expr -> Result.Result wrn Error.Error ()
196validateDefPattern pattern body =
197 case fst (Expr.collectLambdas body) of
198 [] ->
199 return ()
201 args ->
202 case pattern of
203 A.A _ (Pattern.Var _) ->
204 return ()
206 _ ->
207 let
208 (A.A start _) = pattern
209 (A.A end _) = last args
210 in
211 Result.throw (R.merge start end) (Error.BadFunctionName (length args))
215-- VALIDATE EXPRESSIONS
218expression :: Source.Expr -> Result.Result wrn Error.Error Valid.Expr
219expression (A.A ann sourceExpression) =
220 A.A ann <$>
221 case sourceExpression of
222 Var x ->
223 return (Var x)
225 Lambda pattern body ->
226 Lambda
227 <$> validatePattern pattern
228 <*> expression body
230 Binop op leftExpr rightExpr ->
231 Binop op
232 <$> expression leftExpr
233 <*> expression rightExpr
235 Case e branches ->
236 Case
237 <$> expression e
238 <*> T.traverse (\(p,b) -> (,) <$> validatePattern p <*> expression b) branches
240 Data name args ->
241 Data name <$> T.traverse expression args
243 Literal lit ->
244 return (Literal lit)
246 Range lowExpr highExpr ->
247 Range
248 <$> expression lowExpr
249 <*> expression highExpr
251 ExplicitList expressions ->
252 ExplicitList
253 <$> T.traverse expression expressions
255 App funcExpr argExpr ->
256 App
257 <$> expression funcExpr
258 <*> expression argExpr
260 If branches finally ->
261 If
262 <$> T.traverse both branches
263 <*> expression finally
265 Access record field ->
266 Access
267 <$> expression record
268 <*> return field
270 Update record fields ->
271 Update
272 <$> expression record
273 <*> T.traverse second fields
275 Record fields ->
276 let
277 checkDups seenFields (field,_) =
278 if Set.member field seenFields then
279 Result.throw ann (Error.DuplicateFieldName field)
281 else
282 return (Set.insert field seenFields)
283 in
284 do _ <- foldM checkDups Set.empty fields
285 Record <$> T.traverse second fields
287 Let defs body ->
288 Let
289 <$> definitions defs
290 <*> expression body
292 GLShader uid src gltipe ->
293 return (GLShader uid src gltipe)
296second :: (a, Source.Expr) -> Result.Result wrn Error.Error (a, Valid.Expr)
297second (value, expr) =
298 (,) value <$> expression expr
301both
302 :: (Source.Expr, Source.Expr)
303 -> Result.Result wrn Error.Error (Valid.Expr, Valid.Expr)
304both (expr1, expr2) =
305 (,) <$> expression expr1 <*> expression expr2
309-- VALIDATE PATTERNS
312validatePattern :: Pattern.Raw -> Result.Result wrn Error.Error Pattern.Raw
313validatePattern pattern =
314 do detectDuplicates Error.BadPattern (Pattern.boundVars pattern)
315 return pattern
319-- DETECT DUPLICATES
322detectDuplicates
323 :: (String -> Error.Error)
324 -> [A.Located String]
325 -> Result.Result wrn Error.Error ()
326detectDuplicates tag names =
327 let add (A.A region name) dict =
328 Map.insertWith (++) name [region] dict
330 makeGroups pairs =
331 Map.toList (foldr add Map.empty pairs)
333 check (name, regions) =
334 case regions of
335 _ : region : _ ->
336 Result.throw region (tag name)
338 _ ->
339 return ()
340 in
341 F.traverse_ check (makeGroups names)
344defDuplicates :: [Pattern.Raw] -> Result.Result wrn Error.Error ()
345defDuplicates patterns =
346 concatMap Pattern.boundVars patterns
347 |> detectDuplicates Error.DuplicateDefinition
350declDuplicates :: [D.Valid] -> Result.Result wrn Error.Error ()
351declDuplicates decls =
352 let
353 (valueLists, typeLists) =
354 unzip (map extractValues decls)
355 in
356 (\_ _ -> ())
357 <$> detectDuplicates Error.DuplicateValueDeclaration (concat valueLists)
358 <*> detectDuplicates Error.DuplicateTypeDeclaration (concat typeLists)
361extractValues :: D.Valid -> ([A.Located String], [A.Located String])
362extractValues (A.A (region, _) decl) =
363 case decl of
364 D.Def (Valid.Definition pattern _ _) ->
365 ( Pattern.boundVars pattern
366 , []
367 )
369 D.Union name _ ctors ->
370 ( map (A.A region . fst) ctors
371 , [A.A region name]
372 )
374 D.Alias name _ (A.A _ (Type.RRecord _ _)) ->
375 ( [A.A region name]
376 , [A.A region name]
377 )
379 D.Alias name _ _ ->
380 ( []
381 , [A.A region name]
382 )
384 D.Fixity _ _ _ ->
385 ( []
386 , []
387 )
391-- UNBOUND TYPE VARIABLES
394findBadTypeVars :: D.Valid -> Result.Result wrn Error.Error ()
395findBadTypeVars (A.A (region,_) decl) =
396 case decl of
397 D.Def _ ->
398 return ()
400 D.Union name boundVars ctors ->
401 case diff boundVars (concatMap freeVars (concatMap snd ctors)) of
402 (_, []) ->
403 return ()
405 (_, unbound) ->
406 Result.throw region
407 (Error.UnboundTypeVarsInUnion name boundVars unbound)
409 D.Alias name boundVars tipe ->
410 case diff boundVars (freeVars tipe) of
411 ([], []) ->
412 return ()
414 ([], unbound) ->
415 Result.throw region
416 (Error.UnboundTypeVarsInAlias name boundVars unbound)
418 (unused, []) ->
419 Result.throw region
420 (Error.UnusedTypeVarsInAlias name boundVars unused)
422 (unused, unbound) ->
423 Result.throw region
424 (Error.MessyTypeVarsInAlias name boundVars unused unbound)
426 D.Fixity _ _ _ ->
427 return ()
430diff :: [String] -> [A.Located String] -> ([String], [String])
431diff left right =
432 let
433 leftSet =
434 Set.fromList left
436 rightSet =
437 Set.fromList (map A.drop right)
438 in
439 ( Set.toList (Set.difference leftSet rightSet)
440 , Set.toList (Set.difference rightSet leftSet)
441 )
445freeVars :: Type.Raw -> [A.Located String]
446freeVars (A.A region tipe) =
447 case tipe of
448 Type.RLambda t1 t2 ->
449 freeVars t1 ++ freeVars t2
451 Type.RVar x ->
452 [A.A region x]
454 Type.RType _ ->
455 []
457 Type.RApp t ts ->
458 concatMap freeVars (t:ts)
460 Type.RRecord fields ext ->
461 maybe [] freeVars ext
462 ++ concatMap (freeVars . snd) fields