git.iko.soy/elk
on b7403d0 help sign in
elk/src/Validate.hs
687 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
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 do checkDuplicateFields ann fields
508 Src.Update <$> expression record <*> traverse second fields
510 Src.Record fields ->
511 do checkDuplicateFields ann fields
512 Src.Record <$> traverse second fields
514 Src.Let defs body ->
515 Src.Let
516 <$> definitions defs
517 <*> expression body
519 Src.GLShader uid src gltipe ->
520 return (Src.GLShader uid src gltipe)
523second :: (a, Src.RawExpr) -> Result wrn (a, Src.ValidExpr)
524second (value, expr) =
525 (,) value <$> expression expr
528both :: (Src.RawExpr, Src.RawExpr) -> Result wrn (Src.ValidExpr, Src.ValidExpr)
529both (expr1, expr2) =
530 (,) <$> expression expr1 <*> expression expr2
533checkDuplicateFields :: R.Region -> [(A.Located String, a)] -> Result wrn ()
534checkDuplicateFields recordRegion fields =
535 let
536 checkDups seenFields ( A.A region field, _ ) =
537 if Set.member field seenFields then
538 Result.throw recordRegion (Error.DuplicateFieldName region field)
539 else
540 Result.ok (Set.insert field seenFields)
541 in
542 foldM_ checkDups Set.empty fields
546-- VALIDATE PATTERNS
549validatePattern :: Pattern.Raw -> Result wrn Pattern.Raw
550validatePattern pattern =
551 do detectDuplicates Error.BadPattern (Pattern.boundVars pattern)
552 return pattern
556-- DETECT DUPLICATES
559checkDuplicates :: ValidStuff -> Result wrn ()
560checkDuplicates (ValidStuff ports (D.Decls defs unions aliases _)) =
561 let
562 -- SIMPLE NAMES
564 defValues =
565 concatMap (Pattern.boundVars . Src.getPattern . A.drop) defs
567 portValues =
568 map fromPort ports
570 fromPort (A.A (region, _) (Effects.PortRaw name _)) =
571 A.A region name
573 -- TYPE NAMES
575 (types, typeValues) =
576 unzip (map fromUnion unions ++ map fromAlias aliases)
578 fromUnion (A.A (region, _) (D.Type name _ ctors)) =
579 ( A.A region name
580 , map (A.A region . fst) ctors
581 )
583 fromAlias (A.A (region, _) (D.Type name _ (A.A _ tipe))) =
584 (,) (A.A region name) $
585 case tipe of
586 Type.RRecord _ _ ->
587 [A.A region name]
589 _ ->
590 []
591 in
592 F.sequenceA_
593 [ detectDuplicates Error.DuplicateValueDeclaration (portValues ++ defValues)
594 , detectDuplicates Error.DuplicateValueDeclaration (concat typeValues)
595 , detectDuplicates Error.DuplicateTypeDeclaration types
596 ]
599detectDuplicates :: (String -> Error.Error) -> [A.Located String] -> Result wrn ()
600detectDuplicates tag names =
601 let
602 add (A.A region name) dict =
603 Map.insertWith (++) name [region] dict
605 makeGroups pairs =
606 Map.toList (foldr add Map.empty pairs)
608 check (name, regions) =
609 case regions of
610 _ : region : _ ->
611 Result.throw region (tag name)
613 _ ->
614 return ()
615 in
616 F.traverse_ check (makeGroups names)
620-- UNBOUND TYPE VARIABLES
623checkTypeVarsInUnion :: A.Commented (D.Union Type.Raw) -> Result wrn ()
624checkTypeVarsInUnion (A.A (region,_) (D.Type name boundVars ctors)) =
625 do allFreeVars <- concat <$> traverse freeVars (concatMap snd ctors)
626 case diff boundVars allFreeVars of
627 (_, []) ->
628 return ()
630 (_, unbound) ->
631 Result.throw region
632 (Error.UnboundTypeVarsInUnion name boundVars unbound)
635checkTypeVarsInAlias :: A.Commented (D.Alias Type.Raw) -> Result wrn ()
636checkTypeVarsInAlias (A.A (region,_) (D.Type name boundVars tipe)) =
637 do allFreeVars <- freeVars tipe
638 case diff boundVars allFreeVars of
639 ([], []) ->
640 return ()
642 ([], unbound) ->
643 Result.throw region
644 (Error.UnboundTypeVarsInAlias name boundVars unbound)
646 (unused, []) ->
647 Result.throw region
648 (Error.UnusedTypeVarsInAlias name boundVars unused)
650 (unused, unbound) ->
651 Result.throw region
652 (Error.MessyTypeVarsInAlias name boundVars unused unbound)
655diff :: [String] -> [A.Located String] -> ([String], [String])
656diff left right =
657 let
658 leftSet =
659 Set.fromList left
661 rightSet =
662 Set.fromList (map A.drop right)
663 in
664 ( Set.toList (Set.difference leftSet rightSet)
665 , Set.toList (Set.difference rightSet leftSet)
666 )
669freeVars :: Type.Raw -> Result wrn [A.Located String]
670freeVars (A.A region tipe) =
671 case tipe of
672 Type.RLambda t1 t2 ->
673 (++) <$> freeVars t1 <*> freeVars t2
675 Type.RVar x ->
676 Result.ok [A.A region x]
678 Type.RType _ ->
679 Result.ok []
681 Type.RApp t ts ->
682 concat <$> traverse freeVars (t:ts)
684 Type.RRecord fields ext ->
685 do checkDuplicateFields region fields
686 let types = Maybe.maybeToList ext ++ map snd fields
687 concat <$> traverse freeVars types