git.iko.soy/elk
on b97576d help sign in
elk/src/Validate.hs
681 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
10import qualified AST.Effects as Effects
11import qualified AST.Expression.Source as Src
12import qualified AST.Declaration as D
13import qualified AST.Module as Module
14import qualified AST.Module.Name as ModuleName
15import qualified AST.Pattern as Pattern
16import qualified AST.Type as Type
17import qualified Elm.Compiler.Imports as Imports
18import qualified Elm.Package as Package
19import Elm.Utils ((|>))
20import qualified Reporting.Annotation as A
21import qualified Reporting.Error.Syntax as Error
22import qualified Reporting.Region as R
23import qualified Reporting.Result as Result
27type Result warning a =
28 Result.Result () warning Error.Error a
32-- MODULES
35module' :: Module.Source -> Result wrn Module.Valid
36module' (Module.Module name path info) =
37 let
38 (ModuleName.Canonical pkgName _) =
39 name
41 (Module.Source tag settings docs exports imports decls) =
42 info
43 in
44 do (ValidStuff ports structure) <- validateDecls decls
46 validEffects <- validateEffects tag settings ports (D._defs structure)
48 return $ Module.Module name path $
49 Module.Valid docs exports (addDefaults pkgName imports) structure validEffects
53-- IMPORTS
56addDefaults
57 :: Package.Name
58 -> [Module.UserImport]
59 -> ([Module.DefaultImport], [Module.UserImport])
60addDefaults pkgName imports =
61 flip (,) imports $
62 if pkgName == Package.core then
63 []
65 else
66 Imports.defaults
70-- EFFECTS
73validateEffects
74 :: Module.SourceTag
75 -> Module.SourceSettings
76 -> [A.Commented Effects.PortRaw]
77 -> [A.Commented Src.ValidDef]
78 -> Result wrn Effects.Raw
79validateEffects tag settings@(A.A _ pairs) ports validDefs =
80 case tag of
81 Module.Normal ->
82 do noSettings Error.SettingsOnNormalModule settings
83 noPorts ports
84 return Effects.None
86 Module.Port _ ->
87 do noSettings Error.SettingsOnPortModule settings
88 return (Effects.Port ports)
90 Module.Effect tagRegion ->
91 let
92 collectSettings (A.A region setting, userValue) dict =
93 Map.insertWith (++) setting [(region, userValue)] dict
95 settingsDict =
96 foldr collectSettings Map.empty pairs
97 in
98 do noPorts ports
99 managerType <- toManagerType tagRegion settingsDict
100 (r0, r1, r2) <- checkManager tagRegion managerType validDefs
101 return (Effects.Manager () (Effects.Info tagRegion r0 r1 r2 managerType))
104noSettings :: Error.Error -> Module.SourceSettings -> Result wrn ()
105noSettings errorMsg (A.A region settings) =
106 case settings of
107 [] ->
108 Result.ok ()
110 _ : _ ->
111 Result.throw region errorMsg
114noPorts :: [A.Commented Effects.PortRaw] -> Result wrn ()
115noPorts ports =
116 case ports of
117 [] ->
118 Result.ok ()
120 _ : _ ->
121 let
122 toError (A.A (region, _) (Effects.PortRaw name _)) =
123 A.A region (Error.UnexpectedPort name)
124 in
125 Result.throwMany (map toError ports)
128toManagerType
129 :: R.Region
130 -> Map.Map String [(R.Region, A.Located String)]
131 -> Result wrn Effects.ManagerType
132toManagerType tagRegion settingsDict =
133 let
134 toErrors name entries =
135 map (\entry -> A.A (fst entry) (Error.BadSettingOnEffectModule name)) entries
137 errors =
138 settingsDict
139 |> Map.delete "command"
140 |> Map.delete "subscription"
141 |> Map.mapWithKey toErrors
142 |> Map.elems
143 |> concat
144 in
145 do when (not (null errors)) (Result.throwMany errors)
146 maybeEffects <-
147 (,) <$> extractOne "command" settingsDict
148 <*> extractOne "subscription" settingsDict
150 -- TODO check that cmd and sub types exist?
151 case maybeEffects of
152 (Nothing, Nothing) ->
153 Result.throw tagRegion Error.NoSettingsOnEffectModule
155 (Just cmd, Nothing) ->
156 return (Effects.CmdManager cmd)
158 (Nothing, Just sub) ->
159 return (Effects.SubManager sub)
161 (Just cmd, Just sub) ->
162 return (Effects.FxManager cmd sub)
165extractOne
166 :: String
167 -> Map.Map String [(R.Region, A.Located String)]
168 -> Result wrn (Maybe (A.Located String))
169extractOne name settingsDict =
170 case Map.lookup name settingsDict of
171 Nothing ->
172 return Nothing
174 Just [] ->
175 error "Empty lists should never be added to the dictionary of effect module settings."
177 Just [(_, userType)] ->
178 return (Just userType)
180 Just ((region, _) : _) ->
181 Result.throw region (Error.DuplicateSettingOnEffectModule name)
185-- CHECK EFFECT MANAGER
188checkManager
189 :: R.Region
190 -> Effects.ManagerType
191 -> [A.Commented Src.ValidDef]
192 -> Result wrn (R.Region, R.Region, R.Region)
193checkManager tagRegion managerType validDefs =
194 let
195 regionDict =
196 Map.fromList (Maybe.mapMaybe getSimpleDefRegion validDefs)
197 in
198 const (,,)
199 <$> requireMaps tagRegion regionDict managerType
200 <*> requireRegion tagRegion regionDict "init"
201 <*> requireRegion tagRegion regionDict "onEffects"
202 <*> requireRegion tagRegion regionDict "onSelfMsg"
205getSimpleDefRegion :: A.Commented Src.ValidDef -> Maybe (String, R.Region)
206getSimpleDefRegion decl =
207 case decl of
208 A.A _ (Src.Def region (A.A _ (Pattern.Var name)) _ _) ->
209 Just (name, region)
211 _ ->
212 Nothing
215requireMaps
216 :: R.Region
217 -> Map.Map String R.Region
218 -> Effects.ManagerType
219 -> Result wrn ()
220requireMaps tagRegion regionDict managerType =
221 let
222 check name =
223 when (Map.notMember name regionDict) $
224 Result.throw tagRegion (Error.MissingManagerOnEffectModule name)
225 in
226 case managerType of
227 Effects.CmdManager _ ->
228 check "cmdMap"
230 Effects.SubManager _ ->
231 check "subMap"
233 Effects.FxManager _ _ ->
234 check "cmdMap" <* check "subMap"
237requireRegion :: R.Region -> Map.Map String R.Region -> String -> Result wrn R.Region
238requireRegion tagRegion regionDict name =
239 case Map.lookup name regionDict of
240 Just region ->
241 return region
243 Nothing ->
244 Result.throw tagRegion (Error.MissingManagerOnEffectModule name)
248-- COLLAPSE COMMENTS
251collapseComments :: [D.CommentOr (A.Located a)] -> Result wrn [A.Commented a]
252collapseComments listWithComments =
253 case listWithComments of
254 [] ->
255 Result.ok []
257 D.Comment (A.A _ msg) : D.Whatever (A.A region a) : rest ->
258 let
259 entry =
260 A.A (region, Just msg) a
261 in
262 fmap (entry:) (collapseComments rest)
264 D.Comment (A.A region _) : rest ->
265 collapseComments rest
266 <* Result.throw region Error.CommentOnNothing
269 D.Whatever (A.A region a) : rest ->
270 let
271 entry =
272 A.A (region, Nothing) a
273 in
274 fmap (entry:) (collapseComments rest)
278-- VALIDATE STRUCTURED SOURCE
281validateDecls :: [D.Source] -> Result wrn ValidStuff
282validateDecls sourceDecls =
283 do rawDecls <- collapseComments sourceDecls
285 validStuff <- validateRawDecls rawDecls
287 let (D.Decls _ unions aliases _) = _structure validStuff
289 return validStuff
290 <* F.traverse_ checkTypeVarsInUnion unions
291 <* F.traverse_ checkTypeVarsInAlias aliases
292 <* checkDuplicates validStuff
296-- VALIDATE DECLARATIONS
299data ValidStuff =
300 ValidStuff
301 { _ports :: [A.Commented Effects.PortRaw]
302 , _structure :: D.Valid
303 }
306validateRawDecls :: [A.Commented D.Raw] -> Result wrn ValidStuff
307validateRawDecls commentedDecls =
308 vrdHelp commentedDecls [] (D.Decls [] [] [] [])
311vrdHelp
312 :: [A.Commented D.Raw]
313 -> [A.Commented Effects.PortRaw]
314 -> D.Valid
315 -> Result wrn ValidStuff
316vrdHelp commentedDecls ports structure =
317 case commentedDecls of
318 [] ->
319 Result.ok (ValidStuff ports structure)
321 A.A ann decl : rest ->
322 case decl of
323 D.Union (D.Type name tvars ctors) ->
324 vrdHelp rest ports (D.addUnion (A.A ann (D.Type name tvars ctors)) structure)
326 D.Alias (D.Type name tvars alias) ->
327 vrdHelp rest ports (D.addAlias (A.A ann (D.Type name tvars alias)) structure)
329 D.Fixity fixity ->
330 vrdHelp rest ports (D.addInfix fixity structure)
332 D.Def (A.A region def) ->
333 vrdDefHelp rest (A.A (region, snd ann) def) ports structure
335 D.Port name tipe ->
336 vrdHelp rest (A.A ann (Effects.PortRaw name tipe) : ports) structure
339vrdDefHelp
340 :: [A.Commented D.Raw]
341 -> A.Commented Src.RawDef'
342 -> [A.Commented Effects.PortRaw]
343 -> D.Valid
344 -> Result wrn ValidStuff
345vrdDefHelp remainingDecls (A.A ann def) ports structure =
346 let
347 addDef validDef (ValidStuff finalPorts struct) =
348 ValidStuff finalPorts (D.addDef (A.A ann validDef) struct)
349 in
350 case def of
351 Src.Definition pat expr ->
352 addDef
353 <$> validateDef (fst ann) pat expr Nothing
354 <*> vrdHelp remainingDecls ports structure
356 Src.Annotation name tipe ->
357 case remainingDecls of
358 A.A _ (D.Def (A.A defRegion (Src.Definition pat expr))) : rest
359 | Pattern.isVar name pat ->
360 addDef
361 <$> validateDef (R.merge (fst ann) defRegion) pat expr (Just tipe)
362 <*> vrdHelp rest ports structure
364 _ ->
365 vrdHelp remainingDecls ports structure
366 <* Result.throw (fst ann) (Error.TypeWithoutDefinition name)
370-- VALIDATE DEFINITIONS
373definitions :: [Src.RawDef] -> Result wrn [Src.ValidDef]
374definitions sourceDefs =
375 do validDefs <- definitionsHelp sourceDefs
377 validDefs
378 |> map Src.getPattern
379 |> concatMap Pattern.boundVars
380 |> detectDuplicates Error.DuplicateDefinition
382 return validDefs
385definitionsHelp :: [Src.RawDef] -> Result wrn [Src.ValidDef]
386definitionsHelp sourceDefs =
387 case sourceDefs of
388 [] ->
389 return []
391 A.A defRegion (Src.Definition pat expr) : rest ->
392 (:)
393 <$> validateDef defRegion pat expr Nothing
394 <*> definitionsHelp rest
396 A.A annRegion (Src.Annotation name tipe) : rest ->
397 case rest of
398 A.A defRegion (Src.Definition pat expr) : rest'
399 | Pattern.isVar name pat ->
400 (:)
401 <$> validateDef (R.merge annRegion defRegion) pat expr (Just tipe)
402 <*> definitionsHelp rest'
404 _ ->
405 Result.throw annRegion (Error.TypeWithoutDefinition name)
408validateDef
409 :: R.Region
410 -> Pattern.Raw
411 -> Src.RawExpr
412 -> Maybe Type.Raw
413 -> Result wrn Src.ValidDef
414validateDef region pat expr maybeType =
415 do validExpr <- expression expr
416 validateDefPattern pat validExpr
417 return $ Src.Def region pat validExpr maybeType
420validateDefPattern :: Pattern.Raw -> Src.ValidExpr -> Result wrn ()
421validateDefPattern pattern body =
422 case fst (Src.collectLambdas body) of
423 [] ->
424 return ()
426 args ->
427 case pattern of
428 A.A _ (Pattern.Var funcName) ->
429 checkArguments funcName args
431 _ ->
432 let
433 (A.A start _) = pattern
434 (A.A end _) = last args
435 in
436 Result.throw (R.merge start end) (Error.BadFunctionName (length args))
439checkArguments :: String -> [Pattern.Raw] -> Result wrn ()
440checkArguments funcName args =
441 let
442 vars =
443 concatMap Pattern.boundVars args
445 checkDups seenArgs (A.A region arg) =
446 if Set.member arg seenArgs then
447 Result.throw region (Error.DuplicateArgument funcName arg)
449 else
450 return (Set.insert arg seenArgs)
451 in
452 foldM_ checkDups Set.empty vars
456-- VALIDATE EXPRESSIONS
459expression :: Src.RawExpr -> Result wrn Src.ValidExpr
460expression (A.A ann sourceExpression) =
461 A.A ann <$>
462 case sourceExpression of
463 Src.Var x ->
464 return (Src.Var x)
466 Src.Lambda pattern body ->
467 Src.Lambda
468 <$> validatePattern pattern
469 <*> expression body
471 Src.Binop ops lastExpr ->
472 Src.Binop
473 <$> traverse (\(expr,op) -> (,) <$> expression expr <*> pure op) ops
474 <*> expression lastExpr
476 Src.Case e branches ->
477 Src.Case
478 <$> expression e
479 <*> traverse (\(p,b) -> (,) <$> validatePattern p <*> expression b) branches
481 Src.Ctor name args ->
482 Src.Ctor name <$> traverse expression args
484 Src.Literal lit ->
485 return (Src.Literal lit)
487 Src.List expressions ->
488 Src.List
489 <$> traverse expression expressions
491 Src.App funcExpr argExpr ->
492 Src.App
493 <$> expression funcExpr
494 <*> expression argExpr
496 Src.If branches finally ->
497 Src.If
498 <$> traverse both branches
499 <*> expression finally
501 Src.Access record field ->
502 Src.Access
503 <$> expression record
504 <*> return field
506 Src.Update record fields ->
507 Src.Update
508 <$> expression record
509 <*> traverse second fields
511 Src.Record fields ->
512 let
513 checkDups seenFields (field,_) =
514 if Set.member field seenFields then
515 Result.throw ann (Error.DuplicateFieldName field)
517 else
518 return (Set.insert field seenFields)
519 in
520 do foldM_ checkDups Set.empty fields
521 Src.Record <$> traverse second fields
523 Src.Let defs body ->
524 Src.Let
525 <$> definitions defs
526 <*> expression body
528 Src.GLShader uid src gltipe ->
529 return (Src.GLShader uid src gltipe)
532second :: (a, Src.RawExpr) -> Result wrn (a, Src.ValidExpr)
533second (value, expr) =
534 (,) value <$> expression expr
537both :: (Src.RawExpr, Src.RawExpr) -> Result wrn (Src.ValidExpr, Src.ValidExpr)
538both (expr1, expr2) =
539 (,) <$> expression expr1 <*> expression expr2
543-- VALIDATE PATTERNS
546validatePattern :: Pattern.Raw -> Result wrn Pattern.Raw
547validatePattern pattern =
548 do detectDuplicates Error.BadPattern (Pattern.boundVars pattern)
549 return pattern
553-- DETECT DUPLICATES
556checkDuplicates :: ValidStuff -> Result wrn ()
557checkDuplicates (ValidStuff ports (D.Decls defs unions aliases _)) =
558 let
559 -- SIMPLE NAMES
561 defValues =
562 concatMap (Pattern.boundVars . Src.getPattern . A.drop) defs
564 portValues =
565 map fromPort ports
567 fromPort (A.A (region, _) (Effects.PortRaw name _)) =
568 A.A region name
570 -- TYPE NAMES
572 (types, typeValues) =
573 unzip (map fromUnion unions ++ map fromAlias aliases)
575 fromUnion (A.A (region, _) (D.Type name _ ctors)) =
576 ( A.A region name
577 , map (A.A region . fst) ctors
578 )
580 fromAlias (A.A (region, _) (D.Type name _ (A.A _ tipe))) =
581 (,) (A.A region name) $
582 case tipe of
583 Type.RRecord _ _ ->
584 [A.A region name]
586 _ ->
587 []
588 in
589 F.sequenceA_
590 [ detectDuplicates Error.DuplicateValueDeclaration (portValues ++ defValues)
591 , detectDuplicates Error.DuplicateValueDeclaration (concat typeValues)
592 , detectDuplicates Error.DuplicateTypeDeclaration types
593 ]
596detectDuplicates :: (String -> Error.Error) -> [A.Located String] -> Result wrn ()
597detectDuplicates tag names =
598 let
599 add (A.A region name) dict =
600 Map.insertWith (++) name [region] dict
602 makeGroups pairs =
603 Map.toList (foldr add Map.empty pairs)
605 check (name, regions) =
606 case regions of
607 _ : region : _ ->
608 Result.throw region (tag name)
610 _ ->
611 return ()
612 in
613 F.traverse_ check (makeGroups names)
617-- UNBOUND TYPE VARIABLES
620checkTypeVarsInUnion :: A.Commented (D.Union Type.Raw) -> Result wrn ()
621checkTypeVarsInUnion (A.A (region,_) (D.Type name boundVars ctors)) =
622 case diff boundVars (concatMap freeVars (concatMap snd ctors)) of
623 (_, []) ->
624 return ()
626 (_, unbound) ->
627 Result.throw region
628 (Error.UnboundTypeVarsInUnion name boundVars unbound)
631checkTypeVarsInAlias :: A.Commented (D.Alias Type.Raw) -> Result wrn ()
632checkTypeVarsInAlias (A.A (region,_) (D.Type name boundVars tipe)) =
633 case diff boundVars (freeVars tipe) of
634 ([], []) ->
635 return ()
637 ([], unbound) ->
638 Result.throw region
639 (Error.UnboundTypeVarsInAlias name boundVars unbound)
641 (unused, []) ->
642 Result.throw region
643 (Error.UnusedTypeVarsInAlias name boundVars unused)
645 (unused, unbound) ->
646 Result.throw region
647 (Error.MessyTypeVarsInAlias name boundVars unused unbound)
650diff :: [String] -> [A.Located String] -> ([String], [String])
651diff left right =
652 let
653 leftSet =
654 Set.fromList left
656 rightSet =
657 Set.fromList (map A.drop right)
658 in
659 ( Set.toList (Set.difference leftSet rightSet)
660 , Set.toList (Set.difference rightSet leftSet)
661 )
664freeVars :: Type.Raw -> [A.Located String]
665freeVars (A.A region tipe) =
666 case tipe of
667 Type.RLambda t1 t2 ->
668 freeVars t1 ++ freeVars t2
670 Type.RVar x ->
671 [A.A region x]
673 Type.RType _ ->
674 []
676 Type.RApp t ts ->
677 concatMap freeVars (t:ts)
679 Type.RRecord fields ext ->
680 maybe [] freeVars ext
681 ++ concatMap (freeVars . snd) fields