git.iko.soy/elk
on 7de84bc help sign in
elk/src/Validate.hs
710 lines 18 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module Validate (module') where
4import Control.Monad (foldM, when)
5import qualified Data.Map as Map
6import qualified Data.Set as Set
7import qualified Data.Foldable as F
8import qualified Data.Traversable as T
10import AST.Expression.General as Expr
11import qualified AST.Effects as Fx
12import qualified AST.Expression.Source as Source
13import qualified AST.Expression.Valid as Valid
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
29-- MODULES
32module' :: Module.Source -> Result.Result wrn Error.Error Module.Valid
33module' (Module.Module name path info) =
34 let
35 (ModuleName.Canonical pkgName _) =
36 name
38 (Module.Source tag settings docs exports imports decls) =
39 info
40 in
41 do validDecls <- declarations decls
42 validEffects <- validateEffects tag settings validDecls
44 return $ Module.Module name path $
45 Module.Valid docs exports (addDefaults pkgName imports) validDecls validEffects
49-- IMPORTS
52addDefaults
53 :: Package.Name
54 -> [Module.UserImport]
55 -> ([Module.DefaultImport], [Module.UserImport])
56addDefaults pkgName imports =
57 flip (,) imports $
58 if pkgName == Package.coreName then
59 []
61 else
62 Imports.defaults
66-- EFFECTS
69validateEffects
70 :: Module.SourceTag
71 -> Module.SourceSettings
72 -> [D.Valid]
73 -> Result.Result wrn Error.Error Fx.Effects
74validateEffects tag settings@(A.A _ pairs) decls =
75 case tag of
76 Module.Normal ->
77 do noSettings Error.SettingsOnNormalModule settings
78 return Fx.None
80 Module.Foreign _ ->
81 do noSettings Error.SettingsOnForeignModule settings
82 return Fx.Foreign
84 Module.Effect tagRegion ->
85 let
86 collectSettings (A.A region setting, userValue) dict =
87 Map.insertWith (++) setting [(region, userValue)] dict
89 settingsDict =
90 foldr collectSettings Map.empty pairs
91 in
92 do managerType <- toManagerType tagRegion settingsDict
93 (r0, r1, r2) <- checkManagerImpl tagRegion managerType noInfo decls
94 return (Fx.Effect (Fx.Info tagRegion r0 r1 r2 managerType))
97noSettings
98 :: Error.Error
99 -> Module.SourceSettings
100 -> Result.Result wrn Error.Error ()
101noSettings errorMsg (A.A region settings) =
102 case settings of
103 [] ->
104 Result.ok ()
106 _ : _ ->
107 Result.throw region errorMsg
110toManagerType
111 :: R.Region
112 -> Map.Map String [(R.Region, A.Located String)]
113 -> Result.Result wrn Error.Error Fx.ManagerType
114toManagerType tagRegion settingsDict =
115 let
116 toErrors name entries =
117 map (\entry -> A.A (fst entry) (Error.BadSettingOnEffectModule name)) entries
119 errors =
120 settingsDict
121 |> Map.delete "command"
122 |> Map.delete "subscription"
123 |> Map.mapWithKey toErrors
124 |> Map.elems
125 |> concat
126 in
127 do when (not (null errors)) (Result.throwMany errors)
128 maybeEffects <-
129 (,) <$> extractOne "command" settingsDict
130 <*> extractOne "subscription" settingsDict
132 case maybeEffects of
133 (Nothing, Nothing) ->
134 Result.throw tagRegion Error.NoSettingsOnEffectModule
136 (Just cmd, Nothing) ->
137 return (Fx.CmdManager cmd)
139 (Nothing, Just sub) ->
140 return (Fx.SubManager sub)
142 (Just cmd, Just sub) ->
143 return (Fx.FxManager cmd sub)
146extractOne
147 :: String
148 -> Map.Map String [(R.Region, A.Located String)]
149 -> Result.Result w Error.Error (Maybe (A.Located String))
150extractOne name settingsDict =
151 case Map.lookup name settingsDict of
152 Nothing ->
153 return Nothing
155 Just [] ->
156 error "Empty lists should never be added to the dictionary of effect module settings."
158 Just [(_, userType)] ->
159 return (Just userType)
161 Just ((region, _) : _) ->
162 Result.throw region (Error.DuplicateSettingOnEffectModule name)
166-- EFFECT REGIONS
169data ManagerInfo =
170 ManagerInfo
171 { _cmdMap :: Bool
172 , _subMap :: Bool
173 , _init :: Maybe R.Region
174 , _onEffects :: Maybe R.Region
175 , _onSelfMsg :: Maybe R.Region
176 }
179noInfo :: ManagerInfo
180noInfo =
181 ManagerInfo False False Nothing Nothing Nothing
184checkManagerImpl
185 :: R.Region
186 -> Fx.ManagerType
187 -> ManagerInfo
188 -> [D.Valid]
189 -> Result.Result w Error.Error (R.Region, R.Region, R.Region)
190checkManagerImpl tagRegion managerType info decls =
191 case decls of
192 [] ->
193 let
194 (ManagerInfo cmdMap subMap init onEffects onSelfMsg) = info
195 in
196 const (,,)
197 <$> requireMaps tagRegion managerType cmdMap subMap
198 <*> requireRegion tagRegion "init" init
199 <*> requireRegion tagRegion "onEffects" onEffects
200 <*> requireRegion tagRegion "onSelfMsg" onSelfMsg
202 decl : rest ->
203 case getDefInfo decl of
204 Just ("init", region) ->
205 checkManagerImpl tagRegion managerType (info { _init = Just region }) rest
207 Just ("onEffects", region) ->
208 checkManagerImpl tagRegion managerType (info { _onEffects = Just region }) rest
210 Just ("onSelfMsg", region) ->
211 checkManagerImpl tagRegion managerType (info { _onSelfMsg = Just region }) rest
213 Just ("cmdMap", _) ->
214 checkManagerImpl tagRegion managerType (info { _cmdMap = True }) rest
216 Just ("subMap", _) ->
217 checkManagerImpl tagRegion managerType (info { _subMap = True }) rest
219 _ ->
220 checkManagerImpl tagRegion managerType info rest
223getDefInfo :: D.Valid -> Maybe (String, R.Region)
224getDefInfo decl =
225 case decl of
226 A.A region (D.Def (Valid.Definition (A.A _ (Pattern.Var name)) _ _)) ->
227 Just (name, fst region)
229 _ ->
230 Nothing
233requireMaps :: R.Region -> Fx.ManagerType -> Bool -> Bool -> Result.Result w Error.Error ()
234requireMaps tagRegion managerType hasCmdMap hasSubMap =
235 let
236 check hasIt name =
237 when (not hasIt) (Result.throw tagRegion (Error.MissingManagerOnEffectModule name))
238 in
239 case managerType of
240 Fx.CmdManager _ ->
241 check hasCmdMap "cmdMap"
243 Fx.SubManager _ ->
244 check hasSubMap "subMap"
246 Fx.FxManager _ _ ->
247 (\_ _ -> ())
248 <$> check hasCmdMap "cmdMap"
249 <*> check hasSubMap "subMap"
252requireRegion :: R.Region -> String -> Maybe R.Region -> Result.Result w Error.Error R.Region
253requireRegion tagRegion name maybeRegion =
254 case maybeRegion of
255 Just region ->
256 return region
258 Nothing ->
259 Result.throw tagRegion (Error.MissingManagerOnEffectModule name)
263-- COLLAPSE COMMENTS
266type Commented a =
267 A.Annotated (R.Region, Maybe (A.Located String)) a
270collapseComments
271 :: [D.CommentOr (A.Located a)]
272 -> Result.Result wrn Error.Error [Commented a]
273collapseComments listWithComments =
274 case listWithComments of
275 [] ->
276 Result.ok []
278 D.Comment msg : D.Whatever (A.A region a) : rest ->
279 let
280 entry =
281 A.A (region, Just msg) a
282 in
283 fmap (entry:) (collapseComments rest)
285 D.Comment (A.A region _) : D.Comment _ : _ ->
286 Result.throw region Error.CommentOnComment
288 [D.Comment (A.A region _)] ->
289 Result.throw region Error.CommentOnNothing
291 D.Whatever (A.A region a) : rest ->
292 let
293 entry =
294 A.A (region, Nothing) a
295 in
296 fmap (entry:) (collapseComments rest)
300-- VALIDATE STRUCTURED SOURCE
303declarations :: [D.Source] -> Result.Result wrn Error.Error [D.Valid]
304declarations sourceDecls =
305 do decls <-
306 collapseComments sourceDecls
308 validDecls <-
309 validateDecls decls
311 F.traverse_ id
312 (declDuplicates validDecls : map findBadTypeVars validDecls)
314 return validDecls
318-- VALIDATE DECLARATIONS
321validateDecls
322 :: [Commented D.Source']
323 -> Result.Result wrn Error.Error [D.Valid]
324validateDecls commentedDecls =
325 case commentedDecls of
326 [] ->
327 Result.ok []
329 A.A (region, maybeComment) decl : rest ->
330 let
331 addRest validDecl =
332 let
333 entry =
334 A.A (region, fmap A.drop maybeComment) validDecl
335 in
336 fmap (entry:) (validateDecls rest)
337 in
338 case decl of
339 D.Union name tvars ctors ->
340 addRest (D.Union name tvars ctors)
342 D.Alias name tvars alias ->
343 addRest (D.Alias name tvars alias)
345 D.Fixity assoc prec op ->
346 addRest (D.Fixity assoc prec op)
348 D.Def def ->
349 validateDeclsHelp maybeComment def rest
352validateDeclsHelp
353 :: Maybe (A.Located String)
354 -> Source.Def
355 -> [Commented D.Source']
356 -> Result.Result wrn Error.Error [D.Valid]
357validateDeclsHelp maybeComment (A.A region def) decls =
358 let
359 ann =
360 (region, fmap A.drop maybeComment)
362 makeDef pat expr maybeType =
363 D.Def (Valid.Definition pat expr maybeType)
364 in
365 case def of
366 Source.Definition pat expr ->
367 (:)
368 <$> validateDef makeDef ann pat expr Nothing
369 <*> validateDecls decls
371 Source.Annotation name tipe ->
372 case decls of
373 A.A (_, Just (A.A commentRegion _)) _ : _ ->
374 Result.throw commentRegion (Error.CommentAfterAnnotation name)
376 A.A _ (D.Def (A.A _ (Source.Definition pat expr))) : rest
377 | Pattern.isVar name pat ->
378 (:)
379 <$> validateDef makeDef ann pat expr (Just tipe)
380 <*> validateDecls rest
382 _ ->
383 Result.throw region (Error.TypeWithoutDefinition name)
387-- VALIDATE DEFINITIONS
390definitions :: [Source.Def] -> Result.Result wrn Error.Error [Valid.Def]
391definitions sourceDefs =
392 do validDefs <- definitionsHelp sourceDefs
393 let patterns = map (\(Valid.Definition p _ _) -> p) validDefs
394 defDuplicates patterns
395 return validDefs
398definitionsHelp :: [Source.Def] -> Result.Result wrn Error.Error [Valid.Def]
399definitionsHelp sourceDefs =
400 case sourceDefs of
401 [] ->
402 return []
404 A.A region (Source.Definition pat expr) : rest ->
405 (:)
406 <$> fmap A.drop (validateDef Valid.Definition region pat expr Nothing)
407 <*> definitionsHelp rest
409 A.A r1 (Source.Annotation name tipe) : rest ->
410 case rest of
411 A.A r2 (Source.Definition pat expr) : rest'
412 | Pattern.isVar name pat ->
413 (:)
414 <$> fmap A.drop (validateDef Valid.Definition (R.merge r1 r2) pat expr (Just tipe))
415 <*> definitionsHelp rest'
417 _ ->
418 Result.throw r1 (Error.TypeWithoutDefinition name)
421validateDef
422 :: (Pattern.Raw -> Valid.Expr -> Maybe Type.Raw -> def)
423 -> annotation
424 -> Pattern.Raw
425 -> Source.Expr
426 -> Maybe Type.Raw
427 -> Result.Result wrn Error.Error (A.Annotated annotation def)
428validateDef makeDef annotation pat expr maybeType =
429 do validExpr <- expression expr
430 validateDefPattern pat validExpr
431 return $ A.A annotation (makeDef pat validExpr maybeType)
434validateDefPattern :: Pattern.Raw -> Valid.Expr -> Result.Result wrn Error.Error ()
435validateDefPattern pattern body =
436 case fst (Expr.collectLambdas body) of
437 [] ->
438 return ()
440 args ->
441 case pattern of
442 A.A _ (Pattern.Var _) ->
443 return ()
445 _ ->
446 let
447 (A.A start _) = pattern
448 (A.A end _) = last args
449 in
450 Result.throw (R.merge start end) (Error.BadFunctionName (length args))
454-- VALIDATE EXPRESSIONS
457expression :: Source.Expr -> Result.Result wrn Error.Error Valid.Expr
458expression (A.A ann sourceExpression) =
459 A.A ann <$>
460 case sourceExpression of
461 Var x ->
462 return (Var x)
464 Lambda pattern body ->
465 Lambda
466 <$> validatePattern pattern
467 <*> expression body
469 Binop op leftExpr rightExpr ->
470 Binop op
471 <$> expression leftExpr
472 <*> expression rightExpr
474 Case e branches ->
475 Case
476 <$> expression e
477 <*> T.traverse (\(p,b) -> (,) <$> validatePattern p <*> expression b) branches
479 Data name args ->
480 Data name <$> T.traverse expression args
482 Literal lit ->
483 return (Literal lit)
485 Range lowExpr highExpr ->
486 Range
487 <$> expression lowExpr
488 <*> expression highExpr
490 ExplicitList expressions ->
491 ExplicitList
492 <$> T.traverse expression expressions
494 App funcExpr argExpr ->
495 App
496 <$> expression funcExpr
497 <*> expression argExpr
499 If branches finally ->
500 If
501 <$> T.traverse both branches
502 <*> expression finally
504 Access record field ->
505 Access
506 <$> expression record
507 <*> return field
509 Update record fields ->
510 Update
511 <$> expression record
512 <*> T.traverse second fields
514 Record fields ->
515 let
516 checkDups seenFields (field,_) =
517 if Set.member field seenFields then
518 Result.throw ann (Error.DuplicateFieldName field)
520 else
521 return (Set.insert field seenFields)
522 in
523 do _ <- foldM checkDups Set.empty fields
524 Record <$> T.traverse second fields
526 Let defs body ->
527 Let
528 <$> definitions defs
529 <*> expression body
531 Cmd moduleName typeName ->
532 return (Cmd moduleName typeName)
534 Sub moduleName typeName ->
535 return (Sub moduleName typeName)
537 SaveEnv moduleName effects ->
538 return (SaveEnv moduleName effects)
540 GLShader uid src gltipe ->
541 return (GLShader uid src gltipe)
544second :: (a, Source.Expr) -> Result.Result wrn Error.Error (a, Valid.Expr)
545second (value, expr) =
546 (,) value <$> expression expr
549both
550 :: (Source.Expr, Source.Expr)
551 -> Result.Result wrn Error.Error (Valid.Expr, Valid.Expr)
552both (expr1, expr2) =
553 (,) <$> expression expr1 <*> expression expr2
557-- VALIDATE PATTERNS
560validatePattern :: Pattern.Raw -> Result.Result wrn Error.Error Pattern.Raw
561validatePattern pattern =
562 do detectDuplicates Error.BadPattern (Pattern.boundVars pattern)
563 return pattern
567-- DETECT DUPLICATES
570detectDuplicates
571 :: (String -> Error.Error)
572 -> [A.Located String]
573 -> Result.Result wrn Error.Error ()
574detectDuplicates tag names =
575 let add (A.A region name) dict =
576 Map.insertWith (++) name [region] dict
578 makeGroups pairs =
579 Map.toList (foldr add Map.empty pairs)
581 check (name, regions) =
582 case regions of
583 _ : region : _ ->
584 Result.throw region (tag name)
586 _ ->
587 return ()
588 in
589 F.traverse_ check (makeGroups names)
592defDuplicates :: [Pattern.Raw] -> Result.Result wrn Error.Error ()
593defDuplicates patterns =
594 concatMap Pattern.boundVars patterns
595 |> detectDuplicates Error.DuplicateDefinition
598declDuplicates :: [D.Valid] -> Result.Result wrn Error.Error ()
599declDuplicates decls =
600 let
601 (valueLists, typeLists) =
602 unzip (map extractValues decls)
603 in
604 (\_ _ -> ())
605 <$> detectDuplicates Error.DuplicateValueDeclaration (concat valueLists)
606 <*> detectDuplicates Error.DuplicateTypeDeclaration (concat typeLists)
609extractValues :: D.Valid -> ([A.Located String], [A.Located String])
610extractValues (A.A (region, _) decl) =
611 case decl of
612 D.Def (Valid.Definition pattern _ _) ->
613 ( Pattern.boundVars pattern
614 , []
615 )
617 D.Union name _ ctors ->
618 ( map (A.A region . fst) ctors
619 , [A.A region name]
620 )
622 D.Alias name _ (A.A _ (Type.RRecord _ _)) ->
623 ( [A.A region name]
624 , [A.A region name]
625 )
627 D.Alias name _ _ ->
628 ( []
629 , [A.A region name]
630 )
632 D.Fixity _ _ _ ->
633 ( []
634 , []
635 )
639-- UNBOUND TYPE VARIABLES
642findBadTypeVars :: D.Valid -> Result.Result wrn Error.Error ()
643findBadTypeVars (A.A (region,_) decl) =
644 case decl of
645 D.Def _ ->
646 return ()
648 D.Union name boundVars ctors ->
649 case diff boundVars (concatMap freeVars (concatMap snd ctors)) of
650 (_, []) ->
651 return ()
653 (_, unbound) ->
654 Result.throw region
655 (Error.UnboundTypeVarsInUnion name boundVars unbound)
657 D.Alias name boundVars tipe ->
658 case diff boundVars (freeVars tipe) of
659 ([], []) ->
660 return ()
662 ([], unbound) ->
663 Result.throw region
664 (Error.UnboundTypeVarsInAlias name boundVars unbound)
666 (unused, []) ->
667 Result.throw region
668 (Error.UnusedTypeVarsInAlias name boundVars unused)
670 (unused, unbound) ->
671 Result.throw region
672 (Error.MessyTypeVarsInAlias name boundVars unused unbound)
674 D.Fixity _ _ _ ->
675 return ()
678diff :: [String] -> [A.Located String] -> ([String], [String])
679diff left right =
680 let
681 leftSet =
682 Set.fromList left
684 rightSet =
685 Set.fromList (map A.drop right)
686 in
687 ( Set.toList (Set.difference leftSet rightSet)
688 , Set.toList (Set.difference rightSet leftSet)
689 )
693freeVars :: Type.Raw -> [A.Located String]
694freeVars (A.A region tipe) =
695 case tipe of
696 Type.RLambda t1 t2 ->
697 freeVars t1 ++ freeVars t2
699 Type.RVar x ->
700 [A.A region x]
702 Type.RType _ ->
703 []
705 Type.RApp t ts ->
706 concatMap freeVars (t:ts)
708 Type.RRecord fields ext ->
709 maybe [] freeVars ext
710 ++ concatMap (freeVars . snd) fields