git.iko.soy/elk
on ef280ed help sign in
elk/src/Validate.hs
496 lines 13 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module Validate (declarations) where
4import Control.Monad (foldM)
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.Expression.Source as Source
12import qualified AST.Expression.Valid as Valid
13import qualified AST.Declaration as D
14import qualified AST.Pattern as Pattern
15import qualified AST.Type as Type
16import Elm.Utils ((|>))
17import qualified Reporting.Annotation as A
18import qualified Reporting.Error.Syntax as Error
19import qualified Reporting.Region as R
20import qualified Reporting.Result as Result
23-- VALIDATE DECLARATIONS
25declarations
26 :: Bool
27 -> [D.SourceDecl]
28 -> Result.Result wrn Error.Error [D.ValidDecl]
29declarations isRoot sourceDecls =
30 do validDecls <- validateDecls Nothing sourceDecls
31 (\_ _ -> validDecls)
32 <$> declDuplicates validDecls
33 <*> T.traverse (checkDecl isRoot) validDecls
36validateDecls
37 :: Maybe String
38 -> [D.SourceDecl]
39 -> Result.Result wrn Error.Error [D.ValidDecl]
40validateDecls maybeComment sourceDecls =
41 case sourceDecls of
42 [] ->
43 return []
45 sourceDecl : decls ->
46 case sourceDecl of
47 D.Comment comment ->
48 validateDecls (Just comment) decls
50 D.Decl decl ->
51 validateDeclsHelp maybeComment decl decls
54validateDeclsHelp
55 :: Maybe String
56 -> A.Located D.SourceDecl'
57 -> [D.SourceDecl]
58 -> Result.Result wrn Error.Error [D.ValidDecl]
59validateDeclsHelp comment (A.A region decl) decls =
60 let addRest validDecl =
61 (:) (A.A (region, comment) validDecl)
62 <$> validateDecls Nothing decls
63 in
64 case decl of
65 D.Datatype name tvars ctors ->
66 addRest (D.Datatype name tvars ctors)
68 D.TypeAlias name tvars alias ->
69 addRest (D.TypeAlias name tvars alias)
71 D.Fixity assoc prec op ->
72 addRest (D.Fixity assoc prec op)
74 D.Definition def ->
75 defHelp comment def decls
77 D.Port port ->
78 portHelp comment region port decls
81-- VALIDATE DEFINITIONS IN DECLARATIONS
83defHelp
84 :: Maybe String
85 -> Source.Def
86 -> [D.SourceDecl]
87 -> Result.Result wrn Error.Error [D.ValidDecl]
88defHelp comment (A.A region def) decls =
89 let addRest def' rest =
90 (:) (A.A (region, comment) (D.Definition def'))
91 <$> validateDecls Nothing rest
92 in
93 case def of
94 Source.Definition pat expr ->
95 do expr' <- expression expr
96 let def' = Valid.Definition pat expr' Nothing
97 checkDefinition def'
98 addRest def' decls
100 Source.TypeAnnotation name tipe ->
101 case decls of
102 D.Decl (A.A _ (D.Definition (A.A _
103 (Source.Definition pat@(A.A _ (Pattern.Var name')) expr)))) : rest
104 | name == name' ->
105 do expr' <- expression expr
106 let def' = Valid.Definition pat expr' (Just tipe)
107 checkDefinition def'
108 addRest def' rest
110 _ ->
111 Result.throw region (Error.TypeWithoutDefinition name)
114-- VALIDATE PORTS IN DECLARATIONS
116portHelp
117 :: Maybe String
118 -> R.Region
119 -> D.SourcePort
120 -> [D.SourceDecl]
121 -> Result.Result wrn Error.Error [D.ValidDecl]
122portHelp comment region port decls =
123 let addRest port' rest =
124 (:) (A.A (region,comment) (D.Port port'))
125 <$> validateDecls Nothing rest
126 in
127 case port of
128 D.PortDefinition name _ ->
129 Result.throw region (Error.PortWithoutAnnotation name)
131 D.PortAnnotation name tipe ->
132 case decls of
133 D.Decl (A.A _ (D.Port (D.PortDefinition name' expr))) : rest
134 | name == name' ->
135 do expr' <- expression expr
136 let port' = D.Out name expr' tipe
137 addRest port' rest
139 _ ->
140 addRest (D.In name tipe) decls
143-- VALIDATE DEFINITIONS
145definitions :: [Source.Def] -> Result.Result wrn Error.Error [Valid.Def]
146definitions sourceDefs =
147 do validDefs <- definitionsHelp sourceDefs
148 let patterns = map (\(Valid.Definition p _ _) -> p) validDefs
149 defDuplicates patterns
150 return validDefs
153definitionsHelp :: [Source.Def] -> Result.Result wrn Error.Error [Valid.Def]
154definitionsHelp sourceDefs =
155 case sourceDefs of
156 [] ->
157 return []
159 A.A _ (Source.Definition pat expr) : rest ->
160 do expr' <- expression expr
161 let def = Valid.Definition pat expr' Nothing
162 checkDefinition def
163 (:) def <$> definitionsHelp rest
165 A.A region (Source.TypeAnnotation name tipe) : rest ->
166 case rest of
167 A.A _ (Source.Definition pat@(A.A _ (Pattern.Var name')) expr) : rest'
168 | name == name' ->
169 do expr' <- expression expr
170 let def = Valid.Definition pat expr' (Just tipe)
171 checkDefinition def
172 (:) def <$> definitionsHelp rest'
174 _ ->
175 Result.throw region (Error.TypeWithoutDefinition name)
178checkDefinition :: Valid.Def -> Result.Result wrn Error.Error ()
179checkDefinition (Valid.Definition pattern body _) =
180 case fst (Expr.collectLambdas body) of
181 [] ->
182 return ()
184 args ->
185 case pattern of
186 A.A _ (Pattern.Var _) ->
187 checkArguments args
189 _ ->
190 let
191 (A.A start _) = pattern
192 (A.A end _) = last args
193 in
194 Result.throw (R.merge start end) (Error.BadFunctionName (length args))
198checkArguments :: [Pattern.Pattern R.Region var] -> Result.Result wrn Error.Error ()
199checkArguments args =
200 let
201 vars = concatMap (Pattern.boundVarList) args
202 in
203 case firstDuplicate vars of
204 Nothing ->
205 return ()
207 Just var ->
208 let
209 (A.A start _) = head args
210 (A.A end _) = last args
211 in
212 Result.throw (R.merge start end) (Error.RepeatedArgument var)
215firstDuplicate :: [String] -> Maybe String
216firstDuplicate vars =
217 case vars of
218 [] ->
219 Nothing
221 var : rest ->
222 if var `elem` rest then
223 Just var
225 else
226 firstDuplicate rest
229-- VALIDATE EXPRESSIONS
231expression :: Source.Expr -> Result.Result wrn Error.Error Valid.Expr
232expression (A.A ann sourceExpression) =
233 A.A ann <$>
234 case sourceExpression of
235 Var x ->
236 return (Var x)
238 Lambda pattern body ->
239 Lambda
240 <$> validatePattern pattern
241 <*> expression body
243 Binop op leftExpr rightExpr ->
244 Binop op
245 <$> expression leftExpr
246 <*> expression rightExpr
248 Case e branches ->
249 Case
250 <$> expression e
251 <*> T.traverse (\(p,b) -> (,) <$> validatePattern p <*> expression b) branches
253 Data name args ->
254 Data name <$> T.traverse expression args
256 Literal lit ->
257 return (Literal lit)
259 Range lowExpr highExpr ->
260 Range
261 <$> expression lowExpr
262 <*> expression highExpr
264 ExplicitList expressions ->
265 ExplicitList
266 <$> T.traverse expression expressions
268 App funcExpr argExpr ->
269 App
270 <$> expression funcExpr
271 <*> expression argExpr
273 If branches finally ->
274 If
275 <$> T.traverse both branches
276 <*> expression finally
278 Access record field ->
279 Access
280 <$> expression record
281 <*> return field
283 Update record fields ->
284 Update
285 <$> expression record
286 <*> T.traverse second fields
288 Record fields ->
289 let
290 checkDups seenFields (field,_) =
291 if Set.member field seenFields then
292 Result.throw ann (Error.DuplicateFieldName field)
294 else
295 return (Set.insert field seenFields)
296 in
297 do _ <- foldM checkDups Set.empty fields
298 Record <$> T.traverse second fields
300 Let defs body ->
301 Let
302 <$> definitions defs
303 <*> expression body
305 GLShader uid src gltipe ->
306 return (GLShader uid src gltipe)
308 Port impl ->
309 Port <$>
310 case impl of
311 In name tipe ->
312 return (In name tipe)
314 Out name expr tipe ->
315 do expr' <- expression expr
316 return (Out name expr' tipe)
318 Task name expr tipe ->
319 do expr' <- expression expr
320 return (Task name expr' tipe)
323second :: (a, Source.Expr) -> Result.Result wrn Error.Error (a, Valid.Expr)
324second (value, expr) =
325 (,) value <$> expression expr
328both
329 :: (Source.Expr, Source.Expr)
330 -> Result.Result wrn Error.Error (Valid.Expr, Valid.Expr)
331both (expr1, expr2) =
332 (,) <$> expression expr1 <*> expression expr2
335-- VALIDATE PATTERNS
337validatePattern :: Pattern.RawPattern -> Result.Result wrn Error.Error Pattern.RawPattern
338validatePattern pattern =
339 do detectDuplicates Error.BadPattern (Pattern.boundVars pattern)
340 return pattern
343-- DETECT DUPLICATES
345detectDuplicates
346 :: (String -> Error.Error)
347 -> [A.Located String]
348 -> Result.Result wrn Error.Error ()
349detectDuplicates tag names =
350 let add (A.A region name) dict =
351 Map.insertWith (++) name [region] dict
353 makeGroups pairs =
354 Map.toList (foldr add Map.empty pairs)
356 check (name, regions) =
357 case regions of
358 _ : region : _ ->
359 Result.throw region (tag name)
361 _ ->
362 return ()
363 in
364 F.traverse_ check (makeGroups names)
367defDuplicates
368 :: [Pattern.RawPattern]
369 -> Result.Result wrn Error.Error ()
370defDuplicates patterns =
371 concatMap Pattern.boundVars patterns
372 |> detectDuplicates Error.DuplicateDefinition
375declDuplicates :: [D.ValidDecl] -> Result.Result wrn Error.Error ()
376declDuplicates decls =
377 let (valueLists, typeLists) = unzip (map extractValues decls)
378 in
379 (\_ _ -> ())
380 <$> detectDuplicates Error.DuplicateValueDeclaration (concat valueLists)
381 <*> detectDuplicates Error.DuplicateTypeDeclaration (concat typeLists)
384extractValues :: D.ValidDecl -> ([A.Located String], [A.Located String])
385extractValues (A.A (region, _) decl) =
386 case decl of
387 D.Definition (Valid.Definition pattern _ _) ->
388 ( Pattern.boundVars pattern
389 , []
390 )
392 D.Datatype name _ ctors ->
393 ( map (A.A region . fst) ctors
394 , [A.A region name]
395 )
397 D.TypeAlias name _ (A.A _ (Type.RRecord _ _)) ->
398 ( [A.A region name]
399 , [A.A region name]
400 )
402 D.TypeAlias name _ _ ->
403 ( []
404 , [A.A region name]
405 )
407 D.Port port ->
408 ( [A.A region (D.validPortName port)]
409 , []
410 )
412 D.Fixity _ _ _ ->
413 ( []
414 , []
415 )
418-- UNBOUND TYPE VARIABLES
420checkDecl :: Bool -> D.ValidDecl -> Result.Result wrn Error.Error ()
421checkDecl isRoot (A.A (region,_) decl) =
422 case decl of
423 D.Definition _ ->
424 return ()
426 D.Datatype name boundVars ctors ->
427 case diff boundVars (concatMap freeVars (concatMap snd ctors)) of
428 (_, []) ->
429 return ()
431 (_, unbound) ->
432 Result.throw region
433 (Error.UnboundTypeVarsInUnion name boundVars unbound)
435 D.TypeAlias name boundVars tipe ->
436 case diff boundVars (freeVars tipe) of
437 ([], []) ->
438 return ()
440 ([], unbound) ->
441 Result.throw region
442 (Error.UnboundTypeVarsInAlias name boundVars unbound)
444 (unused, []) ->
445 Result.throw region
446 (Error.UnusedTypeVarsInAlias name boundVars unused)
448 (unused, unbound) ->
449 Result.throw region
450 (Error.MessyTypeVarsInAlias name boundVars unused unbound)
452 D.Port _ ->
453 if isRoot then
454 return ()
456 else
457 Result.throw region Error.UnexpectedPort
459 D.Fixity _ _ _ ->
460 return ()
463diff :: [String] -> [A.Located String] -> ([String], [String])
464diff left right =
465 let
466 leftSet =
467 Set.fromList left
469 rightSet =
470 Set.fromList (map A.drop right)
471 in
472 ( Set.toList (Set.difference leftSet rightSet)
473 , Set.toList (Set.difference rightSet leftSet)
474 )
478freeVars :: Type.Raw -> [A.Located String]
479freeVars (A.A region tipe) =
480 case tipe of
481 Type.RLambda t1 t2 ->
482 freeVars t1 ++ freeVars t2
484 Type.RVar x ->
485 [A.A region x]
487 Type.RType _ ->
488 []
490 Type.RApp t ts ->
491 concatMap freeVars (t:ts)
493 Type.RRecord fields ext ->
494 maybe [] freeVars ext
495 ++ concatMap (freeVars . snd) fields