git.iko.soy/elk
on bfb4f2d help sign in
elk/src/Validate.hs
706 lines 18 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module Validate (Result, module') where
4import Control.Monad (foldM_, when)
5import qualified Data.Map as Map
6import qualified Data.Maybe as Maybe
7import qualified Data.Set as Set
8import qualified Data.Foldable as F
9import qualified Data.Traversable as T
11import AST.Expression.General as Expr
12import qualified AST.Effects as Effects
13import qualified AST.Expression.Source as Source
14import qualified AST.Expression.Valid as Valid
15import qualified AST.Declaration as D
16import qualified AST.Module as Module
17import qualified AST.Module.Name as ModuleName
18import qualified AST.Pattern as Pattern
19import qualified AST.Type as Type
20import qualified Elm.Compiler.Imports as Imports
21import qualified Elm.Package as Package
22import Elm.Utils ((|>))
23import qualified Reporting.Annotation as A
24import qualified Reporting.Error.Syntax as Error
25import qualified Reporting.Region as R
26import qualified Reporting.Result as Result
30type Result warning a =
31 Result.Result () warning Error.Error a
35-- MODULES
38module' :: Module.Source -> Result wrn Module.Valid
39module' (Module.Module name path info) =
40 let
41 (ModuleName.Canonical pkgName _) =
42 name
44 (Module.Source tag settings docs exports imports decls) =
45 info
46 in
47 do (ValidStuff ports structure) <- validateDecls decls
49 validEffects <- validateEffects tag settings ports (D._defs structure)
51 return $ Module.Module name path $
52 Module.Valid docs exports (addDefaults pkgName imports) structure validEffects
56-- IMPORTS
59addDefaults
60 :: Package.Name
61 -> [Module.UserImport]
62 -> ([Module.DefaultImport], [Module.UserImport])
63addDefaults pkgName imports =
64 flip (,) imports $
65 if pkgName == Package.core then
66 []
68 else
69 Imports.defaults
73-- EFFECTS
76validateEffects
77 :: Module.SourceTag
78 -> Module.SourceSettings
79 -> [A.Commented Effects.PortRaw]
80 -> [A.Commented Valid.Def]
81 -> Result wrn Effects.Raw
82validateEffects tag settings@(A.A _ pairs) ports validDefs =
83 case tag of
84 Module.Normal ->
85 do noSettings Error.SettingsOnNormalModule settings
86 noPorts ports
87 return Effects.None
89 Module.Port _ ->
90 do noSettings Error.SettingsOnPortModule settings
91 return (Effects.Port ports)
93 Module.Effect tagRegion ->
94 let
95 collectSettings (A.A region setting, userValue) dict =
96 Map.insertWith (++) setting [(region, userValue)] dict
98 settingsDict =
99 foldr collectSettings Map.empty pairs
100 in
101 do noPorts ports
102 managerType <- toManagerType tagRegion settingsDict
103 (r0, r1, r2) <- checkManager tagRegion managerType validDefs
104 return (Effects.Manager () (Effects.Info tagRegion r0 r1 r2 managerType))
107noSettings :: Error.Error -> Module.SourceSettings -> Result wrn ()
108noSettings errorMsg (A.A region settings) =
109 case settings of
110 [] ->
111 Result.ok ()
113 _ : _ ->
114 Result.throw region errorMsg
117noPorts :: [A.Commented Effects.PortRaw] -> Result wrn ()
118noPorts ports =
119 case ports of
120 [] ->
121 Result.ok ()
123 _ : _ ->
124 let
125 toError (A.A (region, _) (Effects.PortRaw name _)) =
126 A.A region (Error.UnexpectedPort name)
127 in
128 Result.throwMany (map toError ports)
131toManagerType
132 :: R.Region
133 -> Map.Map String [(R.Region, A.Located String)]
134 -> Result wrn Effects.ManagerType
135toManagerType tagRegion settingsDict =
136 let
137 toErrors name entries =
138 map (\entry -> A.A (fst entry) (Error.BadSettingOnEffectModule name)) entries
140 errors =
141 settingsDict
142 |> Map.delete "command"
143 |> Map.delete "subscription"
144 |> Map.mapWithKey toErrors
145 |> Map.elems
146 |> concat
147 in
148 do when (not (null errors)) (Result.throwMany errors)
149 maybeEffects <-
150 (,) <$> extractOne "command" settingsDict
151 <*> extractOne "subscription" settingsDict
153 -- TODO check that cmd and sub types exist?
154 case maybeEffects of
155 (Nothing, Nothing) ->
156 Result.throw tagRegion Error.NoSettingsOnEffectModule
158 (Just cmd, Nothing) ->
159 return (Effects.CmdManager cmd)
161 (Nothing, Just sub) ->
162 return (Effects.SubManager sub)
164 (Just cmd, Just sub) ->
165 return (Effects.FxManager cmd sub)
168extractOne
169 :: String
170 -> Map.Map String [(R.Region, A.Located String)]
171 -> Result wrn (Maybe (A.Located String))
172extractOne name settingsDict =
173 case Map.lookup name settingsDict of
174 Nothing ->
175 return Nothing
177 Just [] ->
178 error "Empty lists should never be added to the dictionary of effect module settings."
180 Just [(_, userType)] ->
181 return (Just userType)
183 Just ((region, _) : _) ->
184 Result.throw region (Error.DuplicateSettingOnEffectModule name)
188-- CHECK EFFECT MANAGER
191checkManager
192 :: R.Region
193 -> Effects.ManagerType
194 -> [A.Commented Valid.Def]
195 -> Result wrn (R.Region, R.Region, R.Region)
196checkManager tagRegion managerType validDefs =
197 let
198 regionDict =
199 Map.fromList (Maybe.mapMaybe getSimpleDefRegion validDefs)
200 in
201 const (,,)
202 <$> requireMaps tagRegion regionDict managerType
203 <*> requireRegion tagRegion regionDict "init"
204 <*> requireRegion tagRegion regionDict "onEffects"
205 <*> requireRegion tagRegion regionDict "onSelfMsg"
208getSimpleDefRegion :: A.Commented Valid.Def -> Maybe (String, R.Region)
209getSimpleDefRegion decl =
210 case decl of
211 A.A (region, _) (Valid.Def (A.A _ (Pattern.Var name)) _ _) ->
212 Just (name, region)
214 _ ->
215 Nothing
218requireMaps
219 :: R.Region
220 -> Map.Map String R.Region
221 -> Effects.ManagerType
222 -> Result wrn ()
223requireMaps tagRegion regionDict managerType =
224 let
225 check name =
226 when (Map.notMember name regionDict) $
227 Result.throw tagRegion (Error.MissingManagerOnEffectModule name)
228 in
229 case managerType of
230 Effects.CmdManager _ ->
231 check "cmdMap"
233 Effects.SubManager _ ->
234 check "subMap"
236 Effects.FxManager _ _ ->
237 check "cmdMap" <* check "subMap"
240requireRegion :: R.Region -> Map.Map String R.Region -> String -> Result wrn R.Region
241requireRegion tagRegion regionDict name =
242 case Map.lookup name regionDict of
243 Just region ->
244 return region
246 Nothing ->
247 Result.throw tagRegion (Error.MissingManagerOnEffectModule name)
251-- COLLAPSE COMMENTS
254collapseComments :: [D.CommentOr (A.Located a)] -> Result wrn [A.Commented a]
255collapseComments listWithComments =
256 case listWithComments of
257 [] ->
258 Result.ok []
260 D.Comment (A.A _ msg) : D.Whatever (A.A region a) : rest ->
261 let
262 entry =
263 A.A (region, Just msg) a
264 in
265 fmap (entry:) (collapseComments rest)
267 D.Comment (A.A region _) : rest ->
268 collapseComments rest
269 <* Result.throw region Error.CommentOnNothing
272 D.Whatever (A.A region a) : rest ->
273 let
274 entry =
275 A.A (region, Nothing) a
276 in
277 fmap (entry:) (collapseComments rest)
281-- VALIDATE STRUCTURED SOURCE
284validateDecls :: [D.Source] -> Result wrn ValidStuff
285validateDecls sourceDecls =
286 do rawDecls <- collapseComments sourceDecls
288 validStuff <- validateRawDecls rawDecls
290 let (D.Decls _ unions aliases _) = _structure validStuff
292 return validStuff
293 <* F.traverse_ checkTypeVarsInUnion unions
294 <* F.traverse_ checkTypeVarsInAlias aliases
295 <* checkDuplicates validStuff
299-- VALIDATE DECLARATIONS
302data ValidStuff =
303 ValidStuff
304 { _ports :: [A.Commented Effects.PortRaw]
305 , _structure :: D.Valid
306 }
309validateRawDecls :: [A.Commented D.Raw] -> Result wrn ValidStuff
310validateRawDecls commentedDecls =
311 vrdHelp commentedDecls [] (D.Decls [] [] [] [])
314vrdHelp
315 :: [A.Commented D.Raw]
316 -> [A.Commented Effects.PortRaw]
317 -> D.Valid
318 -> Result wrn ValidStuff
319vrdHelp commentedDecls ports structure =
320 case commentedDecls of
321 [] ->
322 Result.ok (ValidStuff ports structure)
324 A.A ann decl : rest ->
325 case decl of
326 D.Union (D.Type name tvars ctors) ->
327 vrdHelp rest ports (D.addUnion (A.A ann (D.Type name tvars ctors)) structure)
329 D.Alias (D.Type name tvars alias) ->
330 vrdHelp rest ports (D.addAlias (A.A ann (D.Type name tvars alias)) structure)
332 D.Fixity fixity ->
333 vrdHelp rest ports (D.addInfix fixity structure)
335 D.Def (A.A region def) ->
336 vrdDefHelp rest (A.A (region, snd ann) def) ports structure
338 D.Port name tipe ->
339 vrdHelp rest (A.A ann (Effects.PortRaw name tipe) : ports) structure
342vrdDefHelp
343 :: [A.Commented D.Raw]
344 -> A.Commented Source.Def'
345 -> [A.Commented Effects.PortRaw]
346 -> D.Valid
347 -> Result wrn ValidStuff
348vrdDefHelp remainingDecls (A.A ann def) ports structure =
349 let
350 addDef validDef (ValidStuff finalPorts struct) =
351 ValidStuff finalPorts (D.addDef (A.A ann validDef) struct)
352 in
353 case def of
354 Source.Definition pat expr ->
355 addDef
356 <$> validateDef pat expr Nothing
357 <*> vrdHelp remainingDecls ports structure
359 Source.Annotation name tipe ->
360 case remainingDecls of
361 A.A _ (D.Def (A.A _ (Source.Definition pat expr))) : rest
362 | Pattern.isVar name pat ->
363 addDef
364 <$> validateDef pat expr (Just tipe)
365 <*> vrdHelp rest ports structure
367 _ ->
368 vrdHelp remainingDecls ports structure
369 <* Result.throw (fst ann) (Error.TypeWithoutDefinition name)
373-- VALIDATE DEFINITIONS
376definitions :: [Source.Def] -> Result wrn [Valid.Def]
377definitions sourceDefs =
378 do validDefs <- definitionsHelp sourceDefs
380 validDefs
381 |> map Valid.getPattern
382 |> concatMap Pattern.boundVars
383 |> detectDuplicates Error.DuplicateDefinition
385 return validDefs
388definitionsHelp :: [Source.Def] -> Result wrn [Valid.Def]
389definitionsHelp sourceDefs =
390 case sourceDefs of
391 [] ->
392 return []
394 A.A _ (Source.Definition pat expr) : rest ->
395 (:)
396 <$> validateDef pat expr Nothing
397 <*> definitionsHelp rest
399 A.A region (Source.Annotation name tipe) : rest ->
400 case rest of
401 A.A _ (Source.Definition pat expr) : rest'
402 | Pattern.isVar name pat ->
403 (:)
404 <$> validateDef pat expr (Just tipe)
405 <*> definitionsHelp rest'
407 _ ->
408 Result.throw region (Error.TypeWithoutDefinition name)
411validateDef
412 :: Pattern.Raw
413 -> Source.Expr
414 -> Maybe Type.Raw
415 -> Result wrn Valid.Def
416validateDef pat expr maybeType =
417 do validExpr <- expression expr
418 validateDefPattern pat validExpr
419 return $ Valid.Def pat validExpr maybeType
422validateDefPattern :: Pattern.Raw -> Valid.Expr -> Result wrn ()
423validateDefPattern pattern body =
424 case fst (Expr.collectLambdas body) of
425 [] ->
426 return ()
428 args ->
429 case pattern of
430 A.A _ (Pattern.Var funcName) ->
431 checkArguments funcName args
433 _ ->
434 let
435 (A.A start _) = pattern
436 (A.A end _) = last args
437 in
438 Result.throw (R.merge start end) (Error.BadFunctionName (length args))
441checkArguments :: String -> [Pattern.Raw] -> Result wrn ()
442checkArguments funcName args =
443 let
444 vars =
445 concatMap Pattern.boundVars args
447 checkDups seenArgs (A.A region arg) =
448 if Set.member arg seenArgs then
449 Result.throw region (Error.DuplicateArgument funcName arg)
451 else
452 return (Set.insert arg seenArgs)
453 in
454 foldM_ checkDups Set.empty vars
458-- VALIDATE EXPRESSIONS
461expression :: Source.Expr -> Result wrn Valid.Expr
462expression (A.A ann sourceExpression) =
463 A.A ann <$>
464 case sourceExpression of
465 Var x ->
466 return (Var x)
468 Lambda pattern body ->
469 Lambda
470 <$> validatePattern pattern
471 <*> expression body
473 Binop op leftExpr rightExpr ->
474 Binop op
475 <$> expression leftExpr
476 <*> expression rightExpr
478 Case e branches ->
479 Case
480 <$> expression e
481 <*> T.traverse (\(p,b) -> (,) <$> validatePattern p <*> expression b) branches
483 Data name args ->
484 Data name <$> T.traverse expression args
486 Literal lit ->
487 return (Literal lit)
489 Range lowExpr highExpr ->
490 Range
491 <$> expression lowExpr
492 <*> expression highExpr
494 ExplicitList expressions ->
495 ExplicitList
496 <$> T.traverse expression expressions
498 App funcExpr argExpr ->
499 App
500 <$> expression funcExpr
501 <*> expression argExpr
503 If branches finally ->
504 If
505 <$> T.traverse both branches
506 <*> expression finally
508 Access record field ->
509 Access
510 <$> expression record
511 <*> return field
513 Update record fields ->
514 Update
515 <$> expression record
516 <*> T.traverse second fields
518 Record fields ->
519 let
520 checkDups seenFields (field,_) =
521 if Set.member field seenFields then
522 Result.throw ann (Error.DuplicateFieldName field)
524 else
525 return (Set.insert field seenFields)
526 in
527 do foldM_ checkDups Set.empty fields
528 Record <$> T.traverse second fields
530 Let defs body ->
531 Let
532 <$> definitions defs
533 <*> expression body
535 Cmd moduleName ->
536 return (Cmd moduleName)
538 Sub moduleName ->
539 return (Sub moduleName)
541 OutgoingPort name tipe ->
542 return (OutgoingPort name tipe)
544 IncomingPort name tipe ->
545 return (IncomingPort name tipe)
547 Program _ _ ->
548 error "DANGER - Program AST nodes should not be in validation phase."
550 SaveEnv moduleName effects ->
551 return (SaveEnv moduleName effects)
553 GLShader uid src gltipe ->
554 return (GLShader uid src gltipe)
557second :: (a, Source.Expr) -> Result wrn (a, Valid.Expr)
558second (value, expr) =
559 (,) value <$> expression expr
562both :: (Source.Expr, Source.Expr) -> Result wrn (Valid.Expr, Valid.Expr)
563both (expr1, expr2) =
564 (,) <$> expression expr1 <*> expression expr2
568-- VALIDATE PATTERNS
571validatePattern :: Pattern.Raw -> Result wrn Pattern.Raw
572validatePattern pattern =
573 do detectDuplicates Error.BadPattern (Pattern.boundVars pattern)
574 return pattern
578-- DETECT DUPLICATES
581checkDuplicates :: ValidStuff -> Result wrn ()
582checkDuplicates (ValidStuff ports (D.Decls defs unions aliases _)) =
583 let
584 -- SIMPLE NAMES
586 defValues =
587 concatMap (Pattern.boundVars . Valid.getPattern . A.drop) defs
589 portValues =
590 map fromPort ports
592 fromPort (A.A (region, _) (Effects.PortRaw name _)) =
593 A.A region name
595 -- TYPE NAMES
597 (types, typeValues) =
598 unzip (map fromUnion unions ++ map fromAlias aliases)
600 fromUnion (A.A (region, _) (D.Type name _ ctors)) =
601 ( A.A region name
602 , map (A.A region . fst) ctors
603 )
605 fromAlias (A.A (region, _) (D.Type name _ (A.A _ tipe))) =
606 (,) (A.A region name) $
607 case tipe of
608 Type.RRecord _ _ ->
609 [A.A region name]
611 _ ->
612 []
613 in
614 F.sequenceA_
615 [ detectDuplicates Error.DuplicateValueDeclaration (portValues ++ defValues)
616 , detectDuplicates Error.DuplicateValueDeclaration (concat typeValues)
617 , detectDuplicates Error.DuplicateTypeDeclaration types
618 ]
621detectDuplicates :: (String -> Error.Error) -> [A.Located String] -> Result wrn ()
622detectDuplicates tag names =
623 let
624 add (A.A region name) dict =
625 Map.insertWith (++) name [region] dict
627 makeGroups pairs =
628 Map.toList (foldr add Map.empty pairs)
630 check (name, regions) =
631 case regions of
632 _ : region : _ ->
633 Result.throw region (tag name)
635 _ ->
636 return ()
637 in
638 F.traverse_ check (makeGroups names)
642-- UNBOUND TYPE VARIABLES
645checkTypeVarsInUnion :: A.Commented (D.Union Type.Raw) -> Result wrn ()
646checkTypeVarsInUnion (A.A (region,_) (D.Type name boundVars ctors)) =
647 case diff boundVars (concatMap freeVars (concatMap snd ctors)) of
648 (_, []) ->
649 return ()
651 (_, unbound) ->
652 Result.throw region
653 (Error.UnboundTypeVarsInUnion name boundVars unbound)
656checkTypeVarsInAlias :: A.Commented (D.Alias Type.Raw) -> Result wrn ()
657checkTypeVarsInAlias (A.A (region,_) (D.Type name boundVars tipe)) =
658 case diff boundVars (freeVars tipe) of
659 ([], []) ->
660 return ()
662 ([], unbound) ->
663 Result.throw region
664 (Error.UnboundTypeVarsInAlias name boundVars unbound)
666 (unused, []) ->
667 Result.throw region
668 (Error.UnusedTypeVarsInAlias name boundVars unused)
670 (unused, unbound) ->
671 Result.throw region
672 (Error.MessyTypeVarsInAlias name boundVars unused unbound)
675diff :: [String] -> [A.Located String] -> ([String], [String])
676diff left right =
677 let
678 leftSet =
679 Set.fromList left
681 rightSet =
682 Set.fromList (map A.drop right)
683 in
684 ( Set.toList (Set.difference leftSet rightSet)
685 , Set.toList (Set.difference rightSet leftSet)
686 )
689freeVars :: Type.Raw -> [A.Located String]
690freeVars (A.A region tipe) =
691 case tipe of
692 Type.RLambda t1 t2 ->
693 freeVars t1 ++ freeVars t2
695 Type.RVar x ->
696 [A.A region x]
698 Type.RType _ ->
699 []
701 Type.RApp t ts ->
702 concatMap freeVars (t:ts)
704 Type.RRecord fields ext ->
705 maybe [] freeVars ext
706 ++ concatMap (freeVars . snd) fields