git.iko.soy/elk
on df0fb5d help sign in
elk/src/Validate.hs
413 lines 11 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 :: Bool
27 -> [D.SourceDecl]
28 -> Result.Result wrn Error.Error [D.ValidDecl]
29declarations isRoot sourceDecls =
30 do validDecls <- validateDecls sourceDecls
31 (\_ _ -> validDecls)
32 <$> declDuplicates validDecls
33 <*> T.traverse (checkDecl isRoot) validDecls
36validateDecls
37 :: [D.SourceDecl]
38 -> Result.Result wrn Error.Error [D.ValidDecl]
39validateDecls sourceDecls =
40 case sourceDecls of
41 [] ->
42 return []
44 decl : decls ->
45 validateDeclsHelp decl decls
48validateDeclsHelp
49 :: D.SourceDecl
50 -> [D.SourceDecl]
51 -> Result.Result wrn Error.Error [D.ValidDecl]
52validateDeclsHelp (A.A region decl) decls =
53 let addRest validDecl =
54 (:) (A.A region validDecl) <$> validateDecls decls
55 in
56 case decl of
57 D.Datatype name tvars ctors ->
58 addRest (D.Datatype name tvars ctors)
60 D.TypeAlias name tvars alias ->
61 addRest (D.TypeAlias name tvars alias)
63 D.Fixity assoc prec op ->
64 addRest (D.Fixity assoc prec op)
66 D.Definition def ->
67 defHelp def decls
69 D.Port port ->
70 portHelp region port decls
73-- VALIDATE DEFINITIONS IN DECLARATIONS
75defHelp
76 :: Source.Def
77 -> [D.SourceDecl]
78 -> Result.Result wrn Error.Error [D.ValidDecl]
79defHelp (A.A region def) decls =
80 let addRest def' rest =
81 (:) (A.A region (D.Definition def')) <$> validateDecls rest
82 in
83 case def of
84 Source.Definition pat expr ->
85 do expr' <- Validate.expression expr
86 let def' = Valid.Definition pat expr' Nothing
87 addRest def' decls
89 Source.TypeAnnotation name tipe ->
90 case decls of
91 A.A _ (D.Definition (A.A _ (Source.Definition pat@(A.A _ (Pattern.Var name')) expr))) : rest
92 | name == name' ->
93 do expr' <- Validate.expression expr
94 let def' = Valid.Definition pat expr' (Just tipe)
95 addRest def' rest
97 _ ->
98 Result.throw region (Error.TypeWithoutDefinition name)
101-- VALIDATE PORTS IN DECLARATIONS
103portHelp
104 :: R.Region
105 -> D.SourcePort
106 -> [D.SourceDecl]
107 -> Result.Result wrn Error.Error [D.ValidDecl]
108portHelp region port decls =
109 let addRest port' rest =
110 (:) (A.A region (D.Port port')) <$> validateDecls rest
111 in
112 case port of
113 D.PortDefinition name _ ->
114 Result.throw region (Error.PortWithoutAnnotation name)
116 D.PortAnnotation name tipe ->
117 case decls of
118 A.A _ (D.Port (D.PortDefinition name' expr)) : rest
119 | name == name' ->
120 do expr' <- Validate.expression expr
121 let port' = D.Out name expr' tipe
122 addRest port' rest
124 _ ->
125 addRest (D.In name tipe) decls
128-- VALIDATE DEFINITIONS
130definitions :: [Source.Def] -> Result.Result wrn Error.Error [Valid.Def]
131definitions sourceDefs =
132 do validDefs <- definitionsHelp sourceDefs
133 let patterns = map (\(Valid.Definition p _ _) -> p) validDefs
134 defDuplicates patterns
135 return validDefs
138definitionsHelp :: [Source.Def] -> Result.Result wrn Error.Error [Valid.Def]
139definitionsHelp sourceDefs =
140 case sourceDefs of
141 [] ->
142 return []
144 A.A _ (Source.Definition pat expr) : rest ->
145 do expr' <- expression expr
146 let def = Valid.Definition pat expr' Nothing
147 (:) def <$> definitionsHelp rest
149 A.A region (Source.TypeAnnotation name tipe) : rest ->
150 case rest of
151 A.A _ (Source.Definition pat@(A.A _ (Pattern.Var name')) expr) : rest'
152 | name == name' ->
153 do expr' <- expression expr
154 let def = Valid.Definition pat expr' (Just tipe)
155 (:) def <$> definitionsHelp rest'
157 _ ->
158 Result.throw region (Error.TypeWithoutDefinition name)
161-- VALIDATE EXPRESSIONS
163expression :: Source.Expr -> Result.Result wrn Error.Error Valid.Expr
164expression (A.A ann sourceExpression) =
165 A.A ann <$>
166 case sourceExpression of
167 Var x ->
168 return (Var x)
170 Lambda pattern body ->
171 Lambda pattern <$> expression body
173 Binop op leftExpr rightExpr ->
174 Binop op
175 <$> expression leftExpr
176 <*> expression rightExpr
178 Case e branches ->
179 Case
180 <$> expression e
181 <*> T.traverse second branches
183 Data name args ->
184 Data name <$> T.traverse expression args
186 Literal lit ->
187 return (Literal lit)
189 Range lowExpr highExpr ->
190 Range
191 <$> expression lowExpr
192 <*> expression highExpr
194 ExplicitList expressions ->
195 ExplicitList
196 <$> T.traverse expression expressions
198 App funcExpr argExpr ->
199 App
200 <$> expression funcExpr
201 <*> expression argExpr
203 MultiIf branches ->
204 MultiIf <$> T.traverse both branches
206 Access record field ->
207 Access
208 <$> expression record
209 <*> return field
211 Remove record field ->
212 Remove
213 <$> expression record
214 <*> return field
216 Insert record field expr ->
217 Insert
218 <$> expression record
219 <*> return field
220 <*> expression expr
222 Modify record fields ->
223 Modify
224 <$> expression record
225 <*> T.traverse second fields
227 Record fields ->
228 Record
229 <$> T.traverse second fields
231 Let defs body ->
232 Let
233 <$> definitions defs
234 <*> expression body
236 GLShader uid src gltipe ->
237 return (GLShader uid src gltipe)
239 Port impl ->
240 Port <$>
241 case impl of
242 In name tipe ->
243 return (In name tipe)
245 Out name expr tipe ->
246 do expr' <- expression expr
247 return (Out name expr' tipe)
249 Task name expr tipe ->
250 do expr' <- expression expr
251 return (Task name expr' tipe)
254second :: (a, Source.Expr) -> Result.Result wrn Error.Error (a, Valid.Expr)
255second (value, expr) =
256 (,) value <$> expression expr
259both
260 :: (Source.Expr, Source.Expr)
261 -> Result.Result wrn Error.Error (Valid.Expr, Valid.Expr)
262both (expr1, expr2) =
263 (,) <$> expression expr1 <*> expression expr2
266-- DETECT DUPLICATES
268detectDuplicates
269 :: (String -> Error.Error)
270 -> [A.Located String]
271 -> Result.Result wrn Error.Error ()
272detectDuplicates tag names =
273 let add (A.A region name) dict =
274 Map.insertWith (++) name [region] dict
276 makeGroups pairs =
277 Map.toList (foldr add Map.empty pairs)
279 check (name, regions) =
280 case regions of
281 _ : region : _ ->
282 Result.throw region (tag name)
284 _ ->
285 return ()
286 in
287 F.traverse_ check (makeGroups names)
290defDuplicates
291 :: [Pattern.RawPattern]
292 -> Result.Result wrn Error.Error ()
293defDuplicates patterns =
294 concatMap Pattern.boundVars patterns
295 |> detectDuplicates Error.DuplicateDefinition
298declDuplicates :: [D.ValidDecl] -> Result.Result wrn Error.Error ()
299declDuplicates decls =
300 let (valueLists, typeLists) = unzip (map extractValues decls)
301 in
302 (\_ _ -> ())
303 <$> detectDuplicates Error.DuplicateValueDeclaration (concat valueLists)
304 <*> detectDuplicates Error.DuplicateTypeDeclaration (concat typeLists)
307extractValues :: D.ValidDecl -> ([A.Located String], [A.Located String])
308extractValues (A.A region decl) =
309 case decl of
310 D.Definition (Valid.Definition pattern _ _) ->
311 ( Pattern.boundVars pattern
312 , []
313 )
315 D.Datatype name _ ctors ->
316 ( map (A.A region . fst) ctors
317 , [A.A region name]
318 )
320 D.TypeAlias name _ (A.A _ (Type.RRecord _ _)) ->
321 ( [A.A region name]
322 , [A.A region name]
323 )
325 D.TypeAlias name _ _ ->
326 ( []
327 , [A.A region name]
328 )
330 D.Port port ->
331 ( [A.A region (D.validPortName port)]
332 , []
333 )
335 D.Fixity _ _ _ ->
336 ( []
337 , []
338 )
341-- UNBOUND TYPE VARIABLES
343checkDecl :: Bool -> D.ValidDecl -> Result.Result wrn Error.Error ()
344checkDecl isRoot (A.A region decl) =
345 case decl of
346 D.Definition _ ->
347 return ()
349 D.Datatype name boundVars ctors ->
350 let frees = concatMap freeVars (concatMap snd ctors)
351 in
352 case findUnbound boundVars frees of
353 [] ->
354 return ()
356 unbound ->
357 let
358 (v:vs) = Set.toList (Set.fromList unbound)
359 in
360 Result.throw region
361 (Error.UnboundTypeVarsInUnion name boundVars v vs ctors)
363 D.TypeAlias name boundVars tipe ->
364 case findUnbound boundVars (freeVars tipe) of
365 [] ->
366 return ()
368 unbound ->
369 let
370 (v:vs) = Set.toList (Set.fromList unbound)
371 in
372 Result.throw region
373 (Error.UnboundTypeVarsInAlias name boundVars v vs tipe)
375 D.Port _ ->
376 if isRoot
377 then return ()
378 else Result.throw region Error.UnexpectedPort
380 D.Fixity _ _ _ ->
381 return ()
384findUnbound :: [String] -> [A.Located String] -> [String]
385findUnbound boundVars frees =
386 let bounds = Set.fromList boundVars
388 isUnbound x =
389 Set.notMember x bounds
390 in
391 filter isUnbound (map A.drop frees)
395freeVars :: Type.Raw -> [A.Located String]
396freeVars (A.A region tipe) =
397 case tipe of
398 Type.RLambda t1 t2 ->
399 freeVars t1 ++ freeVars t2
401 Type.RVar x ->
402 [A.A region x]
404 Type.RType _ ->
405 []
407 Type.RApp t ts ->
408 concatMap freeVars (t:ts)
410 Type.RRecord fields ext ->
411 maybe [] freeVars ext
412 ++ concatMap (freeVars . snd) fields