git.iko.soy/elk
on eb97f2a help sign in
elk/src/Validate.hs
702 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 _ (Valid.Def region (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 (fst ann) pat expr Nothing
357 <*> vrdHelp remainingDecls ports structure
359 Source.Annotation name tipe ->
360 case remainingDecls of
361 A.A _ (D.Def (A.A defRegion (Source.Definition pat expr))) : rest
362 | Pattern.isVar name pat ->
363 addDef
364 <$> validateDef (R.merge (fst ann) defRegion) 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 defRegion (Source.Definition pat expr) : rest ->
395 (:)
396 <$> validateDef defRegion pat expr Nothing
397 <*> definitionsHelp rest
399 A.A annRegion (Source.Annotation name tipe) : rest ->
400 case rest of
401 A.A defRegion (Source.Definition pat expr) : rest'
402 | Pattern.isVar name pat ->
403 (:)
404 <$> validateDef (R.merge annRegion defRegion) pat expr (Just tipe)
405 <*> definitionsHelp rest'
407 _ ->
408 Result.throw annRegion (Error.TypeWithoutDefinition name)
411validateDef
412 :: R.Region
413 -> Pattern.Raw
414 -> Source.Expr
415 -> Maybe Type.Raw
416 -> Result wrn Valid.Def
417validateDef region pat expr maybeType =
418 do validExpr <- expression expr
419 validateDefPattern pat validExpr
420 return $ Valid.Def region 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 funcName) ->
432 checkArguments funcName args
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))
442checkArguments :: String -> [Pattern.Raw] -> Result wrn ()
443checkArguments funcName args =
444 let
445 vars =
446 concatMap Pattern.boundVars args
448 checkDups seenArgs (A.A region arg) =
449 if Set.member arg seenArgs then
450 Result.throw region (Error.DuplicateArgument funcName arg)
452 else
453 return (Set.insert arg seenArgs)
454 in
455 foldM_ checkDups Set.empty vars
459-- VALIDATE EXPRESSIONS
462expression :: Source.Expr -> Result wrn Valid.Expr
463expression (A.A ann sourceExpression) =
464 A.A ann <$>
465 case sourceExpression of
466 Var x ->
467 return (Var x)
469 Lambda pattern body ->
470 Lambda
471 <$> validatePattern pattern
472 <*> expression body
474 Binop op leftExpr rightExpr ->
475 Binop op
476 <$> expression leftExpr
477 <*> expression rightExpr
479 Case e branches ->
480 Case
481 <$> expression e
482 <*> T.traverse (\(p,b) -> (,) <$> validatePattern p <*> expression b) branches
484 Data name args ->
485 Data name <$> T.traverse expression args
487 Literal lit ->
488 return (Literal lit)
490 ExplicitList expressions ->
491 ExplicitList
492 <$> T.traverse expression expressions
494 App funcExpr argExpr ->
495 App
496 <$> expression funcExpr
497 <*> expression argExpr
499 If branches finally ->
500 If
501 <$> T.traverse both branches
502 <*> expression finally
504 Access record field ->
505 Access
506 <$> expression record
507 <*> return field
509 Update record fields ->
510 Update
511 <$> expression record
512 <*> T.traverse second fields
514 Record fields ->
515 let
516 checkDups seenFields (field,_) =
517 if Set.member field seenFields then
518 Result.throw ann (Error.DuplicateFieldName field)
520 else
521 return (Set.insert field seenFields)
522 in
523 do foldM_ checkDups Set.empty fields
524 Record <$> T.traverse second fields
526 Let defs body ->
527 Let
528 <$> definitions defs
529 <*> expression body
531 Cmd moduleName ->
532 return (Cmd moduleName)
534 Sub moduleName ->
535 return (Sub moduleName)
537 OutgoingPort name tipe ->
538 return (OutgoingPort name tipe)
540 IncomingPort name tipe ->
541 return (IncomingPort name tipe)
543 Program _ _ ->
544 error "DANGER - Program AST nodes should not be in validation phase."
546 SaveEnv moduleName effects ->
547 return (SaveEnv moduleName effects)
549 GLShader uid src gltipe ->
550 return (GLShader uid src gltipe)
553second :: (a, Source.Expr) -> Result wrn (a, Valid.Expr)
554second (value, expr) =
555 (,) value <$> expression expr
558both :: (Source.Expr, Source.Expr) -> Result wrn (Valid.Expr, Valid.Expr)
559both (expr1, expr2) =
560 (,) <$> expression expr1 <*> expression expr2
564-- VALIDATE PATTERNS
567validatePattern :: Pattern.Raw -> Result wrn Pattern.Raw
568validatePattern pattern =
569 do detectDuplicates Error.BadPattern (Pattern.boundVars pattern)
570 return pattern
574-- DETECT DUPLICATES
577checkDuplicates :: ValidStuff -> Result wrn ()
578checkDuplicates (ValidStuff ports (D.Decls defs unions aliases _)) =
579 let
580 -- SIMPLE NAMES
582 defValues =
583 concatMap (Pattern.boundVars . Valid.getPattern . A.drop) defs
585 portValues =
586 map fromPort ports
588 fromPort (A.A (region, _) (Effects.PortRaw name _)) =
589 A.A region name
591 -- TYPE NAMES
593 (types, typeValues) =
594 unzip (map fromUnion unions ++ map fromAlias aliases)
596 fromUnion (A.A (region, _) (D.Type name _ ctors)) =
597 ( A.A region name
598 , map (A.A region . fst) ctors
599 )
601 fromAlias (A.A (region, _) (D.Type name _ (A.A _ tipe))) =
602 (,) (A.A region name) $
603 case tipe of
604 Type.RRecord _ _ ->
605 [A.A region name]
607 _ ->
608 []
609 in
610 F.sequenceA_
611 [ detectDuplicates Error.DuplicateValueDeclaration (portValues ++ defValues)
612 , detectDuplicates Error.DuplicateValueDeclaration (concat typeValues)
613 , detectDuplicates Error.DuplicateTypeDeclaration types
614 ]
617detectDuplicates :: (String -> Error.Error) -> [A.Located String] -> Result wrn ()
618detectDuplicates tag names =
619 let
620 add (A.A region name) dict =
621 Map.insertWith (++) name [region] dict
623 makeGroups pairs =
624 Map.toList (foldr add Map.empty pairs)
626 check (name, regions) =
627 case regions of
628 _ : region : _ ->
629 Result.throw region (tag name)
631 _ ->
632 return ()
633 in
634 F.traverse_ check (makeGroups names)
638-- UNBOUND TYPE VARIABLES
641checkTypeVarsInUnion :: A.Commented (D.Union Type.Raw) -> Result wrn ()
642checkTypeVarsInUnion (A.A (region,_) (D.Type name boundVars ctors)) =
643 case diff boundVars (concatMap freeVars (concatMap snd ctors)) of
644 (_, []) ->
645 return ()
647 (_, unbound) ->
648 Result.throw region
649 (Error.UnboundTypeVarsInUnion name boundVars unbound)
652checkTypeVarsInAlias :: A.Commented (D.Alias Type.Raw) -> Result wrn ()
653checkTypeVarsInAlias (A.A (region,_) (D.Type name boundVars tipe)) =
654 case diff boundVars (freeVars tipe) of
655 ([], []) ->
656 return ()
658 ([], unbound) ->
659 Result.throw region
660 (Error.UnboundTypeVarsInAlias name boundVars unbound)
662 (unused, []) ->
663 Result.throw region
664 (Error.UnusedTypeVarsInAlias name boundVars unused)
666 (unused, unbound) ->
667 Result.throw region
668 (Error.MessyTypeVarsInAlias name boundVars unused unbound)
671diff :: [String] -> [A.Located String] -> ([String], [String])
672diff left right =
673 let
674 leftSet =
675 Set.fromList left
677 rightSet =
678 Set.fromList (map A.drop right)
679 in
680 ( Set.toList (Set.difference leftSet rightSet)
681 , Set.toList (Set.difference rightSet leftSet)
682 )
685freeVars :: Type.Raw -> [A.Located String]
686freeVars (A.A region tipe) =
687 case tipe of
688 Type.RLambda t1 t2 ->
689 freeVars t1 ++ freeVars t2
691 Type.RVar x ->
692 [A.A region x]
694 Type.RType _ ->
695 []
697 Type.RApp t ts ->
698 concatMap freeVars (t:ts)
700 Type.RRecord fields ext ->
701 maybe [] freeVars ext
702 ++ concatMap (freeVars . snd) fields