@@ -1,334 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
9−import Control.Applicative (liftA2)
10−import Control.Monad (forM_)
11−import qualified Data.Map as Map
12−import qualified Data.Name as Name
13−import Data.Text (Text)
15−import qualified AST.Source as Src
16−import qualified AST.Valid as Valid
17−import qualified Reporting.Annotation as A
18−import qualified Reporting.Error.Syntax as Error
19−import qualified Reporting.Region as R
20−import qualified Reporting.Result as Result
28− Result.Result i w Error.Error a
31−validate :: Src.Module [Src.Decl] -> Result i w Valid.Module
32−validate (Src.Module header imports srcDecls) =
33− do (Stuff decls unions aliases binops ports docs) <- validateDecls srcDecls
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
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 Name.Name Text
58−validateDecls :: [Src.Decl] -> Result i w Stuff
60− vsdHelp decls (Stuff [] [] [] [] [] Map.empty)
63−vsdHelp :: [Src.Decl] -> Stuff -> Result i w Stuff
69− A.At region decl : otherDecls ->
71− Src.Union name tvars ctors ->
72− do let union = Valid.Union region name tvars ctors
73− vsdHelp otherDecls $ stuff { _unions = union : _unions stuff }
75− Src.Alias name tvars tipe ->
76− do let alias = Valid.Alias region 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 }
88− validateDocs region 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 }
103−validateDocs :: R.Region -> Text -> [Src.Decl] -> Stuff -> Result i w Stuff
104−validateDocs region docs decls stuff =
107− Result.throw (Error.CommentOnNothing region)
110− do name <- getNameForDocs region decl
111− vsdHelp decls $ stuff { _docs = Map.insert name docs (_docs stuff) }
114−getNameForDocs :: R.Region -> Src.Decl_ -> Result i w Name.Name
115−getNameForDocs region decl =
117− Src.Union (A.At _ name) _ _ ->
120− Src.Alias (A.At _ name) _ _ ->
123− Src.Binop name _ _ _ ->
126− Src.Port (A.At _ name) _ ->
130− Result.throw (Error.CommentOnNothing region)
132− Src.Annotation (A.At _ name) _ ->
135− Src.Definition (A.At _ name) _ _ ->
140−-- VALIDATE ANNOTATION
143−validateAnnotation :: R.Region -> Name.Name -> Src.Type -> [Src.Decl] -> Stuff -> Result i w Stuff
144−validateAnnotation annRegion annotationName tipe decls stuff =
147− Result.throw (Error.TypeWithoutDefinition annRegion annotationName)
149− A.At defRegion decl : otherDecls ->
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 }
159− Result.throw (Error.TypeWithBadDefinition annRegion annotationName definitionName)
162− Result.throw (Error.TypeWithoutDefinition annRegion annotationName)
166−-- VALIDATE EXPRESSIONS
169−expression :: Src.Expr -> Result i w Valid.Expr
170−expression (A.At region sourceExpression) =
172− case sourceExpression of
173− Src.Var varType name ->
174− pure (Valid.Var varType name)
176− Src.VarQual varType home name ->
177− pure (Valid.VarQual varType home name)
179− Src.Lambda pattern body ->
180− Valid.Lambda pattern <$> expression body
183− pure (Valid.Op name)
186− Valid.Negate <$> expression expr
188− Src.Binops ops lastExpr ->
190− <$> traverse (\(expr,op) -> (,) <$> expression expr <*> pure op) ops
191− <*> expression lastExpr
193− Src.Case expr branches ->
196− <*> traverse (traverse expression) branches
199− pure (Valid.Str str)
202− pure (Valid.Chr chr)
205− pure (Valid.Int int)
208− pure (Valid.Float float)
211− Valid.List <$> traverse expression exprs
213− Src.Call func args ->
216− <*> traverse expression args
218− Src.If branches finally ->
220− <$> traverse both branches
221− <*> expression finally
223− Src.Accessor field ->
224− pure (Valid.Accessor field)
226− Src.Access record field ->
228− <$> expression record
231− Src.Update record fields ->
232− Valid.Update record <$> traverse (traverse expression) fields
234− Src.Record fields ->
235− Valid.Record <$> traverse (traverse expression) fields
244− <*> traverse expression cs
246− Src.Let defs body ->
248− <$> definitions defs
251− Src.Shader uid src gltipe ->
252− pure (Valid.Shader uid src gltipe)
255−both :: (Src.Expr, Src.Expr) -> Result i w (Valid.Expr, Valid.Expr)
257− liftA2 (,) (expression a) (expression b)
261−-- VALIDATE DEFINITIONS
264−definitions :: [A.Located Src.Def] -> Result i w [Valid.Def]
265−definitions sourceDefs =
270− A.At region (Src.Destruct pattern expr) : otherDefs ->
272− <$> validateDestruct region pattern expr
273− <*> definitions otherDefs
275− A.At region (Src.Define name args expr) : otherDefs ->
277− <$> validateDefinition region name args expr Nothing
278− <*> definitions otherDefs
280− A.At annRegion (Src.Annotate annotationName tipe) : otherDefs ->
282− A.At defRegion (Src.Define name@(A.At _ definitionName) args expr) : otherOtherDefs
283− | definitionName == annotationName ->
285− <$> validateDefinition (R.merge annRegion defRegion) name args expr (Just tipe)
286− <*> definitions otherOtherDefs
289− Result.throw (Error.TypeWithoutDefinition annRegion annotationName)
292−validateDefinition :: R.Region -> A.Located Name.Name -> [Src.Pattern] -> Src.Expr -> Maybe Src.Type -> Result i w Valid.Def
293−validateDefinition region name args expr maybeType =
294− do validExpr <- expression expr
295− return $ Valid.Define region name args validExpr maybeType
298−validateDestruct :: R.Region -> Src.Pattern -> Src.Expr -> Result i w Valid.Def
299−validateDestruct region pattern expr =
300− Valid.Destruct region pattern <$> expression expr
307−validateEffects :: Src.Effects -> [Valid.Port] -> Result i w Valid.Effects
308−validateEffects effects ports =
312− return Valid.NoEffects
315− return (Valid.Ports ports)
317− Src.Manager region manager ->
319− return $ Valid.Manager region $
331−noPorts :: [Valid.Port] -> Result i w ()
333− forM_ ports $ \(Valid.Port (A.At region name) _) ->
334− Result.throw (Error.UnexpectedPort region name)