git.iko.soy/elk
on e53128c help sign in
elk/src/Validate.hs
713 lines 18 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.Module as Module
16import qualified AST.Module.Name as ModuleName
17import qualified AST.Pattern as Pattern
18import qualified AST.Type as Type
19import qualified Elm.Compiler.Imports as Imports
20import qualified Elm.Package as Package
21import Elm.Utils ((|>))
22import qualified Reporting.Annotation as A
23import qualified Reporting.Error.Syntax as Error
24import qualified Reporting.Region as R
25import qualified Reporting.Result as Result
29type Result warning a =
30 Result.Result () warning Error.Error a
34-- MODULES
37validate :: Module.Source -> Result wrn Module.Valid
38validate (Module.Module name path info) =
39 let
40 (ModuleName.Canonical pkgName _) =
41 name
43 (Module.Source tag settings docs exports imports decls) =
44 info
45 in
46 do (ValidStuff ports structure) <- validateDecls decls
48 validEffects <- validateEffects tag settings ports (D._defs structure)
50 return $ Module.Module name path $
51 Module.Valid docs exports (addDefaults pkgName imports) structure validEffects
55-- IMPORTS
58addDefaults
59 :: Package.Name
60 -> [Module.UserImport]
61 -> ([Module.DefaultImport], [Module.UserImport])
62addDefaults pkgName imports =
63 flip (,) imports $
64 if pkgName == Package.core then
65 []
67 else
68 Imports.defaults
72-- EFFECTS
75validateEffects
76 :: Module.SourceTag
77 -> Module.SourceSettings
78 -> [A.Commented Effects.PortRaw]
79 -> [A.Commented Src.ValidDef]
80 -> Result wrn Effects.Raw
81validateEffects tag settings@(A.A _ pairs) ports validDefs =
82 case tag of
83 Module.Normal ->
84 do noSettings Error.SettingsOnNormalModule settings
85 noPorts ports
86 return Effects.None
88 Module.Port _ ->
89 do noSettings Error.SettingsOnPortModule settings
90 return (Effects.Port ports)
92 Module.Effect tagRegion ->
93 let
94 collectSettings (A.A region setting, userValue) dict =
95 Map.insertWith (++) setting [(region, userValue)] dict
97 settingsDict =
98 foldr collectSettings Map.empty pairs
99 in
100 do noPorts ports
101 managerType <- toManagerType tagRegion settingsDict
102 (r0, r1, r2) <- checkManager tagRegion managerType validDefs
103 return (Effects.Manager () (Effects.Info tagRegion r0 r1 r2 managerType))
106noSettings :: Error.Error -> Module.SourceSettings -> Result wrn ()
107noSettings errorMsg (A.A region settings) =
108 case settings of
109 [] ->
110 Result.ok ()
112 _ : _ ->
113 Result.throw region errorMsg
116noPorts :: [A.Commented Effects.PortRaw] -> Result wrn ()
117noPorts ports =
118 case ports of
119 [] ->
120 Result.ok ()
122 _ : _ ->
123 let
124 toError (A.A (region, _) (Effects.PortRaw name _)) =
125 A.A region (Error.UnexpectedPort name)
126 in
127 Result.throwMany (map toError ports)
130toManagerType
131 :: R.Region
132 -> Map.Map Text [(R.Region, A.Located Text)]
133 -> Result wrn Effects.ManagerType
134toManagerType tagRegion settingsDict =
135 let
136 toErrors name entries =
137 map (\entry -> A.A (fst entry) (Error.BadSettingOnEffectModule name)) entries
139 errors =
140 settingsDict
141 |> Map.delete "command"
142 |> Map.delete "subscription"
143 |> Map.mapWithKey toErrors
144 |> Map.elems
145 |> concat
146 in
147 do when (not (null errors)) (Result.throwMany errors)
148 maybeEffects <-
149 (,) <$> extractOne "command" settingsDict
150 <*> extractOne "subscription" settingsDict
152 -- TODO check that cmd and sub types exist?
153 case maybeEffects of
154 (Nothing, Nothing) ->
155 Result.throw tagRegion Error.NoSettingsOnEffectModule
157 (Just cmd, Nothing) ->
158 return (Effects.CmdManager cmd)
160 (Nothing, Just sub) ->
161 return (Effects.SubManager sub)
163 (Just cmd, Just sub) ->
164 return (Effects.FxManager cmd sub)
167extractOne
168 :: Text
169 -> Map.Map Text [(R.Region, A.Located Text)]
170 -> Result wrn (Maybe (A.Located Text))
171extractOne name settingsDict =
172 case Map.lookup name settingsDict of
173 Nothing ->
174 return Nothing
176 Just [] ->
177 error "Empty lists should never be added to the dictionary of effect module settings."
179 Just [(_, userType)] ->
180 return (Just userType)
182 Just ((region, _) : _) ->
183 Result.throw region (Error.DuplicateSettingOnEffectModule name)
187-- CHECK EFFECT MANAGER
190checkManager
191 :: R.Region
192 -> Effects.ManagerType
193 -> [A.Commented Src.ValidDef]
194 -> Result wrn (R.Region, R.Region, R.Region)
195checkManager tagRegion managerType validDefs =
196 let
197 regionDict =
198 Map.fromList (Maybe.mapMaybe getSimpleDefRegion validDefs)
199 in
200 const (,,)
201 <$> requireMaps tagRegion regionDict managerType
202 <*> requireRegion tagRegion regionDict "init"
203 <*> requireRegion tagRegion regionDict "onEffects"
204 <*> requireRegion tagRegion regionDict "onSelfMsg"
207getSimpleDefRegion :: A.Commented Src.ValidDef -> Maybe (Text, R.Region)
208getSimpleDefRegion decl =
209 case decl of
210 A.A _ (Src.Def region (A.A _ (Pattern.Var name)) _ _) ->
211 Just (name, region)
213 _ ->
214 Nothing
217requireMaps
218 :: R.Region
219 -> Map.Map Text R.Region
220 -> Effects.ManagerType
221 -> Result wrn ()
222requireMaps tagRegion regionDict managerType =
223 let
224 check name =
225 when (Map.notMember name regionDict) $
226 Result.throw tagRegion (Error.MissingManagerOnEffectModule name)
227 in
228 case managerType of
229 Effects.CmdManager _ ->
230 check "cmdMap"
232 Effects.SubManager _ ->
233 check "subMap"
235 Effects.FxManager _ _ ->
236 check "cmdMap" <* check "subMap"
239requireRegion :: R.Region -> Map.Map Text R.Region -> Text -> Result wrn R.Region
240requireRegion tagRegion regionDict name =
241 case Map.lookup name regionDict of
242 Just region ->
243 return region
245 Nothing ->
246 Result.throw tagRegion (Error.MissingManagerOnEffectModule name)
250-- COLLAPSE COMMENTS
253collapseComments :: [D.CommentOr (A.Located a)] -> Result wrn [A.Commented a]
254collapseComments listWithComments =
255 case listWithComments of
256 [] ->
257 Result.ok []
259 D.Comment (A.A _ msg) : D.Whatever (A.A region a) : rest ->
260 let
261 entry =
262 A.A (region, Just msg) a
263 in
264 fmap (entry:) (collapseComments rest)
266 D.Comment (A.A region _) : rest ->
267 collapseComments rest
268 <* Result.throw region Error.CommentOnNothing
271 D.Whatever (A.A region a) : rest ->
272 let
273 entry =
274 A.A (region, Nothing) a
275 in
276 fmap (entry:) (collapseComments rest)
280-- VALIDATE STRUCTURED SOURCE
283validateDecls :: [D.Source] -> Result wrn ValidStuff
284validateDecls sourceDecls =
285 do rawDecls <- collapseComments sourceDecls
287 validStuff <- validateRawDecls rawDecls
289 let (D.Decls _ unions aliases _) = _structure validStuff
291 return validStuff
292 <* F.traverse_ checkTypeVarsInUnion unions
293 <* F.traverse_ checkTypeVarsInAlias aliases
294 <* checkDuplicates validStuff
298-- VALIDATE DECLARATIONS
301data ValidStuff =
302 ValidStuff
303 { _ports :: [A.Commented Effects.PortRaw]
304 , _structure :: D.Valid
305 }
308validateRawDecls :: [A.Commented D.Raw] -> Result wrn ValidStuff
309validateRawDecls commentedDecls =
310 vrdHelp commentedDecls [] (D.Decls [] [] [] [])
313vrdHelp
314 :: [A.Commented D.Raw]
315 -> [A.Commented Effects.PortRaw]
316 -> D.Valid
317 -> Result wrn ValidStuff
318vrdHelp commentedDecls ports structure =
319 case commentedDecls of
320 [] ->
321 Result.ok (ValidStuff ports structure)
323 A.A ann decl : rest ->
324 case decl of
325 D.Union (D.Type name tvars ctors) ->
326 vrdHelp rest ports (D.addUnion (A.A ann (D.Type name tvars ctors)) structure)
328 D.Alias (D.Type name tvars alias) ->
329 vrdHelp rest ports (D.addAlias (A.A ann (D.Type name tvars alias)) structure)
331 D.Fixity fixity ->
332 vrdHelp rest ports (D.addInfix fixity structure)
334 D.Def (A.A region def) ->
335 vrdDefHelp rest (A.A (region, snd ann) def) ports structure
337 D.Port name tipe ->
338 do checkDuplicateFieldsInType tipe
339 vrdHelp rest (A.A ann (Effects.PortRaw name tipe) : ports) structure
342vrdDefHelp
343 :: [A.Commented D.Raw]
344 -> A.Commented Src.RawDef'
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 Src.Definition pat expr ->
355 addDef
356 <$> validateDef (fst ann) pat expr Nothing
357 <*> vrdHelp remainingDecls ports structure
359 Src.Annotation name tipe ->
360 case remainingDecls of
361 A.A _ (D.Def (A.A defRegion (Src.Definition pat expr))) : rest
362 | Pattern.isVar name pat ->
363 addDef
364 <$> validateDef (R.merge (fst ann) defRegion) 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 :: [Src.RawDef] -> Result wrn [Src.ValidDef]
377definitions sourceDefs =
378 do validDefs <- definitionsHelp sourceDefs
380 validDefs
381 |> map Src.getPattern
382 |> concatMap Pattern.boundVars
383 |> detectDuplicates Error.DuplicateDefinition
385 return validDefs
388definitionsHelp :: [Src.RawDef] -> Result wrn [Src.ValidDef]
389definitionsHelp sourceDefs =
390 case sourceDefs of
391 [] ->
392 return []
394 A.A defRegion (Src.Definition pat expr) : rest ->
395 (:)
396 <$> validateDef defRegion pat expr Nothing
397 <*> definitionsHelp rest
399 A.A annRegion (Src.Annotation name tipe) : rest ->
400 case rest of
401 A.A defRegion (Src.Definition pat expr) : rest'
402 | Pattern.isVar name pat ->
403 (:)
404 <$> validateDef (R.merge annRegion defRegion) pat expr (Just tipe)
405 <*> definitionsHelp rest'
407 _ ->
408 Result.throw annRegion (Error.TypeWithoutDefinition name)
411validateDef
412 :: R.Region
413 -> Pattern.Raw
414 -> Src.RawExpr
415 -> Maybe Type.Raw
416 -> Result wrn Src.ValidDef
417validateDef region pat expr maybeType =
418 do validExpr <- expression expr
419 validateDefPattern pat validExpr
420 F.traverse_ checkDuplicateFieldsInType maybeType
421 return $ Src.Def region pat validExpr maybeType
424validateDefPattern :: Pattern.Raw -> Src.ValidExpr -> Result wrn ()
425validateDefPattern pattern body =
426 case fst (Src.collectLambdas body) of
427 [] ->
428 return ()
430 args ->
431 case pattern of
432 A.A _ (Pattern.Var funcName) ->
433 checkArguments funcName args
435 _ ->
436 let
437 (A.A start _) = pattern
438 (A.A end _) = last args
439 in
440 Result.throw (R.merge start end) (Error.BadFunctionName (length args))
443checkArguments :: Text -> [Pattern.Raw] -> Result wrn ()
444checkArguments funcName args =
445 let
446 vars =
447 concatMap Pattern.boundVars args
449 checkDups seenArgs (A.A region arg) =
450 if Set.member arg seenArgs then
451 Result.throw region (Error.DuplicateArgument funcName arg)
453 else
454 return (Set.insert arg seenArgs)
455 in
456 foldM_ checkDups Set.empty vars
460-- VALIDATE EXPRESSIONS
463expression :: Src.RawExpr -> Result wrn Src.ValidExpr
464expression (A.A ann sourceExpression) =
465 A.A ann <$>
466 case sourceExpression of
467 Src.Var x ->
468 return (Src.Var x)
470 Src.Lambda pattern body ->
471 Src.Lambda
472 <$> validatePattern pattern
473 <*> expression body
475 Src.Binop ops lastExpr ->
476 Src.Binop
477 <$> traverse (\(expr,op) -> (,) <$> expression expr <*> pure op) ops
478 <*> expression lastExpr
480 Src.Case e branches ->
481 Src.Case
482 <$> expression e
483 <*> traverse (\(p,b) -> (,) <$> validatePattern p <*> expression b) branches
485 Src.Ctor name args ->
486 Src.Ctor name <$> traverse expression args
488 Src.Literal lit ->
489 return (Src.Literal lit)
491 Src.List expressions ->
492 Src.List
493 <$> traverse expression expressions
495 Src.App funcExpr argExpr ->
496 Src.App
497 <$> expression funcExpr
498 <*> expression argExpr
500 Src.If branches finally ->
501 Src.If
502 <$> traverse both branches
503 <*> expression finally
505 Src.Access record field ->
506 Src.Access
507 <$> expression record
508 <*> return field
510 Src.Update record fields ->
511 do checkDuplicateFields ann fields
512 Src.Update <$> expression record <*> traverse second fields
514 Src.Record fields ->
515 do checkDuplicateFields ann fields
516 Src.Record <$> traverse second fields
518 Src.Let defs body ->
519 Src.Let
520 <$> definitions defs
521 <*> expression body
523 Src.GLShader uid src gltipe ->
524 return (Src.GLShader uid src gltipe)
527second :: (a, Src.RawExpr) -> Result wrn (a, Src.ValidExpr)
528second (value, expr) =
529 (,) value <$> expression expr
532both :: (Src.RawExpr, Src.RawExpr) -> Result wrn (Src.ValidExpr, Src.ValidExpr)
533both (expr1, expr2) =
534 (,) <$> expression expr1 <*> expression expr2
537checkDuplicateFields :: R.Region -> [(A.Located Text, a)] -> Result wrn ()
538checkDuplicateFields recordRegion fields =
539 let
540 checkDups seenFields ( A.A region field, _ ) =
541 if Set.member field seenFields then
542 Result.throw recordRegion (Error.DuplicateFieldName region field)
543 else
544 Result.ok (Set.insert field seenFields)
545 in
546 foldM_ checkDups Set.empty fields
550-- VALIDATE PATTERNS
553validatePattern :: Pattern.Raw -> Result wrn Pattern.Raw
554validatePattern pattern =
555 do detectDuplicates Error.BadPattern (Pattern.boundVars pattern)
556 return pattern
560-- DETECT DUPLICATES
563checkDuplicates :: ValidStuff -> Result wrn ()
564checkDuplicates (ValidStuff ports (D.Decls defs unions aliases _)) =
565 let
566 -- SIMPLE NAMES
568 defValues =
569 concatMap (Pattern.boundVars . Src.getPattern . A.drop) defs
571 portValues =
572 map fromPort ports
574 fromPort (A.A (region, _) (Effects.PortRaw name _)) =
575 A.A region name
577 -- TYPE NAMES
579 (types, typeValues) =
580 unzip (map fromUnion unions ++ map fromAlias aliases)
582 fromUnion (A.A (region, _) (D.Type name _ ctors)) =
583 ( A.A region name
584 , map (A.A region . fst) ctors
585 )
587 fromAlias (A.A (region, _) (D.Type name _ (A.A _ tipe))) =
588 (,) (A.A region name) $
589 case tipe of
590 Type.RRecord _ _ ->
591 [A.A region name]
593 _ ->
594 []
595 in
596 F.sequenceA_
597 [ detectDuplicates Error.DuplicateValueDeclaration (portValues ++ defValues)
598 , detectDuplicates Error.DuplicateValueDeclaration (concat typeValues)
599 , detectDuplicates Error.DuplicateTypeDeclaration types
600 ]
603detectDuplicates :: (Text -> Error.Error) -> [A.Located Text] -> Result wrn ()
604detectDuplicates tag names =
605 let
606 add (A.A region name) dict =
607 Map.insertWith (++) name [region] dict
609 makeGroups pairs =
610 Map.toList (foldr add Map.empty pairs)
612 check (name, regions) =
613 case regions of
614 _ : region : _ ->
615 Result.throw region (tag name)
617 _ ->
618 return ()
619 in
620 F.traverse_ check (makeGroups names)
624-- UNBOUND TYPE VARIABLES
627checkTypeVarsInUnion :: A.Commented (D.Union Type.Raw) -> Result wrn ()
628checkTypeVarsInUnion (A.A (region,_) (D.Type name boundVars ctors)) =
629 do allFreeVars <- concat <$> traverse freeVars (concatMap snd ctors)
630 case diff boundVars allFreeVars of
631 (_, []) ->
632 return ()
634 (_, unbound) ->
635 Result.throw region
636 (Error.UnboundTypeVarsInUnion name boundVars unbound)
639checkTypeVarsInAlias :: A.Commented (D.Alias Type.Raw) -> Result wrn ()
640checkTypeVarsInAlias (A.A (region,_) (D.Type name boundVars tipe)) =
641 do allFreeVars <- freeVars tipe
642 case diff boundVars allFreeVars of
643 ([], []) ->
644 return ()
646 ([], unbound) ->
647 Result.throw region
648 (Error.UnboundTypeVarsInAlias name boundVars unbound)
650 (unused, []) ->
651 Result.throw region
652 (Error.UnusedTypeVarsInAlias name boundVars unused)
654 (unused, unbound) ->
655 Result.throw region
656 (Error.MessyTypeVarsInAlias name boundVars unused unbound)
659diff :: [Text] -> [A.Located Text] -> ([Text], [Text])
660diff left right =
661 let
662 leftSet =
663 Set.fromList left
665 rightSet =
666 Set.fromList (map A.drop right)
667 in
668 ( Set.toList (Set.difference leftSet rightSet)
669 , Set.toList (Set.difference rightSet leftSet)
670 )
673freeVars :: Type.Raw -> Result wrn [A.Located Text]
674freeVars (A.A region tipe) =
675 case tipe of
676 Type.RLambda t1 t2 ->
677 (++) <$> freeVars t1 <*> freeVars t2
679 Type.RVar x ->
680 Result.ok [A.A region x]
682 Type.RType _ ->
683 Result.ok []
685 Type.RApp t ts ->
686 concat <$> traverse freeVars (t:ts)
688 Type.RRecord fields ext ->
689 do checkDuplicateFields region fields
690 let types = Maybe.maybeToList ext ++ map snd fields
691 concat <$> traverse freeVars types
694checkDuplicateFieldsInType :: Type.Raw -> Result wrn ()
695checkDuplicateFieldsInType (A.A region tipe) =
696 case tipe of
697 Type.RLambda t1 t2 ->
698 checkDuplicateFieldsInType t1
699 <* checkDuplicateFieldsInType t2
701 Type.RVar _ ->
702 Result.ok ()
704 Type.RType _ ->
705 Result.ok ()
707 Type.RApp t ts ->
708 F.traverse_ checkDuplicateFieldsInType (t:ts)
710 Type.RRecord fields ext ->
711 do checkDuplicateFields region fields
712 let types = Maybe.maybeToList ext ++ map snd fields
713 F.traverse_ checkDuplicateFieldsInType types