git.iko.soy/elk
on 0d58dee help sign in
elk/src/Validate.hs
667 lines 17 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module Validate (module') where
4import Control.Monad (foldM, when)
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.Effects as Fx
12import qualified AST.Expression.Source as Source
13import qualified AST.Expression.Valid as Valid
14import qualified AST.Declaration as D
15import qualified AST.Module as Module
16import qualified AST.Module.Name as ModuleName
17import qualified AST.Pattern as Pattern
18import qualified AST.Type as Type
19import qualified Elm.Compiler.Imports as Imports
20import qualified Elm.Package as Package
21import Elm.Utils ((|>))
22import qualified Reporting.Annotation as A
23import qualified Reporting.Error.Syntax as Error
24import qualified Reporting.Region as R
25import qualified Reporting.Result as Result
29-- MODULES
32module' :: Module.Source -> Result.Result wrn Error.Error Module.Valid
33module' (Module.Module name path info) =
34 let
35 (ModuleName.Canonical pkgName _) =
36 name
38 (Module.Source tag settings docs exports imports decls) =
39 info
40 in
41 do validDecls <- declarations decls
42 validEffects <- validateEffects tag settings validDecls
44 return $ Module.Module name path $
45 Module.Valid docs exports (addDefaults pkgName imports) validDecls validEffects
49-- IMPORTS
52addDefaults
53 :: Package.Name
54 -> [Module.UserImport]
55 -> ([Module.DefaultImport], [Module.UserImport])
56addDefaults pkgName imports =
57 flip (,) imports $
58 if pkgName == Package.coreName then
59 []
61 else
62 Imports.defaults
66-- EFFECTS
69validateEffects
70 :: Module.SourceTag
71 -> Module.SourceSettings
72 -> [D.Valid]
73 -> Result.Result wrn Error.Error Fx.Effects
74validateEffects tag settings@(A.A _ pairs) decls =
75 case tag of
76 Module.Normal ->
77 do noSettings Error.SettingsOnNormalModule settings
78 return Fx.None
80 Module.Foreign _ ->
81 do noSettings Error.SettingsOnForeignModule settings
82 return Fx.Foreign
84 Module.Effect tagRegion ->
85 let
86 collectSettings (A.A region setting, userValue) dict =
87 Map.insertWith (++) setting [(region, userValue)] dict
89 settingsDict =
90 foldr collectSettings Map.empty pairs
91 in
92 do managerType <- toManagerType tagRegion settingsDict
93 (r0, r1, r2) <- getManagerRegions tagRegion Nothing Nothing Nothing decls
94 return (Fx.Effect (Fx.Info tagRegion r0 r1 r2 managerType))
97noSettings
98 :: Error.Error
99 -> Module.SourceSettings
100 -> Result.Result wrn Error.Error ()
101noSettings errorMsg (A.A region settings) =
102 case settings of
103 [] ->
104 Result.ok ()
106 _ : _ ->
107 Result.throw region errorMsg
110toManagerType
111 :: R.Region
112 -> Map.Map String [(R.Region, A.Located String)]
113 -> Result.Result wrn Error.Error Fx.ManagerType
114toManagerType tagRegion settingsDict =
115 let
116 toErrors name entries =
117 map (\entry -> A.A (fst entry) (Error.BadSettingOnEffectModule name)) entries
119 errors =
120 settingsDict
121 |> Map.delete "command"
122 |> Map.delete "subscription"
123 |> Map.mapWithKey toErrors
124 |> Map.elems
125 |> concat
126 in
127 do when (not (null errors)) (Result.throwMany errors)
128 maybeEffects <-
129 (,) <$> extractOne "command" settingsDict
130 <*> extractOne "subscription" settingsDict
132 case maybeEffects of
133 (Nothing, Nothing) ->
134 Result.throw tagRegion Error.NoSettingsOnEffectModule
136 (Just cmd, Nothing) ->
137 return (Fx.CmdManager cmd)
139 (Nothing, Just sub) ->
140 return (Fx.SubManager sub)
142 (Just cmd, Just sub) ->
143 return (Fx.FxManager cmd sub)
146extractOne
147 :: String
148 -> Map.Map String [(R.Region, A.Located String)]
149 -> Result.Result w Error.Error (Maybe (A.Located String))
150extractOne name settingsDict =
151 case Map.lookup name settingsDict of
152 Nothing ->
153 return Nothing
155 Just [] ->
156 error "Empty lists should never be added to the dictionary of effect module settings."
158 Just [(_, userType)] ->
159 return (Just userType)
161 Just ((region, _) : _) ->
162 Result.throw region (Error.DuplicateSettingOnEffectModule name)
166-- EFFECT REGIONS
169getManagerRegions
170 :: R.Region
171 -> Maybe R.Region
172 -> Maybe R.Region
173 -> Maybe R.Region
174 -> [D.Valid]
175 -> Result.Result w Error.Error (R.Region, R.Region, R.Region)
176getManagerRegions tagRegion r0 r1 r2 decls =
177 case decls of
178 [] ->
179 (,,)
180 <$> requireRegion tagRegion "init" r0
181 <*> requireRegion tagRegion "onEffects" r1
182 <*> requireRegion tagRegion "onSelfMsg" r2
184 decl : rest ->
185 case getDefInfo decl of
186 Just ("init", region) ->
187 getManagerRegions tagRegion (Just region) r1 r2 rest
189 Just ("onEffects", region) ->
190 getManagerRegions tagRegion r0 (Just region) r2 rest
192 Just ("onSelfMsg", region) ->
193 getManagerRegions tagRegion r0 r1 (Just region) rest
195 _ ->
196 getManagerRegions tagRegion r0 r1 r2 rest
199getDefInfo :: D.Valid -> Maybe (String, R.Region)
200getDefInfo decl =
201 case decl of
202 A.A region (D.Def (Valid.Definition (A.A _ (Pattern.Var name)) _ _)) ->
203 Just (name, fst region)
205 _ ->
206 Nothing
209requireRegion :: R.Region -> String -> Maybe R.Region -> Result.Result w Error.Error R.Region
210requireRegion tagRegion name maybeRegion =
211 case maybeRegion of
212 Just region ->
213 return region
215 Nothing ->
216 Result.throw tagRegion (Error.MissingManagerOnEffectModule name)
220-- COLLAPSE COMMENTS
223type Commented a =
224 A.Annotated (R.Region, Maybe (A.Located String)) a
227collapseComments
228 :: [D.CommentOr (A.Located a)]
229 -> Result.Result wrn Error.Error [Commented a]
230collapseComments listWithComments =
231 case listWithComments of
232 [] ->
233 Result.ok []
235 D.Comment msg : D.Whatever (A.A region a) : rest ->
236 let
237 entry =
238 A.A (region, Just msg) a
239 in
240 fmap (entry:) (collapseComments rest)
242 D.Comment (A.A region _) : D.Comment _ : _ ->
243 Result.throw region Error.CommentOnComment
245 [D.Comment (A.A region _)] ->
246 Result.throw region Error.CommentOnNothing
248 D.Whatever (A.A region a) : rest ->
249 let
250 entry =
251 A.A (region, Nothing) a
252 in
253 fmap (entry:) (collapseComments rest)
257-- VALIDATE STRUCTURED SOURCE
260declarations :: [D.Source] -> Result.Result wrn Error.Error [D.Valid]
261declarations sourceDecls =
262 do decls <-
263 collapseComments sourceDecls
265 validDecls <-
266 validateDecls decls
268 F.traverse_ id
269 (declDuplicates validDecls : map findBadTypeVars validDecls)
271 return validDecls
275-- VALIDATE DECLARATIONS
278validateDecls
279 :: [Commented D.Source']
280 -> Result.Result wrn Error.Error [D.Valid]
281validateDecls commentedDecls =
282 case commentedDecls of
283 [] ->
284 Result.ok []
286 A.A (region, maybeComment) decl : rest ->
287 let
288 addRest validDecl =
289 let
290 entry =
291 A.A (region, fmap A.drop maybeComment) validDecl
292 in
293 fmap (entry:) (validateDecls rest)
294 in
295 case decl of
296 D.Union name tvars ctors ->
297 addRest (D.Union name tvars ctors)
299 D.Alias name tvars alias ->
300 addRest (D.Alias name tvars alias)
302 D.Fixity assoc prec op ->
303 addRest (D.Fixity assoc prec op)
305 D.Def def ->
306 validateDeclsHelp maybeComment def rest
309validateDeclsHelp
310 :: Maybe (A.Located String)
311 -> Source.Def
312 -> [Commented D.Source']
313 -> Result.Result wrn Error.Error [D.Valid]
314validateDeclsHelp maybeComment (A.A region def) decls =
315 let
316 ann =
317 (region, fmap A.drop maybeComment)
319 makeDef pat expr maybeType =
320 D.Def (Valid.Definition pat expr maybeType)
321 in
322 case def of
323 Source.Definition pat expr ->
324 (:)
325 <$> validateDef makeDef ann pat expr Nothing
326 <*> validateDecls decls
328 Source.Annotation name tipe ->
329 case decls of
330 A.A (_, Just (A.A commentRegion _)) _ : _ ->
331 Result.throw commentRegion (Error.CommentAfterAnnotation name)
333 A.A _ (D.Def (A.A _ (Source.Definition pat expr))) : rest
334 | Pattern.isVar name pat ->
335 (:)
336 <$> validateDef makeDef ann pat expr (Just tipe)
337 <*> validateDecls rest
339 _ ->
340 Result.throw region (Error.TypeWithoutDefinition name)
344-- VALIDATE DEFINITIONS
347definitions :: [Source.Def] -> Result.Result wrn Error.Error [Valid.Def]
348definitions sourceDefs =
349 do validDefs <- definitionsHelp sourceDefs
350 let patterns = map (\(Valid.Definition p _ _) -> p) validDefs
351 defDuplicates patterns
352 return validDefs
355definitionsHelp :: [Source.Def] -> Result.Result wrn Error.Error [Valid.Def]
356definitionsHelp sourceDefs =
357 case sourceDefs of
358 [] ->
359 return []
361 A.A region (Source.Definition pat expr) : rest ->
362 (:)
363 <$> fmap A.drop (validateDef Valid.Definition region pat expr Nothing)
364 <*> definitionsHelp rest
366 A.A r1 (Source.Annotation name tipe) : rest ->
367 case rest of
368 A.A r2 (Source.Definition pat expr) : rest'
369 | Pattern.isVar name pat ->
370 (:)
371 <$> fmap A.drop (validateDef Valid.Definition (R.merge r1 r2) pat expr (Just tipe))
372 <*> definitionsHelp rest'
374 _ ->
375 Result.throw r1 (Error.TypeWithoutDefinition name)
378validateDef
379 :: (Pattern.Raw -> Valid.Expr -> Maybe Type.Raw -> def)
380 -> annotation
381 -> Pattern.Raw
382 -> Source.Expr
383 -> Maybe Type.Raw
384 -> Result.Result wrn Error.Error (A.Annotated annotation def)
385validateDef makeDef annotation pat expr maybeType =
386 do validExpr <- expression expr
387 validateDefPattern pat validExpr
388 return $ A.A annotation (makeDef pat validExpr maybeType)
391validateDefPattern :: Pattern.Raw -> Valid.Expr -> Result.Result wrn Error.Error ()
392validateDefPattern pattern body =
393 case fst (Expr.collectLambdas body) of
394 [] ->
395 return ()
397 args ->
398 case pattern of
399 A.A _ (Pattern.Var _) ->
400 return ()
402 _ ->
403 let
404 (A.A start _) = pattern
405 (A.A end _) = last args
406 in
407 Result.throw (R.merge start end) (Error.BadFunctionName (length args))
411-- VALIDATE EXPRESSIONS
414expression :: Source.Expr -> Result.Result wrn Error.Error Valid.Expr
415expression (A.A ann sourceExpression) =
416 A.A ann <$>
417 case sourceExpression of
418 Var x ->
419 return (Var x)
421 Lambda pattern body ->
422 Lambda
423 <$> validatePattern pattern
424 <*> expression body
426 Binop op leftExpr rightExpr ->
427 Binop op
428 <$> expression leftExpr
429 <*> expression rightExpr
431 Case e branches ->
432 Case
433 <$> expression e
434 <*> T.traverse (\(p,b) -> (,) <$> validatePattern p <*> expression b) branches
436 Data name args ->
437 Data name <$> T.traverse expression args
439 Literal lit ->
440 return (Literal lit)
442 Range lowExpr highExpr ->
443 Range
444 <$> expression lowExpr
445 <*> expression highExpr
447 ExplicitList expressions ->
448 ExplicitList
449 <$> T.traverse expression expressions
451 App funcExpr argExpr ->
452 App
453 <$> expression funcExpr
454 <*> expression argExpr
456 If branches finally ->
457 If
458 <$> T.traverse both branches
459 <*> expression finally
461 Access record field ->
462 Access
463 <$> expression record
464 <*> return field
466 Update record fields ->
467 Update
468 <$> expression record
469 <*> T.traverse second fields
471 Record fields ->
472 let
473 checkDups seenFields (field,_) =
474 if Set.member field seenFields then
475 Result.throw ann (Error.DuplicateFieldName field)
477 else
478 return (Set.insert field seenFields)
479 in
480 do _ <- foldM checkDups Set.empty fields
481 Record <$> T.traverse second fields
483 Let defs body ->
484 Let
485 <$> definitions defs
486 <*> expression body
488 Cmd moduleName typeName ->
489 return (Cmd moduleName typeName)
491 Sub moduleName typeName ->
492 return (Sub moduleName typeName)
494 SaveEnv moduleName effects ->
495 return (SaveEnv moduleName effects)
497 GLShader uid src gltipe ->
498 return (GLShader uid src gltipe)
501second :: (a, Source.Expr) -> Result.Result wrn Error.Error (a, Valid.Expr)
502second (value, expr) =
503 (,) value <$> expression expr
506both
507 :: (Source.Expr, Source.Expr)
508 -> Result.Result wrn Error.Error (Valid.Expr, Valid.Expr)
509both (expr1, expr2) =
510 (,) <$> expression expr1 <*> expression expr2
514-- VALIDATE PATTERNS
517validatePattern :: Pattern.Raw -> Result.Result wrn Error.Error Pattern.Raw
518validatePattern pattern =
519 do detectDuplicates Error.BadPattern (Pattern.boundVars pattern)
520 return pattern
524-- DETECT DUPLICATES
527detectDuplicates
528 :: (String -> Error.Error)
529 -> [A.Located String]
530 -> Result.Result wrn Error.Error ()
531detectDuplicates tag names =
532 let add (A.A region name) dict =
533 Map.insertWith (++) name [region] dict
535 makeGroups pairs =
536 Map.toList (foldr add Map.empty pairs)
538 check (name, regions) =
539 case regions of
540 _ : region : _ ->
541 Result.throw region (tag name)
543 _ ->
544 return ()
545 in
546 F.traverse_ check (makeGroups names)
549defDuplicates :: [Pattern.Raw] -> Result.Result wrn Error.Error ()
550defDuplicates patterns =
551 concatMap Pattern.boundVars patterns
552 |> detectDuplicates Error.DuplicateDefinition
555declDuplicates :: [D.Valid] -> Result.Result wrn Error.Error ()
556declDuplicates decls =
557 let
558 (valueLists, typeLists) =
559 unzip (map extractValues decls)
560 in
561 (\_ _ -> ())
562 <$> detectDuplicates Error.DuplicateValueDeclaration (concat valueLists)
563 <*> detectDuplicates Error.DuplicateTypeDeclaration (concat typeLists)
566extractValues :: D.Valid -> ([A.Located String], [A.Located String])
567extractValues (A.A (region, _) decl) =
568 case decl of
569 D.Def (Valid.Definition pattern _ _) ->
570 ( Pattern.boundVars pattern
571 , []
572 )
574 D.Union name _ ctors ->
575 ( map (A.A region . fst) ctors
576 , [A.A region name]
577 )
579 D.Alias name _ (A.A _ (Type.RRecord _ _)) ->
580 ( [A.A region name]
581 , [A.A region name]
582 )
584 D.Alias name _ _ ->
585 ( []
586 , [A.A region name]
587 )
589 D.Fixity _ _ _ ->
590 ( []
591 , []
592 )
596-- UNBOUND TYPE VARIABLES
599findBadTypeVars :: D.Valid -> Result.Result wrn Error.Error ()
600findBadTypeVars (A.A (region,_) decl) =
601 case decl of
602 D.Def _ ->
603 return ()
605 D.Union name boundVars ctors ->
606 case diff boundVars (concatMap freeVars (concatMap snd ctors)) of
607 (_, []) ->
608 return ()
610 (_, unbound) ->
611 Result.throw region
612 (Error.UnboundTypeVarsInUnion name boundVars unbound)
614 D.Alias name boundVars tipe ->
615 case diff boundVars (freeVars tipe) of
616 ([], []) ->
617 return ()
619 ([], unbound) ->
620 Result.throw region
621 (Error.UnboundTypeVarsInAlias name boundVars unbound)
623 (unused, []) ->
624 Result.throw region
625 (Error.UnusedTypeVarsInAlias name boundVars unused)
627 (unused, unbound) ->
628 Result.throw region
629 (Error.MessyTypeVarsInAlias name boundVars unused unbound)
631 D.Fixity _ _ _ ->
632 return ()
635diff :: [String] -> [A.Located String] -> ([String], [String])
636diff left right =
637 let
638 leftSet =
639 Set.fromList left
641 rightSet =
642 Set.fromList (map A.drop right)
643 in
644 ( Set.toList (Set.difference leftSet rightSet)
645 , Set.toList (Set.difference rightSet leftSet)
646 )
650freeVars :: Type.Raw -> [A.Located String]
651freeVars (A.A region tipe) =
652 case tipe of
653 Type.RLambda t1 t2 ->
654 freeVars t1 ++ freeVars t2
656 Type.RVar x ->
657 [A.A region x]
659 Type.RType _ ->
660 []
662 Type.RApp t ts ->
663 concatMap freeVars (t:ts)
665 Type.RRecord fields ext ->
666 maybe [] freeVars ext
667 ++ concatMap (freeVars . snd) fields