git.iko.soy/elk
on 3bd0d85 help sign in
elk/src/Validate.hs
419 lines 11 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
24-- VALIDATE DECLARATIONS
27declarations
28 :: [D.SourceDecl]
29 -> Result.Result wrn Error.Error [D.ValidDecl]
30declarations sourceDecls =
31 do validDecls <- validateDecls Nothing sourceDecls
32 (\_ _ -> validDecls)
33 <$> declDuplicates validDecls
34 <*> T.traverse checkDecl validDecls
37validateDecls
38 :: Maybe String
39 -> [D.SourceDecl]
40 -> Result.Result wrn Error.Error [D.ValidDecl]
41validateDecls maybeComment sourceDecls =
42 case sourceDecls of
43 [] ->
44 return []
46 sourceDecl : decls ->
47 case sourceDecl of
48 D.Comment comment ->
49 validateDecls (Just comment) decls
51 D.Decl decl ->
52 validateDeclsHelp maybeComment decl decls
55validateDeclsHelp
56 :: Maybe String
57 -> A.Located D.SourceDecl'
58 -> [D.SourceDecl]
59 -> Result.Result wrn Error.Error [D.ValidDecl]
60validateDeclsHelp comment (A.A region decl) decls =
61 let addRest validDecl =
62 (:) (A.A (region, comment) validDecl)
63 <$> validateDecls Nothing decls
64 in
65 case decl of
66 D.Datatype name tvars ctors ->
67 addRest (D.Datatype name tvars ctors)
69 D.TypeAlias name tvars alias ->
70 addRest (D.TypeAlias name tvars alias)
72 D.Fixity assoc prec op ->
73 addRest (D.Fixity assoc prec op)
75 D.Definition def ->
76 defHelp comment def decls
80-- 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)
115-- VALIDATE DEFINITIONS
118definitions :: [Source.Def] -> Result.Result wrn Error.Error [Valid.Def]
119definitions sourceDefs =
120 do validDefs <- definitionsHelp sourceDefs
121 let patterns = map (\(Valid.Definition p _ _) -> p) validDefs
122 defDuplicates patterns
123 return validDefs
126definitionsHelp :: [Source.Def] -> Result.Result wrn Error.Error [Valid.Def]
127definitionsHelp sourceDefs =
128 case sourceDefs of
129 [] ->
130 return []
132 A.A _ (Source.Definition pat expr) : rest ->
133 do expr' <- expression expr
134 let def = Valid.Definition pat expr' Nothing
135 checkDefinition def
136 (:) def <$> definitionsHelp rest
138 A.A region (Source.TypeAnnotation name tipe) : rest ->
139 case rest of
140 A.A _ (Source.Definition pat@(A.A _ (Pattern.Var name')) expr) : rest'
141 | name == name' ->
142 do expr' <- expression expr
143 let def = Valid.Definition pat expr' (Just tipe)
144 checkDefinition def
145 (:) def <$> definitionsHelp rest'
147 _ ->
148 Result.throw region (Error.TypeWithoutDefinition name)
151checkDefinition :: Valid.Def -> Result.Result wrn Error.Error ()
152checkDefinition (Valid.Definition pattern body _) =
153 case fst (Expr.collectLambdas body) of
154 [] ->
155 return ()
157 args ->
158 case pattern of
159 A.A _ (Pattern.Var _) ->
160 return ()
162 _ ->
163 let
164 (A.A start _) = pattern
165 (A.A end _) = last args
166 in
167 Result.throw (R.merge start end) (Error.BadFunctionName (length args))
171-- VALIDATE EXPRESSIONS
174expression :: Source.Expr -> Result.Result wrn Error.Error Valid.Expr
175expression (A.A ann sourceExpression) =
176 A.A ann <$>
177 case sourceExpression of
178 Var x ->
179 return (Var x)
181 Lambda pattern body ->
182 Lambda
183 <$> validatePattern pattern
184 <*> expression body
186 Binop op leftExpr rightExpr ->
187 Binop op
188 <$> expression leftExpr
189 <*> expression rightExpr
191 Case e branches ->
192 Case
193 <$> expression e
194 <*> T.traverse (\(p,b) -> (,) <$> validatePattern p <*> expression b) branches
196 Data name args ->
197 Data name <$> T.traverse expression args
199 Literal lit ->
200 return (Literal lit)
202 Range lowExpr highExpr ->
203 Range
204 <$> expression lowExpr
205 <*> expression highExpr
207 ExplicitList expressions ->
208 ExplicitList
209 <$> T.traverse expression expressions
211 App funcExpr argExpr ->
212 App
213 <$> expression funcExpr
214 <*> expression argExpr
216 If branches finally ->
217 If
218 <$> T.traverse both branches
219 <*> expression finally
221 Access record field ->
222 Access
223 <$> expression record
224 <*> return field
226 Update record fields ->
227 Update
228 <$> expression record
229 <*> T.traverse second fields
231 Record fields ->
232 let
233 checkDups seenFields (field,_) =
234 if Set.member field seenFields then
235 Result.throw ann (Error.DuplicateFieldName field)
237 else
238 return (Set.insert field seenFields)
239 in
240 do _ <- foldM checkDups Set.empty fields
241 Record <$> T.traverse second fields
243 Let defs body ->
244 Let
245 <$> definitions defs
246 <*> expression body
248 GLShader uid src gltipe ->
249 return (GLShader uid src gltipe)
252second :: (a, Source.Expr) -> Result.Result wrn Error.Error (a, Valid.Expr)
253second (value, expr) =
254 (,) value <$> expression expr
257both
258 :: (Source.Expr, Source.Expr)
259 -> Result.Result wrn Error.Error (Valid.Expr, Valid.Expr)
260both (expr1, expr2) =
261 (,) <$> expression expr1 <*> expression expr2
265-- VALIDATE PATTERNS
268validatePattern :: Pattern.RawPattern -> Result.Result wrn Error.Error Pattern.RawPattern
269validatePattern pattern =
270 do detectDuplicates Error.BadPattern (Pattern.boundVars pattern)
271 return pattern
275-- DETECT DUPLICATES
278detectDuplicates
279 :: (String -> Error.Error)
280 -> [A.Located String]
281 -> Result.Result wrn Error.Error ()
282detectDuplicates tag names =
283 let add (A.A region name) dict =
284 Map.insertWith (++) name [region] dict
286 makeGroups pairs =
287 Map.toList (foldr add Map.empty pairs)
289 check (name, regions) =
290 case regions of
291 _ : region : _ ->
292 Result.throw region (tag name)
294 _ ->
295 return ()
296 in
297 F.traverse_ check (makeGroups names)
300defDuplicates
301 :: [Pattern.RawPattern]
302 -> Result.Result wrn Error.Error ()
303defDuplicates patterns =
304 concatMap Pattern.boundVars patterns
305 |> detectDuplicates Error.DuplicateDefinition
308declDuplicates :: [D.ValidDecl] -> Result.Result wrn Error.Error ()
309declDuplicates decls =
310 let (valueLists, typeLists) = unzip (map extractValues decls)
311 in
312 (\_ _ -> ())
313 <$> detectDuplicates Error.DuplicateValueDeclaration (concat valueLists)
314 <*> detectDuplicates Error.DuplicateTypeDeclaration (concat typeLists)
317extractValues :: D.ValidDecl -> ([A.Located String], [A.Located String])
318extractValues (A.A (region, _) decl) =
319 case decl of
320 D.Definition (Valid.Definition pattern _ _) ->
321 ( Pattern.boundVars pattern
322 , []
323 )
325 D.Datatype name _ ctors ->
326 ( map (A.A region . fst) ctors
327 , [A.A region name]
328 )
330 D.TypeAlias name _ (A.A _ (Type.RRecord _ _)) ->
331 ( [A.A region name]
332 , [A.A region name]
333 )
335 D.TypeAlias name _ _ ->
336 ( []
337 , [A.A region name]
338 )
340 D.Fixity _ _ _ ->
341 ( []
342 , []
343 )
347-- UNBOUND TYPE VARIABLES
350checkDecl :: D.ValidDecl -> Result.Result wrn Error.Error ()
351checkDecl (A.A (region,_) decl) =
352 case decl of
353 D.Definition _ ->
354 return ()
356 D.Datatype name boundVars ctors ->
357 case diff boundVars (concatMap freeVars (concatMap snd ctors)) of
358 (_, []) ->
359 return ()
361 (_, unbound) ->
362 Result.throw region
363 (Error.UnboundTypeVarsInUnion name boundVars unbound)
365 D.TypeAlias name boundVars tipe ->
366 case diff boundVars (freeVars tipe) of
367 ([], []) ->
368 return ()
370 ([], unbound) ->
371 Result.throw region
372 (Error.UnboundTypeVarsInAlias name boundVars unbound)
374 (unused, []) ->
375 Result.throw region
376 (Error.UnusedTypeVarsInAlias name boundVars unused)
378 (unused, unbound) ->
379 Result.throw region
380 (Error.MessyTypeVarsInAlias name boundVars unused unbound)
382 D.Fixity _ _ _ ->
383 return ()
386diff :: [String] -> [A.Located String] -> ([String], [String])
387diff left right =
388 let
389 leftSet =
390 Set.fromList left
392 rightSet =
393 Set.fromList (map A.drop right)
394 in
395 ( Set.toList (Set.difference leftSet rightSet)
396 , Set.toList (Set.difference rightSet leftSet)
397 )
401freeVars :: Type.Raw -> [A.Located String]
402freeVars (A.A region tipe) =
403 case tipe of
404 Type.RLambda t1 t2 ->
405 freeVars t1 ++ freeVars t2
407 Type.RVar x ->
408 [A.A region x]
410 Type.RType _ ->
411 []
413 Type.RApp t ts ->
414 concatMap freeVars (t:ts)
416 Type.RRecord fields ext ->
417 maybe [] freeVars ext
418 ++ concatMap (freeVars . snd) fields