git.iko.soy/elk
on fe1e5d2 help sign in
elk/src/Validate.hs
705 lines 18 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module Validate (declarations) where
4import qualified Control.Arrow as Arrow
5import Control.Monad (foldM)
6import qualified Data.Map as Map
7import qualified Data.Set as Set
8import qualified Data.Foldable as F
9import qualified Data.Traversable as T
11import AST.Expression.General as Expr
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.Pattern as Pattern
17import qualified AST.Type as Type
18import Elm.Utils ((|>))
19import qualified Reporting.Annotation as A
20import qualified Reporting.Error.Syntax as Error
21import qualified Reporting.Region as R
22import qualified Reporting.Result as Result
26-- COLLAPSE COMMENTS
29type Commented a =
30 A.Annotated (R.Region, Maybe (A.Located String)) a
33collapseComments
34 :: [D.CommentOr (A.Located a)]
35 -> Result.Result wrn Error.Error [Commented a]
36collapseComments listWithComments =
37 case listWithComments of
38 [] ->
39 Result.ok []
41 D.Comment msg : D.Whatever (A.A region a) : rest ->
42 let
43 entry =
44 A.A (region, Just msg) a
45 in
46 fmap (entry:) (collapseComments rest)
48 D.Comment (A.A region _) : D.Comment _ : _ ->
49 Result.throw region Error.CommentOnComment
51 [D.Comment (A.A region _)] ->
52 Result.throw region Error.CommentOnNothing
54 D.Whatever (A.A region a) : rest ->
55 let
56 entry =
57 A.A (region, Nothing) a
58 in
59 fmap (entry:) (collapseComments rest)
63-- PARTITION AND VALIDATE DEFINES
66type Defines =
67 Map.Map D.EffectType [A.Located [D.CommentOr (A.Located Source.Effect)]]
70partitionEffects :: [Commented D.SourceOrDefine] -> ([Commented D.Source'], Defines)
71partitionEffects commentedDecls =
72 case commentedDecls of
73 [] ->
74 ([], Map.empty)
76 A.A ann (D.Source decl) : rest ->
77 Arrow.first
78 ((:) (A.A ann decl))
79 (partitionEffects rest)
81 A.A (region, _) (D.Define effectType commentOrEffects) : rest ->
82 Arrow.second
83 (Map.insertWith (++) effectType [A.A region commentOrEffects])
84 (partitionEffects rest)
87validateDefines
88 :: Module.Tag
89 -> Defines
90 -> Result.Result wrn Error.Error Valid.Effects
91validateDefines tag defines =
92 case tag of
93 Module.None ->
94 do disallowLeftoverDefines Error.BadDefineInNormalModule defines
95 return Valid.None
97 Module.Effect region ->
98 let
99 (maybeCmds, smallerDefines) =
100 extractKey D.Cmd defines
102 (maybeSubs, leftovers) =
103 extractKey D.Sub smallerDefines
104 in
105 do disallowLeftoverDefines Error.BadDefineInEffectModule leftovers
106 case (maybeCmds, maybeSubs) of
107 (Nothing, Nothing) ->
108 Result.throw region Error.NoDefineInEffectModule
110 _ ->
112 Valid.Effects
113 <$> validateDefineDefs D.Cmd maybeCmds validateEffects
114 <*> validateDefineDefs D.Sub maybeSubs validateEffects
116 Module.Foreign region ->
117 let
118 (maybeCmds, smallerDefines) =
119 extractKey D.ForeignCmd defines
121 (maybeSubs, leftovers) =
122 extractKey D.ForeignSub smallerDefines
123 in
124 do disallowLeftoverDefines Error.BadDefineInForeignModule leftovers
125 case (maybeCmds, maybeSubs) of
126 (Nothing, Nothing) ->
127 Result.throw region Error.NoDefineInForeignModule
129 (_, _) ->
130 Valid.ForeignEffects
131 <$> validateDefineDefs D.ForeignCmd maybeCmds (T.traverse validateForeignCmd)
132 <*> validateDefineDefs D.ForeignSub maybeSubs (T.traverse validateForeignSub)
135extractKey :: (Ord k) => k -> Map.Map k v -> (Maybe v, Map.Map k v)
136extractKey key dict =
137 ( Map.lookup key dict
138 , Map.delete key dict
139 )
142validateDefineDefs
143 :: D.EffectType
144 -> Maybe [A.Located [D.CommentOr (A.Located Source.Effect)]]
145 -> ([Commented Source.Effect] -> Result.Result wrn Error.Error a)
146 -> Result.Result wrn Error.Error a
147validateDefineDefs effectType maybeAllRawDefines validate =
148 case maybeAllRawDefines of
149 Nothing ->
150 validate []
152 Just [A.A _ sourceDefs] ->
153 validate =<< collapseComments sourceDefs
155 Just allRawDefines ->
156 let
157 (A.A region _) =
158 last allRawDefines
160 errorMsg =
161 Error.DuplicateDefines effectType (length allRawDefines)
162 in
163 Result.throw region errorMsg
166disallowLeftoverDefines
167 :: (D.EffectType -> Error.Error)
168 -> Defines
169 -> Result.Result wrn Error.Error ()
170disallowLeftoverDefines errorTagger leftoverDefines =
171 case Map.toList leftoverDefines of
172 [] ->
173 Result.ok ()
175 pairs ->
176 let
177 toErrors (key, allDefines) =
178 map (A.map (\_ -> errorTagger key)) allDefines
179 in
180 Result.throwMany (concatMap toErrors pairs)
184-- VALIDATE STRUCTURED SOURCE
187declarations
188 :: Module.Tag
189 -> [D.Source]
190 -> Result.Result wrn Error.Error ([D.Valid], Valid.Effects)
191declarations tag sourceDecls =
192 do (decls, defines) <-
193 partitionEffects <$> collapseComments sourceDecls
195 validDecls <-
196 validateDecls decls
198 validEffects <-
199 validateDefines tag defines
201 F.traverse_ id
202 (declDuplicates validDecls validEffects : map findBadTypeVars validDecls)
204 return (validDecls, validEffects)
208-- VALIDATE DECLARATIONS
211validateDecls
212 :: [Commented D.Source']
213 -> Result.Result wrn Error.Error [D.Valid]
214validateDecls commentedDecls =
215 case commentedDecls of
216 [] ->
217 Result.ok []
219 A.A (region, maybeComment) decl : rest ->
220 let
221 addRest validDecl =
222 let
223 entry =
224 A.A (region, fmap A.drop maybeComment) validDecl
225 in
226 fmap (entry:) (validateDecls rest)
227 in
228 case decl of
229 D.Union name tvars ctors ->
230 addRest (D.Union name tvars ctors)
232 D.Alias name tvars alias ->
233 addRest (D.Alias name tvars alias)
235 D.Fixity assoc prec op ->
236 addRest (D.Fixity assoc prec op)
238 D.Def def ->
239 validateDeclsHelp maybeComment def rest
242validateDeclsHelp
243 :: Maybe (A.Located String)
244 -> Source.Def
245 -> [Commented D.Source']
246 -> Result.Result wrn Error.Error [D.Valid]
247validateDeclsHelp maybeComment (A.A region def) decls =
248 let
249 ann =
250 (region, fmap A.drop maybeComment)
252 makeDef pat expr maybeType =
253 D.Def (Valid.Definition pat expr maybeType)
254 in
255 case def of
256 Source.Definition pat expr ->
257 (:)
258 <$> validateDef makeDef ann pat expr Nothing
259 <*> validateDecls decls
261 Source.Annotation name tipe ->
262 case decls of
263 A.A (_, Just (A.A commentRegion _)) _ : _ ->
264 Result.throw commentRegion (Error.CommentAfterAnnotation name)
266 A.A _ (D.Def (A.A _ (Source.Definition pat expr))) : rest
267 | Pattern.isVar name pat ->
268 (:)
269 <$> validateDef makeDef ann pat expr (Just tipe)
270 <*> validateDecls rest
272 _ ->
273 Result.throw region (Error.TypeWithoutDefinition name)
277-- VALIDATE EFFECTS
280validateEffects
281 :: [Commented Source.Effect]
282 -> Result.Result wrn Error.Error [A.Commented Valid.Def]
283validateEffects effects =
284 case effects of
285 [] ->
286 Result.ok []
288 A.A (region, maybeComment) effect : rest ->
289 validateEffectsHelp (region, fmap A.drop maybeComment) effect rest
292validateEffectsHelp
293 :: (R.Region, Maybe String)
294 -> Source.Effect
295 -> [Commented Source.Effect]
296 -> Result.Result wrn Error.Error [A.Commented Valid.Def]
297validateEffectsHelp ann effect remainingEffects =
298 case effect of
299 Source.With _ _ ->
300 Result.throw (fst ann) (error "TODO")
302 Source.Def pat expr ->
303 (:)
304 <$> validateDef Valid.Definition ann pat expr Nothing
305 <*> validateEffects remainingEffects
307 Source.Type name tipe ->
308 case remainingEffects of
309 A.A (_, Just (A.A commentRegion _)) _ : _ ->
310 Result.throw commentRegion (Error.CommentAfterAnnotation name)
312 A.A _ (Source.Def pat expr) : rest
313 | Pattern.isVar name pat ->
314 (:)
315 <$> validateDef Valid.Definition ann pat expr (Just tipe)
316 <*> validateEffects rest
318 _ ->
319 Result.throw (fst ann) (Error.TypeWithoutDefinition name)
322validateForeignCmd
323 :: Commented Source.Effect
324 -> Result.Result wrn Error.Error (A.Commented Valid.ForeignCmd)
325validateForeignCmd (A.A (region, maybeComment) effect) =
326 case effect of
327 Source.With _ _ ->
328 Result.throw region (error "TODO")
330 Source.Def _ _ ->
331 Result.throw region (error "TODO")
333 Source.Type name tipe ->
334 Result.ok $
335 A.A (region, fmap A.drop maybeComment) (Valid.Cmd name tipe)
338validateForeignSub
339 :: Commented Source.Effect
340 -> Result.Result wrn Error.Error (A.Commented Valid.ForeignSub)
341validateForeignSub (A.A (region, maybeComment) effect) =
342 case effect of
343 Source.With name expr ->
344 do validExpr <- expression expr
345 Result.ok $
346 A.A (region, fmap A.drop maybeComment) (Valid.SubWith name validExpr)
348 Source.Def _ _ ->
349 Result.throw region (error "TODO")
351 Source.Type name tipe ->
352 Result.ok $
353 A.A (region, fmap A.drop maybeComment) (Valid.Sub name tipe)
357-- VALIDATE DEFINITIONS
360definitions :: [Source.Def] -> Result.Result wrn Error.Error [Valid.Def]
361definitions sourceDefs =
362 do validDefs <- definitionsHelp sourceDefs
363 let patterns = map (\(Valid.Definition p _ _) -> p) validDefs
364 defDuplicates patterns
365 return validDefs
368definitionsHelp :: [Source.Def] -> Result.Result wrn Error.Error [Valid.Def]
369definitionsHelp sourceDefs =
370 case sourceDefs of
371 [] ->
372 return []
374 A.A region (Source.Definition pat expr) : rest ->
375 (:)
376 <$> fmap A.drop (validateDef Valid.Definition region pat expr Nothing)
377 <*> definitionsHelp rest
379 A.A r1 (Source.Annotation name tipe) : rest ->
380 case rest of
381 A.A r2 (Source.Definition pat expr) : rest'
382 | Pattern.isVar name pat ->
383 (:)
384 <$> fmap A.drop (validateDef Valid.Definition (R.merge r1 r2) pat expr (Just tipe))
385 <*> definitionsHelp rest'
387 _ ->
388 Result.throw r1 (Error.TypeWithoutDefinition name)
391validateDef
392 :: (Pattern.Raw -> Valid.Expr -> Maybe Type.Raw -> def)
393 -> annotation
394 -> Pattern.Raw
395 -> Source.Expr
396 -> Maybe Type.Raw
397 -> Result.Result wrn Error.Error (A.Annotated annotation def)
398validateDef makeDef annotation pat expr maybeType =
399 do validExpr <- expression expr
400 validateDefPattern pat validExpr
401 return $ A.A annotation (makeDef pat validExpr maybeType)
404validateDefPattern :: Pattern.Raw -> Valid.Expr -> Result.Result wrn Error.Error ()
405validateDefPattern pattern body =
406 case fst (Expr.collectLambdas body) of
407 [] ->
408 return ()
410 args ->
411 case pattern of
412 A.A _ (Pattern.Var _) ->
413 return ()
415 _ ->
416 let
417 (A.A start _) = pattern
418 (A.A end _) = last args
419 in
420 Result.throw (R.merge start end) (Error.BadFunctionName (length args))
424-- VALIDATE EXPRESSIONS
427expression :: Source.Expr -> Result.Result wrn Error.Error Valid.Expr
428expression (A.A ann sourceExpression) =
429 A.A ann <$>
430 case sourceExpression of
431 Var x ->
432 return (Var x)
434 Lambda pattern body ->
435 Lambda
436 <$> validatePattern pattern
437 <*> expression body
439 Binop op leftExpr rightExpr ->
440 Binop op
441 <$> expression leftExpr
442 <*> expression rightExpr
444 Case e branches ->
445 Case
446 <$> expression e
447 <*> T.traverse (\(p,b) -> (,) <$> validatePattern p <*> expression b) branches
449 Data name args ->
450 Data name <$> T.traverse expression args
452 Literal lit ->
453 return (Literal lit)
455 Range lowExpr highExpr ->
456 Range
457 <$> expression lowExpr
458 <*> expression highExpr
460 ExplicitList expressions ->
461 ExplicitList
462 <$> T.traverse expression expressions
464 App funcExpr argExpr ->
465 App
466 <$> expression funcExpr
467 <*> expression argExpr
469 If branches finally ->
470 If
471 <$> T.traverse both branches
472 <*> expression finally
474 Access record field ->
475 Access
476 <$> expression record
477 <*> return field
479 Update record fields ->
480 Update
481 <$> expression record
482 <*> T.traverse second fields
484 Record fields ->
485 let
486 checkDups seenFields (field,_) =
487 if Set.member field seenFields then
488 Result.throw ann (Error.DuplicateFieldName field)
490 else
491 return (Set.insert field seenFields)
492 in
493 do _ <- foldM checkDups Set.empty fields
494 Record <$> T.traverse second fields
496 Let defs body ->
497 Let
498 <$> definitions defs
499 <*> expression body
501 GLShader uid src gltipe ->
502 return (GLShader uid src gltipe)
505second :: (a, Source.Expr) -> Result.Result wrn Error.Error (a, Valid.Expr)
506second (value, expr) =
507 (,) value <$> expression expr
510both
511 :: (Source.Expr, Source.Expr)
512 -> Result.Result wrn Error.Error (Valid.Expr, Valid.Expr)
513both (expr1, expr2) =
514 (,) <$> expression expr1 <*> expression expr2
518-- VALIDATE PATTERNS
521validatePattern :: Pattern.Raw -> Result.Result wrn Error.Error Pattern.Raw
522validatePattern pattern =
523 do detectDuplicates Error.BadPattern (Pattern.boundVars pattern)
524 return pattern
528-- DETECT DUPLICATES
531detectDuplicates
532 :: (String -> Error.Error)
533 -> [A.Located String]
534 -> Result.Result wrn Error.Error ()
535detectDuplicates tag names =
536 let add (A.A region name) dict =
537 Map.insertWith (++) name [region] dict
539 makeGroups pairs =
540 Map.toList (foldr add Map.empty pairs)
542 check (name, regions) =
543 case regions of
544 _ : region : _ ->
545 Result.throw region (tag name)
547 _ ->
548 return ()
549 in
550 F.traverse_ check (makeGroups names)
553defDuplicates :: [Pattern.Raw] -> Result.Result wrn Error.Error ()
554defDuplicates patterns =
555 concatMap Pattern.boundVars patterns
556 |> detectDuplicates Error.DuplicateDefinition
559declDuplicates :: [D.Valid] -> Valid.Effects -> Result.Result wrn Error.Error ()
560declDuplicates decls effects =
561 let
562 (valueLists, typeLists) =
563 unzip (map extractValues decls)
565 effectValues =
566 extractEffectValues effects
567 in
568 (\_ _ -> ())
569 <$> detectDuplicates Error.DuplicateValueDeclaration (effectValues ++ concat valueLists)
570 <*> detectDuplicates Error.DuplicateTypeDeclaration (concat typeLists)
573extractValues :: D.Valid -> ([A.Located String], [A.Located String])
574extractValues (A.A (region, _) decl) =
575 case decl of
576 D.Def (Valid.Definition pattern _ _) ->
577 ( Pattern.boundVars pattern
578 , []
579 )
581 D.Union name _ ctors ->
582 ( map (A.A region . fst) ctors
583 , [A.A region name]
584 )
586 D.Alias name _ (A.A _ (Type.RRecord _ _)) ->
587 ( [A.A region name]
588 , [A.A region name]
589 )
591 D.Alias name _ _ ->
592 ( []
593 , [A.A region name]
594 )
596 D.Fixity _ _ _ ->
597 ( []
598 , []
599 )
602extractEffectValues :: Valid.Effects -> [A.Located String]
603extractEffectValues effects =
604 case effects of
605 Valid.None ->
606 []
608 Valid.Effects cmds subs ->
609 let
610 extractNames (Valid.Definition pat _ _) =
611 Pattern.boundVars pat
612 in
613 concatMap (extractNames . A.drop) (cmds ++ subs)
615 Valid.ForeignEffects cmds subs ->
616 let
617 extractCmdNames (A.A (region, _) (Valid.Cmd name _)) =
618 A.A region name
620 extractSubNames (A.A (region, _) sub) =
621 A.A region $
622 case sub of
623 Valid.Sub name _ ->
624 name
626 Valid.SubWith name _ ->
627 name
628 in
629 map extractCmdNames cmds ++ map extractSubNames subs
633-- UNBOUND TYPE VARIABLES
636findBadTypeVars :: D.Valid -> Result.Result wrn Error.Error ()
637findBadTypeVars (A.A (region,_) decl) =
638 case decl of
639 D.Def _ ->
640 return ()
642 D.Union name boundVars ctors ->
643 case diff boundVars (concatMap freeVars (concatMap snd ctors)) of
644 (_, []) ->
645 return ()
647 (_, unbound) ->
648 Result.throw region
649 (Error.UnboundTypeVarsInUnion name boundVars unbound)
651 D.Alias name boundVars tipe ->
652 case diff boundVars (freeVars tipe) of
653 ([], []) ->
654 return ()
656 ([], unbound) ->
657 Result.throw region
658 (Error.UnboundTypeVarsInAlias name boundVars unbound)
660 (unused, []) ->
661 Result.throw region
662 (Error.UnusedTypeVarsInAlias name boundVars unused)
664 (unused, unbound) ->
665 Result.throw region
666 (Error.MessyTypeVarsInAlias name boundVars unused unbound)
668 D.Fixity _ _ _ ->
669 return ()
672diff :: [String] -> [A.Located String] -> ([String], [String])
673diff left right =
674 let
675 leftSet =
676 Set.fromList left
678 rightSet =
679 Set.fromList (map A.drop right)
680 in
681 ( Set.toList (Set.difference leftSet rightSet)
682 , Set.toList (Set.difference rightSet leftSet)
683 )
687freeVars :: Type.Raw -> [A.Located String]
688freeVars (A.A region tipe) =
689 case tipe of
690 Type.RLambda t1 t2 ->
691 freeVars t1 ++ freeVars t2
693 Type.RVar x ->
694 [A.A region x]
696 Type.RType _ ->
697 []
699 Type.RApp t ts ->
700 concatMap freeVars (t:ts)
702 Type.RRecord fields ext ->
703 maybe [] freeVars ext
704 ++ concatMap (freeVars . snd) fields