git.iko.soy/elk
on bfb8eca help sign in
elk/src/Validate.hs
317 lines 8.2 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Validate
4 ( Result
5 , validate
6 )
7 where
10import Control.Applicative (liftA2)
11import Control.Monad (forM_)
12import qualified Data.Map as Map
13import Data.Text (Text)
15import qualified AST.Expression.Source as Src
16import qualified AST.Expression.Valid as Valid
17import qualified AST.Type as Type
18import qualified Elm.Name as N
19import qualified Reporting.Annotation as A
20import qualified Reporting.Error.Syntax as Error
21import qualified Reporting.Region as R
22import qualified Reporting.Result as Result
26-- VALIDATE
29type Result warning a =
30 Result.Result () warning Error.Error a
33validate :: Src.Module [Src.Decl] -> Result w Valid.Module
34validate (Src.Module name srcEffects overview exports imports srcDecls) =
35 do (Stuff decls unions aliases binops ports docs) <- validateDecls srcDecls
36 effects <- validateEffects srcEffects ports
37 return $ Valid.Module name overview docs exports imports decls unions aliases binops effects
41-- VALIDATE DECLARATIONS
44data Stuff =
45 Stuff
46 { _decls :: [Valid.Decl]
47 , _unions :: [Valid.Union]
48 , _aliases :: [Valid.Alias]
49 , _binops :: [Valid.Binop]
50 , _ports :: [Valid.Port]
51 , _docs :: Map.Map N.Name Text
52 }
55validateDecls :: [Src.Decl] -> Result w Stuff
56validateDecls decls =
57 vsdHelp decls (Stuff [] [] [] [] [] Map.empty)
60vsdHelp :: [Src.Decl] -> Stuff -> Result w Stuff
61vsdHelp decls stuff =
62 case decls of
63 [] ->
64 Result.ok stuff
66 A.A _ decl : otherDecls ->
67 case decl of
68 Src.Union name tvars ctors ->
69 do let union = Valid.Union name tvars ctors
70 vsdHelp otherDecls $ stuff { _unions = union : _unions stuff }
72 Src.Alias name tvars tipe ->
73 do let alias = Valid.Alias name tvars tipe
74 vsdHelp otherDecls $ stuff { _aliases = alias : _aliases stuff }
76 Src.Binop op assoc prec val ->
77 do let binop = Valid.Binop op assoc prec val
78 vsdHelp otherDecls $ stuff { _binops = binop : _binops stuff }
80 Src.Port name tipe ->
81 do let port_ = Valid.Port name tipe
82 vsdHelp otherDecls $ stuff { _ports = port_ : _ports stuff }
84 Src.Docs docs ->
85 validateDocs docs otherDecls stuff
87 Src.Annotation (A.A _ name) tipe ->
88 validateAnnotation name tipe otherDecls stuff
90 Src.Definition name args body ->
91 do validBody <- expression body
92 let validDecl = Valid.Decl name args validBody Nothing
93 vsdHelp otherDecls $ stuff { _decls = validDecl : _decls stuff }
97-- VALIDATE DOCS
100validateDocs :: Text -> [Src.Decl] -> Stuff -> Result w Stuff
101validateDocs docs decls stuff =
102 case decls of
103 [] ->
104 error "TODO no docs on nothing"
106 A.A _ decl : _ ->
107 do name <- getNameForDocs decl
108 vsdHelp decls $ stuff { _docs = Map.insert name docs (_docs stuff) }
111getNameForDocs :: Src.Decl_ -> Result w N.Name
112getNameForDocs decl =
113 case decl of
114 Src.Union (A.A _ name) _ _ ->
115 return name
117 Src.Alias (A.A _ name) _ _ ->
118 return name
120 Src.Binop _ _ _ _ ->
121 error "TODO no docs on binop"
123 Src.Port _ _ ->
124 error "TODO no docs on ports"
126 Src.Docs _ ->
127 error "TODO no docs on docs"
129 Src.Annotation (A.A _ name) _ ->
130 return name
132 Src.Definition (A.A _ name) _ _ ->
133 return name
137-- VALIDATE ANNOTATION
140validateAnnotation :: N.Name -> Type.Raw -> [Src.Decl] -> Stuff -> Result w Stuff
141validateAnnotation annotationName tipe decls stuff =
142 case decls of
143 [] ->
144 error "TODO no attotations on nothing"
146 A.A _ decl : otherDecls ->
147 case decl of
148 Src.Definition name@(A.A _ definitionName) args body ->
149 if annotationName == definitionName then
150 do validBody <- expression body
151 let validDecl = Valid.Decl name args validBody (Just tipe)
152 vsdHelp otherDecls $ stuff { _decls = validDecl : _decls stuff }
154 else
155 error "TODO annotation does not match following definition"
157 _ ->
158 error "TODO annotation needs to be on a definition"
162-- VALIDATE EXPRESSIONS
165expression :: Src.Expr -> Result w Valid.Expr
166expression (A.A region sourceExpression) =
167 A.A region <$>
168 case sourceExpression of
169 Src.Var prefix name ->
170 pure (Valid.Var prefix name)
172 Src.Lambda pattern body ->
173 Valid.Lambda pattern <$> expression body
175 Src.Op name ->
176 pure (Valid.Op name)
178 Src.Negate expr ->
179 Valid.Negate <$> expression expr
181 Src.Binops ops lastExpr ->
182 Valid.Binops
183 <$> traverse (\(expr,op) -> (,) <$> expression expr <*> pure op) ops
184 <*> expression lastExpr
186 Src.Case expr branches ->
187 Valid.Case
188 <$> expression expr
189 <*> traverse (traverse expression) branches
191 Src.Literal lit ->
192 pure (Valid.Literal lit)
194 Src.List exprs ->
195 Valid.List <$> traverse expression exprs
197 Src.Call func args ->
198 Valid.Call
199 <$> expression func
200 <*> traverse expression args
202 Src.If branches finally ->
203 Valid.If
204 <$> traverse both branches
205 <*> expression finally
207 Src.Accessor field ->
208 pure (Valid.Accessor field)
210 Src.Access record field ->
211 Valid.Access
212 <$> expression record
213 <*> pure field
215 Src.Update record fields ->
216 Valid.Update record <$> traverse (traverse expression) fields
218 Src.Record fields ->
219 Valid.Record <$> traverse (traverse expression) fields
221 Src.Unit ->
222 pure Valid.Unit
224 Src.Tuple a b cs ->
225 Valid.Tuple
226 <$> expression a
227 <*> expression b
228 <*> traverse expression cs
230 Src.Let defs body ->
231 Valid.Let
232 <$> definitions defs
233 <*> expression body
235 Src.GLShader uid src gltipe ->
236 pure (Valid.GLShader uid src gltipe)
239both :: (Src.Expr, Src.Expr) -> Result w (Valid.Expr, Valid.Expr)
240both (a, b) =
241 liftA2 (,) (expression a) (expression b)
245-- VALIDATE DEFINITIONS
248definitions :: [A.Located Src.Def] -> Result w [Valid.Def]
249definitions sourceDefs =
250 case sourceDefs of
251 [] ->
252 return []
254 A.A region (Src.Destruct pattern expr) : otherDefs ->
255 (:)
256 <$> validateDestruct region pattern expr
257 <*> definitions otherDefs
259 A.A region (Src.Define name args expr) : otherDefs ->
260 (:)
261 <$> validateDefinition region name args expr Nothing
262 <*> definitions otherDefs
264 A.A annRegion (Src.Annotate annotationName tipe) : otherDefs ->
265 case otherDefs of
266 A.A defRegion (Src.Define name@(A.A _ definitionName) args expr) : otherOtherDefs
267 | definitionName == annotationName ->
268 (:)
269 <$> validateDefinition (R.merge annRegion defRegion) name args expr (Just tipe)
270 <*> definitions otherOtherDefs
272 _ ->
273 Result.throw annRegion (Error.TypeWithoutDefinition annotationName)
276validateDefinition :: R.Region -> A.Located Text -> [Src.Pattern] -> Src.Expr -> Maybe Type.Raw -> Result w Valid.Def
277validateDefinition region name args expr maybeType =
278 do validExpr <- expression expr
279 return $ Valid.Define region name args validExpr maybeType
282validateDestruct :: R.Region -> Src.Pattern -> Src.Expr -> Result w Valid.Def
283validateDestruct region pattern expr =
284 Valid.Destruct region pattern <$> expression expr
288-- VALIDATE EFFECTS
291validateEffects :: Src.Effects -> [Valid.Port] -> Result w Valid.Effects
292validateEffects effects ports =
293 case effects of
294 Src.NoEffects ->
295 do noPorts ports
296 return Valid.NoEffects
298 Src.Ports _ ->
299 return (Valid.Ports ports)
301 Src.Effects _ manager ->
302 do noPorts ports
303 case manager of
304 Src.Cmd cmd ->
305 return (Valid.Cmd cmd)
307 Src.Sub sub ->
308 return (Valid.Sub sub)
310 Src.Fx cmd sub ->
311 return (Valid.Fx cmd sub)
314noPorts :: [Valid.Port] -> Result w ()
315noPorts ports =
316 forM_ ports $ \(Valid.Port (A.A region name) _) ->
317 Result.throw region (Error.UnexpectedPort name)