git.iko.soy/elk
on fa09513 help sign in
elk/src/Validate.hs
605 lines 15 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 validEffects <- validateModuleDecl tag settings
42 validDecls <- declarations decls
44 return $ Module.Module name path $
45 Module.Valid docs exports (addDefaults pkgName imports) validDecls validEffects
48-- determine if default imports should be added, only elm-lang/core is exempt
49addDefaults
50 :: Package.Name
51 -> [Module.UserImport]
52 -> ([Module.DefaultImport], [Module.UserImport])
53addDefaults pkgName imports =
54 flip (,) imports $
55 if pkgName == Package.coreName then
56 []
58 else
59 Imports.defaults
62validateModuleDecl
63 :: Module.SourceTag
64 -> Module.SourceSettings
65 -> Result.Result wrn Error.Error Fx.Effects
66validateModuleDecl tag settings@(A.A _ pairs) =
67 case tag of
68 Module.Normal ->
69 do noSettings Error.SettingsOnNormalModule settings
70 return Fx.None
72 Module.Foreign _ ->
73 do noSettings Error.SettingsOnForeignModule settings
74 return Fx.Foreign
76 Module.Effect tagRegion ->
77 let
78 collectSettings (A.A region setting, userValue) dict =
79 Map.insertWith (++) setting [(region, userValue)] dict
81 settingsDict =
82 foldr collectSettings Map.empty pairs
83 in
84 do managerType <- toManagerType tagRegion settingsDict
85 return $ Fx.Effect $
86 Fx.Info tagRegion (error "TODO") (error "TODO") (error "TODO") managerType
89noSettings
90 :: Error.Error
91 -> Module.SourceSettings
92 -> Result.Result wrn Error.Error ()
93noSettings errorMsg (A.A region settings) =
94 case settings of
95 [] ->
96 Result.ok ()
98 _ : _ ->
99 Result.throw region errorMsg
102toManagerType
103 :: R.Region
104 -> Map.Map String [(R.Region, A.Located String)]
105 -> Result.Result wrn Error.Error Fx.ManagerType
106toManagerType tagRegion settingsDict =
107 let
108 toErrors name entries =
109 map (\entry -> A.A (fst entry) (Error.BadSettingOnEffectModule name)) entries
111 errors =
112 settingsDict
113 |> Map.delete "command"
114 |> Map.delete "subscription"
115 |> Map.mapWithKey toErrors
116 |> Map.elems
117 |> concat
118 in
119 do when (not (null errors)) (Result.throwMany errors)
120 maybeEffects <-
121 (,) <$> extractOne "command" settingsDict
122 <*> extractOne "subscription" settingsDict
124 case maybeEffects of
125 (Nothing, Nothing) ->
126 Result.throw tagRegion Error.NoSettingsOnEffectModule
128 (Just cmd, Nothing) ->
129 return (Fx.CmdManager cmd)
131 (Nothing, Just sub) ->
132 return (Fx.SubManager sub)
134 (Just cmd, Just sub) ->
135 return (Fx.FxManager cmd sub)
138extractOne
139 :: String
140 -> Map.Map String [(R.Region, A.Located String)]
141 -> Result.Result w Error.Error (Maybe (A.Located String))
142extractOne name settingsDict =
143 case Map.lookup name settingsDict of
144 Nothing ->
145 return Nothing
147 Just [] ->
148 error "Empty lists should never be added to the dictionary of effect module settings."
150 Just [(_, userType)] ->
151 return (Just userType)
153 Just ((region, _) : _) ->
154 Result.throw region (Error.DuplicateSettingOnEffectModule name)
158-- COLLAPSE COMMENTS
161type Commented a =
162 A.Annotated (R.Region, Maybe (A.Located String)) a
165collapseComments
166 :: [D.CommentOr (A.Located a)]
167 -> Result.Result wrn Error.Error [Commented a]
168collapseComments listWithComments =
169 case listWithComments of
170 [] ->
171 Result.ok []
173 D.Comment msg : D.Whatever (A.A region a) : rest ->
174 let
175 entry =
176 A.A (region, Just msg) a
177 in
178 fmap (entry:) (collapseComments rest)
180 D.Comment (A.A region _) : D.Comment _ : _ ->
181 Result.throw region Error.CommentOnComment
183 [D.Comment (A.A region _)] ->
184 Result.throw region Error.CommentOnNothing
186 D.Whatever (A.A region a) : rest ->
187 let
188 entry =
189 A.A (region, Nothing) a
190 in
191 fmap (entry:) (collapseComments rest)
195-- VALIDATE STRUCTURED SOURCE
198declarations :: [D.Source] -> Result.Result wrn Error.Error [D.Valid]
199declarations sourceDecls =
200 do decls <-
201 collapseComments sourceDecls
203 validDecls <-
204 validateDecls decls
206 F.traverse_ id
207 (declDuplicates validDecls : map findBadTypeVars validDecls)
209 return validDecls
213-- VALIDATE DECLARATIONS
216validateDecls
217 :: [Commented D.Source']
218 -> Result.Result wrn Error.Error [D.Valid]
219validateDecls commentedDecls =
220 case commentedDecls of
221 [] ->
222 Result.ok []
224 A.A (region, maybeComment) decl : rest ->
225 let
226 addRest validDecl =
227 let
228 entry =
229 A.A (region, fmap A.drop maybeComment) validDecl
230 in
231 fmap (entry:) (validateDecls rest)
232 in
233 case decl of
234 D.Union name tvars ctors ->
235 addRest (D.Union name tvars ctors)
237 D.Alias name tvars alias ->
238 addRest (D.Alias name tvars alias)
240 D.Fixity assoc prec op ->
241 addRest (D.Fixity assoc prec op)
243 D.Def def ->
244 validateDeclsHelp maybeComment def rest
247validateDeclsHelp
248 :: Maybe (A.Located String)
249 -> Source.Def
250 -> [Commented D.Source']
251 -> Result.Result wrn Error.Error [D.Valid]
252validateDeclsHelp maybeComment (A.A region def) decls =
253 let
254 ann =
255 (region, fmap A.drop maybeComment)
257 makeDef pat expr maybeType =
258 D.Def (Valid.Definition pat expr maybeType)
259 in
260 case def of
261 Source.Definition pat expr ->
262 (:)
263 <$> validateDef makeDef ann pat expr Nothing
264 <*> validateDecls decls
266 Source.Annotation name tipe ->
267 case decls of
268 A.A (_, Just (A.A commentRegion _)) _ : _ ->
269 Result.throw commentRegion (Error.CommentAfterAnnotation name)
271 A.A _ (D.Def (A.A _ (Source.Definition pat expr))) : rest
272 | Pattern.isVar name pat ->
273 (:)
274 <$> validateDef makeDef ann pat expr (Just tipe)
275 <*> validateDecls rest
277 _ ->
278 Result.throw region (Error.TypeWithoutDefinition name)
282-- VALIDATE DEFINITIONS
285definitions :: [Source.Def] -> Result.Result wrn Error.Error [Valid.Def]
286definitions sourceDefs =
287 do validDefs <- definitionsHelp sourceDefs
288 let patterns = map (\(Valid.Definition p _ _) -> p) validDefs
289 defDuplicates patterns
290 return validDefs
293definitionsHelp :: [Source.Def] -> Result.Result wrn Error.Error [Valid.Def]
294definitionsHelp sourceDefs =
295 case sourceDefs of
296 [] ->
297 return []
299 A.A region (Source.Definition pat expr) : rest ->
300 (:)
301 <$> fmap A.drop (validateDef Valid.Definition region pat expr Nothing)
302 <*> definitionsHelp rest
304 A.A r1 (Source.Annotation name tipe) : rest ->
305 case rest of
306 A.A r2 (Source.Definition pat expr) : rest'
307 | Pattern.isVar name pat ->
308 (:)
309 <$> fmap A.drop (validateDef Valid.Definition (R.merge r1 r2) pat expr (Just tipe))
310 <*> definitionsHelp rest'
312 _ ->
313 Result.throw r1 (Error.TypeWithoutDefinition name)
316validateDef
317 :: (Pattern.Raw -> Valid.Expr -> Maybe Type.Raw -> def)
318 -> annotation
319 -> Pattern.Raw
320 -> Source.Expr
321 -> Maybe Type.Raw
322 -> Result.Result wrn Error.Error (A.Annotated annotation def)
323validateDef makeDef annotation pat expr maybeType =
324 do validExpr <- expression expr
325 validateDefPattern pat validExpr
326 return $ A.A annotation (makeDef pat validExpr maybeType)
329validateDefPattern :: Pattern.Raw -> Valid.Expr -> Result.Result wrn Error.Error ()
330validateDefPattern pattern body =
331 case fst (Expr.collectLambdas body) of
332 [] ->
333 return ()
335 args ->
336 case pattern of
337 A.A _ (Pattern.Var _) ->
338 return ()
340 _ ->
341 let
342 (A.A start _) = pattern
343 (A.A end _) = last args
344 in
345 Result.throw (R.merge start end) (Error.BadFunctionName (length args))
349-- VALIDATE EXPRESSIONS
352expression :: Source.Expr -> Result.Result wrn Error.Error Valid.Expr
353expression (A.A ann sourceExpression) =
354 A.A ann <$>
355 case sourceExpression of
356 Var x ->
357 return (Var x)
359 Lambda pattern body ->
360 Lambda
361 <$> validatePattern pattern
362 <*> expression body
364 Binop op leftExpr rightExpr ->
365 Binop op
366 <$> expression leftExpr
367 <*> expression rightExpr
369 Case e branches ->
370 Case
371 <$> expression e
372 <*> T.traverse (\(p,b) -> (,) <$> validatePattern p <*> expression b) branches
374 Data name args ->
375 Data name <$> T.traverse expression args
377 Literal lit ->
378 return (Literal lit)
380 Range lowExpr highExpr ->
381 Range
382 <$> expression lowExpr
383 <*> expression highExpr
385 ExplicitList expressions ->
386 ExplicitList
387 <$> T.traverse expression expressions
389 App funcExpr argExpr ->
390 App
391 <$> expression funcExpr
392 <*> expression argExpr
394 If branches finally ->
395 If
396 <$> T.traverse both branches
397 <*> expression finally
399 Access record field ->
400 Access
401 <$> expression record
402 <*> return field
404 Update record fields ->
405 Update
406 <$> expression record
407 <*> T.traverse second fields
409 Record fields ->
410 let
411 checkDups seenFields (field,_) =
412 if Set.member field seenFields then
413 Result.throw ann (Error.DuplicateFieldName field)
415 else
416 return (Set.insert field seenFields)
417 in
418 do _ <- foldM checkDups Set.empty fields
419 Record <$> T.traverse second fields
421 Let defs body ->
422 Let
423 <$> definitions defs
424 <*> expression body
426 Cmd moduleName typeName ->
427 return (Cmd moduleName typeName)
429 Sub moduleName typeName ->
430 return (Sub moduleName typeName)
432 SaveEnv moduleName effects ->
433 return (SaveEnv moduleName effects)
435 GLShader uid src gltipe ->
436 return (GLShader uid src gltipe)
439second :: (a, Source.Expr) -> Result.Result wrn Error.Error (a, Valid.Expr)
440second (value, expr) =
441 (,) value <$> expression expr
444both
445 :: (Source.Expr, Source.Expr)
446 -> Result.Result wrn Error.Error (Valid.Expr, Valid.Expr)
447both (expr1, expr2) =
448 (,) <$> expression expr1 <*> expression expr2
452-- VALIDATE PATTERNS
455validatePattern :: Pattern.Raw -> Result.Result wrn Error.Error Pattern.Raw
456validatePattern pattern =
457 do detectDuplicates Error.BadPattern (Pattern.boundVars pattern)
458 return pattern
462-- DETECT DUPLICATES
465detectDuplicates
466 :: (String -> Error.Error)
467 -> [A.Located String]
468 -> Result.Result wrn Error.Error ()
469detectDuplicates tag names =
470 let add (A.A region name) dict =
471 Map.insertWith (++) name [region] dict
473 makeGroups pairs =
474 Map.toList (foldr add Map.empty pairs)
476 check (name, regions) =
477 case regions of
478 _ : region : _ ->
479 Result.throw region (tag name)
481 _ ->
482 return ()
483 in
484 F.traverse_ check (makeGroups names)
487defDuplicates :: [Pattern.Raw] -> Result.Result wrn Error.Error ()
488defDuplicates patterns =
489 concatMap Pattern.boundVars patterns
490 |> detectDuplicates Error.DuplicateDefinition
493declDuplicates :: [D.Valid] -> Result.Result wrn Error.Error ()
494declDuplicates decls =
495 let
496 (valueLists, typeLists) =
497 unzip (map extractValues decls)
498 in
499 (\_ _ -> ())
500 <$> detectDuplicates Error.DuplicateValueDeclaration (concat valueLists)
501 <*> detectDuplicates Error.DuplicateTypeDeclaration (concat typeLists)
504extractValues :: D.Valid -> ([A.Located String], [A.Located String])
505extractValues (A.A (region, _) decl) =
506 case decl of
507 D.Def (Valid.Definition pattern _ _) ->
508 ( Pattern.boundVars pattern
509 , []
510 )
512 D.Union name _ ctors ->
513 ( map (A.A region . fst) ctors
514 , [A.A region name]
515 )
517 D.Alias name _ (A.A _ (Type.RRecord _ _)) ->
518 ( [A.A region name]
519 , [A.A region name]
520 )
522 D.Alias name _ _ ->
523 ( []
524 , [A.A region name]
525 )
527 D.Fixity _ _ _ ->
528 ( []
529 , []
530 )
534-- UNBOUND TYPE VARIABLES
537findBadTypeVars :: D.Valid -> Result.Result wrn Error.Error ()
538findBadTypeVars (A.A (region,_) decl) =
539 case decl of
540 D.Def _ ->
541 return ()
543 D.Union name boundVars ctors ->
544 case diff boundVars (concatMap freeVars (concatMap snd ctors)) of
545 (_, []) ->
546 return ()
548 (_, unbound) ->
549 Result.throw region
550 (Error.UnboundTypeVarsInUnion name boundVars unbound)
552 D.Alias name boundVars tipe ->
553 case diff boundVars (freeVars tipe) of
554 ([], []) ->
555 return ()
557 ([], unbound) ->
558 Result.throw region
559 (Error.UnboundTypeVarsInAlias name boundVars unbound)
561 (unused, []) ->
562 Result.throw region
563 (Error.UnusedTypeVarsInAlias name boundVars unused)
565 (unused, unbound) ->
566 Result.throw region
567 (Error.MessyTypeVarsInAlias name boundVars unused unbound)
569 D.Fixity _ _ _ ->
570 return ()
573diff :: [String] -> [A.Located String] -> ([String], [String])
574diff left right =
575 let
576 leftSet =
577 Set.fromList left
579 rightSet =
580 Set.fromList (map A.drop right)
581 in
582 ( Set.toList (Set.difference leftSet rightSet)
583 , Set.toList (Set.difference rightSet leftSet)
584 )
588freeVars :: Type.Raw -> [A.Located String]
589freeVars (A.A region tipe) =
590 case tipe of
591 Type.RLambda t1 t2 ->
592 freeVars t1 ++ freeVars t2
594 Type.RVar x ->
595 [A.A region x]
597 Type.RType _ ->
598 []
600 Type.RApp t ts ->
601 concatMap freeVars (t:ts)
603 Type.RRecord fields ext ->
604 maybe [] freeVars ext
605 ++ concatMap (freeVars . snd) fields