git.iko.soy/elk
on feb5ece help sign in
elk/src/Validate.hs
326 lines 8.5 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 name srcEffects overview exports imports srcDecls) =
33 do (Stuff decls unions aliases binops ports docs) <- validateDecls srcDecls
34 effects <- validateEffects srcEffects ports
35 return $ Valid.Module name overview docs exports imports decls unions aliases binops effects
39-- VALIDATE DECLARATIONS
42data Stuff =
43 Stuff
44 { _decls :: [A.Located Valid.Decl]
45 , _unions :: [Valid.Union]
46 , _aliases :: [Valid.Alias]
47 , _binops :: [Valid.Binop]
48 , _ports :: [Valid.Port]
49 , _docs :: Map.Map N.Name Text
50 }
53validateDecls :: [Src.Decl] -> Result i w Stuff
54validateDecls decls =
55 vsdHelp decls (Stuff [] [] [] [] [] Map.empty)
58vsdHelp :: [Src.Decl] -> Stuff -> Result i w Stuff
59vsdHelp decls stuff =
60 case decls of
61 [] ->
62 Result.ok stuff
64 A.At region decl : otherDecls ->
65 case decl of
66 Src.Union name tvars ctors ->
67 do let union = Valid.Union name tvars ctors
68 vsdHelp otherDecls $ stuff { _unions = union : _unions stuff }
70 Src.Alias name tvars tipe ->
71 do let alias = Valid.Alias name tvars tipe
72 vsdHelp otherDecls $ stuff { _aliases = alias : _aliases stuff }
74 Src.Binop op assoc prec val ->
75 do let binop = Valid.Binop op assoc prec val
76 vsdHelp otherDecls $ stuff { _binops = binop : _binops stuff }
78 Src.Port name tipe ->
79 do let port_ = Valid.Port name tipe
80 vsdHelp otherDecls $ stuff { _ports = port_ : _ports stuff }
82 Src.Docs docs ->
83 validateDocs docs otherDecls stuff
85 Src.Annotation (A.At _ name) tipe ->
86 validateAnnotation region name tipe otherDecls stuff
88 Src.Definition name args body ->
89 do validBody <- expression body
90 let validDecl = A.At region (Valid.Decl name args validBody Nothing)
91 vsdHelp otherDecls $ stuff { _decls = validDecl : _decls stuff }
95-- VALIDATE DOCS
98validateDocs :: Text -> [Src.Decl] -> Stuff -> Result i w Stuff
99validateDocs docs decls stuff =
100 case decls of
101 [] ->
102 error "TODO no docs on nothing"
104 A.At _ decl : _ ->
105 do name <- getNameForDocs decl
106 vsdHelp decls $ stuff { _docs = Map.insert name docs (_docs stuff) }
109getNameForDocs :: Src.Decl_ -> Result i w N.Name
110getNameForDocs decl =
111 case decl of
112 Src.Union (A.At _ name) _ _ ->
113 return name
115 Src.Alias (A.At _ name) _ _ ->
116 return name
118 Src.Binop _ _ _ _ ->
119 error "TODO no docs on binop"
121 Src.Port _ _ ->
122 error "TODO no docs on ports"
124 Src.Docs _ ->
125 error "TODO no docs on docs"
127 Src.Annotation (A.At _ name) _ ->
128 return name
130 Src.Definition (A.At _ name) _ _ ->
131 return name
135-- VALIDATE ANNOTATION
138validateAnnotation :: R.Region -> N.Name -> Src.Type -> [Src.Decl] -> Stuff -> Result i w Stuff
139validateAnnotation annRegion annotationName tipe decls stuff =
140 case decls of
141 [] ->
142 error "TODO no attotations on nothing"
144 A.At defRegion decl : otherDecls ->
145 case decl of
146 Src.Definition name@(A.At _ definitionName) args body ->
147 if annotationName == definitionName then
148 do validBody <- expression body
149 let region = R.merge annRegion defRegion
150 let validDecl = A.At region (Valid.Decl name args validBody (Just tipe))
151 vsdHelp otherDecls $ stuff { _decls = validDecl : _decls stuff }
153 else
154 error "TODO annotation does not match following definition"
156 _ ->
157 error "TODO annotation needs to be on a definition"
161-- VALIDATE EXPRESSIONS
164expression :: Src.Expr -> Result i w Valid.Expr
165expression (A.At region sourceExpression) =
166 A.At region <$>
167 case sourceExpression of
168 Src.Var prefix name ->
169 pure (Valid.Var prefix name)
171 Src.Lambda pattern body ->
172 Valid.Lambda pattern <$> expression body
174 Src.Op name ->
175 pure (Valid.Op name)
177 Src.Negate expr ->
178 Valid.Negate <$> expression expr
180 Src.Binops ops lastExpr ->
181 Valid.Binops
182 <$> traverse (\(expr,op) -> (,) <$> expression expr <*> pure op) ops
183 <*> expression lastExpr
185 Src.Case expr branches ->
186 Valid.Case
187 <$> expression expr
188 <*> traverse (traverse expression) branches
190 Src.Str str ->
191 pure (Valid.Str str)
193 Src.Chr chr ->
194 pure (Valid.Chr chr)
196 Src.Int int ->
197 pure (Valid.Int int)
199 Src.Float float ->
200 pure (Valid.Float float)
202 Src.List exprs ->
203 Valid.List <$> traverse expression exprs
205 Src.Call func args ->
206 Valid.Call
207 <$> expression func
208 <*> traverse expression args
210 Src.If branches finally ->
211 Valid.If
212 <$> traverse both branches
213 <*> expression finally
215 Src.Accessor field ->
216 pure (Valid.Accessor field)
218 Src.Access record field ->
219 Valid.Access
220 <$> expression record
221 <*> pure field
223 Src.Update record fields ->
224 Valid.Update record <$> traverse (traverse expression) fields
226 Src.Record fields ->
227 Valid.Record <$> traverse (traverse expression) fields
229 Src.Unit ->
230 pure Valid.Unit
232 Src.Tuple a b cs ->
233 Valid.Tuple
234 <$> expression a
235 <*> expression b
236 <*> traverse expression cs
238 Src.Let defs body ->
239 Valid.Let
240 <$> definitions defs
241 <*> expression body
243 Src.Shader uid src gltipe ->
244 pure (Valid.Shader uid src gltipe)
247both :: (Src.Expr, Src.Expr) -> Result i w (Valid.Expr, Valid.Expr)
248both (a, b) =
249 liftA2 (,) (expression a) (expression b)
253-- VALIDATE DEFINITIONS
256definitions :: [A.Located Src.Def] -> Result i w [Valid.Def]
257definitions sourceDefs =
258 case sourceDefs of
259 [] ->
260 return []
262 A.At region (Src.Destruct pattern expr) : otherDefs ->
263 (:)
264 <$> validateDestruct region pattern expr
265 <*> definitions otherDefs
267 A.At region (Src.Define name args expr) : otherDefs ->
268 (:)
269 <$> validateDefinition region name args expr Nothing
270 <*> definitions otherDefs
272 A.At annRegion (Src.Annotate annotationName tipe) : otherDefs ->
273 case otherDefs of
274 A.At defRegion (Src.Define name@(A.At _ definitionName) args expr) : otherOtherDefs
275 | definitionName == annotationName ->
276 (:)
277 <$> validateDefinition (R.merge annRegion defRegion) name args expr (Just tipe)
278 <*> definitions otherOtherDefs
280 _ ->
281 Result.throw (Error.TypeWithoutDefinition annRegion annotationName)
284validateDefinition :: R.Region -> A.Located Text -> [Src.Pattern] -> Src.Expr -> Maybe Src.Type -> Result i w Valid.Def
285validateDefinition region name args expr maybeType =
286 do validExpr <- expression expr
287 return $ Valid.Define region name args validExpr maybeType
290validateDestruct :: R.Region -> Src.Pattern -> Src.Expr -> Result i w Valid.Def
291validateDestruct region pattern expr =
292 Valid.Destruct region pattern <$> expression expr
296-- VALIDATE EFFECTS
299validateEffects :: Src.Effects -> [Valid.Port] -> Result i w Valid.Effects
300validateEffects effects ports =
301 case effects of
302 Src.NoEffects ->
303 do noPorts ports
304 return Valid.NoEffects
306 Src.Ports _ ->
307 return (Valid.Ports ports)
309 Src.Manager region manager ->
310 do noPorts ports
311 return $ Valid.Manager region $
312 case manager of
313 Src.Cmd cmd ->
314 Valid.Cmd cmd
316 Src.Sub sub ->
317 Valid.Sub sub
319 Src.Fx cmd sub ->
320 Valid.Fx cmd sub
323noPorts :: [Valid.Port] -> Result i w ()
324noPorts ports =
325 forM_ ports $ \(Valid.Port (A.At region name) _) ->
326 Result.throw (Error.UnexpectedPort region name)