git.iko.soy/elk
on a950bc5 help sign in
elk/src/Validate.hs
431 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 Nothing sourceDecls
31 (\_ _ -> validDecls)
32 <$> declDuplicates validDecls
33 <*> T.traverse (checkDecl isRoot) validDecls
36validateDecls
37 :: Maybe String
38 -> [D.SourceDecl]
39 -> Result.Result wrn Error.Error [D.ValidDecl]
40validateDecls maybeComment sourceDecls =
41 case sourceDecls of
42 [] ->
43 return []
45 sourceDecl : decls ->
46 case sourceDecl of
47 D.Comment comment ->
48 validateDecls (Just comment) decls
50 D.Decl decl ->
51 validateDeclsHelp maybeComment decl decls
54validateDeclsHelp
55 :: Maybe String
56 -> A.Located D.SourceDecl'
57 -> [D.SourceDecl]
58 -> Result.Result wrn Error.Error [D.ValidDecl]
59validateDeclsHelp comment (A.A region decl) decls =
60 let addRest validDecl =
61 (:) (A.A (region, comment) validDecl)
62 <$> validateDecls Nothing decls
63 in
64 case decl of
65 D.Datatype name tvars ctors ->
66 addRest (D.Datatype name tvars ctors)
68 D.TypeAlias name tvars alias ->
69 addRest (D.TypeAlias name tvars alias)
71 D.Fixity assoc prec op ->
72 addRest (D.Fixity assoc prec op)
74 D.Definition def ->
75 defHelp comment def decls
77 D.Port port ->
78 portHelp comment region port decls
81-- 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' <- Validate.expression expr
96 let def' = Valid.Definition pat expr' Nothing
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' <- Validate.expression expr
105 let def' = Valid.Definition pat expr' (Just tipe)
106 addRest def' rest
108 _ ->
109 Result.throw region (Error.TypeWithoutDefinition name)
112-- VALIDATE PORTS IN DECLARATIONS
114portHelp
115 :: Maybe String
116 -> R.Region
117 -> D.SourcePort
118 -> [D.SourceDecl]
119 -> Result.Result wrn Error.Error [D.ValidDecl]
120portHelp comment region port decls =
121 let addRest port' rest =
122 (:) (A.A (region,comment) (D.Port port'))
123 <$> validateDecls Nothing rest
124 in
125 case port of
126 D.PortDefinition name _ ->
127 Result.throw region (Error.PortWithoutAnnotation name)
129 D.PortAnnotation name tipe ->
130 case decls of
131 D.Decl (A.A _ (D.Port (D.PortDefinition name' expr))) : rest
132 | name == name' ->
133 do expr' <- Validate.expression expr
134 let port' = D.Out name expr' tipe
135 addRest port' rest
137 _ ->
138 addRest (D.In name tipe) decls
141-- VALIDATE DEFINITIONS
143definitions :: [Source.Def] -> Result.Result wrn Error.Error [Valid.Def]
144definitions sourceDefs =
145 do validDefs <- definitionsHelp sourceDefs
146 let patterns = map (\(Valid.Definition p _ _) -> p) validDefs
147 defDuplicates patterns
148 return validDefs
151definitionsHelp :: [Source.Def] -> Result.Result wrn Error.Error [Valid.Def]
152definitionsHelp sourceDefs =
153 case sourceDefs of
154 [] ->
155 return []
157 A.A _ (Source.Definition pat expr) : rest ->
158 do expr' <- expression expr
159 let def = Valid.Definition pat expr' Nothing
160 (:) def <$> definitionsHelp rest
162 A.A region (Source.TypeAnnotation name tipe) : rest ->
163 case rest of
164 A.A _ (Source.Definition pat@(A.A _ (Pattern.Var name')) expr) : rest'
165 | name == name' ->
166 do expr' <- expression expr
167 let def = Valid.Definition pat expr' (Just tipe)
168 (:) def <$> definitionsHelp rest'
170 _ ->
171 Result.throw region (Error.TypeWithoutDefinition name)
174-- VALIDATE EXPRESSIONS
176expression :: Source.Expr -> Result.Result wrn Error.Error Valid.Expr
177expression (A.A ann sourceExpression) =
178 A.A ann <$>
179 case sourceExpression of
180 Var x ->
181 return (Var x)
183 Lambda pattern body ->
184 Lambda pattern <$> 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 second 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 MultiIf branches finally ->
217 MultiIf
218 <$> T.traverse both branches
219 <*> expression finally
221 Access record field ->
222 Access
223 <$> expression record
224 <*> return field
226 Remove record field ->
227 Remove
228 <$> expression record
229 <*> return field
231 Insert record field expr ->
232 Insert
233 <$> expression record
234 <*> return field
235 <*> expression expr
237 Modify record fields ->
238 Modify
239 <$> expression record
240 <*> T.traverse second fields
242 Record fields ->
243 Record
244 <$> T.traverse second fields
246 Let defs body ->
247 Let
248 <$> definitions defs
249 <*> expression body
251 GLShader uid src gltipe ->
252 return (GLShader uid src gltipe)
254 Port impl ->
255 Port <$>
256 case impl of
257 In name tipe ->
258 return (In name tipe)
260 Out name expr tipe ->
261 do expr' <- expression expr
262 return (Out name expr' tipe)
264 Task name expr tipe ->
265 do expr' <- expression expr
266 return (Task name expr' tipe)
268 Crash details ->
269 return (Crash details)
272second :: (a, Source.Expr) -> Result.Result wrn Error.Error (a, Valid.Expr)
273second (value, expr) =
274 (,) value <$> expression expr
277both
278 :: (Source.Expr, Source.Expr)
279 -> Result.Result wrn Error.Error (Valid.Expr, Valid.Expr)
280both (expr1, expr2) =
281 (,) <$> expression expr1 <*> expression expr2
284-- DETECT DUPLICATES
286detectDuplicates
287 :: (String -> Error.Error)
288 -> [A.Located String]
289 -> Result.Result wrn Error.Error ()
290detectDuplicates tag names =
291 let add (A.A region name) dict =
292 Map.insertWith (++) name [region] dict
294 makeGroups pairs =
295 Map.toList (foldr add Map.empty pairs)
297 check (name, regions) =
298 case regions of
299 _ : region : _ ->
300 Result.throw region (tag name)
302 _ ->
303 return ()
304 in
305 F.traverse_ check (makeGroups names)
308defDuplicates
309 :: [Pattern.RawPattern]
310 -> Result.Result wrn Error.Error ()
311defDuplicates patterns =
312 concatMap Pattern.boundVars patterns
313 |> detectDuplicates Error.DuplicateDefinition
316declDuplicates :: [D.ValidDecl] -> Result.Result wrn Error.Error ()
317declDuplicates decls =
318 let (valueLists, typeLists) = unzip (map extractValues decls)
319 in
320 (\_ _ -> ())
321 <$> detectDuplicates Error.DuplicateValueDeclaration (concat valueLists)
322 <*> detectDuplicates Error.DuplicateTypeDeclaration (concat typeLists)
325extractValues :: D.ValidDecl -> ([A.Located String], [A.Located String])
326extractValues (A.A (region, _) decl) =
327 case decl of
328 D.Definition (Valid.Definition pattern _ _) ->
329 ( Pattern.boundVars pattern
330 , []
331 )
333 D.Datatype name _ ctors ->
334 ( map (A.A region . fst) ctors
335 , [A.A region name]
336 )
338 D.TypeAlias name _ (A.A _ (Type.RRecord _ _)) ->
339 ( [A.A region name]
340 , [A.A region name]
341 )
343 D.TypeAlias name _ _ ->
344 ( []
345 , [A.A region name]
346 )
348 D.Port port ->
349 ( [A.A region (D.validPortName port)]
350 , []
351 )
353 D.Fixity _ _ _ ->
354 ( []
355 , []
356 )
359-- UNBOUND TYPE VARIABLES
361checkDecl :: Bool -> D.ValidDecl -> Result.Result wrn Error.Error ()
362checkDecl isRoot (A.A (region,_) decl) =
363 case decl of
364 D.Definition _ ->
365 return ()
367 D.Datatype name boundVars ctors ->
368 let frees = concatMap freeVars (concatMap snd ctors)
369 in
370 case findUnbound boundVars frees of
371 [] ->
372 return ()
374 unbound ->
375 let
376 (v:vs) = Set.toList (Set.fromList unbound)
377 in
378 Result.throw region
379 (Error.UnboundTypeVarsInUnion name boundVars v vs ctors)
381 D.TypeAlias name boundVars tipe ->
382 case findUnbound boundVars (freeVars tipe) of
383 [] ->
384 return ()
386 unbound ->
387 let
388 (v:vs) = Set.toList (Set.fromList unbound)
389 in
390 Result.throw region
391 (Error.UnboundTypeVarsInAlias name boundVars v vs tipe)
393 D.Port _ ->
394 if isRoot
395 then return ()
396 else Result.throw region Error.UnexpectedPort
398 D.Fixity _ _ _ ->
399 return ()
402findUnbound :: [String] -> [A.Located String] -> [String]
403findUnbound boundVars frees =
404 let bounds = Set.fromList boundVars
406 isUnbound x =
407 Set.notMember x bounds
408 in
409 filter isUnbound (map A.drop frees)
413freeVars :: Type.Raw -> [A.Located String]
414freeVars (A.A region tipe) =
415 case tipe of
416 Type.RLambda t1 t2 ->
417 freeVars t1 ++ freeVars t2
419 Type.RVar x ->
420 [A.A region x]
422 Type.RType _ ->
423 []
425 Type.RApp t ts ->
426 concatMap freeVars (t:ts)
428 Type.RRecord fields ext ->
429 maybe [] freeVars ext
430 ++ concatMap (freeVars . snd) fields