git.iko.soy/elk
on 94ebc2d help sign in
elk/src/Validate.hs
688 lines 17 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module Validate (Result, module') where
4import Prelude hiding (init)
5import Control.Monad (foldM, when)
6import qualified Data.Map as Map
7import qualified Data.Maybe as Maybe
8import qualified Data.Set as Set
9import qualified Data.Foldable as F
10import qualified Data.Traversable as T
12import AST.Expression.General as Expr
13import qualified AST.Effects as Effects
14import qualified AST.Expression.Source as Source
15import qualified AST.Expression.Valid as Valid
16import qualified AST.Declaration as D
17import qualified AST.Module as Module
18import qualified AST.Module.Name as ModuleName
19import qualified AST.Pattern as Pattern
20import qualified AST.Type as Type
21import qualified Elm.Compiler.Imports as Imports
22import qualified Elm.Package as Package
23import Elm.Utils ((|>))
24import qualified Reporting.Annotation as A
25import qualified Reporting.Error.Syntax as Error
26import qualified Reporting.Region as R
27import qualified Reporting.Result as Result
31type Result warning a =
32 Result.Result () warning Error.Error a
36-- MODULES
39module' :: Module.Source -> Result wrn Module.Valid
40module' (Module.Module name path info) =
41 let
42 (ModuleName.Canonical pkgName _) =
43 name
45 (Module.Source tag settings docs exports imports decls) =
46 info
47 in
48 do (ValidStuff foreigns structure) <- validateDecls decls
50 validEffects <- validateEffects tag settings foreigns (D._defs structure)
52 return $ Module.Module name path $
53 Module.Valid docs exports (addDefaults pkgName imports) structure validEffects
57-- IMPORTS
60addDefaults
61 :: Package.Name
62 -> [Module.UserImport]
63 -> ([Module.DefaultImport], [Module.UserImport])
64addDefaults pkgName imports =
65 flip (,) imports $
66 if pkgName == Package.coreName then
67 []
69 else
70 Imports.defaults
74-- EFFECTS
77validateEffects
78 :: Module.SourceTag
79 -> Module.SourceSettings
80 -> [A.Commented Effects.ForeignRaw]
81 -> [A.Commented Valid.Def]
82 -> Result wrn Effects.Raw
83validateEffects tag settings@(A.A _ pairs) foreigns validDefs =
84 case tag of
85 Module.Normal ->
86 do noSettings Error.SettingsOnNormalModule settings
87 noForeigns foreigns
88 return Effects.None
90 Module.Foreign _ ->
91 do noSettings Error.SettingsOnForeignModule settings
92 return (Effects.Foreign foreigns)
94 Module.Effect tagRegion ->
95 let
96 collectSettings (A.A region setting, userValue) dict =
97 Map.insertWith (++) setting [(region, userValue)] dict
99 settingsDict =
100 foldr collectSettings Map.empty pairs
101 in
102 do noForeigns foreigns
103 managerType <- toManagerType tagRegion settingsDict
104 (r0, r1, r2) <- checkManager tagRegion managerType validDefs
105 return (Effects.Manager (Effects.Info tagRegion r0 r1 r2 managerType))
108noSettings :: Error.Error -> Module.SourceSettings -> Result wrn ()
109noSettings errorMsg (A.A region settings) =
110 case settings of
111 [] ->
112 Result.ok ()
114 _ : _ ->
115 Result.throw region errorMsg
118noForeigns :: [A.Commented Effects.ForeignRaw] -> Result wrn ()
119noForeigns foreigns =
120 case foreigns of
121 [] ->
122 Result.ok ()
124 _ : _ ->
125 let
126 toError (A.A (region, _) (Effects.ForeignRaw name _)) =
127 A.A region (Error.UnexpectedForeign name)
128 in
129 Result.throwMany (map toError foreigns)
132toManagerType
133 :: R.Region
134 -> Map.Map String [(R.Region, A.Located String)]
135 -> Result wrn Effects.ManagerType
136toManagerType tagRegion settingsDict =
137 let
138 toErrors name entries =
139 map (\entry -> A.A (fst entry) (Error.BadSettingOnEffectModule name)) entries
141 errors =
142 settingsDict
143 |> Map.delete "command"
144 |> Map.delete "subscription"
145 |> Map.mapWithKey toErrors
146 |> Map.elems
147 |> concat
148 in
149 do when (not (null errors)) (Result.throwMany errors)
150 maybeEffects <-
151 (,) <$> extractOne "command" settingsDict
152 <*> extractOne "subscription" settingsDict
154 -- TODO check that cmd and sub types exist?
155 case maybeEffects of
156 (Nothing, Nothing) ->
157 Result.throw tagRegion Error.NoSettingsOnEffectModule
159 (Just cmd, Nothing) ->
160 return (Effects.CmdManager cmd)
162 (Nothing, Just sub) ->
163 return (Effects.SubManager sub)
165 (Just cmd, Just sub) ->
166 return (Effects.FxManager cmd sub)
169extractOne
170 :: String
171 -> Map.Map String [(R.Region, A.Located String)]
172 -> Result wrn (Maybe (A.Located String))
173extractOne name settingsDict =
174 case Map.lookup name settingsDict of
175 Nothing ->
176 return Nothing
178 Just [] ->
179 error "Empty lists should never be added to the dictionary of effect module settings."
181 Just [(_, userType)] ->
182 return (Just userType)
184 Just ((region, _) : _) ->
185 Result.throw region (Error.DuplicateSettingOnEffectModule name)
189-- CHECK EFFECT MANAGER
192checkManager
193 :: R.Region
194 -> Effects.ManagerType
195 -> [A.Commented Valid.Def]
196 -> Result wrn (R.Region, R.Region, R.Region)
197checkManager tagRegion managerType validDefs =
198 let
199 regionDict =
200 Map.fromList (Maybe.mapMaybe getSimpleDefRegion validDefs)
201 in
202 const (,,)
203 <$> requireMaps tagRegion regionDict managerType
204 <*> requireRegion tagRegion regionDict "init"
205 <*> requireRegion tagRegion regionDict "onEffects"
206 <*> requireRegion tagRegion regionDict "onSelfMsg"
209getSimpleDefRegion :: A.Commented Valid.Def -> Maybe (String, R.Region)
210getSimpleDefRegion decl =
211 case decl of
212 A.A (region, _) (Valid.Def (A.A _ (Pattern.Var name)) _ _) ->
213 Just (name, region)
215 _ ->
216 Nothing
219requireMaps
220 :: R.Region
221 -> Map.Map String R.Region
222 -> Effects.ManagerType
223 -> Result wrn ()
224requireMaps tagRegion regionDict managerType =
225 let
226 check name =
227 when (Map.notMember name regionDict) $
228 Result.throw tagRegion (Error.MissingManagerOnEffectModule name)
229 in
230 case managerType of
231 Effects.CmdManager _ ->
232 check "cmdMap"
234 Effects.SubManager _ ->
235 check "subMap"
237 Effects.FxManager _ _ ->
238 check "cmdMap" <* check "subMap"
241requireRegion :: R.Region -> Map.Map String R.Region -> String -> Result wrn R.Region
242requireRegion tagRegion regionDict name =
243 case Map.lookup name regionDict of
244 Just region ->
245 return region
247 Nothing ->
248 Result.throw tagRegion (Error.MissingManagerOnEffectModule name)
252-- COLLAPSE COMMENTS
255collapseComments :: [D.CommentOr (A.Located a)] -> Result wrn [A.Commented a]
256collapseComments listWithComments =
257 case listWithComments of
258 [] ->
259 Result.ok []
261 D.Comment (A.A _ msg) : D.Whatever (A.A region a) : rest ->
262 let
263 entry =
264 A.A (region, Just msg) a
265 in
266 fmap (entry:) (collapseComments rest)
268 D.Comment (A.A region _) : rest ->
269 collapseComments rest
270 <* Result.throw region Error.CommentOnNothing
273 D.Whatever (A.A region a) : rest ->
274 let
275 entry =
276 A.A (region, Nothing) a
277 in
278 fmap (entry:) (collapseComments rest)
282-- VALIDATE STRUCTURED SOURCE
285validateDecls :: [D.Source] -> Result wrn ValidStuff
286validateDecls sourceDecls =
287 do rawDecls <- collapseComments sourceDecls
289 validStuff <- validateRawDecls rawDecls
291 let (D.Decls _ unions aliases _) = _structure validStuff
293 return validStuff
294 <* F.traverse_ checkTypeVarsInUnion unions
295 <* F.traverse_ checkTypeVarsInAlias aliases
296 <* checkDuplicates validStuff
300-- VALIDATE DECLARATIONS
303data ValidStuff =
304 ValidStuff
305 { _foreigns :: [A.Commented Effects.ForeignRaw]
306 , _structure :: D.Valid
307 }
310validateRawDecls :: [A.Commented D.Raw] -> Result wrn ValidStuff
311validateRawDecls commentedDecls =
312 vrdHelp commentedDecls [] (D.Decls [] [] [] [])
315vrdHelp
316 :: [A.Commented D.Raw]
317 -> [A.Commented Effects.ForeignRaw]
318 -> D.Valid
319 -> Result wrn ValidStuff
320vrdHelp commentedDecls foreigns structure =
321 case commentedDecls of
322 [] ->
323 Result.ok (ValidStuff foreigns structure)
325 A.A ann decl : rest ->
326 case decl of
327 D.Union (D.Type name tvars ctors) ->
328 vrdHelp rest foreigns (D.addUnion (A.A ann (D.Type name tvars ctors)) structure)
330 D.Alias (D.Type name tvars alias) ->
331 vrdHelp rest foreigns (D.addAlias (A.A ann (D.Type name tvars alias)) structure)
333 D.Fixity fixity ->
334 vrdHelp rest foreigns (D.addInfix fixity structure)
336 D.Def (A.A region def) ->
337 vrdDefHelp rest (A.A (region, snd ann) def) foreigns structure
339 D.Foreign name tipe ->
340 vrdHelp rest (A.A ann (Effects.ForeignRaw name tipe) : foreigns) structure
343vrdDefHelp
344 :: [A.Commented D.Raw]
345 -> A.Commented Source.Def'
346 -> [A.Commented Effects.ForeignRaw]
347 -> D.Valid
348 -> Result wrn ValidStuff
349vrdDefHelp remainingDecls (A.A ann def) foreigns structure =
350 let
351 addDef validDef (ValidStuff finalForeigns struct) =
352 ValidStuff finalForeigns (D.addDef (A.A ann validDef) struct)
353 in
354 case def of
355 Source.Definition pat expr ->
356 addDef
357 <$> validateDef pat expr Nothing
358 <*> vrdHelp remainingDecls foreigns structure
360 Source.Annotation name tipe ->
361 case remainingDecls of
362 A.A _ (D.Def (A.A _ (Source.Definition pat expr))) : rest
363 | Pattern.isVar name pat ->
364 addDef
365 <$> validateDef pat expr (Just tipe)
366 <*> vrdHelp rest foreigns structure
368 _ ->
369 vrdHelp remainingDecls foreigns structure
370 <* Result.throw (fst ann) (Error.TypeWithoutDefinition name)
374-- VALIDATE DEFINITIONS
377definitions :: [Source.Def] -> Result wrn [Valid.Def]
378definitions sourceDefs =
379 do validDefs <- definitionsHelp sourceDefs
381 validDefs
382 |> map Valid.getPattern
383 |> concatMap Pattern.boundVars
384 |> detectDuplicates Error.DuplicateDefinition
386 return validDefs
389definitionsHelp :: [Source.Def] -> Result wrn [Valid.Def]
390definitionsHelp sourceDefs =
391 case sourceDefs of
392 [] ->
393 return []
395 A.A _ (Source.Definition pat expr) : rest ->
396 (:)
397 <$> validateDef pat expr Nothing
398 <*> definitionsHelp rest
400 A.A region (Source.Annotation name tipe) : rest ->
401 case rest of
402 A.A _ (Source.Definition pat expr) : rest'
403 | Pattern.isVar name pat ->
404 (:)
405 <$> validateDef pat expr (Just tipe)
406 <*> definitionsHelp rest'
408 _ ->
409 Result.throw region (Error.TypeWithoutDefinition name)
412validateDef
413 :: Pattern.Raw
414 -> Source.Expr
415 -> Maybe Type.Raw
416 -> Result wrn Valid.Def
417validateDef pat expr maybeType =
418 do validExpr <- expression expr
419 validateDefPattern pat validExpr
420 return $ Valid.Def pat validExpr maybeType
423validateDefPattern :: Pattern.Raw -> Valid.Expr -> Result wrn ()
424validateDefPattern pattern body =
425 case fst (Expr.collectLambdas body) of
426 [] ->
427 return ()
429 args ->
430 case pattern of
431 A.A _ (Pattern.Var _) ->
432 return ()
434 _ ->
435 let
436 (A.A start _) = pattern
437 (A.A end _) = last args
438 in
439 Result.throw (R.merge start end) (Error.BadFunctionName (length args))
443-- VALIDATE EXPRESSIONS
446expression :: Source.Expr -> Result wrn Valid.Expr
447expression (A.A ann sourceExpression) =
448 A.A ann <$>
449 case sourceExpression of
450 Var x ->
451 return (Var x)
453 Lambda pattern body ->
454 Lambda
455 <$> validatePattern pattern
456 <*> expression body
458 Binop op leftExpr rightExpr ->
459 Binop op
460 <$> expression leftExpr
461 <*> expression rightExpr
463 Case e branches ->
464 Case
465 <$> expression e
466 <*> T.traverse (\(p,b) -> (,) <$> validatePattern p <*> expression b) branches
468 Data name args ->
469 Data name <$> T.traverse expression args
471 Literal lit ->
472 return (Literal lit)
474 Range lowExpr highExpr ->
475 Range
476 <$> expression lowExpr
477 <*> expression highExpr
479 ExplicitList expressions ->
480 ExplicitList
481 <$> T.traverse expression expressions
483 App funcExpr argExpr ->
484 App
485 <$> expression funcExpr
486 <*> expression argExpr
488 If branches finally ->
489 If
490 <$> T.traverse both branches
491 <*> expression finally
493 Access record field ->
494 Access
495 <$> expression record
496 <*> return field
498 Update record fields ->
499 Update
500 <$> expression record
501 <*> T.traverse second fields
503 Record fields ->
504 let
505 checkDups seenFields (field,_) =
506 if Set.member field seenFields then
507 Result.throw ann (Error.DuplicateFieldName field)
509 else
510 return (Set.insert field seenFields)
511 in
512 do _ <- foldM checkDups Set.empty fields
513 Record <$> T.traverse second fields
515 Let defs body ->
516 Let
517 <$> definitions defs
518 <*> expression body
520 Cmd moduleName ->
521 return (Cmd moduleName)
523 Sub moduleName ->
524 return (Sub moduleName)
526 ForeignCmd name tipe ->
527 return (ForeignCmd name tipe)
529 ForeignSub name tipe ->
530 return (ForeignSub name tipe)
532 SaveEnv moduleName effects ->
533 return (SaveEnv moduleName effects)
535 GLShader uid src gltipe ->
536 return (GLShader uid src gltipe)
539second :: (a, Source.Expr) -> Result wrn (a, Valid.Expr)
540second (value, expr) =
541 (,) value <$> expression expr
544both :: (Source.Expr, Source.Expr) -> Result wrn (Valid.Expr, Valid.Expr)
545both (expr1, expr2) =
546 (,) <$> expression expr1 <*> expression expr2
550-- VALIDATE PATTERNS
553validatePattern :: Pattern.Raw -> Result wrn Pattern.Raw
554validatePattern pattern =
555 do detectDuplicates Error.BadPattern (Pattern.boundVars pattern)
556 return pattern
560-- DETECT DUPLICATES
563checkDuplicates :: ValidStuff -> Result wrn ()
564checkDuplicates (ValidStuff foreigns (D.Decls defs unions aliases _)) =
565 let
566 -- SIMPLE NAMES
568 defValues =
569 concatMap (Pattern.boundVars . Valid.getPattern . A.drop) defs
571 foreignValues =
572 map fromForeign foreigns
574 fromForeign (A.A (region, _) (Effects.ForeignRaw name _)) =
575 A.A region name
577 -- TYPE NAMES
579 (types, typeValues) =
580 unzip (map fromUnion unions ++ map fromAlias aliases)
582 fromUnion (A.A (region, _) (D.Type name _ ctors)) =
583 ( A.A region name
584 , map (A.A region . fst) ctors
585 )
587 fromAlias (A.A (region, _) (D.Type name _ (A.A _ tipe))) =
588 (,) (A.A region name) $
589 case tipe of
590 Type.RRecord _ _ ->
591 [A.A region name]
593 _ ->
594 []
595 in
596 F.sequenceA_
597 [ detectDuplicates Error.DuplicateValueDeclaration (foreignValues ++ defValues)
598 , detectDuplicates Error.DuplicateValueDeclaration (concat typeValues)
599 , detectDuplicates Error.DuplicateTypeDeclaration types
600 ]
603detectDuplicates :: (String -> Error.Error) -> [A.Located String] -> Result wrn ()
604detectDuplicates tag names =
605 let
606 add (A.A region name) dict =
607 Map.insertWith (++) name [region] dict
609 makeGroups pairs =
610 Map.toList (foldr add Map.empty pairs)
612 check (name, regions) =
613 case regions of
614 _ : region : _ ->
615 Result.throw region (tag name)
617 _ ->
618 return ()
619 in
620 F.traverse_ check (makeGroups names)
624-- UNBOUND TYPE VARIABLES
627checkTypeVarsInUnion :: A.Commented (D.Union Type.Raw) -> Result wrn ()
628checkTypeVarsInUnion (A.A (region,_) (D.Type name boundVars ctors)) =
629 case diff boundVars (concatMap freeVars (concatMap snd ctors)) of
630 (_, []) ->
631 return ()
633 (_, unbound) ->
634 Result.throw region
635 (Error.UnboundTypeVarsInUnion name boundVars unbound)
638checkTypeVarsInAlias :: A.Commented (D.Alias Type.Raw) -> Result wrn ()
639checkTypeVarsInAlias (A.A (region,_) (D.Type name boundVars tipe)) =
640 case diff boundVars (freeVars tipe) of
641 ([], []) ->
642 return ()
644 ([], unbound) ->
645 Result.throw region
646 (Error.UnboundTypeVarsInAlias name boundVars unbound)
648 (unused, []) ->
649 Result.throw region
650 (Error.UnusedTypeVarsInAlias name boundVars unused)
652 (unused, unbound) ->
653 Result.throw region
654 (Error.MessyTypeVarsInAlias name boundVars unused unbound)
657diff :: [String] -> [A.Located String] -> ([String], [String])
658diff left right =
659 let
660 leftSet =
661 Set.fromList left
663 rightSet =
664 Set.fromList (map A.drop right)
665 in
666 ( Set.toList (Set.difference leftSet rightSet)
667 , Set.toList (Set.difference rightSet leftSet)
668 )
671freeVars :: Type.Raw -> [A.Located String]
672freeVars (A.A region tipe) =
673 case tipe of
674 Type.RLambda t1 t2 ->
675 freeVars t1 ++ freeVars t2
677 Type.RVar x ->
678 [A.A region x]
680 Type.RType _ ->
681 []
683 Type.RApp t ts ->
684 concatMap freeVars (t:ts)
686 Type.RRecord fields ext ->
687 maybe [] freeVars ext
688 ++ concatMap (freeVars . snd) fields