git.iko.soy/elk
on 9d6d260 help sign in
elk/src/Validate.hs
328 lines 8.6 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 :: [A.Located 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 region 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 region name tipe otherDecls stuff
90 Src.Definition name args body ->
91 do validBody <- expression body
92 let validDecl = A.A region (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 :: R.Region -> N.Name -> Type.Raw -> [Src.Decl] -> Stuff -> Result w Stuff
141validateAnnotation annRegion annotationName tipe decls stuff =
142 case decls of
143 [] ->
144 error "TODO no attotations on nothing"
146 A.A defRegion 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 region = R.merge annRegion defRegion
152 let validDecl = A.A region (Valid.Decl name args validBody (Just tipe))
153 vsdHelp otherDecls $ stuff { _decls = validDecl : _decls stuff }
155 else
156 error "TODO annotation does not match following definition"
158 _ ->
159 error "TODO annotation needs to be on a definition"
163-- VALIDATE EXPRESSIONS
166expression :: Src.Expr -> Result w Valid.Expr
167expression (A.A region sourceExpression) =
168 A.A region <$>
169 case sourceExpression of
170 Src.Var prefix name ->
171 pure (Valid.Var prefix name)
173 Src.Lambda pattern body ->
174 Valid.Lambda pattern <$> expression body
176 Src.Op name ->
177 pure (Valid.Op name)
179 Src.Negate expr ->
180 Valid.Negate <$> expression expr
182 Src.Binops ops lastExpr ->
183 Valid.Binops
184 <$> traverse (\(expr,op) -> (,) <$> expression expr <*> pure op) ops
185 <*> expression lastExpr
187 Src.Case expr branches ->
188 Valid.Case
189 <$> expression expr
190 <*> traverse (traverse expression) branches
192 Src.Str str ->
193 pure (Valid.Str str)
195 Src.Chr chr ->
196 pure (Valid.Chr chr)
198 Src.Int int ->
199 pure (Valid.Int int)
201 Src.Float float ->
202 pure (Valid.Float float)
204 Src.List exprs ->
205 Valid.List <$> traverse expression exprs
207 Src.Call func args ->
208 Valid.Call
209 <$> expression func
210 <*> traverse expression args
212 Src.If branches finally ->
213 Valid.If
214 <$> traverse both branches
215 <*> expression finally
217 Src.Accessor field ->
218 pure (Valid.Accessor field)
220 Src.Access record field ->
221 Valid.Access
222 <$> expression record
223 <*> pure field
225 Src.Update record fields ->
226 Valid.Update record <$> traverse (traverse expression) fields
228 Src.Record fields ->
229 Valid.Record <$> traverse (traverse expression) fields
231 Src.Unit ->
232 pure Valid.Unit
234 Src.Tuple a b cs ->
235 Valid.Tuple
236 <$> expression a
237 <*> expression b
238 <*> traverse expression cs
240 Src.Let defs body ->
241 Valid.Let
242 <$> definitions defs
243 <*> expression body
245 Src.Shader uid src gltipe ->
246 pure (Valid.Shader uid src gltipe)
249both :: (Src.Expr, Src.Expr) -> Result w (Valid.Expr, Valid.Expr)
250both (a, b) =
251 liftA2 (,) (expression a) (expression b)
255-- VALIDATE DEFINITIONS
258definitions :: [A.Located Src.Def] -> Result w [Valid.Def]
259definitions sourceDefs =
260 case sourceDefs of
261 [] ->
262 return []
264 A.A region (Src.Destruct pattern expr) : otherDefs ->
265 (:)
266 <$> validateDestruct region pattern expr
267 <*> definitions otherDefs
269 A.A region (Src.Define name args expr) : otherDefs ->
270 (:)
271 <$> validateDefinition region name args expr Nothing
272 <*> definitions otherDefs
274 A.A annRegion (Src.Annotate annotationName tipe) : otherDefs ->
275 case otherDefs of
276 A.A defRegion (Src.Define name@(A.A _ definitionName) args expr) : otherOtherDefs
277 | definitionName == annotationName ->
278 (:)
279 <$> validateDefinition (R.merge annRegion defRegion) name args expr (Just tipe)
280 <*> definitions otherOtherDefs
282 _ ->
283 Result.throw annRegion (Error.TypeWithoutDefinition annotationName)
286validateDefinition :: R.Region -> A.Located Text -> [Src.Pattern] -> Src.Expr -> Maybe Type.Raw -> Result w Valid.Def
287validateDefinition region name args expr maybeType =
288 do validExpr <- expression expr
289 return $ Valid.Define region name args validExpr maybeType
292validateDestruct :: R.Region -> Src.Pattern -> Src.Expr -> Result w Valid.Def
293validateDestruct region pattern expr =
294 Valid.Destruct region pattern <$> expression expr
298-- VALIDATE EFFECTS
301validateEffects :: Src.Effects -> [Valid.Port] -> Result w Valid.Effects
302validateEffects effects ports =
303 case effects of
304 Src.NoEffects ->
305 do noPorts ports
306 return Valid.NoEffects
308 Src.Ports _ ->
309 return (Valid.Ports ports)
311 Src.Manager region manager ->
312 do noPorts ports
313 return $ Valid.Manager region $
314 case manager of
315 Src.Cmd cmd ->
316 Valid.Cmd cmd
318 Src.Sub sub ->
319 Valid.Sub sub
321 Src.Fx cmd sub ->
322 Valid.Fx cmd sub
325noPorts :: [Valid.Port] -> Result w ()
326noPorts ports =
327 forM_ ports $ \(Valid.Port (A.A region name) _) ->
328 Result.throw region (Error.UnexpectedPort name)