git.iko.soy/elk
on 64038dc help sign in
elk/src/Validate.hs
319 lines 8.4 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.Literal lit ->
193 pure (Valid.Literal lit)
195 Src.List exprs ->
196 Valid.List <$> traverse expression exprs
198 Src.Call func args ->
199 Valid.Call
200 <$> expression func
201 <*> traverse expression args
203 Src.If branches finally ->
204 Valid.If
205 <$> traverse both branches
206 <*> expression finally
208 Src.Accessor field ->
209 pure (Valid.Accessor field)
211 Src.Access record field ->
212 Valid.Access
213 <$> expression record
214 <*> pure field
216 Src.Update record fields ->
217 Valid.Update record <$> traverse (traverse expression) fields
219 Src.Record fields ->
220 Valid.Record <$> traverse (traverse expression) fields
222 Src.Unit ->
223 pure Valid.Unit
225 Src.Tuple a b cs ->
226 Valid.Tuple
227 <$> expression a
228 <*> expression b
229 <*> traverse expression cs
231 Src.Let defs body ->
232 Valid.Let
233 <$> definitions defs
234 <*> expression body
236 Src.GLShader uid src gltipe ->
237 pure (Valid.GLShader uid src gltipe)
240both :: (Src.Expr, Src.Expr) -> Result w (Valid.Expr, Valid.Expr)
241both (a, b) =
242 liftA2 (,) (expression a) (expression b)
246-- VALIDATE DEFINITIONS
249definitions :: [A.Located Src.Def] -> Result w [Valid.Def]
250definitions sourceDefs =
251 case sourceDefs of
252 [] ->
253 return []
255 A.A region (Src.Destruct pattern expr) : otherDefs ->
256 (:)
257 <$> validateDestruct region pattern expr
258 <*> definitions otherDefs
260 A.A region (Src.Define name args expr) : otherDefs ->
261 (:)
262 <$> validateDefinition region name args expr Nothing
263 <*> definitions otherDefs
265 A.A annRegion (Src.Annotate annotationName tipe) : otherDefs ->
266 case otherDefs of
267 A.A defRegion (Src.Define name@(A.A _ definitionName) args expr) : otherOtherDefs
268 | definitionName == annotationName ->
269 (:)
270 <$> validateDefinition (R.merge annRegion defRegion) name args expr (Just tipe)
271 <*> definitions otherOtherDefs
273 _ ->
274 Result.throw annRegion (Error.TypeWithoutDefinition annotationName)
277validateDefinition :: R.Region -> A.Located Text -> [Src.Pattern] -> Src.Expr -> Maybe Type.Raw -> Result w Valid.Def
278validateDefinition region name args expr maybeType =
279 do validExpr <- expression expr
280 return $ Valid.Define region name args validExpr maybeType
283validateDestruct :: R.Region -> Src.Pattern -> Src.Expr -> Result w Valid.Def
284validateDestruct region pattern expr =
285 Valid.Destruct region pattern <$> expression expr
289-- VALIDATE EFFECTS
292validateEffects :: Src.Effects -> [Valid.Port] -> Result w Valid.Effects
293validateEffects effects ports =
294 case effects of
295 Src.NoEffects ->
296 do noPorts ports
297 return Valid.NoEffects
299 Src.Ports _ ->
300 return (Valid.Ports ports)
302 Src.Manager region manager ->
303 do noPorts ports
304 return $ Valid.Manager region $
305 case manager of
306 Src.Cmd cmd ->
307 Valid.Cmd cmd
309 Src.Sub sub ->
310 Valid.Sub sub
312 Src.Fx cmd sub ->
313 Valid.Fx cmd sub
316noPorts :: [Valid.Port] -> Result w ()
317noPorts ports =
318 forM_ ports $ \(Valid.Port (A.A region name) _) ->
319 Result.throw region (Error.UnexpectedPort name)