git.iko.soy/elk
on 7dfbc30 help sign in
elk/src/Validate.hs
331 lines 8.7 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 name tvars ctors
73 vsdHelp otherDecls $ stuff { _unions = union : _unions stuff }
75 Src.Alias name tvars tipe ->
76 do let alias = Valid.Alias 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 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 :: Text -> [Src.Decl] -> Stuff -> Result i w Stuff
104validateDocs docs decls stuff =
105 case decls of
106 [] ->
107 error "TODO no docs on nothing"
109 A.At _ decl : _ ->
110 do name <- getNameForDocs decl
111 vsdHelp decls $ stuff { _docs = Map.insert name docs (_docs stuff) }
114getNameForDocs :: Src.Decl_ -> Result i w N.Name
115getNameForDocs decl =
116 case decl of
117 Src.Union (A.At _ name) _ _ ->
118 return name
120 Src.Alias (A.At _ name) _ _ ->
121 return name
123 Src.Binop _ _ _ _ ->
124 error "TODO no docs on binop"
126 Src.Port _ _ ->
127 error "TODO no docs on ports"
129 Src.Docs _ ->
130 error "TODO no docs on docs"
132 Src.Annotation (A.At _ name) _ ->
133 return name
135 Src.Definition (A.At _ name) _ _ ->
136 return 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 error "TODO no attotations on nothing"
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 error "TODO annotation does not match following definition"
161 _ ->
162 error "TODO annotation needs to be on a definition"
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 prefix name ->
174 pure (Valid.Var prefix name)
176 Src.Lambda pattern body ->
177 Valid.Lambda pattern <$> expression body
179 Src.Op name ->
180 pure (Valid.Op name)
182 Src.Negate expr ->
183 Valid.Negate <$> expression expr
185 Src.Binops ops lastExpr ->
186 Valid.Binops
187 <$> traverse (\(expr,op) -> (,) <$> expression expr <*> pure op) ops
188 <*> expression lastExpr
190 Src.Case expr branches ->
191 Valid.Case
192 <$> expression expr
193 <*> traverse (traverse expression) branches
195 Src.Str str ->
196 pure (Valid.Str str)
198 Src.Chr chr ->
199 pure (Valid.Chr chr)
201 Src.Int int ->
202 pure (Valid.Int int)
204 Src.Float float ->
205 pure (Valid.Float float)
207 Src.List exprs ->
208 Valid.List <$> traverse expression exprs
210 Src.Call func args ->
211 Valid.Call
212 <$> expression func
213 <*> traverse expression args
215 Src.If branches finally ->
216 Valid.If
217 <$> traverse both branches
218 <*> expression finally
220 Src.Accessor field ->
221 pure (Valid.Accessor field)
223 Src.Access record field ->
224 Valid.Access
225 <$> expression record
226 <*> pure field
228 Src.Update record fields ->
229 Valid.Update record <$> traverse (traverse expression) fields
231 Src.Record fields ->
232 Valid.Record <$> traverse (traverse expression) fields
234 Src.Unit ->
235 pure Valid.Unit
237 Src.Tuple a b cs ->
238 Valid.Tuple
239 <$> expression a
240 <*> expression b
241 <*> traverse expression cs
243 Src.Let defs body ->
244 Valid.Let
245 <$> definitions defs
246 <*> expression body
248 Src.Shader uid src gltipe ->
249 pure (Valid.Shader uid src gltipe)
252both :: (Src.Expr, Src.Expr) -> Result i w (Valid.Expr, Valid.Expr)
253both (a, b) =
254 liftA2 (,) (expression a) (expression b)
258-- VALIDATE DEFINITIONS
261definitions :: [A.Located Src.Def] -> Result i w [Valid.Def]
262definitions sourceDefs =
263 case sourceDefs of
264 [] ->
265 return []
267 A.At region (Src.Destruct pattern expr) : otherDefs ->
268 (:)
269 <$> validateDestruct region pattern expr
270 <*> definitions otherDefs
272 A.At region (Src.Define name args expr) : otherDefs ->
273 (:)
274 <$> validateDefinition region name args expr Nothing
275 <*> definitions otherDefs
277 A.At annRegion (Src.Annotate annotationName tipe) : otherDefs ->
278 case otherDefs of
279 A.At defRegion (Src.Define name@(A.At _ definitionName) args expr) : otherOtherDefs
280 | definitionName == annotationName ->
281 (:)
282 <$> validateDefinition (R.merge annRegion defRegion) name args expr (Just tipe)
283 <*> definitions otherOtherDefs
285 _ ->
286 Result.throw (Error.TypeWithoutDefinition annRegion annotationName)
289validateDefinition :: R.Region -> A.Located Text -> [Src.Pattern] -> Src.Expr -> Maybe Src.Type -> Result i w Valid.Def
290validateDefinition region name args expr maybeType =
291 do validExpr <- expression expr
292 return $ Valid.Define region name args validExpr maybeType
295validateDestruct :: R.Region -> Src.Pattern -> Src.Expr -> Result i w Valid.Def
296validateDestruct region pattern expr =
297 Valid.Destruct region pattern <$> expression expr
301-- VALIDATE EFFECTS
304validateEffects :: Src.Effects -> [Valid.Port] -> Result i w Valid.Effects
305validateEffects effects ports =
306 case effects of
307 Src.NoEffects ->
308 do noPorts ports
309 return Valid.NoEffects
311 Src.Ports _ ->
312 return (Valid.Ports ports)
314 Src.Manager region manager ->
315 do noPorts ports
316 return $ Valid.Manager region $
317 case manager of
318 Src.Cmd cmd ->
319 Valid.Cmd cmd
321 Src.Sub sub ->
322 Valid.Sub sub
324 Src.Fx cmd sub ->
325 Valid.Fx cmd sub
328noPorts :: [Valid.Port] -> Result i w ()
329noPorts ports =
330 forM_ ports $ \(Valid.Port (A.At region name) _) ->
331 Result.throw (Error.UnexpectedPort region name)