git.iko.soy/elk
on 684504e help sign in
elk/src/Validate.hs
691 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 Program _ _ ->
533 error "DANGER - Program AST nodes should not be in validation phase."
535 SaveEnv moduleName effects ->
536 return (SaveEnv moduleName effects)
538 GLShader uid src gltipe ->
539 return (GLShader uid src gltipe)
542second :: (a, Source.Expr) -> Result wrn (a, Valid.Expr)
543second (value, expr) =
544 (,) value <$> expression expr
547both :: (Source.Expr, Source.Expr) -> Result wrn (Valid.Expr, Valid.Expr)
548both (expr1, expr2) =
549 (,) <$> expression expr1 <*> expression expr2
553-- VALIDATE PATTERNS
556validatePattern :: Pattern.Raw -> Result wrn Pattern.Raw
557validatePattern pattern =
558 do detectDuplicates Error.BadPattern (Pattern.boundVars pattern)
559 return pattern
563-- DETECT DUPLICATES
566checkDuplicates :: ValidStuff -> Result wrn ()
567checkDuplicates (ValidStuff foreigns (D.Decls defs unions aliases _)) =
568 let
569 -- SIMPLE NAMES
571 defValues =
572 concatMap (Pattern.boundVars . Valid.getPattern . A.drop) defs
574 foreignValues =
575 map fromForeign foreigns
577 fromForeign (A.A (region, _) (Effects.ForeignRaw name _)) =
578 A.A region name
580 -- TYPE NAMES
582 (types, typeValues) =
583 unzip (map fromUnion unions ++ map fromAlias aliases)
585 fromUnion (A.A (region, _) (D.Type name _ ctors)) =
586 ( A.A region name
587 , map (A.A region . fst) ctors
588 )
590 fromAlias (A.A (region, _) (D.Type name _ (A.A _ tipe))) =
591 (,) (A.A region name) $
592 case tipe of
593 Type.RRecord _ _ ->
594 [A.A region name]
596 _ ->
597 []
598 in
599 F.sequenceA_
600 [ detectDuplicates Error.DuplicateValueDeclaration (foreignValues ++ defValues)
601 , detectDuplicates Error.DuplicateValueDeclaration (concat typeValues)
602 , detectDuplicates Error.DuplicateTypeDeclaration types
603 ]
606detectDuplicates :: (String -> Error.Error) -> [A.Located String] -> Result wrn ()
607detectDuplicates tag names =
608 let
609 add (A.A region name) dict =
610 Map.insertWith (++) name [region] dict
612 makeGroups pairs =
613 Map.toList (foldr add Map.empty pairs)
615 check (name, regions) =
616 case regions of
617 _ : region : _ ->
618 Result.throw region (tag name)
620 _ ->
621 return ()
622 in
623 F.traverse_ check (makeGroups names)
627-- UNBOUND TYPE VARIABLES
630checkTypeVarsInUnion :: A.Commented (D.Union Type.Raw) -> Result wrn ()
631checkTypeVarsInUnion (A.A (region,_) (D.Type name boundVars ctors)) =
632 case diff boundVars (concatMap freeVars (concatMap snd ctors)) of
633 (_, []) ->
634 return ()
636 (_, unbound) ->
637 Result.throw region
638 (Error.UnboundTypeVarsInUnion name boundVars unbound)
641checkTypeVarsInAlias :: A.Commented (D.Alias Type.Raw) -> Result wrn ()
642checkTypeVarsInAlias (A.A (region,_) (D.Type name boundVars tipe)) =
643 case diff boundVars (freeVars tipe) of
644 ([], []) ->
645 return ()
647 ([], unbound) ->
648 Result.throw region
649 (Error.UnboundTypeVarsInAlias name boundVars unbound)
651 (unused, []) ->
652 Result.throw region
653 (Error.UnusedTypeVarsInAlias name boundVars unused)
655 (unused, unbound) ->
656 Result.throw region
657 (Error.MessyTypeVarsInAlias name boundVars unused unbound)
660diff :: [String] -> [A.Located String] -> ([String], [String])
661diff left right =
662 let
663 leftSet =
664 Set.fromList left
666 rightSet =
667 Set.fromList (map A.drop right)
668 in
669 ( Set.toList (Set.difference leftSet rightSet)
670 , Set.toList (Set.difference rightSet leftSet)
671 )
674freeVars :: Type.Raw -> [A.Located String]
675freeVars (A.A region tipe) =
676 case tipe of
677 Type.RLambda t1 t2 ->
678 freeVars t1 ++ freeVars t2
680 Type.RVar x ->
681 [A.A region x]
683 Type.RType _ ->
684 []
686 Type.RApp t ts ->
687 concatMap freeVars (t:ts)
689 Type.RRecord fields ext ->
690 maybe [] freeVars ext
691 ++ concatMap (freeVars . snd) fields