git.iko.soy/elk
on 6aa367f help sign in
elk/src/Validate.hs
313 lines 8.2 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Validate (Result, validate) where
5import Control.Applicative (liftA2)
6import Control.Monad (forM_)
7import qualified Data.Map as Map
8import Data.Text (Text)
10import qualified AST.Expression.Source as Src
11import qualified AST.Expression.Valid as Valid
12import qualified AST.Pattern as Pattern
13import qualified AST.Type as Type
14import qualified Elm.Name as N
15import qualified Reporting.Annotation as A
16import qualified Reporting.Error.Syntax as Error
17import qualified Reporting.Region as R
18import qualified Reporting.Result as Result
23-- VALIDATE
26type Result warning a =
27 Result.Result () warning Error.Error a
30validate :: Src.Module [Src.Decl] -> Result w Valid.Module
31validate (Src.Module name srcEffects overview exports imports srcDecls) =
32 do (Stuff decls unions aliases binops ports docs) <- validateDecls srcDecls
33 effects <- validateEffects srcEffects ports
34 return $ Valid.Module name overview docs exports imports decls unions aliases binops effects
38-- VALIDATE DECLARATIONS
41data Stuff =
42 Stuff
43 { _decls :: [Valid.Decl]
44 , _unions :: [Valid.Union]
45 , _aliases :: [Valid.Alias]
46 , _binops :: [Valid.Binop]
47 , _ports :: [Valid.Port]
48 , _docs :: Map.Map N.Name Text
49 }
52validateDecls :: [Src.Decl] -> Result w Stuff
53validateDecls decls =
54 vsdHelp decls (Stuff [] [] [] [] [] Map.empty)
57vsdHelp :: [Src.Decl] -> Stuff -> Result w Stuff
58vsdHelp decls stuff =
59 case decls of
60 [] ->
61 Result.ok stuff
63 A.A _ decl : otherDecls ->
64 case decl of
65 Src.Union name tvars ctors ->
66 do let union = Valid.Union name tvars ctors
67 vsdHelp otherDecls $ stuff { _unions = union : _unions stuff }
69 Src.Alias name tvars tipe ->
70 do let alias = Valid.Alias name tvars tipe
71 vsdHelp otherDecls $ stuff { _aliases = alias : _aliases stuff }
73 Src.Binop op assoc prec val ->
74 do let binop = Valid.Binop op assoc prec val
75 vsdHelp otherDecls $ stuff { _binops = binop : _binops stuff }
77 Src.Port name tipe ->
78 do let port_ = Valid.Port name tipe
79 vsdHelp otherDecls $ stuff { _ports = port_ : _ports stuff }
81 Src.Docs docs ->
82 validateDocs docs otherDecls stuff
84 Src.Annotation (A.A _ name) tipe ->
85 validateAnnotation name tipe otherDecls stuff
87 Src.Definition name args body ->
88 do validBody <- expression body
89 let validDecl = Valid.Decl name args validBody Nothing
90 vsdHelp otherDecls $ stuff { _decls = validDecl : _decls stuff }
94-- VALIDATE DOCS
97validateDocs :: Text -> [Src.Decl] -> Stuff -> Result w Stuff
98validateDocs docs decls stuff =
99 case decls of
100 [] ->
101 error "TODO no docs on nothing"
103 A.A _ decl : _ ->
104 do name <- getNameForDocs decl
105 vsdHelp decls $ stuff { _docs = Map.insert name docs (_docs stuff) }
108getNameForDocs :: Src.Decl_ -> Result w N.Name
109getNameForDocs decl =
110 case decl of
111 Src.Union (A.A _ name) _ _ ->
112 return name
114 Src.Alias (A.A _ name) _ _ ->
115 return name
117 Src.Binop _ _ _ _ ->
118 error "TODO no docs on binop"
120 Src.Port _ _ ->
121 error "TODO no docs on ports"
123 Src.Docs _ ->
124 error "TODO no docs on docs"
126 Src.Annotation (A.A _ name) _ ->
127 return name
129 Src.Definition (A.A _ name) _ _ ->
130 return name
134-- VALIDATE ANNOTATION
137validateAnnotation :: N.Name -> Type.Raw -> [Src.Decl] -> Stuff -> Result w Stuff
138validateAnnotation annotationName tipe decls stuff =
139 case decls of
140 [] ->
141 error "TODO no attotations on nothing"
143 A.A _ decl : otherDecls ->
144 case decl of
145 Src.Definition name@(A.A _ definitionName) args body ->
146 if annotationName == definitionName then
147 do validBody <- expression body
148 let validDecl = Valid.Decl name args validBody (Just tipe)
149 vsdHelp otherDecls $ stuff { _decls = validDecl : _decls stuff }
151 else
152 error "TODO annotation does not match following definition"
154 _ ->
155 error "TODO annotation needs to be on a definition"
159-- VALIDATE EXPRESSIONS
162expression :: Src.Expr -> Result w Valid.Expr
163expression (A.A region sourceExpression) =
164 A.A region <$>
165 case sourceExpression of
166 Src.Var prefix name ->
167 pure (Valid.Var prefix name)
169 Src.Lambda pattern body ->
170 Valid.Lambda pattern <$> expression body
172 Src.Op name ->
173 pure (Valid.Op name)
175 Src.Negate expr ->
176 Valid.Negate <$> expression expr
178 Src.Binops ops lastExpr ->
179 Valid.Binops
180 <$> traverse (\(expr,op) -> (,) <$> expression expr <*> pure op) ops
181 <*> expression lastExpr
183 Src.Case expr branches ->
184 Valid.Case
185 <$> expression expr
186 <*> traverse (traverse expression) branches
188 Src.Literal lit ->
189 pure (Valid.Literal lit)
191 Src.List exprs ->
192 Valid.List <$> traverse expression exprs
194 Src.Call func args ->
195 Valid.Call
196 <$> expression func
197 <*> traverse expression args
199 Src.If branches finally ->
200 Valid.If
201 <$> traverse both branches
202 <*> expression finally
204 Src.Accessor field ->
205 pure (Valid.Accessor field)
207 Src.Access record field ->
208 Valid.Access
209 <$> expression record
210 <*> pure field
212 Src.Update record fields ->
213 Valid.Update record <$> traverse (traverse expression) fields
215 Src.Record fields ->
216 Valid.Record <$> traverse (traverse expression) fields
218 Src.Unit ->
219 pure Valid.Unit
221 Src.Tuple a b cs ->
222 Valid.Tuple
223 <$> expression a
224 <*> expression b
225 <*> traverse expression cs
227 Src.Let defs body ->
228 Valid.Let
229 <$> definitions defs
230 <*> expression body
232 Src.GLShader uid src gltipe ->
233 pure (Valid.GLShader uid src gltipe)
236both :: (Src.Expr, Src.Expr) -> Result w (Valid.Expr, Valid.Expr)
237both (a, b) =
238 liftA2 (,) (expression a) (expression b)
242-- VALIDATE DEFINITIONS
245definitions :: [A.Located Src.Def] -> Result w [Valid.Def]
246definitions sourceDefs =
247 case sourceDefs of
248 [] ->
249 return []
251 A.A region (Src.Destruct pattern expr) : otherDefs ->
252 (:)
253 <$> validateDestruct region pattern expr
254 <*> definitions otherDefs
256 A.A region (Src.Define name args expr) : otherDefs ->
257 (:)
258 <$> validateDefinition region name args expr Nothing
259 <*> definitions otherDefs
261 A.A annRegion (Src.Annotate annotationName tipe) : otherDefs ->
262 case otherDefs of
263 A.A defRegion (Src.Define name args expr) : otherOtherDefs | name == annotationName ->
264 (:)
265 <$> validateDefinition (R.merge annRegion defRegion) name args expr (Just tipe)
266 <*> definitions otherOtherDefs
268 _ ->
269 Result.throw annRegion (Error.TypeWithoutDefinition annotationName)
272validateDefinition :: R.Region -> Text -> [Pattern.Raw] -> Src.Expr -> Maybe Type.Raw -> Result w Valid.Def
273validateDefinition region name args expr maybeType =
274 do validExpr <- expression expr
275 return $ Valid.Define region name args validExpr maybeType
278validateDestruct :: R.Region -> Pattern.Raw -> Src.Expr -> Result w Valid.Def
279validateDestruct region pattern expr =
280 Valid.Destruct region pattern <$> expression expr
284-- VALIDATE EFFECTS
287validateEffects :: Src.Effects -> [Valid.Port] -> Result w Valid.Effects
288validateEffects effects ports =
289 case effects of
290 Src.NoEffects ->
291 do noPorts ports
292 return Valid.NoEffects
294 Src.Ports _ ->
295 return (Valid.Ports ports)
297 Src.Effects _ manager ->
298 do noPorts ports
299 case manager of
300 Src.Cmd cmd ->
301 return (Valid.Cmd cmd)
303 Src.Sub sub ->
304 return (Valid.Sub sub)
306 Src.Fx cmd sub ->
307 return (Valid.Fx cmd sub)
310noPorts :: [Valid.Port] -> Result w ()
311noPorts ports =
312 forM_ ports $ \(Valid.Port (A.A region name) _) ->
313 Result.throw region (Error.UnexpectedPort name)