git.iko.soy/elk
on 455dcb2 help sign in
elk/src/Validate.hs
560 lines 14 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module Validate (declarations) where
4import Control.Monad (foldM)
5import qualified Data.Map as Map
6import qualified Data.Maybe as Maybe
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.Pattern as Pattern
16import qualified AST.Type as Type
17import Elm.Utils ((|>))
18import qualified Reporting.Annotation as A
19import qualified Reporting.Error.Syntax as Error
20import qualified Reporting.Region as R
21import qualified Reporting.Result as Result
25-- COLLAPSE COMMENTS
28type Commented a =
29 A.Annotated (R.Region, Maybe (A.Located String)) a
32collapseComments
33 :: [D.CommentOr (A.Located a)]
34 -> Result.Result wrn Error.Error [Commented a]
35collapseComments listWithComments =
36 case listWithComments of
37 [] ->
38 Result.ok []
40 D.Comment msg : D.Whatever (A.A region a) : rest ->
41 let
42 entry =
43 A.A (region, Just msg) a
44 in
45 fmap (entry:) (collapseComments rest)
47 D.Comment (A.A region _) : D.Comment _ : _ ->
48 Result.throw region Error.CommentOnComment
50 [D.Comment (A.A region _)] ->
51 Result.throw region Error.CommentOnNothing
53 D.Whatever (A.A region a) : rest ->
54 let
55 entry =
56 A.A (region, Nothing) a
57 in
58 fmap (entry:) (collapseComments rest)
62-- EXTRACT DEFINES
65data StructuredSource =
66 Src
67 { _decls :: [Commented D.Source']
68 , _cmds :: Maybe [Commented Source.Effect]
69 , _subs :: Maybe [Commented Source.Effect]
70 }
73extractEffects :: [Commented D.SourceOrDefine] -> Result.Result wrn Error.Error StructuredSource
74extractEffects commentedDecls =
75 case commentedDecls of
76 [] ->
77 Result.ok (Src [] Nothing Nothing)
79 A.A ann (D.Source decl) : rest ->
80 do restSrc <- extractEffects rest
81 return $ restSrc { _decls = A.A ann decl : _decls restSrc }
83 A.A (region, _) (D.Define name commentOrEffects) : rest ->
84 do restSrc <- extractEffects rest
85 case name of
86 "commands" ->
87 case _cmds restSrc of
88 Nothing ->
89 do effects <- collapseComments commentOrEffects
90 Result.ok $ restSrc { _cmds = Just effects }
92 Just _ ->
93 Result.throw region (Error.DefineDuplicate name)
95 "subscriptions" ->
96 case _subs restSrc of
97 Nothing ->
98 do effects <- collapseComments commentOrEffects
99 Result.ok $ restSrc { _subs = Just effects }
101 Just _ ->
102 Result.throw region (Error.DefineDuplicate name)
104 _ ->
105 Result.throw region (Error.DefineUnknown name)
109-- VALIDATE STRUCTURED SOURCE
112declarations :: [D.Source] -> Result.Result wrn Error.Error [D.Valid]
113declarations sourceDecls =
114 do (Src decls cmds subs) <-
115 extractEffects =<< collapseComments sourceDecls
117 validDecls <-
118 validateDecls decls
120 validCmds <-
121 validateEffects (Maybe.fromMaybe [] cmds)
123 validSubs <-
124 validateEffects (Maybe.fromMaybe [] subs)
126 (\_ _ -> validDecls)
127 <$> declDuplicates validDecls
128 <*> T.traverse checkDecl validDecls
132-- VALIDATE DECLARATIONS
135validateDecls
136 :: [Commented D.Source']
137 -> Result.Result wrn Error.Error [D.Valid]
138validateDecls commentedDecls =
139 case commentedDecls of
140 [] ->
141 Result.ok []
143 A.A (region, maybeComment) decl : rest ->
144 let
145 addRest validDecl =
146 let
147 entry =
148 A.A (region, fmap A.drop maybeComment) validDecl
149 in
150 fmap (entry:) (validateDecls rest)
151 in
152 case decl of
153 D.Union name tvars ctors ->
154 addRest (D.Union name tvars ctors)
156 D.Alias name tvars alias ->
157 addRest (D.Alias name tvars alias)
159 D.Fixity assoc prec op ->
160 addRest (D.Fixity assoc prec op)
162 D.Def def ->
163 validateDeclsHelp maybeComment def rest
166validateDeclsHelp
167 :: Maybe (A.Located String)
168 -> Source.Def
169 -> [Commented D.Source']
170 -> Result.Result wrn Error.Error [D.Valid]
171validateDeclsHelp maybeComment (A.A region def) decls =
172 let
173 makeDef pat expr maybeType =
174 D.Def (Valid.Definition pat expr maybeType)
176 ann =
177 (region, fmap A.drop maybeComment)
178 in
179 case def of
180 Source.Definition pat expr ->
181 (:)
182 <$> validateDef makeDef ann pat expr Nothing
183 <*> validateDecls decls
185 Source.Annotation name tipe ->
186 case decls of
187 A.A (_, Just (A.A commentRegion _)) _ : _ ->
188 Result.throw commentRegion (Error.CommentAfterAnnotation name)
190 A.A _ (D.Def (A.A _ (Source.Definition pat expr))) : rest
191 | Pattern.isVar name pat ->
192 (:)
193 <$> validateDef makeDef ann pat expr (Just tipe)
194 <*> validateDecls rest
196 _ ->
197 Result.throw region (Error.TypeWithoutDefinition name)
201-- VALIDATE EFFECTS
204validateEffects
205 :: [Commented Source.Effect]
206 -> Result.Result wrn Error.Error [A.Commented Valid.Effect]
207validateEffects effects =
208 case effects of
209 [] ->
210 Result.ok []
212 A.A (region, maybeComment) effect : rest ->
213 validateEffectsHelp (region, fmap A.drop maybeComment) effect rest
216validateEffectsHelp
217 :: (R.Region, Maybe String)
218 -> Source.Effect
219 -> [Commented Source.Effect]
220 -> Result.Result wrn Error.Error [A.Commented Valid.Effect]
221validateEffectsHelp ann effect remainingEffects =
222 case effect of
223 Source.With _ _ ->
224 Result.throw (fst ann) (error "TODO")
226 Source.Def pat expr ->
227 (:)
228 <$> validateDef Valid.Def ann pat expr Nothing
229 <*> validateEffects remainingEffects
231 Source.Type name tipe ->
232 case remainingEffects of
233 A.A (_, Just (A.A commentRegion _)) _ : _ ->
234 Result.throw commentRegion (Error.CommentAfterAnnotation name)
236 A.A _ (Source.Def pat expr) : rest
237 | Pattern.isVar name pat ->
238 (:)
239 <$> validateDef Valid.Def ann pat expr (Just tipe)
240 <*> validateEffects rest
242 _ ->
243 Result.throw (fst ann) (Error.TypeWithoutDefinition name)
247-- VALIDATE DEFINITIONS
250definitions :: [Source.Def] -> Result.Result wrn Error.Error [Valid.Def]
251definitions sourceDefs =
252 do validDefs <- definitionsHelp sourceDefs
253 let patterns = map (\(Valid.Definition p _ _) -> p) validDefs
254 defDuplicates patterns
255 return validDefs
258definitionsHelp :: [Source.Def] -> Result.Result wrn Error.Error [Valid.Def]
259definitionsHelp sourceDefs =
260 case sourceDefs of
261 [] ->
262 return []
264 A.A region (Source.Definition pat expr) : rest ->
265 (:)
266 <$> fmap A.drop (validateDef Valid.Definition region pat expr Nothing)
267 <*> definitionsHelp rest
269 A.A r1 (Source.Annotation name tipe) : rest ->
270 case rest of
271 A.A r2 (Source.Definition pat expr) : rest'
272 | Pattern.isVar name pat ->
273 (:)
274 <$> fmap A.drop (validateDef Valid.Definition (R.merge r1 r2) pat expr (Just tipe))
275 <*> definitionsHelp rest'
277 _ ->
278 Result.throw r1 (Error.TypeWithoutDefinition name)
281validateDef
282 :: (Pattern.Raw -> Valid.Expr -> Maybe Type.Raw -> def)
283 -> annotation
284 -> Pattern.Raw
285 -> Source.Expr
286 -> Maybe Type.Raw
287 -> Result.Result wrn Error.Error (A.Annotated annotation def)
288validateDef makeDef annotation pat expr maybeType =
289 do validExpr <- expression expr
290 validateDefPattern pat validExpr
291 return $ A.A annotation (makeDef pat validExpr maybeType)
294validateDefPattern :: Pattern.Raw -> Valid.Expr -> Result.Result wrn Error.Error ()
295validateDefPattern pattern body =
296 case fst (Expr.collectLambdas body) of
297 [] ->
298 return ()
300 args ->
301 case pattern of
302 A.A _ (Pattern.Var _) ->
303 return ()
305 _ ->
306 let
307 (A.A start _) = pattern
308 (A.A end _) = last args
309 in
310 Result.throw (R.merge start end) (Error.BadFunctionName (length args))
314-- VALIDATE EXPRESSIONS
317expression :: Source.Expr -> Result.Result wrn Error.Error Valid.Expr
318expression (A.A ann sourceExpression) =
319 A.A ann <$>
320 case sourceExpression of
321 Var x ->
322 return (Var x)
324 Lambda pattern body ->
325 Lambda
326 <$> validatePattern pattern
327 <*> expression body
329 Binop op leftExpr rightExpr ->
330 Binop op
331 <$> expression leftExpr
332 <*> expression rightExpr
334 Case e branches ->
335 Case
336 <$> expression e
337 <*> T.traverse (\(p,b) -> (,) <$> validatePattern p <*> expression b) branches
339 Data name args ->
340 Data name <$> T.traverse expression args
342 Literal lit ->
343 return (Literal lit)
345 Range lowExpr highExpr ->
346 Range
347 <$> expression lowExpr
348 <*> expression highExpr
350 ExplicitList expressions ->
351 ExplicitList
352 <$> T.traverse expression expressions
354 App funcExpr argExpr ->
355 App
356 <$> expression funcExpr
357 <*> expression argExpr
359 If branches finally ->
360 If
361 <$> T.traverse both branches
362 <*> expression finally
364 Access record field ->
365 Access
366 <$> expression record
367 <*> return field
369 Update record fields ->
370 Update
371 <$> expression record
372 <*> T.traverse second fields
374 Record fields ->
375 let
376 checkDups seenFields (field,_) =
377 if Set.member field seenFields then
378 Result.throw ann (Error.DuplicateFieldName field)
380 else
381 return (Set.insert field seenFields)
382 in
383 do _ <- foldM checkDups Set.empty fields
384 Record <$> T.traverse second fields
386 Let defs body ->
387 Let
388 <$> definitions defs
389 <*> expression body
391 GLShader uid src gltipe ->
392 return (GLShader uid src gltipe)
395second :: (a, Source.Expr) -> Result.Result wrn Error.Error (a, Valid.Expr)
396second (value, expr) =
397 (,) value <$> expression expr
400both
401 :: (Source.Expr, Source.Expr)
402 -> Result.Result wrn Error.Error (Valid.Expr, Valid.Expr)
403both (expr1, expr2) =
404 (,) <$> expression expr1 <*> expression expr2
408-- VALIDATE PATTERNS
411validatePattern :: Pattern.Raw -> Result.Result wrn Error.Error Pattern.Raw
412validatePattern pattern =
413 do detectDuplicates Error.BadPattern (Pattern.boundVars pattern)
414 return pattern
418-- DETECT DUPLICATES
421detectDuplicates
422 :: (String -> Error.Error)
423 -> [A.Located String]
424 -> Result.Result wrn Error.Error ()
425detectDuplicates tag names =
426 let add (A.A region name) dict =
427 Map.insertWith (++) name [region] dict
429 makeGroups pairs =
430 Map.toList (foldr add Map.empty pairs)
432 check (name, regions) =
433 case regions of
434 _ : region : _ ->
435 Result.throw region (tag name)
437 _ ->
438 return ()
439 in
440 F.traverse_ check (makeGroups names)
443defDuplicates :: [Pattern.Raw] -> Result.Result wrn Error.Error ()
444defDuplicates patterns =
445 concatMap Pattern.boundVars patterns
446 |> detectDuplicates Error.DuplicateDefinition
449declDuplicates :: [D.Valid] -> Result.Result wrn Error.Error ()
450declDuplicates decls =
451 let (valueLists, typeLists) = unzip (map extractValues decls)
452 in
453 (\_ _ -> ())
454 <$> detectDuplicates Error.DuplicateValueDeclaration (concat valueLists)
455 <*> detectDuplicates Error.DuplicateTypeDeclaration (concat typeLists)
458extractValues :: D.Valid -> ([A.Located String], [A.Located String])
459extractValues (A.A (region, _) decl) =
460 case decl of
461 D.Def (Valid.Definition pattern _ _) ->
462 ( Pattern.boundVars pattern
463 , []
464 )
466 D.Union name _ ctors ->
467 ( map (A.A region . fst) ctors
468 , [A.A region name]
469 )
471 D.Alias name _ (A.A _ (Type.RRecord _ _)) ->
472 ( [A.A region name]
473 , [A.A region name]
474 )
476 D.Alias name _ _ ->
477 ( []
478 , [A.A region name]
479 )
481 D.Fixity _ _ _ ->
482 ( []
483 , []
484 )
488-- UNBOUND TYPE VARIABLES
491checkDecl :: D.Valid -> Result.Result wrn Error.Error ()
492checkDecl (A.A (region,_) decl) =
493 case decl of
494 D.Def _ ->
495 return ()
497 D.Union name boundVars ctors ->
498 case diff boundVars (concatMap freeVars (concatMap snd ctors)) of
499 (_, []) ->
500 return ()
502 (_, unbound) ->
503 Result.throw region
504 (Error.UnboundTypeVarsInUnion name boundVars unbound)
506 D.Alias name boundVars tipe ->
507 case diff boundVars (freeVars tipe) of
508 ([], []) ->
509 return ()
511 ([], unbound) ->
512 Result.throw region
513 (Error.UnboundTypeVarsInAlias name boundVars unbound)
515 (unused, []) ->
516 Result.throw region
517 (Error.UnusedTypeVarsInAlias name boundVars unused)
519 (unused, unbound) ->
520 Result.throw region
521 (Error.MessyTypeVarsInAlias name boundVars unused unbound)
523 D.Fixity _ _ _ ->
524 return ()
527diff :: [String] -> [A.Located String] -> ([String], [String])
528diff left right =
529 let
530 leftSet =
531 Set.fromList left
533 rightSet =
534 Set.fromList (map A.drop right)
535 in
536 ( Set.toList (Set.difference leftSet rightSet)
537 , Set.toList (Set.difference rightSet leftSet)
538 )
542freeVars :: Type.Raw -> [A.Located String]
543freeVars (A.A region tipe) =
544 case tipe of
545 Type.RLambda t1 t2 ->
546 freeVars t1 ++ freeVars t2
548 Type.RVar x ->
549 [A.A region x]
551 Type.RType _ ->
552 []
554 Type.RApp t ts ->
555 concatMap freeVars (t:ts)
557 Type.RRecord fields ext ->
558 maybe [] freeVars ext
559 ++ concatMap (freeVars . snd) fields