git.iko.soy/elk
on 2c8bd43 help sign in
elk/src/Validate.hs
404 lines 10 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.Result as Result
23-- VALIDATE DECLARATIONS
25declarations
26 :: [D.SourceDecl]
27 -> Result.Result 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 -> Result.Result 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 -> Result.Result 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 -> Result.Result 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 Result.throw region (Error.TypeWithoutDefinition name)
100-- VALIDATE PORTS IN DECLARATIONS
102portHelp
103 :: R.Region
104 -> D.SourcePort
105 -> [D.SourceDecl]
106 -> Result.Result 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 Result.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] -> Result.Result 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] -> Result.Result 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 Result.throw region (Error.TypeWithoutDefinition name)
160-- VALIDATE EXPRESSIONS
162expression :: Source.Expr -> Result.Result 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) -> Result.Result wrn Error.Error (a, Valid.Expr)
254second (value, expr) =
255 (,) value <$> expression expr
258both
259 :: (Source.Expr, Source.Expr)
260 -> Result.Result 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 -> Result.Result 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 Result.throw region (tag name)
283 _ ->
284 return ()
285 in
286 F.traverse_ check (makeGroups names)
289defDuplicates
290 :: [Pattern.RawPattern]
291 -> Result.Result wrn Error.Error ()
292defDuplicates patterns =
293 concatMap Pattern.boundVars patterns
294 |> detectDuplicates Error.DuplicateDefinition
297declDuplicates :: [D.ValidDecl] -> Result.Result 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 -> Result.Result wrn Error.Error ()
343checkDecl (A.A region decl) =
344 case decl of
345 D.Definition _ ->
346 return ()
348 D.Datatype name boundVars ctors ->
349 let frees = concatMap freeVars (concatMap snd ctors)
350 in
351 case findUnbound boundVars frees of
352 [] ->
353 return ()
355 v:vs ->
356 Result.throw region
357 (Error.UnboundTypeVarsInUnion name boundVars v vs ctors)
359 D.TypeAlias name boundVars tipe ->
360 case findUnbound boundVars (freeVars tipe) of
361 [] ->
362 return ()
364 v:vs ->
365 Result.throw region
366 (Error.UnboundTypeVarsInAlias name boundVars v vs tipe)
368 D.Port _ ->
369 return ()
371 D.Fixity _ _ _ ->
372 return ()
375findUnbound :: [String] -> [A.Located String] -> [String]
376findUnbound boundVars frees =
377 let bounds = Set.fromList boundVars
379 isUnbound x =
380 Set.notMember x bounds
381 in
382 filter isUnbound (map A.drop frees)
386freeVars :: Type.Raw -> [A.Located String]
387freeVars (A.A region tipe) =
388 case tipe of
389 Type.RLambda t1 t2 ->
390 freeVars t1 ++ freeVars t2
392 Type.RVar x ->
393 [A.A region x]
395 Type.RType _ ->
396 []
398 Type.RApp t ts ->
399 concatMap freeVars (t:ts)
401 Type.RRecord fields ext ->
402 maybe [] freeVars ext
403 ++ concatMap (freeVars . snd) fields