git.iko.soy/elk
on 7c33c13 help sign in
elk/src/Validate.hs
327 lines 8.5 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.Source as Src
16import qualified AST.Valid as Valid
17import qualified Elm.Name as N
18import qualified Reporting.Annotation as A
19import qualified Reporting.Error.Syntax as Error
20import qualified Reporting.Region as R
21import qualified Reporting.Result as Result
25-- VALIDATE
28type Result warning a =
29 Result.Result () warning Error.Error a
32validate :: Src.Module [Src.Decl] -> Result w Valid.Module
33validate (Src.Module name srcEffects overview exports imports srcDecls) =
34 do (Stuff decls unions aliases binops ports docs) <- validateDecls srcDecls
35 effects <- validateEffects srcEffects ports
36 return $ Valid.Module name overview docs exports imports decls unions aliases binops effects
40-- VALIDATE DECLARATIONS
43data Stuff =
44 Stuff
45 { _decls :: [A.Located Valid.Decl]
46 , _unions :: [Valid.Union]
47 , _aliases :: [Valid.Alias]
48 , _binops :: [Valid.Binop]
49 , _ports :: [Valid.Port]
50 , _docs :: Map.Map N.Name Text
51 }
54validateDecls :: [Src.Decl] -> Result w Stuff
55validateDecls decls =
56 vsdHelp decls (Stuff [] [] [] [] [] Map.empty)
59vsdHelp :: [Src.Decl] -> Stuff -> Result w Stuff
60vsdHelp decls stuff =
61 case decls of
62 [] ->
63 Result.ok stuff
65 A.At region decl : otherDecls ->
66 case decl of
67 Src.Union name tvars ctors ->
68 do let union = Valid.Union name tvars ctors
69 vsdHelp otherDecls $ stuff { _unions = union : _unions stuff }
71 Src.Alias name tvars tipe ->
72 do let alias = Valid.Alias name tvars tipe
73 vsdHelp otherDecls $ stuff { _aliases = alias : _aliases stuff }
75 Src.Binop op assoc prec val ->
76 do let binop = Valid.Binop op assoc prec val
77 vsdHelp otherDecls $ stuff { _binops = binop : _binops stuff }
79 Src.Port name tipe ->
80 do let port_ = Valid.Port name tipe
81 vsdHelp otherDecls $ stuff { _ports = port_ : _ports stuff }
83 Src.Docs docs ->
84 validateDocs docs otherDecls stuff
86 Src.Annotation (A.At _ name) tipe ->
87 validateAnnotation region name tipe otherDecls stuff
89 Src.Definition name args body ->
90 do validBody <- expression body
91 let validDecl = A.At region (Valid.Decl name args validBody Nothing)
92 vsdHelp otherDecls $ stuff { _decls = validDecl : _decls stuff }
96-- VALIDATE DOCS
99validateDocs :: Text -> [Src.Decl] -> Stuff -> Result w Stuff
100validateDocs docs decls stuff =
101 case decls of
102 [] ->
103 error "TODO no docs on nothing"
105 A.At _ decl : _ ->
106 do name <- getNameForDocs decl
107 vsdHelp decls $ stuff { _docs = Map.insert name docs (_docs stuff) }
110getNameForDocs :: Src.Decl_ -> Result w N.Name
111getNameForDocs decl =
112 case decl of
113 Src.Union (A.At _ name) _ _ ->
114 return name
116 Src.Alias (A.At _ name) _ _ ->
117 return name
119 Src.Binop _ _ _ _ ->
120 error "TODO no docs on binop"
122 Src.Port _ _ ->
123 error "TODO no docs on ports"
125 Src.Docs _ ->
126 error "TODO no docs on docs"
128 Src.Annotation (A.At _ name) _ ->
129 return name
131 Src.Definition (A.At _ name) _ _ ->
132 return name
136-- VALIDATE ANNOTATION
139validateAnnotation :: R.Region -> N.Name -> Src.Type -> [Src.Decl] -> Stuff -> Result w Stuff
140validateAnnotation annRegion annotationName tipe decls stuff =
141 case decls of
142 [] ->
143 error "TODO no attotations on nothing"
145 A.At defRegion decl : otherDecls ->
146 case decl of
147 Src.Definition name@(A.At _ definitionName) args body ->
148 if annotationName == definitionName then
149 do validBody <- expression body
150 let region = R.merge annRegion defRegion
151 let validDecl = A.At region (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.At region sourceExpression) =
167 A.At 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.Str str ->
192 pure (Valid.Str str)
194 Src.Chr chr ->
195 pure (Valid.Chr chr)
197 Src.Int int ->
198 pure (Valid.Int int)
200 Src.Float float ->
201 pure (Valid.Float float)
203 Src.List exprs ->
204 Valid.List <$> traverse expression exprs
206 Src.Call func args ->
207 Valid.Call
208 <$> expression func
209 <*> traverse expression args
211 Src.If branches finally ->
212 Valid.If
213 <$> traverse both branches
214 <*> expression finally
216 Src.Accessor field ->
217 pure (Valid.Accessor field)
219 Src.Access record field ->
220 Valid.Access
221 <$> expression record
222 <*> pure field
224 Src.Update record fields ->
225 Valid.Update record <$> traverse (traverse expression) fields
227 Src.Record fields ->
228 Valid.Record <$> traverse (traverse expression) fields
230 Src.Unit ->
231 pure Valid.Unit
233 Src.Tuple a b cs ->
234 Valid.Tuple
235 <$> expression a
236 <*> expression b
237 <*> traverse expression cs
239 Src.Let defs body ->
240 Valid.Let
241 <$> definitions defs
242 <*> expression body
244 Src.Shader uid src gltipe ->
245 pure (Valid.Shader uid src gltipe)
248both :: (Src.Expr, Src.Expr) -> Result w (Valid.Expr, Valid.Expr)
249both (a, b) =
250 liftA2 (,) (expression a) (expression b)
254-- VALIDATE DEFINITIONS
257definitions :: [A.Located Src.Def] -> Result w [Valid.Def]
258definitions sourceDefs =
259 case sourceDefs of
260 [] ->
261 return []
263 A.At region (Src.Destruct pattern expr) : otherDefs ->
264 (:)
265 <$> validateDestruct region pattern expr
266 <*> definitions otherDefs
268 A.At region (Src.Define name args expr) : otherDefs ->
269 (:)
270 <$> validateDefinition region name args expr Nothing
271 <*> definitions otherDefs
273 A.At annRegion (Src.Annotate annotationName tipe) : otherDefs ->
274 case otherDefs of
275 A.At defRegion (Src.Define name@(A.At _ definitionName) args expr) : otherOtherDefs
276 | definitionName == annotationName ->
277 (:)
278 <$> validateDefinition (R.merge annRegion defRegion) name args expr (Just tipe)
279 <*> definitions otherOtherDefs
281 _ ->
282 Result.throw annRegion (Error.TypeWithoutDefinition annotationName)
285validateDefinition :: R.Region -> A.Located Text -> [Src.Pattern] -> Src.Expr -> Maybe Src.Type -> Result w Valid.Def
286validateDefinition region name args expr maybeType =
287 do validExpr <- expression expr
288 return $ Valid.Define region name args validExpr maybeType
291validateDestruct :: R.Region -> Src.Pattern -> Src.Expr -> Result w Valid.Def
292validateDestruct region pattern expr =
293 Valid.Destruct region pattern <$> expression expr
297-- VALIDATE EFFECTS
300validateEffects :: Src.Effects -> [Valid.Port] -> Result w Valid.Effects
301validateEffects effects ports =
302 case effects of
303 Src.NoEffects ->
304 do noPorts ports
305 return Valid.NoEffects
307 Src.Ports _ ->
308 return (Valid.Ports ports)
310 Src.Manager region manager ->
311 do noPorts ports
312 return $ Valid.Manager region $
313 case manager of
314 Src.Cmd cmd ->
315 Valid.Cmd cmd
317 Src.Sub sub ->
318 Valid.Sub sub
320 Src.Fx cmd sub ->
321 Valid.Fx cmd sub
324noPorts :: [Valid.Port] -> Result w ()
325noPorts ports =
326 forM_ ports $ \(Valid.Port (A.At region name) _) ->
327 Result.throw region (Error.UnexpectedPort name)