git.iko.soy/elk
on 4bec0ec help sign in
elk/src/Validate.hs
701 lines 17 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 ExplicitList expressions ->
490 ExplicitList
491 <$> T.traverse expression expressions
493 App funcExpr argExpr ->
494 App
495 <$> expression funcExpr
496 <*> expression argExpr
498 If branches finally ->
499 If
500 <$> T.traverse both branches
501 <*> expression finally
503 Access record field ->
504 Access
505 <$> expression record
506 <*> return field
508 Update record fields ->
509 Update
510 <$> expression record
511 <*> T.traverse second fields
513 Record fields ->
514 let
515 checkDups seenFields (field,_) =
516 if Set.member field seenFields then
517 Result.throw ann (Error.DuplicateFieldName field)
519 else
520 return (Set.insert field seenFields)
521 in
522 do foldM_ checkDups Set.empty fields
523 Record <$> T.traverse second fields
525 Let defs body ->
526 Let
527 <$> definitions defs
528 <*> expression body
530 Cmd moduleName ->
531 return (Cmd moduleName)
533 Sub moduleName ->
534 return (Sub moduleName)
536 OutgoingPort name tipe ->
537 return (OutgoingPort name tipe)
539 IncomingPort name tipe ->
540 return (IncomingPort name tipe)
542 Program _ _ ->
543 error "DANGER - Program AST nodes should not be in validation phase."
545 SaveEnv moduleName effects ->
546 return (SaveEnv moduleName effects)
548 GLShader uid src gltipe ->
549 return (GLShader uid src gltipe)
552second :: (a, Source.Expr) -> Result wrn (a, Valid.Expr)
553second (value, expr) =
554 (,) value <$> expression expr
557both :: (Source.Expr, Source.Expr) -> Result wrn (Valid.Expr, Valid.Expr)
558both (expr1, expr2) =
559 (,) <$> expression expr1 <*> expression expr2
563-- VALIDATE PATTERNS
566validatePattern :: Pattern.Raw -> Result wrn Pattern.Raw
567validatePattern pattern =
568 do detectDuplicates Error.BadPattern (Pattern.boundVars pattern)
569 return pattern
573-- DETECT DUPLICATES
576checkDuplicates :: ValidStuff -> Result wrn ()
577checkDuplicates (ValidStuff ports (D.Decls defs unions aliases _)) =
578 let
579 -- SIMPLE NAMES
581 defValues =
582 concatMap (Pattern.boundVars . Valid.getPattern . A.drop) defs
584 portValues =
585 map fromPort ports
587 fromPort (A.A (region, _) (Effects.PortRaw name _)) =
588 A.A region name
590 -- TYPE NAMES
592 (types, typeValues) =
593 unzip (map fromUnion unions ++ map fromAlias aliases)
595 fromUnion (A.A (region, _) (D.Type name _ ctors)) =
596 ( A.A region name
597 , map (A.A region . fst) ctors
598 )
600 fromAlias (A.A (region, _) (D.Type name _ (A.A _ tipe))) =
601 (,) (A.A region name) $
602 case tipe of
603 Type.RRecord _ _ ->
604 [A.A region name]
606 _ ->
607 []
608 in
609 F.sequenceA_
610 [ detectDuplicates Error.DuplicateValueDeclaration (portValues ++ defValues)
611 , detectDuplicates Error.DuplicateValueDeclaration (concat typeValues)
612 , detectDuplicates Error.DuplicateTypeDeclaration types
613 ]
616detectDuplicates :: (String -> Error.Error) -> [A.Located String] -> Result wrn ()
617detectDuplicates tag names =
618 let
619 add (A.A region name) dict =
620 Map.insertWith (++) name [region] dict
622 makeGroups pairs =
623 Map.toList (foldr add Map.empty pairs)
625 check (name, regions) =
626 case regions of
627 _ : region : _ ->
628 Result.throw region (tag name)
630 _ ->
631 return ()
632 in
633 F.traverse_ check (makeGroups names)
637-- UNBOUND TYPE VARIABLES
640checkTypeVarsInUnion :: A.Commented (D.Union Type.Raw) -> Result wrn ()
641checkTypeVarsInUnion (A.A (region,_) (D.Type name boundVars ctors)) =
642 case diff boundVars (concatMap freeVars (concatMap snd ctors)) of
643 (_, []) ->
644 return ()
646 (_, unbound) ->
647 Result.throw region
648 (Error.UnboundTypeVarsInUnion name boundVars unbound)
651checkTypeVarsInAlias :: A.Commented (D.Alias Type.Raw) -> Result wrn ()
652checkTypeVarsInAlias (A.A (region,_) (D.Type name boundVars tipe)) =
653 case diff boundVars (freeVars tipe) of
654 ([], []) ->
655 return ()
657 ([], unbound) ->
658 Result.throw region
659 (Error.UnboundTypeVarsInAlias name boundVars unbound)
661 (unused, []) ->
662 Result.throw region
663 (Error.UnusedTypeVarsInAlias name boundVars unused)
665 (unused, unbound) ->
666 Result.throw region
667 (Error.MessyTypeVarsInAlias name boundVars unused unbound)
670diff :: [String] -> [A.Located String] -> ([String], [String])
671diff left right =
672 let
673 leftSet =
674 Set.fromList left
676 rightSet =
677 Set.fromList (map A.drop right)
678 in
679 ( Set.toList (Set.difference leftSet rightSet)
680 , Set.toList (Set.difference rightSet leftSet)
681 )
684freeVars :: Type.Raw -> [A.Located String]
685freeVars (A.A region tipe) =
686 case tipe of
687 Type.RLambda t1 t2 ->
688 freeVars t1 ++ freeVars t2
690 Type.RVar x ->
691 [A.A region x]
693 Type.RType _ ->
694 []
696 Type.RApp t ts ->
697 concatMap freeVars (t:ts)
699 Type.RRecord fields ext ->
700 maybe [] freeVars ext
701 ++ concatMap (freeVars . snd) fields