git.iko.soy/elk
on e5093cd help sign in
elk/src/Validate.hs
711 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 do checkDuplicateFieldsInType tipe
337 vrdHelp rest (A.A ann (Effects.PortRaw name tipe) : ports) structure
340vrdDefHelp
341 :: [A.Commented D.Raw]
342 -> A.Commented Src.RawDef'
343 -> [A.Commented Effects.PortRaw]
344 -> D.Valid
345 -> Result wrn ValidStuff
346vrdDefHelp remainingDecls (A.A ann def) ports structure =
347 let
348 addDef validDef (ValidStuff finalPorts struct) =
349 ValidStuff finalPorts (D.addDef (A.A ann validDef) struct)
350 in
351 case def of
352 Src.Definition pat expr ->
353 addDef
354 <$> validateDef (fst ann) pat expr Nothing
355 <*> vrdHelp remainingDecls ports structure
357 Src.Annotation name tipe ->
358 case remainingDecls of
359 A.A _ (D.Def (A.A defRegion (Src.Definition pat expr))) : rest
360 | Pattern.isVar name pat ->
361 addDef
362 <$> validateDef (R.merge (fst ann) defRegion) pat expr (Just tipe)
363 <*> vrdHelp rest ports structure
365 _ ->
366 vrdHelp remainingDecls ports structure
367 <* Result.throw (fst ann) (Error.TypeWithoutDefinition name)
371-- VALIDATE DEFINITIONS
374definitions :: [Src.RawDef] -> Result wrn [Src.ValidDef]
375definitions sourceDefs =
376 do validDefs <- definitionsHelp sourceDefs
378 validDefs
379 |> map Src.getPattern
380 |> concatMap Pattern.boundVars
381 |> detectDuplicates Error.DuplicateDefinition
383 return validDefs
386definitionsHelp :: [Src.RawDef] -> Result wrn [Src.ValidDef]
387definitionsHelp sourceDefs =
388 case sourceDefs of
389 [] ->
390 return []
392 A.A defRegion (Src.Definition pat expr) : rest ->
393 (:)
394 <$> validateDef defRegion pat expr Nothing
395 <*> definitionsHelp rest
397 A.A annRegion (Src.Annotation name tipe) : rest ->
398 case rest of
399 A.A defRegion (Src.Definition pat expr) : rest'
400 | Pattern.isVar name pat ->
401 (:)
402 <$> validateDef (R.merge annRegion defRegion) pat expr (Just tipe)
403 <*> definitionsHelp rest'
405 _ ->
406 Result.throw annRegion (Error.TypeWithoutDefinition name)
409validateDef
410 :: R.Region
411 -> Pattern.Raw
412 -> Src.RawExpr
413 -> Maybe Type.Raw
414 -> Result wrn Src.ValidDef
415validateDef region pat expr maybeType =
416 do validExpr <- expression expr
417 validateDefPattern pat validExpr
418 F.traverse_ checkDuplicateFieldsInType maybeType
419 return $ Src.Def region pat validExpr maybeType
422validateDefPattern :: Pattern.Raw -> Src.ValidExpr -> Result wrn ()
423validateDefPattern pattern body =
424 case fst (Src.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 :: Src.RawExpr -> Result wrn Src.ValidExpr
462expression (A.A ann sourceExpression) =
463 A.A ann <$>
464 case sourceExpression of
465 Src.Var x ->
466 return (Src.Var x)
468 Src.Lambda pattern body ->
469 Src.Lambda
470 <$> validatePattern pattern
471 <*> expression body
473 Src.Binop ops lastExpr ->
474 Src.Binop
475 <$> traverse (\(expr,op) -> (,) <$> expression expr <*> pure op) ops
476 <*> expression lastExpr
478 Src.Case e branches ->
479 Src.Case
480 <$> expression e
481 <*> traverse (\(p,b) -> (,) <$> validatePattern p <*> expression b) branches
483 Src.Ctor name args ->
484 Src.Ctor name <$> traverse expression args
486 Src.Literal lit ->
487 return (Src.Literal lit)
489 Src.List expressions ->
490 Src.List
491 <$> traverse expression expressions
493 Src.App funcExpr argExpr ->
494 Src.App
495 <$> expression funcExpr
496 <*> expression argExpr
498 Src.If branches finally ->
499 Src.If
500 <$> traverse both branches
501 <*> expression finally
503 Src.Access record field ->
504 Src.Access
505 <$> expression record
506 <*> return field
508 Src.Update record fields ->
509 do checkDuplicateFields ann fields
510 Src.Update <$> expression record <*> traverse second fields
512 Src.Record fields ->
513 do checkDuplicateFields ann fields
514 Src.Record <$> traverse second fields
516 Src.Let defs body ->
517 Src.Let
518 <$> definitions defs
519 <*> expression body
521 Src.GLShader uid src gltipe ->
522 return (Src.GLShader uid src gltipe)
525second :: (a, Src.RawExpr) -> Result wrn (a, Src.ValidExpr)
526second (value, expr) =
527 (,) value <$> expression expr
530both :: (Src.RawExpr, Src.RawExpr) -> Result wrn (Src.ValidExpr, Src.ValidExpr)
531both (expr1, expr2) =
532 (,) <$> expression expr1 <*> expression expr2
535checkDuplicateFields :: R.Region -> [(A.Located String, a)] -> Result wrn ()
536checkDuplicateFields recordRegion fields =
537 let
538 checkDups seenFields ( A.A region field, _ ) =
539 if Set.member field seenFields then
540 Result.throw recordRegion (Error.DuplicateFieldName region field)
541 else
542 Result.ok (Set.insert field seenFields)
543 in
544 foldM_ checkDups Set.empty fields
548-- VALIDATE PATTERNS
551validatePattern :: Pattern.Raw -> Result wrn Pattern.Raw
552validatePattern pattern =
553 do detectDuplicates Error.BadPattern (Pattern.boundVars pattern)
554 return pattern
558-- DETECT DUPLICATES
561checkDuplicates :: ValidStuff -> Result wrn ()
562checkDuplicates (ValidStuff ports (D.Decls defs unions aliases _)) =
563 let
564 -- SIMPLE NAMES
566 defValues =
567 concatMap (Pattern.boundVars . Src.getPattern . A.drop) defs
569 portValues =
570 map fromPort ports
572 fromPort (A.A (region, _) (Effects.PortRaw name _)) =
573 A.A region name
575 -- TYPE NAMES
577 (types, typeValues) =
578 unzip (map fromUnion unions ++ map fromAlias aliases)
580 fromUnion (A.A (region, _) (D.Type name _ ctors)) =
581 ( A.A region name
582 , map (A.A region . fst) ctors
583 )
585 fromAlias (A.A (region, _) (D.Type name _ (A.A _ tipe))) =
586 (,) (A.A region name) $
587 case tipe of
588 Type.RRecord _ _ ->
589 [A.A region name]
591 _ ->
592 []
593 in
594 F.sequenceA_
595 [ detectDuplicates Error.DuplicateValueDeclaration (portValues ++ defValues)
596 , detectDuplicates Error.DuplicateValueDeclaration (concat typeValues)
597 , detectDuplicates Error.DuplicateTypeDeclaration types
598 ]
601detectDuplicates :: (String -> Error.Error) -> [A.Located String] -> Result wrn ()
602detectDuplicates tag names =
603 let
604 add (A.A region name) dict =
605 Map.insertWith (++) name [region] dict
607 makeGroups pairs =
608 Map.toList (foldr add Map.empty pairs)
610 check (name, regions) =
611 case regions of
612 _ : region : _ ->
613 Result.throw region (tag name)
615 _ ->
616 return ()
617 in
618 F.traverse_ check (makeGroups names)
622-- UNBOUND TYPE VARIABLES
625checkTypeVarsInUnion :: A.Commented (D.Union Type.Raw) -> Result wrn ()
626checkTypeVarsInUnion (A.A (region,_) (D.Type name boundVars ctors)) =
627 do allFreeVars <- concat <$> traverse freeVars (concatMap snd ctors)
628 case diff boundVars allFreeVars of
629 (_, []) ->
630 return ()
632 (_, unbound) ->
633 Result.throw region
634 (Error.UnboundTypeVarsInUnion name boundVars unbound)
637checkTypeVarsInAlias :: A.Commented (D.Alias Type.Raw) -> Result wrn ()
638checkTypeVarsInAlias (A.A (region,_) (D.Type name boundVars tipe)) =
639 do allFreeVars <- freeVars tipe
640 case diff boundVars allFreeVars of
641 ([], []) ->
642 return ()
644 ([], unbound) ->
645 Result.throw region
646 (Error.UnboundTypeVarsInAlias name boundVars unbound)
648 (unused, []) ->
649 Result.throw region
650 (Error.UnusedTypeVarsInAlias name boundVars unused)
652 (unused, unbound) ->
653 Result.throw region
654 (Error.MessyTypeVarsInAlias name boundVars unused unbound)
657diff :: [String] -> [A.Located String] -> ([String], [String])
658diff left right =
659 let
660 leftSet =
661 Set.fromList left
663 rightSet =
664 Set.fromList (map A.drop right)
665 in
666 ( Set.toList (Set.difference leftSet rightSet)
667 , Set.toList (Set.difference rightSet leftSet)
668 )
671freeVars :: Type.Raw -> Result wrn [A.Located String]
672freeVars (A.A region tipe) =
673 case tipe of
674 Type.RLambda t1 t2 ->
675 (++) <$> freeVars t1 <*> freeVars t2
677 Type.RVar x ->
678 Result.ok [A.A region x]
680 Type.RType _ ->
681 Result.ok []
683 Type.RApp t ts ->
684 concat <$> traverse freeVars (t:ts)
686 Type.RRecord fields ext ->
687 do checkDuplicateFields region fields
688 let types = Maybe.maybeToList ext ++ map snd fields
689 concat <$> traverse freeVars types
692checkDuplicateFieldsInType :: Type.Raw -> Result wrn ()
693checkDuplicateFieldsInType (A.A region tipe) =
694 case tipe of
695 Type.RLambda t1 t2 ->
696 checkDuplicateFieldsInType t1
697 <* checkDuplicateFieldsInType t2
699 Type.RVar _ ->
700 Result.ok ()
702 Type.RType _ ->
703 Result.ok ()
705 Type.RApp t ts ->
706 F.traverse_ checkDuplicateFieldsInType (t:ts)
708 Type.RRecord fields ext ->
709 do checkDuplicateFields region fields
710 let types = Maybe.maybeToList ext ++ map snd fields
711 F.traverse_ checkDuplicateFieldsInType types