git.iko.soy/elk
on 357dedf help sign in
elk/src/Validate.hs
391 lines 9.9 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module Validate (declarations) where
4import Control.Applicative ((<$>),(<*>))
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
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.Task as Task
23-- VALIDATE DECLARATIONS
25declarations
26 :: [D.SourceDecl]
27 -> Task.Task wrn Error.Error [D.ValidDecl]
28declarations sourceDecls =
29 do validDecls <- validateDecls sourceDecls
30 (\_ _ -> validDecls)
31 <$> declDuplicates validDecls
32 <*> T.traverse checkDecl validDecls
35validateDecls
36 :: [D.SourceDecl]
37 -> Task.Task wrn Error.Error [D.ValidDecl]
38validateDecls sourceDecls =
39 case sourceDecls of
40 [] ->
41 return []
43 decl : decls ->
44 validateDeclsHelp decl decls
47validateDeclsHelp
48 :: D.SourceDecl
49 -> [D.SourceDecl]
50 -> Task.Task wrn Error.Error [D.ValidDecl]
51validateDeclsHelp (A.A region decl) decls =
52 let addRest validDecl =
53 (:) (A.A region validDecl) <$> validateDecls decls
54 in
55 case decl of
56 D.Datatype name tvars ctors ->
57 addRest (D.Datatype name tvars ctors)
59 D.TypeAlias name tvars alias ->
60 addRest (D.TypeAlias name tvars alias)
62 D.Fixity assoc prec op ->
63 addRest (D.Fixity assoc prec op)
65 D.Definition def ->
66 defHelp def decls
68 D.Port port ->
69 portHelp region port decls
72-- VALIDATE DEFINITIONS IN DECLARATIONS
74defHelp
75 :: Source.Def
76 -> [D.SourceDecl]
77 -> Task.Task wrn Error.Error [D.ValidDecl]
78defHelp (A.A region def) decls =
79 let addRest def' rest =
80 (:) (A.A region (D.Definition def')) <$> validateDecls rest
81 in
82 case def of
83 Source.Definition pat expr ->
84 do expr' <- Validate.expression expr
85 let def' = Valid.Definition pat expr' Nothing
86 addRest def' decls
88 Source.TypeAnnotation name tipe ->
89 case decls of
90 A.A _ (D.Definition (A.A _ (Source.Definition pat@(A.A _ (Pattern.Var name')) expr))) : rest
91 | name == name' ->
92 do expr' <- Validate.expression expr
93 let def' = Valid.Definition pat expr' (Just tipe)
94 addRest def' rest
96 _ ->
97 Task.throw region (Error.TypeWithoutDefinition name)
100-- VALIDATE PORTS IN DECLARATIONS
102portHelp
103 :: R.Region
104 -> D.SourcePort
105 -> [D.SourceDecl]
106 -> Task.Task wrn Error.Error [D.ValidDecl]
107portHelp region port decls =
108 let addRest port' rest =
109 (:) (A.A region (D.Port port')) <$> validateDecls rest
110 in
111 case port of
112 D.PortDefinition name _ ->
113 Task.throw region (Error.PortWithoutAnnotation name)
115 D.PortAnnotation name tipe ->
116 case decls of
117 A.A _ (D.Port (D.PortDefinition name' expr)) : rest
118 | name == name' ->
119 do expr' <- Validate.expression expr
120 let port' = D.Out name expr' tipe
121 addRest port' rest
123 _ ->
124 addRest (D.In name tipe) decls
127-- VALIDATE DEFINITIONS
129definitions :: [Source.Def] -> Task.Task wrn Error.Error [Valid.Def]
130definitions sourceDefs =
131 do validDefs <- definitionsHelp sourceDefs
132 let patterns = map (\(Valid.Definition p _ _) -> p) validDefs
133 defDuplicates patterns
134 return validDefs
137definitionsHelp :: [Source.Def] -> Task.Task wrn Error.Error [Valid.Def]
138definitionsHelp sourceDefs =
139 case sourceDefs of
140 [] ->
141 return []
143 A.A _ (Source.Definition pat expr) : rest ->
144 do expr' <- expression expr
145 let def = Valid.Definition pat expr' Nothing
146 (:) def <$> definitionsHelp rest
148 A.A region (Source.TypeAnnotation name tipe) : rest ->
149 case rest of
150 A.A _ (Source.Definition pat@(A.A _ (Pattern.Var name')) expr) : rest'
151 | name == name' ->
152 do expr' <- expression expr
153 let def = Valid.Definition pat expr' (Just tipe)
154 (:) def <$> definitionsHelp rest'
156 _ ->
157 Task.throw region (Error.TypeWithoutDefinition name)
160-- VALIDATE EXPRESSIONS
162expression :: Source.Expr -> Task.Task wrn Error.Error Valid.Expr
163expression (A.A ann sourceExpression) =
164 A.A ann <$>
165 case sourceExpression of
166 Var x ->
167 return (Var x)
169 Lambda pattern body ->
170 Lambda pattern <$> expression body
172 Binop op leftExpr rightExpr ->
173 Binop op
174 <$> expression leftExpr
175 <*> expression rightExpr
177 Case e branches ->
178 Case
179 <$> expression e
180 <*> T.traverse second branches
182 Data name args ->
183 Data name <$> T.traverse expression args
185 Literal lit ->
186 return (Literal lit)
188 Range lowExpr highExpr ->
189 Range
190 <$> expression lowExpr
191 <*> expression highExpr
193 ExplicitList expressions ->
194 ExplicitList
195 <$> T.traverse expression expressions
197 App funcExpr argExpr ->
198 App
199 <$> expression funcExpr
200 <*> expression argExpr
202 MultiIf branches ->
203 MultiIf <$> T.traverse both branches
205 Access record field ->
206 Access
207 <$> expression record
208 <*> return field
210 Remove record field ->
211 Remove
212 <$> expression record
213 <*> return field
215 Insert record field expr ->
216 Insert
217 <$> expression record
218 <*> return field
219 <*> expression expr
221 Modify record fields ->
222 Modify
223 <$> expression record
224 <*> T.traverse second fields
226 Record fields ->
227 Record
228 <$> T.traverse second fields
230 Let defs body ->
231 Let
232 <$> definitions defs
233 <*> expression body
235 GLShader uid src gltipe ->
236 return (GLShader uid src gltipe)
238 Port impl ->
239 Port <$>
240 case impl of
241 In name tipe ->
242 return (In name tipe)
244 Out name expr tipe ->
245 do expr' <- expression expr
246 return (Out name expr' tipe)
248 Task name expr tipe ->
249 do expr' <- expression expr
250 return (Task name expr' tipe)
253second :: (a, Source.Expr) -> Task.Task wrn Error.Error (a, Valid.Expr)
254second (value, expr) =
255 (,) value <$> expression expr
258both
259 :: (Source.Expr, Source.Expr)
260 -> Task.Task wrn Error.Error (Valid.Expr, Valid.Expr)
261both (expr1, expr2) =
262 (,) <$> expression expr1 <*> expression expr2
265-- DETECT DUPLICATES
267detectDuplicates
268 :: (String -> Error.Error)
269 -> [A.Located String]
270 -> Task.Task wrn Error.Error ()
271detectDuplicates tag names =
272 let add (A.A region name) dict =
273 Map.insertWith (++) name [region] dict
275 makeGroups pairs =
276 Map.toList (foldr add Map.empty pairs)
278 check (name, regions) =
279 case regions of
280 _ : region : _ ->
281 Task.throw region (tag name)
283 _ ->
284 return ()
285 in
286 F.traverse_ check (makeGroups names)
289defDuplicates
290 :: [Pattern.RawPattern]
291 -> Task.Task wrn Error.Error ()
292defDuplicates patterns =
293 concatMap Pattern.boundVars patterns
294 |> detectDuplicates Error.DuplicateDefinition
297declDuplicates :: [D.ValidDecl] -> Task.Task wrn Error.Error ()
298declDuplicates decls =
299 let (valueLists, typeLists) = unzip (map extractValues decls)
300 in
301 (\_ _ -> ())
302 <$> detectDuplicates Error.DuplicateValueDeclaration (concat valueLists)
303 <*> detectDuplicates Error.DuplicateTypeDeclaration (concat typeLists)
306extractValues :: D.ValidDecl -> ([A.Located String], [A.Located String])
307extractValues (A.A region decl) =
308 case decl of
309 D.Definition (Valid.Definition pattern _ _) ->
310 ( Pattern.boundVars pattern
311 , []
312 )
314 D.Datatype name _ ctors ->
315 ( map (A.A region . fst) ctors
316 , [A.A region name]
317 )
319 D.TypeAlias name _ (A.A _ (Type.RRecord _ _)) ->
320 ( [A.A region name]
321 , [A.A region name]
322 )
324 D.TypeAlias name _ _ ->
325 ( []
326 , [A.A region name]
327 )
329 D.Port port ->
330 ( [A.A region (D.validPortName port)]
331 , []
332 )
334 D.Fixity _ _ _ ->
335 ( []
336 , []
337 )
340-- UNBOUND TYPE VARIABLES
342checkDecl :: D.ValidDecl -> Task.Task wrn Error.Error ()
343checkDecl (A.A _ decl) =
344 case decl of
345 D.Definition _ ->
346 return ()
348 D.Datatype name boundVars ctors ->
349 F.traverse_ (checkTypeVars name boundVars) (concatMap snd ctors)
351 D.TypeAlias name boundVars tipe ->
352 checkTypeVars name boundVars tipe
354 D.Port _ ->
355 return ()
357 D.Fixity _ _ _ ->
358 return ()
361checkTypeVars :: String -> [String] -> Type.Raw -> Task.Task wrn Error.Error ()
362checkTypeVars name boundVars tipe =
363 let bounds = Set.fromList boundVars
365 check (A.A region free) =
366 if Set.member free bounds
367 then return ()
368 else Task.throw region (Error.UnboundTypeVar name free)
369 in
370 F.traverse_ check (freeVars tipe)
373freeVars :: Type.Raw -> [A.Located String]
374freeVars (A.A region tipe) =
375 case tipe of
376 Type.RLambda t1 t2 ->
377 freeVars t1 ++ freeVars t2
379 Type.RVar x ->
380 [A.A region x]
382 Type.RType _ ->
383 []
385 Type.RApp t ts ->
386 concatMap freeVars (t:ts)
388 Type.RRecord fields ext ->
389 maybe [] freeVars ext
390 ++ concatMap (freeVars . snd) fields