git.iko.soy/elk
on master help sign in
Simplify validation phase a bunch
5fab52aEvan Czaplicki
src/Validate.hs+186−588
compare with master
unifiedsplit
@@ -2,25 +2,16 @@
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Validate (Result, validate) where
3module Validate (Result, validate) where
4
4
5−import Control.Monad (foldM_, when)
5+import Control.Applicative (liftA2)
6−import qualified Data.Foldable as F
6+import Control.Monad (forM_)
7import qualified Data.Map as Map
7import qualified Data.Map as Map
8−import qualified Data.Maybe as Maybe
9−import qualified Data.Set as Set
10import Data.Text (Text)
8import Data.Text (Text)
11
9
12−import qualified AST.Effects as Effects
13import qualified AST.Expression.Source as Src
10import qualified AST.Expression.Source as Src
14−import qualified AST.Declaration as D
11+import qualified AST.Expression.Valid as Valid
15−import qualified AST.Literal as L
16−import qualified AST.Module as Module
17−import qualified AST.Module.Name as ModuleName
18import qualified AST.Pattern as Pattern
12import qualified AST.Pattern as Pattern
19import qualified AST.Type as Type
13import qualified AST.Type as Type
20−import qualified AST.Variable as Var
14+import qualified Elm.Name as N
21−import qualified Elm.Compiler.Imports as Imports
22−import qualified Elm.Package as Package
23−import Elm.Utils ((|>))
24import qualified Reporting.Annotation as A
15import qualified Reporting.Annotation as A
25import qualified Reporting.Error.Syntax as Error
16import qualified Reporting.Error.Syntax as Error
26import qualified Reporting.Region as R
17import qualified Reporting.Region as R
@@ -28,688 +19,295 @@ import qualified Reporting.Result as Result
28
19
29
20
30
21
31−type Result warning a =
32− Result.Result () warning Error.Error a
33−
34−
35−
36−-- MODULES
37−
38−
39−validate :: Module.Source -> Result w Module.Valid
40−validate (Module.Module name info) =
41− let
42− (ModuleName.Canonical pkgName _) =
43− name
44−
45− (Module.Source tag settings docs exports imports decls) =
46− info
47− in
48− do (ValidStuff ports structure) <- validateDecls decls
49−
50− validEffects <- validateEffects tag settings ports (D._defs structure)
51−
52− return $ Module.Module name $
53− Module.Valid docs exports (addDefaults pkgName imports) structure validEffects
54−
55−
56−
57−-- IMPORTS
58−
59
22
60−addDefaults
23+-- VALIDATE
61− :: Package.Name
62− -> [Module.UserImport]
63− -> ([Module.DefaultImport], [Module.UserImport])
64−addDefaults pkgName imports =
65− flip (,) imports $
66− if pkgName == Package.core then
67− []
68−
69− else
70− Imports.defaults
71
24
72
25
26+type Result warning a =
27+ Result.Result () warning Error.Error a
73
28
74−-- EFFECTS
75
29
30+validate :: Src.Module [Src.Decl] -> Result w Valid.Module
31+validate (Src.Module name srcEffects overview exports imports srcDecls) =
32+ do (Stuff decls unions aliases binops ports docs) <- validateDecls srcDecls
33+ effects <- validateEffects srcEffects ports
34+ return $ Valid.Module name overview docs exports imports decls unions aliases binops effects
76
35
77−validateEffects
78− :: Module.SourceTag
79− -> Module.SourceSettings
80− -> [A.Commented Effects.PortRaw]
81− -> [A.Commented Src.ValidDef]
82− -> Result w Effects.Raw
83−validateEffects tag settings@(A.A _ pairs) ports validDefs =
84− case tag of
85− Module.Normal ->
86− do noSettings Error.SettingsOnNormalModule settings
87− noPorts ports
88− return Effects.None
89
36
90− Module.Port _ ->
91− do noSettings Error.SettingsOnPortModule settings
92− return (Effects.Port ports)
93
37
94− Module.Effect tagRegion ->
38+-- VALIDATE DECLARATIONS
95− let
96− collectSettings (A.A region setting, userValue) dict =
97− Map.insertWith (++) setting [(region, userValue)] dict
98
39
99− settingsDict =
100− foldr collectSettings Map.empty pairs
101− in
102− do noPorts ports
103− managerType <- toManagerType tagRegion settingsDict
104− (r0, r1, r2) <- checkManager tagRegion managerType validDefs
105− return (Effects.Manager () (Effects.Info tagRegion r0 r1 r2 managerType))
106
40
41+data Stuff =
42+ Stuff
43+ { _decls :: [Valid.Decl]
44+ , _unions :: [Valid.Union]
45+ , _aliases :: [Valid.Alias]
46+ , _binops :: [Valid.Binop]
47+ , _ports :: [Valid.Port]
48+ , _docs :: Map.Map N.Name Text
49+ }
107
50
108−noSettings :: Error.Error -> Module.SourceSettings -> Result w ()
109−noSettings errorMsg (A.A region settings) =
110− case settings of
111− [] ->
112− Result.ok ()
113
51
114− _ : _ ->
52+validateDecls :: [Src.Decl] -> Result w Stuff
115− Result.throw region errorMsg
53+validateDecls decls =
54+ vsdHelp decls (Stuff [] [] [] [] [] Map.empty)
116
55
117
56
118−noPorts :: [A.Commented Effects.PortRaw] -> Result w ()
57+vsdHelp :: [Src.Decl] -> Stuff -> Result w Stuff
119−noPorts ports =
58+vsdHelp decls stuff =
120− case ports of
59+ case decls of
121 [] ->
60 [] ->
122− Result.ok ()
61+ Result.ok stuff
123−
124− _ : _ ->
125− let
126− toError (A.A (region, _) (Effects.PortRaw name _)) =
127− A.A region (Error.UnexpectedPort name)
128− in
129− Result.throwMany (map toError ports)
130−
131−
132−toManagerType
133− :: R.Region
134− -> Map.Map Text [(R.Region, A.Located Text)]
135− -> Result w Effects.RawManagerType
136−toManagerType tagRegion settingsDict =
137− let
138− toErrors name entries =
139− map (\entry -> A.A (fst entry) (Error.BadSettingOnEffectModule name)) entries
140−
141− errors =
142− settingsDict
143− |> Map.delete "command"
144− |> Map.delete "subscription"
145− |> Map.mapWithKey toErrors
146− |> Map.elems
147− |> concat
148− in
149− do when (not (null errors)) (Result.throwMany errors)
150− maybeEffects <-
151− (,) <$> extractOne "command" settingsDict
152− <*> extractOne "subscription" settingsDict
153−
154− -- TODO check that cmd and sub types exist?
155− case maybeEffects of
156− (Nothing, Nothing) ->
157− Result.throw tagRegion Error.NoSettingsOnEffectModule
158−
159− (Just cmd, Nothing) ->
160− return (Effects.CmdManager cmd)
161−
162− (Nothing, Just sub) ->
163− return (Effects.SubManager sub)
164−
165− (Just cmd, Just sub) ->
166− return (Effects.FxManager cmd sub)
167−
168−
169−extractOne
170− :: Text
171− -> Map.Map Text [(R.Region, A.Located Text)]
172− -> Result w (Maybe (A.Located Text))
173−extractOne name settingsDict =
174− case Map.lookup name settingsDict of
175− Nothing ->
176− return Nothing
177−
178− Just [] ->
179− error "Empty lists should never be added to the dictionary of effect module settings."
180−
181− Just [(_, userType)] ->
182− return (Just userType)
183−
184− Just ((region, _) : _) ->
185− Result.throw region (Error.DuplicateSettingOnEffectModule name)
186−
187−
188−
189−-- CHECK EFFECT MANAGER
190−
191−
192−checkManager
193− :: R.Region
194− -> Effects.RawManagerType
195− -> [A.Commented Src.ValidDef]
196− -> Result w (R.Region, R.Region, R.Region)
197−checkManager tagRegion managerType validDefs =
198− let
199− regionDict =
200− Map.fromList (Maybe.mapMaybe getSimpleDefRegion validDefs)
201− in
202− const (,,)
203− <$> requireMaps tagRegion regionDict managerType
204− <*> requireRegion tagRegion regionDict "init"
205− <*> requireRegion tagRegion regionDict "onEffects"
206− <*> requireRegion tagRegion regionDict "onSelfMsg"
207−
208−
209−getSimpleDefRegion :: A.Commented Src.ValidDef -> Maybe (Text, R.Region)
210−getSimpleDefRegion decl =
211− case decl of
212− A.A _ (Src.Def region (A.A _ (Pattern.Var name)) _ _) ->
213− Just (name, region)
214−
215− _ ->
216− Nothing
217
62
63+ A.A _ decl : otherDecls ->
64+ case decl of
65+ Src.Union name tvars ctors ->
66+ do let union = Valid.Union name tvars ctors
67+ vsdHelp otherDecls $ stuff { _unions = union : _unions stuff }
218
68
219−requireMaps
69+ Src.Alias name tvars tipe ->
220− :: R.Region
70+ do let alias = Valid.Alias name tvars tipe
221− -> Map.Map Text R.Region
71+ vsdHelp otherDecls $ stuff { _aliases = alias : _aliases stuff }
222− -> Effects.RawManagerType
223− -> Result w ()
224−requireMaps tagRegion regionDict managerType =
225− let
226− check name =
227− when (Map.notMember name regionDict) $
228− Result.throw tagRegion (Error.MissingManagerOnEffectModule name)
229− in
230− case managerType of
231− Effects.CmdManager _ ->
232− check "cmdMap"
233
72
234− Effects.SubManager _ ->
73+ Src.Binop op assoc prec val ->
235− check "subMap"
74+ do let binop = Valid.Binop op assoc prec val
75+ vsdHelp otherDecls $ stuff { _binops = binop : _binops stuff }
236
76
237− Effects.FxManager _ _ ->
77+ Src.Port name tipe ->
238− check "cmdMap" <* check "subMap"
78+ do let port_ = Valid.Port name tipe
79+ vsdHelp otherDecls $ stuff { _ports = port_ : _ports stuff }
239
80
81+ Src.Docs docs ->
82+ validateDocs docs otherDecls stuff
240
83
241−requireRegion :: R.Region -> Map.Map Text R.Region -> Text -> Result w R.Region
84+ Src.Annotation (A.A _ name) tipe ->
242−requireRegion tagRegion regionDict name =
85+ validateAnnotation name tipe otherDecls stuff
243− case Map.lookup name regionDict of
244− Just region ->
245− return region
246
86
247− Nothing ->
87+ Src.Definition name args body ->
248− Result.throw tagRegion (Error.MissingManagerOnEffectModule name)
88+ do validBody <- expression body
89+ let validDecl = Valid.Decl name args validBody Nothing
90+ vsdHelp otherDecls $ stuff { _decls = validDecl : _decls stuff }
249
91
250
92
251
93
252−-- COLLAPSE COMMENTS
94+-- VALIDATE DOCS
253
95
254
96
255−collapseComments :: [D.CommentOr (A.Located a)] -> Result w [A.Commented a]
97+validateDocs :: Text -> [Src.Decl] -> Stuff -> Result w Stuff
256−collapseComments listWithComments =
98+validateDocs docs decls stuff =
257− case listWithComments of
99+ case decls of
258 [] ->
100 [] ->
259− Result.ok []
101+ error "TODO no docs on nothing"
260−
261− D.Comment (A.A _ msg) : D.Whatever (A.A region a) : rest ->
262− let
263− entry =
264− A.A (region, Just msg) a
265− in
266− fmap (entry:) (collapseComments rest)
267−
268− D.Comment (A.A region _) : rest ->
269− collapseComments rest
270− <* Result.throw region Error.CommentOnNothing
271−
272
102
273− D.Whatever (A.A region a) : rest ->
103+ A.A _ decl : _ ->
274− let
104+ do name <- getNameForDocs decl
275− entry =
105+ vsdHelp decls $ stuff { _docs = Map.insert name docs (_docs stuff) }
276− A.A (region, Nothing) a
277− in
278− fmap (entry:) (collapseComments rest)
279
106
280
107
108+getNameForDocs :: Src.Decl_ -> Result w N.Name
109+getNameForDocs decl =
110+ case decl of
111+ Src.Union (A.A _ name) _ _ ->
112+ return name
281
113
282−-- VALIDATE STRUCTURED SOURCE
114+ Src.Alias (A.A _ name) _ _ ->
283−
115+ return name
284−
285−validateDecls :: [D.Source] -> Result w ValidStuff
286−validateDecls sourceDecls =
287− do rawDecls <- collapseComments sourceDecls
288−
289− validStuff <- validateRawDecls rawDecls
290−
291− let (D.Decls _ unions aliases _) = _structure validStuff
292
116
293− return validStuff
117+ Src.Binop _ _ _ _ ->
294− <* F.traverse_ checkTypeVarsInUnion unions
118+ error "TODO no docs on binop"
295− <* F.traverse_ checkTypeVarsInAlias aliases
296− <* checkDuplicates validStuff
297
119
120+ Src.Port _ _ ->
121+ error "TODO no docs on ports"
298
122
123+ Src.Docs _ ->
124+ error "TODO no docs on docs"
299
125
300−-- VALIDATE DECLARATIONS
126+ Src.Annotation (A.A _ name) _ ->
127+ return name
301
128
129+ Src.Definition (A.A _ name) _ _ ->
130+ return name
302
131
303−data ValidStuff =
304− ValidStuff
305− { _ports :: [A.Commented Effects.PortRaw]
306− , _structure :: D.Valid
307− }
308
132
309
133
310−validateRawDecls :: [A.Commented D.Raw] -> Result w ValidStuff
134+-- VALIDATE ANNOTATION
311−validateRawDecls commentedDecls =
312− vrdHelp commentedDecls [] (D.Decls [] [] [] [])
313
135
314
136
315−vrdHelp
137+validateAnnotation :: N.Name -> Type.Raw -> [Src.Decl] -> Stuff -> Result w Stuff
316− :: [A.Commented D.Raw]
138+validateAnnotation annotationName tipe decls stuff =
317− -> [A.Commented Effects.PortRaw]
139+ case decls of
318− -> D.Valid
319− -> Result w ValidStuff
320−vrdHelp commentedDecls ports structure =
321− case commentedDecls of
322 [] ->
140 [] ->
323− Result.ok (ValidStuff ports structure)
141+ error "TODO no attotations on nothing"
324
142
325− A.A ann decl : rest ->
143+ A.A _ decl : otherDecls ->
326 case decl of
144 case decl of
327− D.Union (D.Type name tvars ctors) ->
328− vrdHelp rest ports (D.addUnion (A.A ann (D.Type name tvars ctors)) structure)
329−
330− D.Alias (D.Type name tvars alias) ->
331− vrdHelp rest ports (D.addAlias (A.A ann (D.Type name tvars alias)) structure)
332−
333− D.Fixity fixity ->
334− vrdHelp rest ports (D.addInfix fixity structure)
335−
336− D.Def (A.A region def) ->
337− vrdDefHelp rest (A.A (region, snd ann) def) ports structure
338−
339− D.Port name tipe ->
340− do checkDuplicateFieldsInType tipe
341− vrdHelp rest (A.A ann (Effects.PortRaw name tipe) : ports) structure
342−
343−
344−vrdDefHelp
345− :: [A.Commented D.Raw]
346− -> A.Commented Src.RawDef'
347− -> [A.Commented Effects.PortRaw]
348− -> D.Valid
349− -> Result w ValidStuff
350−vrdDefHelp remainingDecls (A.A ann def) ports structure =
351− let
352− addDef validDef (ValidStuff finalPorts struct) =
353− ValidStuff finalPorts (D.addDef (A.A ann validDef) struct)
354− in
355− case def of
356− Src.Definition pat expr ->
145+ Src.Definition name@(A.A _ definitionName) args body ->
357− addDef
146+ if annotationName == definitionName then
358− <$> validateDef (fst ann) pat expr Nothing
147+ do validBody <- expression body
359− <*> vrdHelp remainingDecls ports structure
148+ let validDecl = Valid.Decl name args validBody (Just tipe)
360−
149+ vsdHelp otherDecls $ stuff { _decls = validDecl : _decls stuff }
361− Src.Annotation name tipe ->
362− case remainingDecls of
363− A.A _ (D.Def (A.A defRegion (Src.Definition pat expr))) : rest
364− | Pattern.isVar name pat ->
365− addDef
366− <$> validateDef (R.merge (fst ann) defRegion) pat expr (Just tipe)
367− <*> vrdHelp rest ports structure
368−
369− _ ->
370− vrdHelp remainingDecls ports structure
371− <* Result.throw (fst ann) (Error.TypeWithoutDefinition name)
372−
373−
374−
375−-- VALIDATE DEFINITIONS
376−
377−
378−definitions :: [Src.RawDef] -> Result w [Src.ValidDef]
379−definitions sourceDefs =
380− do validDefs <- definitionsHelp sourceDefs
381−
382− validDefs
383− |> map Src.getPattern
384− |> concatMap Pattern.boundVars
385− |> detectDuplicates Error.DuplicateDefinition
386−
387− return validDefs
388−
389
150
390−definitionsHelp :: [Src.RawDef] -> Result w [Src.ValidDef]
151+ else
391−definitionsHelp sourceDefs =
152+ error "TODO annotation does not match following definition"
392− case sourceDefs of
393− [] ->
394− return []
395−
396− A.A defRegion (Src.Definition pat expr) : rest ->
397− (:)
398− <$> validateDef defRegion pat expr Nothing
399− <*> definitionsHelp rest
400−
401− A.A annRegion (Src.Annotation name tipe) : rest ->
402− case rest of
403− A.A defRegion (Src.Definition pat expr) : rest'
404− | Pattern.isVar name pat ->
405− (:)
406− <$> validateDef (R.merge annRegion defRegion) pat expr (Just tipe)
407− <*> definitionsHelp rest'
408
153
409 _ ->
154 _ ->
410− Result.throw annRegion (Error.TypeWithoutDefinition name)
155+ error "TODO annotation needs to be on a definition"
411−
412−
413−validateDef
414− :: R.Region
415− -> Pattern.Raw
416− -> Src.RawExpr
417− -> Maybe Type.Raw
418− -> Result w Src.ValidDef
419−validateDef region pat expr maybeType =
420− do validExpr <- expression expr
421− validateDefPattern pat validExpr
422− F.traverse_ checkDuplicateFieldsInType maybeType
423− return $ Src.Def region pat validExpr maybeType
424−
425−
426−validateDefPattern :: Pattern.Raw -> Src.ValidExpr -> Result w ()
427−validateDefPattern pattern body =
428− case fst (Src.collectLambdas body) of
429− [] ->
430− return ()
431−
432− args ->
433− case pattern of
434− A.A _ (Pattern.Var funcName) ->
435− checkArguments funcName args
436−
437− _ ->
438− let
439− (A.A start _) = pattern
440− (A.A end _) = last args
441− in
442− Result.throw (R.merge start end) (Error.BadFunctionName (length args))
443−
444−
445−checkArguments :: Text -> [Pattern.Raw] -> Result w ()
446−checkArguments funcName args =
447− let
448− vars =
449− concatMap Pattern.boundVars args
450−
451− checkDups seenArgs (A.A region arg) =
452− if Set.member arg seenArgs then
453− Result.throw region (Error.DuplicateArgument funcName arg)
454−
455− else
456− return (Set.insert arg seenArgs)
457− in
458− foldM_ checkDups Set.empty vars
459
156
460
157
461
158
462-- VALIDATE EXPRESSIONS
159-- VALIDATE EXPRESSIONS
463
160
464
161
465−expression :: Src.RawExpr -> Result w Src.ValidExpr
162+expression :: Src.Expr -> Result w Valid.Expr
466−expression (A.A ann sourceExpression) =
163+expression (A.A region sourceExpression) =
467− A.A ann <$>
164+ A.A region <$>
468 case sourceExpression of
165 case sourceExpression of
469− Src.Var (Var.Raw "True") ->
166+ Src.Var prefix name ->
470− return (Src.Literal (L.Boolean True))
167+ pure (Valid.Var prefix name)
471
168
472− Src.Var (Var.Raw "False") ->
169+ Src.Lambda pattern body ->
473− return (Src.Literal (L.Boolean False))
170+ Valid.Lambda pattern <$> expression body
474
171
475− Src.Var x ->
172+ Src.Op name ->
476− return (Src.Var x)
173+ pure (Valid.Op name)
477
174
478− Src.Lambda pattern body ->
175+ Src.Negate expr ->
479− Src.Lambda
480− <$> validatePattern pattern
481− <*> expression body
176+ Valid.Negate <$> expression expr
482
177
483− Src.Binop ops lastExpr ->
178+ Src.Binops ops lastExpr ->
484− Src.Binop
179+ Valid.Binops
485 <$> traverse (\(expr,op) -> (,) <$> expression expr <*> pure op) ops
180 <$> traverse (\(expr,op) -> (,) <$> expression expr <*> pure op) ops
486 <*> expression lastExpr
181 <*> expression lastExpr
487
182
488− Src.Case e branches ->
183+ Src.Case expr branches ->
489− Src.Case
184+ Valid.Case
490− <$> expression e
185+ <$> expression expr
491− <*> traverse (\(p,b) -> (,) <$> validatePattern p <*> expression b) branches
186+ <*> traverse (traverse expression) branches
492−
493− Src.Ctor name args ->
494− Src.Ctor name <$> traverse expression args
495
187
496 Src.Literal lit ->
188 Src.Literal lit ->
497− return (Src.Literal lit)
189+ pure (Valid.Literal lit)
498
190
499− Src.List expressions ->
191+ Src.List exprs ->
500− Src.List
501− <$> traverse expression expressions
192+ Valid.List <$> traverse expression exprs
502
193
503− Src.App funcExpr argExpr ->
194+ Src.Call func args ->
504− Src.App
195+ Valid.Call
505− <$> expression funcExpr
196+ <$> expression func
506− <*> expression argExpr
197+ <*> traverse expression args
507
198
508 Src.If branches finally ->
199 Src.If branches finally ->
509− Src.If
200+ Valid.If
510 <$> traverse both branches
201 <$> traverse both branches
511 <*> expression finally
202 <*> expression finally
512
203
204+ Src.Accessor field ->
205+ pure (Valid.Accessor field)
206+
513 Src.Access record field ->
207 Src.Access record field ->
514− Src.Access
208+ Valid.Access
515 <$> expression record
209 <$> expression record
516− <*> return field
210+ <*> pure field
517
211
518 Src.Update record fields ->
212 Src.Update record fields ->
519− do checkDuplicateFields ann fields
520− Src.Update <$> expression record <*> traverse second fields
213+ Valid.Update record <$> traverse (traverse expression) fields
521
214
522 Src.Record fields ->
215 Src.Record fields ->
523− do checkDuplicateFields ann fields
524− Src.Record <$> traverse second fields
216+ Valid.Record <$> traverse (traverse expression) fields
217+
218+ Src.Unit ->
219+ pure Valid.Unit
220+
221+ Src.Tuple a b cs ->
222+ Valid.Tuple
223+ <$> expression a
224+ <*> expression b
225+ <*> traverse expression cs
525
226
526 Src.Let defs body ->
227 Src.Let defs body ->
527− Src.Let
228+ Valid.Let
528 <$> definitions defs
229 <$> definitions defs
529 <*> expression body
230 <*> expression body
530
231
531 Src.GLShader uid src gltipe ->
232 Src.GLShader uid src gltipe ->
532− return (Src.GLShader uid src gltipe)
233+ pure (Valid.GLShader uid src gltipe)
533−
534−
535−second :: (a, Src.RawExpr) -> Result w (a, Src.ValidExpr)
536−second (value, expr) =
537− (,) value <$> expression expr
538−
539−
540−both :: (Src.RawExpr, Src.RawExpr) -> Result w (Src.ValidExpr, Src.ValidExpr)
541−both (expr1, expr2) =
542− (,) <$> expression expr1 <*> expression expr2
543−
544−
545−checkDuplicateFields :: R.Region -> [(A.Located Text, a)] -> Result w ()
546−checkDuplicateFields recordRegion fields =
547− let
548− checkDups seenFields ( A.A region field, _ ) =
549− if Set.member field seenFields then
550− Result.throw recordRegion (Error.DuplicateFieldName region field)
551− else
552− Result.ok (Set.insert field seenFields)
553− in
554− foldM_ checkDups Set.empty fields
555−
556−
557−
558−-- VALIDATE PATTERNS
559−
560
234
561−validatePattern :: Pattern.Raw -> Result w Pattern.Raw
562−validatePattern pattern =
563− do detectDuplicates Error.BadPattern (Pattern.boundVars pattern)
564− return pattern
565
235
236+both :: (Src.Expr, Src.Expr) -> Result w (Valid.Expr, Valid.Expr)
237+both (a, b) =
238+ liftA2 (,) (expression a) (expression b)
566
239
567
240
568−-- DETECT DUPLICATES
569
241
242+-- VALIDATE DEFINITIONS
570
243
571−checkDuplicates :: ValidStuff -> Result w ()
572−checkDuplicates (ValidStuff ports (D.Decls defs unions aliases _)) =
573− let
574− -- SIMPLE NAMES
575−
576− defValues =
577− concatMap (Pattern.boundVars . Src.getPattern . A.drop) defs
578−
579− portValues =
580− map fromPort ports
581−
582− fromPort (A.A (region, _) (Effects.PortRaw name _)) =
583− A.A region name
584−
585− -- TYPE NAMES
586−
587− (types, typeValues) =
588− unzip (map fromUnion unions ++ map fromAlias aliases)
589−
590− fromUnion (A.A (region, _) (D.Type name _ ctors)) =
591− ( A.A region name
592− , map (A.A region . fst) ctors
593− )
594−
595− fromAlias (A.A (region, _) (D.Type name _ (A.A _ tipe))) =
596− (,) (A.A region name) $
597− case tipe of
598− Type.RRecord _ _ ->
599− [A.A region name]
600−
601− _ ->
602− []
603− in
604− F.sequenceA_
605− [ detectDuplicates Error.DuplicateValueDeclaration (portValues ++ defValues)
606− , detectDuplicates Error.DuplicateValueDeclaration (concat typeValues)
607− , detectDuplicates Error.DuplicateTypeDeclaration types
608− ]
609
244
245+definitions :: [A.Located Src.Def] -> Result w [Valid.Def]
246+definitions sourceDefs =
247+ case sourceDefs of
248+ [] ->
249+ return []
610
250
611−detectDuplicates :: (Text -> Error.Error) -> [A.Located Text] -> Result w ()
251+ A.A region (Src.Destruct pattern expr) : otherDefs ->
612−detectDuplicates tag names =
252+ (:)
613− let
253+ <$> validateDestruct region pattern expr
614− add (A.A region name) dict =
254+ <*> definitions otherDefs
615− Map.insertWith (++) name [region] dict
616
255
617− makeGroups pairs =
256+ A.A region (Src.Define name args expr) : otherDefs ->
618− Map.toList (foldr add Map.empty pairs)
257+ (:)
258+ <$> validateDefinition region name args expr Nothing
259+ <*> definitions otherDefs
619
260
620− check (name, regions) =
261+ A.A annRegion (Src.Annotate annotationName tipe) : otherDefs ->
621− case regions of
262+ case otherDefs of
622− _ : region : _ ->
263+ A.A defRegion (Src.Define name args expr) : otherOtherDefs | name == annotationName ->
623− Result.throw region (tag name)
264+ (:)
265+ <$> validateDefinition (R.merge annRegion defRegion) name args expr (Just tipe)
266+ <*> definitions otherOtherDefs
624
267
625 _ ->
268 _ ->
626− return ()
269+ Result.throw annRegion (Error.TypeWithoutDefinition annotationName)
627− in
628− F.traverse_ check (makeGroups names)
629−
630−
631−
632−-- UNBOUND TYPE VARIABLES
633−
634−
635−checkTypeVarsInUnion :: A.Commented (D.Union Type.Raw) -> Result w ()
636−checkTypeVarsInUnion (A.A (region,_) (D.Type name boundVars ctors)) =
637− do allFreeVars <- concat <$> traverse freeVars (concatMap snd ctors)
638− case diff boundVars allFreeVars of
639− (_, []) ->
640− return ()
641
270
642− (_, unbound) ->
643− Result.throw region
644− (Error.UnboundTypeVarsInUnion name boundVars unbound)
645
271
646−
272+validateDefinition :: R.Region -> Text -> [Pattern.Raw] -> Src.Expr -> Maybe Type.Raw -> Result w Valid.Def
647−checkTypeVarsInAlias :: A.Commented (D.Alias Type.Raw) -> Result w ()
273+validateDefinition region name args expr maybeType =
648−checkTypeVarsInAlias (A.A (region,_) (D.Type name boundVars tipe)) =
274+ do validExpr <- expression expr
649− do allFreeVars <- freeVars tipe
275+ return $ Valid.Define region name args validExpr maybeType
650− case diff boundVars allFreeVars of
651− ([], []) ->
652− return ()
653−
654− ([], unbound) ->
655− Result.throw region
656− (Error.UnboundTypeVarsInAlias name boundVars unbound)
657−
658− (unused, []) ->
659− Result.throw region
660− (Error.UnusedTypeVarsInAlias name boundVars unused)
661−
662− (unused, unbound) ->
663− Result.throw region
664− (Error.MessyTypeVarsInAlias name boundVars unused unbound)
665
276
666
277
667−diff :: [Text] -> [A.Located Text] -> ([Text], [Text])
278+validateDestruct :: R.Region -> Pattern.Raw -> Src.Expr -> Result w Valid.Def
668−diff left right =
279+validateDestruct region pattern expr =
669− let
280+ Valid.Destruct region pattern <$> expression expr
670− leftSet =
671− Set.fromList left
672
281
673− rightSet =
674− Set.fromList (map A.drop right)
675− in
676− ( Set.toList (Set.difference leftSet rightSet)
677− , Set.toList (Set.difference rightSet leftSet)
678− )
679
282
680
283
681−freeVars :: Type.Raw -> Result w [A.Located Text]
284+-- VALIDATE EFFECTS
682−freeVars (A.A region tipe) =
683− case tipe of
684− Type.RLambda t1 t2 ->
685− (++) <$> freeVars t1 <*> freeVars t2
686
285
687− Type.RVar x ->
688− Result.ok [A.A region x]
689
286
690− Type.RType _ args ->
287+validateEffects :: Src.Effects -> [Valid.Port] -> Result w Valid.Effects
691− concat <$> traverse freeVars args
288+validateEffects effects ports =
289+ case effects of
290+ Src.NoEffects ->
291+ do noPorts ports
292+ return Valid.NoEffects
692
293
693− Type.RRecord fields ext ->
294+ Src.Ports _ ->
694− do checkDuplicateFields region fields
295+ return (Valid.Ports ports)
695− let types = Maybe.maybeToList ext ++ map snd fields
696− concat <$> traverse freeVars types
697
296
297+ Src.Effects _ manager ->
298+ do noPorts ports
299+ case manager of
300+ Src.Cmd cmd ->
301+ return (Valid.Cmd cmd)
698
302
699−checkDuplicateFieldsInType :: Type.Raw -> Result w ()
303+ Src.Sub sub ->
700−checkDuplicateFieldsInType (A.A region tipe) =
304+ return (Valid.Sub sub)
701− case tipe of
702− Type.RLambda t1 t2 ->
703− checkDuplicateFieldsInType t1
704− <* checkDuplicateFieldsInType t2
705
305
706− Type.RVar _ ->
306+ Src.Fx cmd sub ->
707− Result.ok ()
307+ return (Valid.Fx cmd sub)
708
308
709− Type.RType _ args ->
710− F.traverse_ checkDuplicateFieldsInType args
711
309
712− Type.RRecord fields ext ->
310+noPorts :: [Valid.Port] -> Result w ()
713− do checkDuplicateFields region fields
311+noPorts ports =
714− let types = Maybe.maybeToList ext ++ map snd fields
312+ forM_ ports $ \(Valid.Port (A.A region name) _) ->
715− F.traverse_ checkDuplicateFieldsInType types
313+ Result.throw region (Error.UnexpectedPort name)