git.iko.soy/elk
on bbb6583 help sign in
elk/src/Validate.hs
580 lines 14 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module Validate (module') 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.Module as Module
15import qualified AST.Module.Name as ModuleName
16import qualified AST.Pattern as Pattern
17import qualified AST.Type as Type
18import qualified Elm.Compiler.Imports as Imports
19import qualified Elm.Package as Package
20import Elm.Utils ((|>))
21import qualified Reporting.Annotation as A
22import qualified Reporting.Error.Syntax as Error
23import qualified Reporting.Region as R
24import qualified Reporting.Result as Result
28-- MODULES
31module' :: Module.Source -> Result.Result wrn Error.Error Module.Valid
32module' (Module.Module name path info) =
33 let
34 (ModuleName.Canonical pkgName _) =
35 name
37 (Module.Source tag settings docs exports imports decls) =
38 info
39 in
40 do validEffects <- validateModuleDecl tag settings
41 validDecls <- declarations decls
43 return $ Module.Module name path $
44 Module.Valid docs exports (addDefaults pkgName imports) validDecls validEffects
47-- determine if default imports should be added, only elm-lang/core is exempt
48addDefaults
49 :: Package.Name
50 -> [Module.UserImport]
51 -> ([Module.DefaultImport], [Module.UserImport])
52addDefaults pkgName imports =
53 flip (,) imports $
54 if pkgName == Package.coreName then
55 []
57 else
58 Imports.defaults
61validateModuleDecl
62 :: Module.SourceTag
63 -> Module.SourceSettings
64 -> Result.Result wrn Error.Error Module.ValidEffects
65validateModuleDecl tag settings =
66 case tag of
67 Module.SrcNormal ->
68 do noSettings Error.SettingsOnNormalModule settings
69 return Module.ValidNormal
71 Module.SrcForeign ->
72 do noSettings Error.SettingsOnForeignModule settings
73 return Module.ValidForeign
75 Module.SrcEffect ->
76 gatherEffectSettings settings
79noSettings
80 :: Error.Error
81 -> Module.SourceSettings
82 -> Result.Result wrn Error.Error ()
83noSettings errorMsg (A.A region settings) =
84 case settings of
85 [] ->
86 Result.ok ()
88 _ : _ ->
89 Result.throw region errorMsg
92gatherEffectSettings
93 :: Module.SourceSettings
94 -> Result.Result wrn Error.Error Module.ValidEffects
95gatherEffectSettings (A.A _ pairs) =
96 uncurry Module.ValidEffect <$>
97 gatherEffectSettingsHelp (Nothing, Nothing) pairs
100type Effects =
101 (Maybe (A.Located String), Maybe (A.Located String))
104gatherEffectSettingsHelp
105 :: Effects
106 -> [(A.Located String, A.Located String)]
107 -> Result.Result wrn Error.Error Effects
108gatherEffectSettingsHelp effects@(maybeCmd, maybeSub) pairs =
109 case pairs of
110 [] ->
111 Result.ok effects
113 (A.A region name, effect) : rest ->
114 case name of
115 "command" ->
116 case maybeCmd of
117 Nothing ->
118 gatherEffectSettingsHelp (Just effect, maybeSub) rest
120 Just _ ->
121 Result.throw region (Error.DuplicateSettingOnEffectModule name)
123 "subscription" ->
124 case maybeSub of
125 Nothing ->
126 gatherEffectSettingsHelp (maybeCmd, Just effect) rest
128 Just _ ->
129 Result.throw region (Error.DuplicateSettingOnEffectModule name)
131 _ ->
132 Result.throw region (Error.BadSettingOnEffectModule name)
136-- COLLAPSE COMMENTS
139type Commented a =
140 A.Annotated (R.Region, Maybe (A.Located String)) a
143collapseComments
144 :: [D.CommentOr (A.Located a)]
145 -> Result.Result wrn Error.Error [Commented a]
146collapseComments listWithComments =
147 case listWithComments of
148 [] ->
149 Result.ok []
151 D.Comment msg : D.Whatever (A.A region a) : rest ->
152 let
153 entry =
154 A.A (region, Just msg) a
155 in
156 fmap (entry:) (collapseComments rest)
158 D.Comment (A.A region _) : D.Comment _ : _ ->
159 Result.throw region Error.CommentOnComment
161 [D.Comment (A.A region _)] ->
162 Result.throw region Error.CommentOnNothing
164 D.Whatever (A.A region a) : rest ->
165 let
166 entry =
167 A.A (region, Nothing) a
168 in
169 fmap (entry:) (collapseComments rest)
173-- VALIDATE STRUCTURED SOURCE
176declarations :: [D.Source] -> Result.Result wrn Error.Error [D.Valid]
177declarations sourceDecls =
178 do decls <-
179 collapseComments sourceDecls
181 validDecls <-
182 validateDecls decls
184 F.traverse_ id
185 (declDuplicates validDecls : map findBadTypeVars validDecls)
187 return validDecls
191-- VALIDATE DECLARATIONS
194validateDecls
195 :: [Commented D.Source']
196 -> Result.Result wrn Error.Error [D.Valid]
197validateDecls commentedDecls =
198 case commentedDecls of
199 [] ->
200 Result.ok []
202 A.A (region, maybeComment) decl : rest ->
203 let
204 addRest validDecl =
205 let
206 entry =
207 A.A (region, fmap A.drop maybeComment) validDecl
208 in
209 fmap (entry:) (validateDecls rest)
210 in
211 case decl of
212 D.Union name tvars ctors ->
213 addRest (D.Union name tvars ctors)
215 D.Alias name tvars alias ->
216 addRest (D.Alias name tvars alias)
218 D.Fixity assoc prec op ->
219 addRest (D.Fixity assoc prec op)
221 D.Def def ->
222 validateDeclsHelp maybeComment def rest
225validateDeclsHelp
226 :: Maybe (A.Located String)
227 -> Source.Def
228 -> [Commented D.Source']
229 -> Result.Result wrn Error.Error [D.Valid]
230validateDeclsHelp maybeComment (A.A region def) decls =
231 let
232 ann =
233 (region, fmap A.drop maybeComment)
235 makeDef pat expr maybeType =
236 D.Def (Valid.Definition pat expr maybeType)
237 in
238 case def of
239 Source.Definition pat expr ->
240 (:)
241 <$> validateDef makeDef ann pat expr Nothing
242 <*> validateDecls decls
244 Source.Annotation name tipe ->
245 case decls of
246 A.A (_, Just (A.A commentRegion _)) _ : _ ->
247 Result.throw commentRegion (Error.CommentAfterAnnotation name)
249 A.A _ (D.Def (A.A _ (Source.Definition pat expr))) : rest
250 | Pattern.isVar name pat ->
251 (:)
252 <$> validateDef makeDef ann pat expr (Just tipe)
253 <*> validateDecls rest
255 _ ->
256 Result.throw region (Error.TypeWithoutDefinition name)
260-- VALIDATE DEFINITIONS
263definitions :: [Source.Def] -> Result.Result wrn Error.Error [Valid.Def]
264definitions sourceDefs =
265 do validDefs <- definitionsHelp sourceDefs
266 let patterns = map (\(Valid.Definition p _ _) -> p) validDefs
267 defDuplicates patterns
268 return validDefs
271definitionsHelp :: [Source.Def] -> Result.Result wrn Error.Error [Valid.Def]
272definitionsHelp sourceDefs =
273 case sourceDefs of
274 [] ->
275 return []
277 A.A region (Source.Definition pat expr) : rest ->
278 (:)
279 <$> fmap A.drop (validateDef Valid.Definition region pat expr Nothing)
280 <*> definitionsHelp rest
282 A.A r1 (Source.Annotation name tipe) : rest ->
283 case rest of
284 A.A r2 (Source.Definition pat expr) : rest'
285 | Pattern.isVar name pat ->
286 (:)
287 <$> fmap A.drop (validateDef Valid.Definition (R.merge r1 r2) pat expr (Just tipe))
288 <*> definitionsHelp rest'
290 _ ->
291 Result.throw r1 (Error.TypeWithoutDefinition name)
294validateDef
295 :: (Pattern.Raw -> Valid.Expr -> Maybe Type.Raw -> def)
296 -> annotation
297 -> Pattern.Raw
298 -> Source.Expr
299 -> Maybe Type.Raw
300 -> Result.Result wrn Error.Error (A.Annotated annotation def)
301validateDef makeDef annotation pat expr maybeType =
302 do validExpr <- expression expr
303 validateDefPattern pat validExpr
304 return $ A.A annotation (makeDef pat validExpr maybeType)
307validateDefPattern :: Pattern.Raw -> Valid.Expr -> Result.Result wrn Error.Error ()
308validateDefPattern pattern body =
309 case fst (Expr.collectLambdas body) of
310 [] ->
311 return ()
313 args ->
314 case pattern of
315 A.A _ (Pattern.Var _) ->
316 return ()
318 _ ->
319 let
320 (A.A start _) = pattern
321 (A.A end _) = last args
322 in
323 Result.throw (R.merge start end) (Error.BadFunctionName (length args))
327-- VALIDATE EXPRESSIONS
330expression :: Source.Expr -> Result.Result wrn Error.Error Valid.Expr
331expression (A.A ann sourceExpression) =
332 A.A ann <$>
333 case sourceExpression of
334 Var x ->
335 return (Var x)
337 Lambda pattern body ->
338 Lambda
339 <$> validatePattern pattern
340 <*> expression body
342 Binop op leftExpr rightExpr ->
343 Binop op
344 <$> expression leftExpr
345 <*> expression rightExpr
347 Case e branches ->
348 Case
349 <$> expression e
350 <*> T.traverse (\(p,b) -> (,) <$> validatePattern p <*> expression b) branches
352 Data name args ->
353 Data name <$> T.traverse expression args
355 Literal lit ->
356 return (Literal lit)
358 Range lowExpr highExpr ->
359 Range
360 <$> expression lowExpr
361 <*> expression highExpr
363 ExplicitList expressions ->
364 ExplicitList
365 <$> T.traverse expression expressions
367 App funcExpr argExpr ->
368 App
369 <$> expression funcExpr
370 <*> expression argExpr
372 If branches finally ->
373 If
374 <$> T.traverse both branches
375 <*> expression finally
377 Access record field ->
378 Access
379 <$> expression record
380 <*> return field
382 Update record fields ->
383 Update
384 <$> expression record
385 <*> T.traverse second fields
387 Record fields ->
388 let
389 checkDups seenFields (field,_) =
390 if Set.member field seenFields then
391 Result.throw ann (Error.DuplicateFieldName field)
393 else
394 return (Set.insert field seenFields)
395 in
396 do _ <- foldM checkDups Set.empty fields
397 Record <$> T.traverse second fields
399 Let defs body ->
400 Let
401 <$> definitions defs
402 <*> expression body
404 Cmd moduleName typeName ->
405 return (Cmd moduleName typeName)
407 Sub moduleName typeName ->
408 return (Sub moduleName typeName)
410 GLShader uid src gltipe ->
411 return (GLShader uid src gltipe)
414second :: (a, Source.Expr) -> Result.Result wrn Error.Error (a, Valid.Expr)
415second (value, expr) =
416 (,) value <$> expression expr
419both
420 :: (Source.Expr, Source.Expr)
421 -> Result.Result wrn Error.Error (Valid.Expr, Valid.Expr)
422both (expr1, expr2) =
423 (,) <$> expression expr1 <*> expression expr2
427-- VALIDATE PATTERNS
430validatePattern :: Pattern.Raw -> Result.Result wrn Error.Error Pattern.Raw
431validatePattern pattern =
432 do detectDuplicates Error.BadPattern (Pattern.boundVars pattern)
433 return pattern
437-- DETECT DUPLICATES
440detectDuplicates
441 :: (String -> Error.Error)
442 -> [A.Located String]
443 -> Result.Result wrn Error.Error ()
444detectDuplicates tag names =
445 let add (A.A region name) dict =
446 Map.insertWith (++) name [region] dict
448 makeGroups pairs =
449 Map.toList (foldr add Map.empty pairs)
451 check (name, regions) =
452 case regions of
453 _ : region : _ ->
454 Result.throw region (tag name)
456 _ ->
457 return ()
458 in
459 F.traverse_ check (makeGroups names)
462defDuplicates :: [Pattern.Raw] -> Result.Result wrn Error.Error ()
463defDuplicates patterns =
464 concatMap Pattern.boundVars patterns
465 |> detectDuplicates Error.DuplicateDefinition
468declDuplicates :: [D.Valid] -> Result.Result wrn Error.Error ()
469declDuplicates decls =
470 let
471 (valueLists, typeLists) =
472 unzip (map extractValues decls)
473 in
474 (\_ _ -> ())
475 <$> detectDuplicates Error.DuplicateValueDeclaration (concat valueLists)
476 <*> detectDuplicates Error.DuplicateTypeDeclaration (concat typeLists)
479extractValues :: D.Valid -> ([A.Located String], [A.Located String])
480extractValues (A.A (region, _) decl) =
481 case decl of
482 D.Def (Valid.Definition pattern _ _) ->
483 ( Pattern.boundVars pattern
484 , []
485 )
487 D.Union name _ ctors ->
488 ( map (A.A region . fst) ctors
489 , [A.A region name]
490 )
492 D.Alias name _ (A.A _ (Type.RRecord _ _)) ->
493 ( [A.A region name]
494 , [A.A region name]
495 )
497 D.Alias name _ _ ->
498 ( []
499 , [A.A region name]
500 )
502 D.Fixity _ _ _ ->
503 ( []
504 , []
505 )
509-- UNBOUND TYPE VARIABLES
512findBadTypeVars :: D.Valid -> Result.Result wrn Error.Error ()
513findBadTypeVars (A.A (region,_) decl) =
514 case decl of
515 D.Def _ ->
516 return ()
518 D.Union name boundVars ctors ->
519 case diff boundVars (concatMap freeVars (concatMap snd ctors)) of
520 (_, []) ->
521 return ()
523 (_, unbound) ->
524 Result.throw region
525 (Error.UnboundTypeVarsInUnion name boundVars unbound)
527 D.Alias name boundVars tipe ->
528 case diff boundVars (freeVars tipe) of
529 ([], []) ->
530 return ()
532 ([], unbound) ->
533 Result.throw region
534 (Error.UnboundTypeVarsInAlias name boundVars unbound)
536 (unused, []) ->
537 Result.throw region
538 (Error.UnusedTypeVarsInAlias name boundVars unused)
540 (unused, unbound) ->
541 Result.throw region
542 (Error.MessyTypeVarsInAlias name boundVars unused unbound)
544 D.Fixity _ _ _ ->
545 return ()
548diff :: [String] -> [A.Located String] -> ([String], [String])
549diff left right =
550 let
551 leftSet =
552 Set.fromList left
554 rightSet =
555 Set.fromList (map A.drop right)
556 in
557 ( Set.toList (Set.difference leftSet rightSet)
558 , Set.toList (Set.difference rightSet leftSet)
559 )
563freeVars :: Type.Raw -> [A.Located String]
564freeVars (A.A region tipe) =
565 case tipe of
566 Type.RLambda t1 t2 ->
567 freeVars t1 ++ freeVars t2
569 Type.RVar x ->
570 [A.A region x]
572 Type.RType _ ->
573 []
575 Type.RApp t ts ->
576 concatMap freeVars (t:ts)
578 Type.RRecord fields ext ->
579 maybe [] freeVars ext
580 ++ concatMap (freeVars . snd) fields