git.iko.soy/elk
on 2feb357 help sign in
elk/src/Validate.hs
721 lines 19 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Validate (Result, validate) where
5import Control.Monad (foldM_, when)
6import qualified Data.Foldable as F
7import qualified Data.Map as Map
8import qualified Data.Maybe as Maybe
9import qualified Data.Set as Set
10import Data.Text (Text)
12import qualified AST.Effects as Effects
13import qualified AST.Expression.Source as Src
14import qualified AST.Declaration as D
15import qualified AST.Literal as L
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 AST.Variable as Var
21import qualified Elm.Compiler.Imports as Imports
22import qualified Elm.Package as Package
23import Elm.Utils ((|>))
24import qualified Reporting.Annotation as A
25import qualified Reporting.Error.Syntax as Error
26import qualified Reporting.Region as R
27import qualified Reporting.Result as Result
31type Result warning a =
32 Result.Result () warning Error.Error a
36-- MODULES
39validate :: Module.Source -> Result wrn Module.Valid
40validate (Module.Module name path info) =
41 let
42 (ModuleName.Canonical pkgName _) =
43 name
45 (Module.Source tag settings docs exports imports decls) =
46 info
47 in
48 do (ValidStuff ports structure) <- validateDecls decls
50 validEffects <- validateEffects tag settings ports (D._defs structure)
52 return $ Module.Module name path $
53 Module.Valid docs exports (addDefaults pkgName imports) structure validEffects
57-- IMPORTS
60addDefaults
61 :: Package.Name
62 -> [Module.UserImport]
63 -> ([Module.DefaultImport], [Module.UserImport])
64addDefaults pkgName imports =
65 flip (,) imports $
66 if pkgName == Package.core then
67 []
69 else
70 Imports.defaults
74-- EFFECTS
77validateEffects
78 :: Module.SourceTag
79 -> Module.SourceSettings
80 -> [A.Commented Effects.PortRaw]
81 -> [A.Commented Src.ValidDef]
82 -> Result wrn Effects.Raw
83validateEffects tag settings@(A.A _ pairs) ports validDefs =
84 case tag of
85 Module.Normal ->
86 do noSettings Error.SettingsOnNormalModule settings
87 noPorts ports
88 return Effects.None
90 Module.Port _ ->
91 do noSettings Error.SettingsOnPortModule settings
92 return (Effects.Port ports)
94 Module.Effect tagRegion ->
95 let
96 collectSettings (A.A region setting, userValue) dict =
97 Map.insertWith (++) setting [(region, userValue)] dict
99 settingsDict =
100 foldr collectSettings Map.empty pairs
101 in
102 do noPorts ports
103 managerType <- toManagerType tagRegion settingsDict
104 (r0, r1, r2) <- checkManager tagRegion managerType validDefs
105 return (Effects.Manager () (Effects.Info tagRegion r0 r1 r2 managerType))
108noSettings :: Error.Error -> Module.SourceSettings -> Result wrn ()
109noSettings errorMsg (A.A region settings) =
110 case settings of
111 [] ->
112 Result.ok ()
114 _ : _ ->
115 Result.throw region errorMsg
118noPorts :: [A.Commented Effects.PortRaw] -> Result wrn ()
119noPorts ports =
120 case ports of
121 [] ->
122 Result.ok ()
124 _ : _ ->
125 let
126 toError (A.A (region, _) (Effects.PortRaw name _)) =
127 A.A region (Error.UnexpectedPort name)
128 in
129 Result.throwMany (map toError ports)
132toManagerType
133 :: R.Region
134 -> Map.Map Text [(R.Region, A.Located Text)]
135 -> Result wrn Effects.ManagerType
136toManagerType tagRegion settingsDict =
137 let
138 toErrors name entries =
139 map (\entry -> A.A (fst entry) (Error.BadSettingOnEffectModule name)) entries
141 errors =
142 settingsDict
143 |> Map.delete "command"
144 |> Map.delete "subscription"
145 |> Map.mapWithKey toErrors
146 |> Map.elems
147 |> concat
148 in
149 do when (not (null errors)) (Result.throwMany errors)
150 maybeEffects <-
151 (,) <$> extractOne "command" settingsDict
152 <*> extractOne "subscription" settingsDict
154 -- TODO check that cmd and sub types exist?
155 case maybeEffects of
156 (Nothing, Nothing) ->
157 Result.throw tagRegion Error.NoSettingsOnEffectModule
159 (Just cmd, Nothing) ->
160 return (Effects.CmdManager cmd)
162 (Nothing, Just sub) ->
163 return (Effects.SubManager sub)
165 (Just cmd, Just sub) ->
166 return (Effects.FxManager cmd sub)
169extractOne
170 :: Text
171 -> Map.Map Text [(R.Region, A.Located Text)]
172 -> Result wrn (Maybe (A.Located Text))
173extractOne name settingsDict =
174 case Map.lookup name settingsDict of
175 Nothing ->
176 return Nothing
178 Just [] ->
179 error "Empty lists should never be added to the dictionary of effect module settings."
181 Just [(_, userType)] ->
182 return (Just userType)
184 Just ((region, _) : _) ->
185 Result.throw region (Error.DuplicateSettingOnEffectModule name)
189-- CHECK EFFECT MANAGER
192checkManager
193 :: R.Region
194 -> Effects.ManagerType
195 -> [A.Commented Src.ValidDef]
196 -> Result wrn (R.Region, R.Region, R.Region)
197checkManager tagRegion managerType validDefs =
198 let
199 regionDict =
200 Map.fromList (Maybe.mapMaybe getSimpleDefRegion validDefs)
201 in
202 const (,,)
203 <$> requireMaps tagRegion regionDict managerType
204 <*> requireRegion tagRegion regionDict "init"
205 <*> requireRegion tagRegion regionDict "onEffects"
206 <*> requireRegion tagRegion regionDict "onSelfMsg"
209getSimpleDefRegion :: A.Commented Src.ValidDef -> Maybe (Text, R.Region)
210getSimpleDefRegion decl =
211 case decl of
212 A.A _ (Src.Def region (A.A _ (Pattern.Var name)) _ _) ->
213 Just (name, region)
215 _ ->
216 Nothing
219requireMaps
220 :: R.Region
221 -> Map.Map Text R.Region
222 -> Effects.ManagerType
223 -> Result wrn ()
224requireMaps tagRegion regionDict managerType =
225 let
226 check name =
227 when (Map.notMember name regionDict) $
228 Result.throw tagRegion (Error.MissingManagerOnEffectModule name)
229 in
230 case managerType of
231 Effects.CmdManager _ ->
232 check "cmdMap"
234 Effects.SubManager _ ->
235 check "subMap"
237 Effects.FxManager _ _ ->
238 check "cmdMap" <* check "subMap"
241requireRegion :: R.Region -> Map.Map Text R.Region -> Text -> Result wrn R.Region
242requireRegion tagRegion regionDict name =
243 case Map.lookup name regionDict of
244 Just region ->
245 return region
247 Nothing ->
248 Result.throw tagRegion (Error.MissingManagerOnEffectModule name)
252-- COLLAPSE COMMENTS
255collapseComments :: [D.CommentOr (A.Located a)] -> Result wrn [A.Commented a]
256collapseComments listWithComments =
257 case listWithComments of
258 [] ->
259 Result.ok []
261 D.Comment (A.A _ msg) : D.Whatever (A.A region a) : rest ->
262 let
263 entry =
264 A.A (region, Just msg) a
265 in
266 fmap (entry:) (collapseComments rest)
268 D.Comment (A.A region _) : rest ->
269 collapseComments rest
270 <* Result.throw region Error.CommentOnNothing
273 D.Whatever (A.A region a) : rest ->
274 let
275 entry =
276 A.A (region, Nothing) a
277 in
278 fmap (entry:) (collapseComments rest)
282-- VALIDATE STRUCTURED SOURCE
285validateDecls :: [D.Source] -> Result wrn ValidStuff
286validateDecls sourceDecls =
287 do rawDecls <- collapseComments sourceDecls
289 validStuff <- validateRawDecls rawDecls
291 let (D.Decls _ unions aliases _) = _structure validStuff
293 return validStuff
294 <* F.traverse_ checkTypeVarsInUnion unions
295 <* F.traverse_ checkTypeVarsInAlias aliases
296 <* checkDuplicates validStuff
300-- VALIDATE DECLARATIONS
303data ValidStuff =
304 ValidStuff
305 { _ports :: [A.Commented Effects.PortRaw]
306 , _structure :: D.Valid
307 }
310validateRawDecls :: [A.Commented D.Raw] -> Result wrn ValidStuff
311validateRawDecls commentedDecls =
312 vrdHelp commentedDecls [] (D.Decls [] [] [] [])
315vrdHelp
316 :: [A.Commented D.Raw]
317 -> [A.Commented Effects.PortRaw]
318 -> D.Valid
319 -> Result wrn ValidStuff
320vrdHelp commentedDecls ports structure =
321 case commentedDecls of
322 [] ->
323 Result.ok (ValidStuff ports structure)
325 A.A ann decl : rest ->
326 case decl of
327 D.Union (D.Type name tvars ctors) ->
328 vrdHelp rest ports (D.addUnion (A.A ann (D.Type name tvars ctors)) structure)
330 D.Alias (D.Type name tvars alias) ->
331 vrdHelp rest ports (D.addAlias (A.A ann (D.Type name tvars alias)) structure)
333 D.Fixity fixity ->
334 vrdHelp rest ports (D.addInfix fixity structure)
336 D.Def (A.A region def) ->
337 vrdDefHelp rest (A.A (region, snd ann) def) ports structure
339 D.Port name tipe ->
340 do checkDuplicateFieldsInType tipe
341 vrdHelp rest (A.A ann (Effects.PortRaw name tipe) : ports) structure
344vrdDefHelp
345 :: [A.Commented D.Raw]
346 -> A.Commented Src.RawDef'
347 -> [A.Commented Effects.PortRaw]
348 -> D.Valid
349 -> Result wrn ValidStuff
350vrdDefHelp remainingDecls (A.A ann def) ports structure =
351 let
352 addDef validDef (ValidStuff finalPorts struct) =
353 ValidStuff finalPorts (D.addDef (A.A ann validDef) struct)
354 in
355 case def of
356 Src.Definition pat expr ->
357 addDef
358 <$> validateDef (fst ann) pat expr Nothing
359 <*> vrdHelp remainingDecls ports structure
361 Src.Annotation name tipe ->
362 case remainingDecls of
363 A.A _ (D.Def (A.A defRegion (Src.Definition pat expr))) : rest
364 | Pattern.isVar name pat ->
365 addDef
366 <$> validateDef (R.merge (fst ann) defRegion) pat expr (Just tipe)
367 <*> vrdHelp rest ports structure
369 _ ->
370 vrdHelp remainingDecls ports structure
371 <* Result.throw (fst ann) (Error.TypeWithoutDefinition name)
375-- VALIDATE DEFINITIONS
378definitions :: [Src.RawDef] -> Result wrn [Src.ValidDef]
379definitions sourceDefs =
380 do validDefs <- definitionsHelp sourceDefs
382 validDefs
383 |> map Src.getPattern
384 |> concatMap Pattern.boundVars
385 |> detectDuplicates Error.DuplicateDefinition
387 return validDefs
390definitionsHelp :: [Src.RawDef] -> Result wrn [Src.ValidDef]
391definitionsHelp sourceDefs =
392 case sourceDefs of
393 [] ->
394 return []
396 A.A defRegion (Src.Definition pat expr) : rest ->
397 (:)
398 <$> validateDef defRegion pat expr Nothing
399 <*> definitionsHelp rest
401 A.A annRegion (Src.Annotation name tipe) : rest ->
402 case rest of
403 A.A defRegion (Src.Definition pat expr) : rest'
404 | Pattern.isVar name pat ->
405 (:)
406 <$> validateDef (R.merge annRegion defRegion) pat expr (Just tipe)
407 <*> definitionsHelp rest'
409 _ ->
410 Result.throw annRegion (Error.TypeWithoutDefinition name)
413validateDef
414 :: R.Region
415 -> Pattern.Raw
416 -> Src.RawExpr
417 -> Maybe Type.Raw
418 -> Result wrn Src.ValidDef
419validateDef region pat expr maybeType =
420 do validExpr <- expression expr
421 validateDefPattern pat validExpr
422 F.traverse_ checkDuplicateFieldsInType maybeType
423 return $ Src.Def region pat validExpr maybeType
426validateDefPattern :: Pattern.Raw -> Src.ValidExpr -> Result wrn ()
427validateDefPattern pattern body =
428 case fst (Src.collectLambdas body) of
429 [] ->
430 return ()
432 args ->
433 case pattern of
434 A.A _ (Pattern.Var funcName) ->
435 checkArguments funcName args
437 _ ->
438 let
439 (A.A start _) = pattern
440 (A.A end _) = last args
441 in
442 Result.throw (R.merge start end) (Error.BadFunctionName (length args))
445checkArguments :: Text -> [Pattern.Raw] -> Result wrn ()
446checkArguments funcName args =
447 let
448 vars =
449 concatMap Pattern.boundVars args
451 checkDups seenArgs (A.A region arg) =
452 if Set.member arg seenArgs then
453 Result.throw region (Error.DuplicateArgument funcName arg)
455 else
456 return (Set.insert arg seenArgs)
457 in
458 foldM_ checkDups Set.empty vars
462-- VALIDATE EXPRESSIONS
465expression :: Src.RawExpr -> Result wrn Src.ValidExpr
466expression (A.A ann sourceExpression) =
467 A.A ann <$>
468 case sourceExpression of
469 Src.Var (Var.Raw "True") ->
470 return (Src.Literal (L.Boolean True))
472 Src.Var (Var.Raw "False") ->
473 return (Src.Literal (L.Boolean False))
475 Src.Var x ->
476 return (Src.Var x)
478 Src.Lambda pattern body ->
479 Src.Lambda
480 <$> validatePattern pattern
481 <*> expression body
483 Src.Binop ops lastExpr ->
484 Src.Binop
485 <$> traverse (\(expr,op) -> (,) <$> expression expr <*> pure op) ops
486 <*> expression lastExpr
488 Src.Case e branches ->
489 Src.Case
490 <$> expression e
491 <*> traverse (\(p,b) -> (,) <$> validatePattern p <*> expression b) branches
493 Src.Ctor name args ->
494 Src.Ctor name <$> traverse expression args
496 Src.Literal lit ->
497 return (Src.Literal lit)
499 Src.List expressions ->
500 Src.List
501 <$> traverse expression expressions
503 Src.App funcExpr argExpr ->
504 Src.App
505 <$> expression funcExpr
506 <*> expression argExpr
508 Src.If branches finally ->
509 Src.If
510 <$> traverse both branches
511 <*> expression finally
513 Src.Access record field ->
514 Src.Access
515 <$> expression record
516 <*> return field
518 Src.Update record fields ->
519 do checkDuplicateFields ann fields
520 Src.Update <$> expression record <*> traverse second fields
522 Src.Record fields ->
523 do checkDuplicateFields ann fields
524 Src.Record <$> traverse second fields
526 Src.Let defs body ->
527 Src.Let
528 <$> definitions defs
529 <*> expression body
531 Src.GLShader uid src gltipe ->
532 return (Src.GLShader uid src gltipe)
535second :: (a, Src.RawExpr) -> Result wrn (a, Src.ValidExpr)
536second (value, expr) =
537 (,) value <$> expression expr
540both :: (Src.RawExpr, Src.RawExpr) -> Result wrn (Src.ValidExpr, Src.ValidExpr)
541both (expr1, expr2) =
542 (,) <$> expression expr1 <*> expression expr2
545checkDuplicateFields :: R.Region -> [(A.Located Text, a)] -> Result wrn ()
546checkDuplicateFields recordRegion fields =
547 let
548 checkDups seenFields ( A.A region field, _ ) =
549 if Set.member field seenFields then
550 Result.throw recordRegion (Error.DuplicateFieldName region field)
551 else
552 Result.ok (Set.insert field seenFields)
553 in
554 foldM_ checkDups Set.empty fields
558-- VALIDATE PATTERNS
561validatePattern :: Pattern.Raw -> Result wrn Pattern.Raw
562validatePattern pattern =
563 do detectDuplicates Error.BadPattern (Pattern.boundVars pattern)
564 return pattern
568-- DETECT DUPLICATES
571checkDuplicates :: ValidStuff -> Result wrn ()
572checkDuplicates (ValidStuff ports (D.Decls defs unions aliases _)) =
573 let
574 -- SIMPLE NAMES
576 defValues =
577 concatMap (Pattern.boundVars . Src.getPattern . A.drop) defs
579 portValues =
580 map fromPort ports
582 fromPort (A.A (region, _) (Effects.PortRaw name _)) =
583 A.A region name
585 -- TYPE NAMES
587 (types, typeValues) =
588 unzip (map fromUnion unions ++ map fromAlias aliases)
590 fromUnion (A.A (region, _) (D.Type name _ ctors)) =
591 ( A.A region name
592 , map (A.A region . fst) ctors
593 )
595 fromAlias (A.A (region, _) (D.Type name _ (A.A _ tipe))) =
596 (,) (A.A region name) $
597 case tipe of
598 Type.RRecord _ _ ->
599 [A.A region name]
601 _ ->
602 []
603 in
604 F.sequenceA_
605 [ detectDuplicates Error.DuplicateValueDeclaration (portValues ++ defValues)
606 , detectDuplicates Error.DuplicateValueDeclaration (concat typeValues)
607 , detectDuplicates Error.DuplicateTypeDeclaration types
608 ]
611detectDuplicates :: (Text -> Error.Error) -> [A.Located Text] -> Result wrn ()
612detectDuplicates tag names =
613 let
614 add (A.A region name) dict =
615 Map.insertWith (++) name [region] dict
617 makeGroups pairs =
618 Map.toList (foldr add Map.empty pairs)
620 check (name, regions) =
621 case regions of
622 _ : region : _ ->
623 Result.throw region (tag name)
625 _ ->
626 return ()
627 in
628 F.traverse_ check (makeGroups names)
632-- UNBOUND TYPE VARIABLES
635checkTypeVarsInUnion :: A.Commented (D.Union Type.Raw) -> Result wrn ()
636checkTypeVarsInUnion (A.A (region,_) (D.Type name boundVars ctors)) =
637 do allFreeVars <- concat <$> traverse freeVars (concatMap snd ctors)
638 case diff boundVars allFreeVars of
639 (_, []) ->
640 return ()
642 (_, unbound) ->
643 Result.throw region
644 (Error.UnboundTypeVarsInUnion name boundVars unbound)
647checkTypeVarsInAlias :: A.Commented (D.Alias Type.Raw) -> Result wrn ()
648checkTypeVarsInAlias (A.A (region,_) (D.Type name boundVars tipe)) =
649 do allFreeVars <- freeVars tipe
650 case diff boundVars allFreeVars of
651 ([], []) ->
652 return ()
654 ([], unbound) ->
655 Result.throw region
656 (Error.UnboundTypeVarsInAlias name boundVars unbound)
658 (unused, []) ->
659 Result.throw region
660 (Error.UnusedTypeVarsInAlias name boundVars unused)
662 (unused, unbound) ->
663 Result.throw region
664 (Error.MessyTypeVarsInAlias name boundVars unused unbound)
667diff :: [Text] -> [A.Located Text] -> ([Text], [Text])
668diff left right =
669 let
670 leftSet =
671 Set.fromList left
673 rightSet =
674 Set.fromList (map A.drop right)
675 in
676 ( Set.toList (Set.difference leftSet rightSet)
677 , Set.toList (Set.difference rightSet leftSet)
678 )
681freeVars :: Type.Raw -> Result wrn [A.Located Text]
682freeVars (A.A region tipe) =
683 case tipe of
684 Type.RLambda t1 t2 ->
685 (++) <$> freeVars t1 <*> freeVars t2
687 Type.RVar x ->
688 Result.ok [A.A region x]
690 Type.RType _ ->
691 Result.ok []
693 Type.RApp t ts ->
694 concat <$> traverse freeVars (t:ts)
696 Type.RRecord fields ext ->
697 do checkDuplicateFields region fields
698 let types = Maybe.maybeToList ext ++ map snd fields
699 concat <$> traverse freeVars types
702checkDuplicateFieldsInType :: Type.Raw -> Result wrn ()
703checkDuplicateFieldsInType (A.A region tipe) =
704 case tipe of
705 Type.RLambda t1 t2 ->
706 checkDuplicateFieldsInType t1
707 <* checkDuplicateFieldsInType t2
709 Type.RVar _ ->
710 Result.ok ()
712 Type.RType _ ->
713 Result.ok ()
715 Type.RApp t ts ->
716 F.traverse_ checkDuplicateFieldsInType (t:ts)
718 Type.RRecord fields ext ->
719 do checkDuplicateFields region fields
720 let types = Maybe.maybeToList ext ++ map snd fields
721 F.traverse_ checkDuplicateFieldsInType types