git.iko.soy/elk
on 32ff950 help sign in
elk/compiler/src/Validate.hs
334 lines 8.9 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Validate
4 ( validate
5 )
6 where
9import Control.Applicative (liftA2)
10import Control.Monad (forM_)
11import qualified Data.Map as Map
12import Data.Text (Text)
14import qualified AST.Source as Src
15import qualified AST.Valid as Valid
16import qualified Elm.Name as N
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
24-- VALIDATE
27type Result i w a =
28 Result.Result i w Error.Error a
31validate :: Src.Module [Src.Decl] -> Result i w Valid.Module
32validate (Src.Module header imports srcDecls) =
33 do (Stuff decls unions aliases binops ports docs) <- validateDecls srcDecls
34 case header of
35 Nothing ->
36 return $ Valid.defaultModule docs imports decls unions aliases binops
38 Just (Src.Header name srcEffects exports overview) ->
39 do effects <- validateEffects srcEffects ports
40 return $ Valid.Module name overview docs exports imports decls unions aliases binops effects
44-- VALIDATE DECLARATIONS
47data Stuff =
48 Stuff
49 { _decls :: [A.Located Valid.Decl]
50 , _unions :: [Valid.Union]
51 , _aliases :: [Valid.Alias]
52 , _binops :: [Valid.Binop]
53 , _ports :: [Valid.Port]
54 , _docs :: Map.Map N.Name Text
55 }
58validateDecls :: [Src.Decl] -> Result i w Stuff
59validateDecls decls =
60 vsdHelp decls (Stuff [] [] [] [] [] Map.empty)
63vsdHelp :: [Src.Decl] -> Stuff -> Result i w Stuff
64vsdHelp decls stuff =
65 case decls of
66 [] ->
67 Result.ok stuff
69 A.At region decl : otherDecls ->
70 case decl of
71 Src.Union name tvars ctors ->
72 do let union = Valid.Union region name tvars ctors
73 vsdHelp otherDecls $ stuff { _unions = union : _unions stuff }
75 Src.Alias name tvars tipe ->
76 do let alias = Valid.Alias region name tvars tipe
77 vsdHelp otherDecls $ stuff { _aliases = alias : _aliases stuff }
79 Src.Binop op assoc prec val ->
80 do let binop = Valid.Binop op assoc prec val
81 vsdHelp otherDecls $ stuff { _binops = binop : _binops stuff }
83 Src.Port name tipe ->
84 do let port_ = Valid.Port name tipe
85 vsdHelp otherDecls $ stuff { _ports = port_ : _ports stuff }
87 Src.Docs docs ->
88 validateDocs region docs otherDecls stuff
90 Src.Annotation (A.At _ name) tipe ->
91 validateAnnotation region name tipe otherDecls stuff
93 Src.Definition name args body ->
94 do validBody <- expression body
95 let validDecl = A.At region (Valid.Decl name args validBody Nothing)
96 vsdHelp otherDecls $ stuff { _decls = validDecl : _decls stuff }
100-- VALIDATE DOCS
103validateDocs :: R.Region -> Text -> [Src.Decl] -> Stuff -> Result i w Stuff
104validateDocs region docs decls stuff =
105 case decls of
106 [] ->
107 Result.throw (Error.CommentOnNothing region)
109 A.At _ decl : _ ->
110 do name <- getNameForDocs region decl
111 vsdHelp decls $ stuff { _docs = Map.insert name docs (_docs stuff) }
114getNameForDocs :: R.Region -> Src.Decl_ -> Result i w N.Name
115getNameForDocs region decl =
116 case decl of
117 Src.Union (A.At _ name) _ _ ->
118 Result.ok name
120 Src.Alias (A.At _ name) _ _ ->
121 Result.ok name
123 Src.Binop name _ _ _ ->
124 Result.ok name
126 Src.Port (A.At _ name) _ ->
127 Result.ok name
129 Src.Docs _ ->
130 Result.throw (Error.CommentOnNothing region)
132 Src.Annotation (A.At _ name) _ ->
133 Result.ok name
135 Src.Definition (A.At _ name) _ _ ->
136 Result.ok name
140-- VALIDATE ANNOTATION
143validateAnnotation :: R.Region -> N.Name -> Src.Type -> [Src.Decl] -> Stuff -> Result i w Stuff
144validateAnnotation annRegion annotationName tipe decls stuff =
145 case decls of
146 [] ->
147 Result.throw (Error.TypeWithoutDefinition annRegion annotationName)
149 A.At defRegion decl : otherDecls ->
150 case decl of
151 Src.Definition name@(A.At _ definitionName) args body ->
152 if annotationName == definitionName then
153 do validBody <- expression body
154 let region = R.merge annRegion defRegion
155 let validDecl = A.At region (Valid.Decl name args validBody (Just tipe))
156 vsdHelp otherDecls $ stuff { _decls = validDecl : _decls stuff }
158 else
159 Result.throw (Error.TypeWithBadDefinition annRegion annotationName definitionName)
161 _ ->
162 Result.throw (Error.TypeWithoutDefinition annRegion annotationName)
166-- VALIDATE EXPRESSIONS
169expression :: Src.Expr -> Result i w Valid.Expr
170expression (A.At region sourceExpression) =
171 A.At region <$>
172 case sourceExpression of
173 Src.Var varType name ->
174 pure (Valid.Var varType name)
176 Src.VarQual varType home name ->
177 pure (Valid.VarQual varType home name)
179 Src.Lambda pattern body ->
180 Valid.Lambda pattern <$> expression body
182 Src.Op name ->
183 pure (Valid.Op name)
185 Src.Negate expr ->
186 Valid.Negate <$> expression expr
188 Src.Binops ops lastExpr ->
189 Valid.Binops
190 <$> traverse (\(expr,op) -> (,) <$> expression expr <*> pure op) ops
191 <*> expression lastExpr
193 Src.Case expr branches ->
194 Valid.Case
195 <$> expression expr
196 <*> traverse (traverse expression) branches
198 Src.Str str ->
199 pure (Valid.Str str)
201 Src.Chr chr ->
202 pure (Valid.Chr chr)
204 Src.Int int ->
205 pure (Valid.Int int)
207 Src.Float float ->
208 pure (Valid.Float float)
210 Src.List exprs ->
211 Valid.List <$> traverse expression exprs
213 Src.Call func args ->
214 Valid.Call
215 <$> expression func
216 <*> traverse expression args
218 Src.If branches finally ->
219 Valid.If
220 <$> traverse both branches
221 <*> expression finally
223 Src.Accessor field ->
224 pure (Valid.Accessor field)
226 Src.Access record field ->
227 Valid.Access
228 <$> expression record
229 <*> pure field
231 Src.Update record fields ->
232 Valid.Update record <$> traverse (traverse expression) fields
234 Src.Record fields ->
235 Valid.Record <$> traverse (traverse expression) fields
237 Src.Unit ->
238 pure Valid.Unit
240 Src.Tuple a b cs ->
241 Valid.Tuple
242 <$> expression a
243 <*> expression b
244 <*> traverse expression cs
246 Src.Let defs body ->
247 Valid.Let
248 <$> definitions defs
249 <*> expression body
251 Src.Shader uid src gltipe ->
252 pure (Valid.Shader uid src gltipe)
255both :: (Src.Expr, Src.Expr) -> Result i w (Valid.Expr, Valid.Expr)
256both (a, b) =
257 liftA2 (,) (expression a) (expression b)
261-- VALIDATE DEFINITIONS
264definitions :: [A.Located Src.Def] -> Result i w [Valid.Def]
265definitions sourceDefs =
266 case sourceDefs of
267 [] ->
268 return []
270 A.At region (Src.Destruct pattern expr) : otherDefs ->
271 (:)
272 <$> validateDestruct region pattern expr
273 <*> definitions otherDefs
275 A.At region (Src.Define name args expr) : otherDefs ->
276 (:)
277 <$> validateDefinition region name args expr Nothing
278 <*> definitions otherDefs
280 A.At annRegion (Src.Annotate annotationName tipe) : otherDefs ->
281 case otherDefs of
282 A.At defRegion (Src.Define name@(A.At _ definitionName) args expr) : otherOtherDefs
283 | definitionName == annotationName ->
284 (:)
285 <$> validateDefinition (R.merge annRegion defRegion) name args expr (Just tipe)
286 <*> definitions otherOtherDefs
288 _ ->
289 Result.throw (Error.TypeWithoutDefinition annRegion annotationName)
292validateDefinition :: R.Region -> A.Located N.Name -> [Src.Pattern] -> Src.Expr -> Maybe Src.Type -> Result i w Valid.Def
293validateDefinition region name args expr maybeType =
294 do validExpr <- expression expr
295 return $ Valid.Define region name args validExpr maybeType
298validateDestruct :: R.Region -> Src.Pattern -> Src.Expr -> Result i w Valid.Def
299validateDestruct region pattern expr =
300 Valid.Destruct region pattern <$> expression expr
304-- VALIDATE EFFECTS
307validateEffects :: Src.Effects -> [Valid.Port] -> Result i w Valid.Effects
308validateEffects effects ports =
309 case effects of
310 Src.NoEffects ->
311 do noPorts ports
312 return Valid.NoEffects
314 Src.Ports _ ->
315 return (Valid.Ports ports)
317 Src.Manager region manager ->
318 do noPorts ports
319 return $ Valid.Manager region $
320 case manager of
321 Src.Cmd cmd ->
322 Valid.Cmd cmd
324 Src.Sub sub ->
325 Valid.Sub sub
327 Src.Fx cmd sub ->
328 Valid.Fx cmd sub
331noPorts :: [Valid.Port] -> Result i w ()
332noPorts ports =
333 forM_ ports $ \(Valid.Port (A.At region name) _) ->
334 Result.throw (Error.UnexpectedPort region name)