git.iko.soy/elk
on 255f9df help sign in
elk/src/Validate.hs
449 lines 12 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module Validate (declarations) where
4import qualified Data.Map as Map
5import qualified Data.Set as Set
6import qualified Data.Foldable as F
7import qualified Data.Traversable as T
9import AST.Expression.General as Expr
10import qualified AST.Expression.Source as Source
11import qualified AST.Expression.Valid as Valid
12import qualified AST.Declaration as D
13import qualified AST.Pattern as Pattern
14import qualified AST.Type as Type
15import Elm.Utils ((|>))
16import qualified Reporting.Annotation as A
17import qualified Reporting.Error.Syntax as Error
18import qualified Reporting.Region as R
19import qualified Reporting.Result as Result
22-- VALIDATE DECLARATIONS
24declarations
25 :: Bool
26 -> [D.SourceDecl]
27 -> Result.Result wrn Error.Error [D.ValidDecl]
28declarations isRoot sourceDecls =
29 do validDecls <- validateDecls Nothing sourceDecls
30 (\_ _ -> validDecls)
31 <$> declDuplicates validDecls
32 <*> T.traverse (checkDecl isRoot) validDecls
35validateDecls
36 :: Maybe String
37 -> [D.SourceDecl]
38 -> Result.Result wrn Error.Error [D.ValidDecl]
39validateDecls maybeComment sourceDecls =
40 case sourceDecls of
41 [] ->
42 return []
44 sourceDecl : decls ->
45 case sourceDecl of
46 D.Comment comment ->
47 validateDecls (Just comment) decls
49 D.Decl decl ->
50 validateDeclsHelp maybeComment decl decls
53validateDeclsHelp
54 :: Maybe String
55 -> A.Located D.SourceDecl'
56 -> [D.SourceDecl]
57 -> Result.Result wrn Error.Error [D.ValidDecl]
58validateDeclsHelp comment (A.A region decl) decls =
59 let addRest validDecl =
60 (:) (A.A (region, comment) validDecl)
61 <$> validateDecls Nothing decls
62 in
63 case decl of
64 D.Datatype name tvars ctors ->
65 addRest (D.Datatype name tvars ctors)
67 D.TypeAlias name tvars alias ->
68 addRest (D.TypeAlias name tvars alias)
70 D.Fixity assoc prec op ->
71 addRest (D.Fixity assoc prec op)
73 D.Definition def ->
74 defHelp comment def decls
76 D.Port port ->
77 portHelp comment region port decls
80-- VALIDATE DEFINITIONS IN DECLARATIONS
82defHelp
83 :: Maybe String
84 -> Source.Def
85 -> [D.SourceDecl]
86 -> Result.Result wrn Error.Error [D.ValidDecl]
87defHelp comment (A.A region def) decls =
88 let addRest def' rest =
89 (:) (A.A (region, comment) (D.Definition def'))
90 <$> validateDecls Nothing rest
91 in
92 case def of
93 Source.Definition pat expr ->
94 do expr' <- expression expr
95 let def' = Valid.Definition pat expr' Nothing
96 checkDefinition def'
97 addRest def' decls
99 Source.TypeAnnotation name tipe ->
100 case decls of
101 D.Decl (A.A _ (D.Definition (A.A _
102 (Source.Definition pat@(A.A _ (Pattern.Var name')) expr)))) : rest
103 | name == name' ->
104 do expr' <- expression expr
105 let def' = Valid.Definition pat expr' (Just tipe)
106 checkDefinition def'
107 addRest def' rest
109 _ ->
110 Result.throw region (Error.TypeWithoutDefinition name)
113-- VALIDATE PORTS IN DECLARATIONS
115portHelp
116 :: Maybe String
117 -> R.Region
118 -> D.SourcePort
119 -> [D.SourceDecl]
120 -> Result.Result wrn Error.Error [D.ValidDecl]
121portHelp comment region port decls =
122 let addRest port' rest =
123 (:) (A.A (region,comment) (D.Port port'))
124 <$> validateDecls Nothing rest
125 in
126 case port of
127 D.PortDefinition name _ ->
128 Result.throw region (Error.PortWithoutAnnotation name)
130 D.PortAnnotation name tipe ->
131 case decls of
132 D.Decl (A.A _ (D.Port (D.PortDefinition name' expr))) : rest
133 | name == name' ->
134 do expr' <- expression expr
135 let port' = D.Out name expr' tipe
136 addRest port' rest
138 _ ->
139 addRest (D.In name tipe) decls
142-- VALIDATE DEFINITIONS
144definitions :: [Source.Def] -> Result.Result wrn Error.Error [Valid.Def]
145definitions sourceDefs =
146 do validDefs <- definitionsHelp sourceDefs
147 let patterns = map (\(Valid.Definition p _ _) -> p) validDefs
148 defDuplicates patterns
149 return validDefs
152definitionsHelp :: [Source.Def] -> Result.Result wrn Error.Error [Valid.Def]
153definitionsHelp sourceDefs =
154 case sourceDefs of
155 [] ->
156 return []
158 A.A _ (Source.Definition pat expr) : rest ->
159 do expr' <- expression expr
160 let def = Valid.Definition pat expr' Nothing
161 checkDefinition def
162 (:) def <$> definitionsHelp rest
164 A.A region (Source.TypeAnnotation name tipe) : rest ->
165 case rest of
166 A.A _ (Source.Definition pat@(A.A _ (Pattern.Var name')) expr) : rest'
167 | name == name' ->
168 do expr' <- expression expr
169 let def = Valid.Definition pat expr' (Just tipe)
170 checkDefinition def
171 (:) def <$> definitionsHelp rest'
173 _ ->
174 Result.throw region (Error.TypeWithoutDefinition name)
177checkDefinition :: Valid.Def -> Result.Result wrn Error.Error ()
178checkDefinition (Valid.Definition pattern body _) =
179 case fst (Expr.collectLambdas body) of
180 [] ->
181 return ()
183 args ->
184 case pattern of
185 A.A _ (Pattern.Var _) ->
186 return ()
188 _ ->
189 let
190 (A.A start _) = pattern
191 (A.A end _) = last args
192 in
193 Result.throw (R.merge start end) (Error.BadFunctionName (length args))
196-- VALIDATE EXPRESSIONS
198expression :: Source.Expr -> Result.Result wrn Error.Error Valid.Expr
199expression (A.A ann sourceExpression) =
200 A.A ann <$>
201 case sourceExpression of
202 Var x ->
203 return (Var x)
205 Lambda pattern body ->
206 Lambda
207 <$> validatePattern pattern
208 <*> expression body
210 Binop op leftExpr rightExpr ->
211 Binop op
212 <$> expression leftExpr
213 <*> expression rightExpr
215 Case e branches ->
216 Case
217 <$> expression e
218 <*> T.traverse (\(p,b) -> (,) <$> validatePattern p <*> expression b) branches
220 Data name args ->
221 Data name <$> T.traverse expression args
223 Literal lit ->
224 return (Literal lit)
226 Range lowExpr highExpr ->
227 Range
228 <$> expression lowExpr
229 <*> expression highExpr
231 ExplicitList expressions ->
232 ExplicitList
233 <$> T.traverse expression expressions
235 App funcExpr argExpr ->
236 App
237 <$> expression funcExpr
238 <*> expression argExpr
240 If branches finally ->
241 If
242 <$> T.traverse both branches
243 <*> expression finally
245 Access record field ->
246 Access
247 <$> expression record
248 <*> return field
250 Update record fields ->
251 Update
252 <$> expression record
253 <*> T.traverse second fields
255 Record fields ->
256 Record
257 <$> T.traverse second fields
259 Let defs body ->
260 Let
261 <$> definitions defs
262 <*> expression body
264 GLShader uid src gltipe ->
265 return (GLShader uid src gltipe)
267 Port impl ->
268 Port <$>
269 case impl of
270 In name tipe ->
271 return (In name tipe)
273 Out name expr tipe ->
274 do expr' <- expression expr
275 return (Out name expr' tipe)
277 Task name expr tipe ->
278 do expr' <- expression expr
279 return (Task name expr' tipe)
282second :: (a, Source.Expr) -> Result.Result wrn Error.Error (a, Valid.Expr)
283second (value, expr) =
284 (,) value <$> expression expr
287both
288 :: (Source.Expr, Source.Expr)
289 -> Result.Result wrn Error.Error (Valid.Expr, Valid.Expr)
290both (expr1, expr2) =
291 (,) <$> expression expr1 <*> expression expr2
294-- VALIDATE PATTERNS
296validatePattern :: Pattern.RawPattern -> Result.Result wrn Error.Error Pattern.RawPattern
297validatePattern pattern =
298 do detectDuplicates Error.BadPattern (Pattern.boundVars pattern)
299 return pattern
302-- DETECT DUPLICATES
304detectDuplicates
305 :: (String -> Error.Error)
306 -> [A.Located String]
307 -> Result.Result wrn Error.Error ()
308detectDuplicates tag names =
309 let add (A.A region name) dict =
310 Map.insertWith (++) name [region] dict
312 makeGroups pairs =
313 Map.toList (foldr add Map.empty pairs)
315 check (name, regions) =
316 case regions of
317 _ : region : _ ->
318 Result.throw region (tag name)
320 _ ->
321 return ()
322 in
323 F.traverse_ check (makeGroups names)
326defDuplicates
327 :: [Pattern.RawPattern]
328 -> Result.Result wrn Error.Error ()
329defDuplicates patterns =
330 concatMap Pattern.boundVars patterns
331 |> detectDuplicates Error.DuplicateDefinition
334declDuplicates :: [D.ValidDecl] -> Result.Result wrn Error.Error ()
335declDuplicates decls =
336 let (valueLists, typeLists) = unzip (map extractValues decls)
337 in
338 (\_ _ -> ())
339 <$> detectDuplicates Error.DuplicateValueDeclaration (concat valueLists)
340 <*> detectDuplicates Error.DuplicateTypeDeclaration (concat typeLists)
343extractValues :: D.ValidDecl -> ([A.Located String], [A.Located String])
344extractValues (A.A (region, _) decl) =
345 case decl of
346 D.Definition (Valid.Definition pattern _ _) ->
347 ( Pattern.boundVars pattern
348 , []
349 )
351 D.Datatype name _ ctors ->
352 ( map (A.A region . fst) ctors
353 , [A.A region name]
354 )
356 D.TypeAlias name _ (A.A _ (Type.RRecord _ _)) ->
357 ( [A.A region name]
358 , [A.A region name]
359 )
361 D.TypeAlias name _ _ ->
362 ( []
363 , [A.A region name]
364 )
366 D.Port port ->
367 ( [A.A region (D.validPortName port)]
368 , []
369 )
371 D.Fixity _ _ _ ->
372 ( []
373 , []
374 )
377-- UNBOUND TYPE VARIABLES
379checkDecl :: Bool -> D.ValidDecl -> Result.Result wrn Error.Error ()
380checkDecl isRoot (A.A (region,_) decl) =
381 case decl of
382 D.Definition _ ->
383 return ()
385 D.Datatype name boundVars ctors ->
386 let frees = concatMap freeVars (concatMap snd ctors)
387 in
388 case findUnbound boundVars frees of
389 [] ->
390 return ()
392 unbound ->
393 let
394 (v:vs) = Set.toList (Set.fromList unbound)
395 in
396 Result.throw region
397 (Error.UnboundTypeVarsInUnion name boundVars v vs ctors)
399 D.TypeAlias name boundVars tipe ->
400 case findUnbound boundVars (freeVars tipe) of
401 [] ->
402 return ()
404 unbound ->
405 let
406 (v:vs) = Set.toList (Set.fromList unbound)
407 in
408 Result.throw region
409 (Error.UnboundTypeVarsInAlias name boundVars v vs tipe)
411 D.Port _ ->
412 if isRoot
413 then return ()
414 else Result.throw region Error.UnexpectedPort
416 D.Fixity _ _ _ ->
417 return ()
420findUnbound :: [String] -> [A.Located String] -> [String]
421findUnbound boundVars frees =
422 let bounds = Set.fromList boundVars
424 isUnbound x =
425 Set.notMember x bounds
426 in
427 filter isUnbound (map A.drop frees)
431freeVars :: Type.Raw -> [A.Located String]
432freeVars (A.A region tipe) =
433 case tipe of
434 Type.RLambda t1 t2 ->
435 freeVars t1 ++ freeVars t2
437 Type.RVar x ->
438 [A.A region x]
440 Type.RType _ ->
441 []
443 Type.RApp t ts ->
444 concatMap freeVars (t:ts)
446 Type.RRecord fields ext ->
447 maybe [] freeVars ext
448 ++ concatMap (freeVars . snd) fields