@@ -1,18 +1,25 @@
11{-# OPTIONS_GHC -Wall #-}
2−module Validate (declarations) where
2+module Validate (Result, module') where
33
4−import Control.Monad (foldM)
4+import Prelude hiding (init)
5+import Control.Monad (foldM, when)
56import qualified Data.Map as Map
7+import qualified Data.Maybe as Maybe
68import qualified Data.Set as Set
79import qualified Data.Foldable as F
810import qualified Data.Traversable as T
911
1012import AST.Expression.General as Expr
13+import qualified AST.Effects as Effects
1114import qualified AST.Expression.Source as Source
1215import qualified AST.Expression.Valid as Valid
1316import qualified AST.Declaration as D
17+import qualified AST.Module as Module
18+import qualified AST.Module.Name as ModuleName
1419import qualified AST.Pattern as Pattern
1520import qualified AST.Type as Type
21+import qualified Elm.Compiler.Imports as Imports
22+import qualified Elm.Package as Package
1623import Elm.Utils ((|>))
1724import qualified Reporting.Annotation as A
1825import qualified Reporting.Error.Syntax as Error
@@ -20,163 +27,401 @@ import qualified Reporting.Region as R
2027import qualified Reporting.Result as Result
2128
2229
23−-- VALIDATE DECLARATIONS
2430
25−declarations
26− :: Bool
27− -> [D.SourceDecl]
28− -> Result.Result wrn Error.Error [D.ValidDecl]
29−declarations isRoot sourceDecls =
30− do validDecls <- validateDecls Nothing sourceDecls
31− (\_ _ -> validDecls)
32− <$> declDuplicates validDecls
33− <*> T.traverse (checkDecl isRoot) validDecls
34−
35−
36−validateDecls
37− :: Maybe String
38− -> [D.SourceDecl]
39− -> Result.Result wrn Error.Error [D.ValidDecl]
40−validateDecls maybeComment sourceDecls =
41− case sourceDecls of
31+type Result warning a =
32+ Result.Result () warning Error.Error a
33+
34+
35+
36+-- MODULES
37+
38+
39+module' :: Module.Source -> Result wrn Module.Valid
40+module' (Module.Module name path 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 path $
53+ Module.Valid docs exports (addDefaults pkgName imports) structure validEffects
54+
55+
56+
57+-- IMPORTS
58+
59+
60+addDefaults
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+
72+
73+
74+-- EFFECTS
75+
76+
77+validateEffects
78+ :: Module.SourceTag
79+ -> Module.SourceSettings
80+ -> [A.Commented Effects.PortRaw]
81+ -> [A.Commented Valid.Def]
82+ -> Result wrn 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+
90+ Module.Port _ ->
91+ do noSettings Error.SettingsOnPortModule settings
92+ return (Effects.Port ports)
93+
94+ Module.Effect tagRegion ->
95+ let
96+ collectSettings (A.A region setting, userValue) dict =
97+ Map.insertWith (++) setting [(region, userValue)] dict
98+
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+
107+
108+noSettings :: Error.Error -> Module.SourceSettings -> Result wrn ()
109+noSettings errorMsg (A.A region settings) =
110+ case settings of
42111 [] ->
43− return []
44−
45− sourceDecl : decls ->
46− case sourceDecl of
47− D.Comment comment ->
48− validateDecls (Just comment) decls
49−
50− D.Decl decl ->
51− validateDeclsHelp maybeComment decl decls
52−
53−
54−validateDeclsHelp
55− :: Maybe String
56− -> A.Located D.SourceDecl'
57− -> [D.SourceDecl]
58− -> Result.Result wrn Error.Error [D.ValidDecl]
59−validateDeclsHelp comment (A.A region decl) decls =
60− let addRest validDecl =
61− (:) (A.A (region, comment) validDecl)
62− <$> validateDecls Nothing decls
112+ Result.ok ()
113+
114+ _ : _ ->
115+ Result.throw region errorMsg
116+
117+
118+noPorts :: [A.Commented Effects.PortRaw] -> Result wrn ()
119+noPorts ports =
120+ case ports of
121+ [] ->
122+ Result.ok ()
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 String [(R.Region, A.Located String)]
135+ -> Result wrn Effects.ManagerType
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
63148 in
64− case decl of
65− D.Datatype name tvars ctors ->
66− addRest (D.Datatype name tvars ctors)
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)
67167
68− D.TypeAlias name tvars alias ->
69− addRest (D.TypeAlias name tvars alias)
70168
71− D.Fixity assoc prec op ->
72− addRest (D.Fixity assoc prec op)
169+extractOne
170+ :: String
171+ -> Map.Map String [(R.Region, A.Located String)]
172+ -> Result wrn (Maybe (A.Located String))
173+extractOne name settingsDict =
174+ case Map.lookup name settingsDict of
175+ Nothing ->
176+ return Nothing
73177
74− D.Definition def ->
75− defHelp comment def decls
178+ Just [] ->
179+ error "Empty lists should never be added to the dictionary of effect module settings."
76180
77− D.Port port ->
78− portHelp comment region port decls
181+ Just [(_, userType)] ->
182+ return (Just userType)
79183
184+ Just ((region, _) : _) ->
185+ Result.throw region (Error.DuplicateSettingOnEffectModule name)
80186
81−-- VALIDATE DEFINITIONS IN DECLARATIONS
82187
83−defHelp
84− :: Maybe String
85− -> Source.Def
86− -> [D.SourceDecl]
87− -> Result.Result wrn Error.Error [D.ValidDecl]
88−defHelp comment (A.A region def) decls =
89− let addRest def' rest =
90− (:) (A.A (region, comment) (D.Definition def'))
91− <$> validateDecls Nothing rest
188+
189+-- CHECK EFFECT MANAGER
190+
191+
192+checkManager
193+ :: R.Region
194+ -> Effects.ManagerType
195+ -> [A.Commented Valid.Def]
196+ -> Result wrn (R.Region, R.Region, R.Region)
197+checkManager tagRegion managerType validDefs =
198+ let
199+ regionDict =
200+ Map.fromList (Maybe.mapMaybe getSimpleDefRegion validDefs)
92201 in
93− case def of
94− Source.Definition pat expr ->
95− do expr' <- expression expr
96− let def' = Valid.Definition pat expr' Nothing
97− checkDefinition def'
98− addRest def' decls
99−
100− Source.TypeAnnotation name tipe ->
101− case decls of
102− D.Decl (A.A _ (D.Definition (A.A _
103− (Source.Definition pat@(A.A _ (Pattern.Var name')) expr)))) : rest
104− | name == name' ->
105− do expr' <- expression expr
106− let def' = Valid.Definition pat expr' (Just tipe)
107− checkDefinition def'
108− addRest def' rest
202+ const (,,)
203+ <$> requireMaps tagRegion regionDict managerType
204+ <*> requireRegion tagRegion regionDict "init"
205+ <*> requireRegion tagRegion regionDict "onEffects"
206+ <*> requireRegion tagRegion regionDict "onSelfMsg"
109207
110− _ ->
111− Result.throw region (Error.TypeWithoutDefinition name)
112208
209+getSimpleDefRegion :: A.Commented Valid.Def -> Maybe (String, R.Region)
210+getSimpleDefRegion decl =
211+ case decl of
212+ A.A (region, _) (Valid.Def (A.A _ (Pattern.Var name)) _ _) ->
213+ Just (name, region)
214+
215+ _ ->
216+ Nothing
113217
114−-- VALIDATE PORTS IN DECLARATIONS
115218
116−portHelp
117− :: Maybe String
118− -> R.Region
119− -> D.SourcePort
120− -> [D.SourceDecl]
121− -> Result.Result wrn Error.Error [D.ValidDecl]
122−portHelp comment region port decls =
123− let addRest port' rest =
124− (:) (A.A (region,comment) (D.Port port'))
125− <$> validateDecls Nothing rest
219+requireMaps
220+ :: R.Region
221+ -> Map.Map String R.Region
222+ -> Effects.ManagerType
223+ -> Result wrn ()
224+requireMaps tagRegion regionDict managerType =
225+ let
226+ check name =
227+ when (Map.notMember name regionDict) $
228+ Result.throw tagRegion (Error.MissingManagerOnEffectModule name)
126229 in
127− case port of
128− D.PortDefinition name _ ->
129− Result.throw region (Error.PortWithoutAnnotation name)
130−
131− D.PortAnnotation name tipe ->
132− case decls of
133− D.Decl (A.A _ (D.Port (D.PortDefinition name' expr))) : rest
134− | name == name' ->
135− do expr' <- expression expr
136− let port' = D.Out name expr' tipe
137− addRest port' rest
230+ case managerType of
231+ Effects.CmdManager _ ->
232+ check "cmdMap"
233+
234+ Effects.SubManager _ ->
235+ check "subMap"
236+
237+ Effects.FxManager _ _ ->
238+ check "cmdMap" <* check "subMap"
239+
240+
241+requireRegion :: R.Region -> Map.Map String R.Region -> String -> Result wrn R.Region
242+requireRegion tagRegion regionDict name =
243+ case Map.lookup name regionDict of
244+ Just region ->
245+ return region
246+
247+ Nothing ->
248+ Result.throw tagRegion (Error.MissingManagerOnEffectModule name)
249+
250+
251+
252+-- COLLAPSE COMMENTS
253+
254+
255+collapseComments :: [D.CommentOr (A.Located a)] -> Result wrn [A.Commented a]
256+collapseComments listWithComments =
257+ case listWithComments of
258+ [] ->
259+ Result.ok []
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+
273+ D.Whatever (A.A region a) : rest ->
274+ let
275+ entry =
276+ A.A (region, Nothing) a
277+ in
278+ fmap (entry:) (collapseComments rest)
279+
280+
281+
282+-- VALIDATE STRUCTURED SOURCE
283+
284+
285+validateDecls :: [D.Source] -> Result wrn ValidStuff
286+validateDecls sourceDecls =
287+ do rawDecls <- collapseComments sourceDecls
288+
289+ validStuff <- validateRawDecls rawDecls
290+
291+ let (D.Decls _ unions aliases _) = _structure validStuff
292+
293+ return validStuff
294+ <* F.traverse_ checkTypeVarsInUnion unions
295+ <* F.traverse_ checkTypeVarsInAlias aliases
296+ <* checkDuplicates validStuff
297+
298+
299+
300+-- VALIDATE DECLARATIONS
301+
302+
303+data ValidStuff =
304+ ValidStuff
305+ { _ports :: [A.Commented Effects.PortRaw]
306+ , _structure :: D.Valid
307+ }
308+
309+
310+validateRawDecls :: [A.Commented D.Raw] -> Result wrn ValidStuff
311+validateRawDecls commentedDecls =
312+ vrdHelp commentedDecls [] (D.Decls [] [] [] [])
313+
314+
315+vrdHelp
316+ :: [A.Commented D.Raw]
317+ -> [A.Commented Effects.PortRaw]
318+ -> D.Valid
319+ -> Result wrn ValidStuff
320+vrdHelp commentedDecls ports structure =
321+ case commentedDecls of
322+ [] ->
323+ Result.ok (ValidStuff ports structure)
324+
325+ A.A ann decl : rest ->
326+ 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+ vrdHelp rest (A.A ann (Effects.PortRaw name tipe) : ports) structure
341+
342+
343+vrdDefHelp
344+ :: [A.Commented D.Raw]
345+ -> A.Commented Source.Def'
346+ -> [A.Commented Effects.PortRaw]
347+ -> D.Valid
348+ -> Result wrn ValidStuff
349+vrdDefHelp remainingDecls (A.A ann def) ports structure =
350+ let
351+ addDef validDef (ValidStuff finalPorts struct) =
352+ ValidStuff finalPorts (D.addDef (A.A ann validDef) struct)
353+ in
354+ case def of
355+ Source.Definition pat expr ->
356+ addDef
357+ <$> validateDef pat expr Nothing
358+ <*> vrdHelp remainingDecls ports structure
359+
360+ Source.Annotation name tipe ->
361+ case remainingDecls of
362+ A.A _ (D.Def (A.A _ (Source.Definition pat expr))) : rest
363+ | Pattern.isVar name pat ->
364+ addDef
365+ <$> validateDef pat expr (Just tipe)
366+ <*> vrdHelp rest ports structure
138367
139368 _ ->
140− addRest (D.In name tipe) decls
369+ vrdHelp remainingDecls ports structure
370+ <* Result.throw (fst ann) (Error.TypeWithoutDefinition name)
371+
141372
142373
143374-- VALIDATE DEFINITIONS
144375
145−definitions :: [Source.Def] -> Result.Result wrn Error.Error [Valid.Def]
376+
377+definitions :: [Source.Def] -> Result wrn [Valid.Def]
146378definitions sourceDefs =
147379 do validDefs <- definitionsHelp sourceDefs
148− let patterns = map (\(Valid.Definition p _ _) -> p) validDefs
149− defDuplicates patterns
380+
381+ validDefs
382+ |> map Valid.getPattern
383+ |> concatMap Pattern.boundVars
384+ |> detectDuplicates Error.DuplicateDefinition
385+
150386 return validDefs
151387
152388
153−definitionsHelp :: [Source.Def] -> Result.Result wrn Error.Error [Valid.Def]
389+definitionsHelp :: [Source.Def] -> Result wrn [Valid.Def]
154390definitionsHelp sourceDefs =
155391 case sourceDefs of
156392 [] ->
157− return []
393+ return []
158394
159395 A.A _ (Source.Definition pat expr) : rest ->
160− do expr' <- expression expr
161− let def = Valid.Definition pat expr' Nothing
162− checkDefinition def
163− (:) def <$> definitionsHelp rest
164−
165− A.A region (Source.TypeAnnotation name tipe) : rest ->
166− case rest of
167− A.A _ (Source.Definition pat@(A.A _ (Pattern.Var name')) expr) : rest'
168− | name == name' ->
169− do expr' <- expression expr
170− let def = Valid.Definition pat expr' (Just tipe)
171− checkDefinition def
172− (:) def <$> definitionsHelp rest'
173−
174− _ ->
175− Result.throw region (Error.TypeWithoutDefinition name)
176−
177−
178−checkDefinition :: Valid.Def -> Result.Result wrn Error.Error ()
179−checkDefinition (Valid.Definition pattern body _) =
396+ (:)
397+ <$> validateDef pat expr Nothing
398+ <*> definitionsHelp rest
399+
400+ A.A region (Source.Annotation name tipe) : rest ->
401+ case rest of
402+ A.A _ (Source.Definition pat expr) : rest'
403+ | Pattern.isVar name pat ->
404+ (:)
405+ <$> validateDef pat expr (Just tipe)
406+ <*> definitionsHelp rest'
407+
408+ _ ->
409+ Result.throw region (Error.TypeWithoutDefinition name)
410+
411+
412+validateDef
413+ :: Pattern.Raw
414+ -> Source.Expr
415+ -> Maybe Type.Raw
416+ -> Result wrn Valid.Def
417+validateDef pat expr maybeType =
418+ do validExpr <- expression expr
419+ validateDefPattern pat validExpr
420+ return $ Valid.Def pat validExpr maybeType
421+
422+
423+validateDefPattern :: Pattern.Raw -> Valid.Expr -> Result wrn ()
424+validateDefPattern pattern body =
180425 case fst (Expr.collectLambdas body) of
181426 [] ->
182427 return ()
@@ -194,9 +439,11 @@ checkDefinition (Valid.Definition pattern body _) =
194439 Result.throw (R.merge start end) (Error.BadFunctionName (length args))
195440
196441
442+
197443-- VALIDATE EXPRESSIONS
198444
199−expression :: Source.Expr -> Result.Result wrn Error.Error Valid.Expr
445+
446+expression :: Source.Expr -> Result wrn Valid.Expr
200447expression (A.A ann sourceExpression) =
201448 A.A ann <$>
202449 case sourceExpression of
@@ -270,162 +517,144 @@ expression (A.A ann sourceExpression) =
270517 <$> definitions defs
271518 <*> expression body
272519
273− GLShader uid src gltipe ->
274− return (GLShader uid src gltipe)
520+ Cmd moduleName ->
521+ return (Cmd moduleName)
275522
276− Port impl ->
277− Port <$>
278− case impl of
279− In name tipe ->
280− return (In name tipe)
523+ Sub moduleName ->
524+ return (Sub moduleName)
281525
282− Out name expr tipe ->
283− do expr' <- expression expr
284− return (Out name expr' tipe)
526+ OutgoingPort name tipe ->
527+ return (OutgoingPort name tipe)
285528
286− Task name expr tipe ->
287− do expr' <- expression expr
288− return (Task name expr' tipe)
529+ IncomingPort name tipe ->
530+ return (IncomingPort name tipe)
289531
532+ Program _ _ ->
533+ error "DANGER - Program AST nodes should not be in validation phase."
290534
291−second :: (a, Source.Expr) -> Result.Result wrn Error.Error (a, Valid.Expr)
535+ SaveEnv moduleName effects ->
536+ return (SaveEnv moduleName effects)
537+
538+ GLShader uid src gltipe ->
539+ return (GLShader uid src gltipe)
540+
541+
542+second :: (a, Source.Expr) -> Result wrn (a, Valid.Expr)
292543second (value, expr) =
293544 (,) value <$> expression expr
294545
295546
296−both
297− :: (Source.Expr, Source.Expr)
298− -> Result.Result wrn Error.Error (Valid.Expr, Valid.Expr)
547+both :: (Source.Expr, Source.Expr) -> Result wrn (Valid.Expr, Valid.Expr)
299548both (expr1, expr2) =
300549 (,) <$> expression expr1 <*> expression expr2
301550
302551
552+
303553-- VALIDATE PATTERNS
304554
305−validatePattern :: Pattern.RawPattern -> Result.Result wrn Error.Error Pattern.RawPattern
555+
556+validatePattern :: Pattern.Raw -> Result wrn Pattern.Raw
306557validatePattern pattern =
307558 do detectDuplicates Error.BadPattern (Pattern.boundVars pattern)
308559 return pattern
309560
310561
311−-- DETECT DUPLICATES
312562
313−detectDuplicates
314− :: (String -> Error.Error)
315− -> [A.Located String]
316− -> Result.Result wrn Error.Error ()
317−detectDuplicates tag names =
318− let add (A.A region name) dict =
319− Map.insertWith (++) name [region] dict
563+-- DETECT DUPLICATES
320564
321− makeGroups pairs =
322− Map.toList (foldr add Map.empty pairs)
323565
324− check (name, regions) =
325− case regions of
326− _ : region : _ ->
327− Result.throw region (tag name)
566+checkDuplicates :: ValidStuff -> Result wrn ()
567+checkDuplicates (ValidStuff ports (D.Decls defs unions aliases _)) =
568+ let
569+ -- SIMPLE NAMES
328570
329− _ ->
330− return ()
331− in
332− F.traverse_ check (makeGroups names)
571+ defValues =
572+ concatMap (Pattern.boundVars . Valid.getPattern . A.drop) defs
333573
574+ portValues =
575+ map fromPort ports
334576
335−defDuplicates
336− :: [Pattern.RawPattern]
337− -> Result.Result wrn Error.Error ()
338−defDuplicates patterns =
339− concatMap Pattern.boundVars patterns
340− |> detectDuplicates Error.DuplicateDefinition
577+ fromPort (A.A (region, _) (Effects.PortRaw name _)) =
578+ A.A region name
341579
580+ -- TYPE NAMES
342581
343−declDuplicates :: [D.ValidDecl] -> Result.Result wrn Error.Error ()
344−declDuplicates decls =
345− let (valueLists, typeLists) = unzip (map extractValues decls)
346− in
347− (\_ _ -> ())
348− <$> detectDuplicates Error.DuplicateValueDeclaration (concat valueLists)
349− <*> detectDuplicates Error.DuplicateTypeDeclaration (concat typeLists)
582+ (types, typeValues) =
583+ unzip (map fromUnion unions ++ map fromAlias aliases)
350584
585+ fromUnion (A.A (region, _) (D.Type name _ ctors)) =
586+ ( A.A region name
587+ , map (A.A region . fst) ctors
588+ )
351589
352−extractValues :: D.ValidDecl -> ([A.Located String], [A.Located String])
353−extractValues (A.A (region, _) decl) =
354− case decl of
355− D.Definition (Valid.Definition pattern _ _) ->
356− ( Pattern.boundVars pattern
357− , []
358− )
590+ fromAlias (A.A (region, _) (D.Type name _ (A.A _ tipe))) =
591+ (,) (A.A region name) $
592+ case tipe of
593+ Type.RRecord _ _ ->
594+ [A.A region name]
359595
360− D.Datatype name _ ctors ->
361− ( map (A.A region . fst) ctors
362− , [A.A region name]
363− )
596+ _ ->
597+ []
598+ in
599+ F.sequenceA_
600+ [ detectDuplicates Error.DuplicateValueDeclaration (portValues ++ defValues)
601+ , detectDuplicates Error.DuplicateValueDeclaration (concat typeValues)
602+ , detectDuplicates Error.DuplicateTypeDeclaration types
603+ ]
364604
365− D.TypeAlias name _ (A.A _ (Type.RRecord _ _)) ->
366− ( [A.A region name]
367− , [A.A region name]
368− )
369605
370− D.TypeAlias name _ _ ->
371− ( []
372− , [A.A region name]
373− )
606+detectDuplicates :: (String -> Error.Error) -> [A.Located String] -> Result wrn ()
607+detectDuplicates tag names =
608+ let
609+ add (A.A region name) dict =
610+ Map.insertWith (++) name [region] dict
374611
375− D.Port port ->
376− ( [A.A region (D.validPortName port)]
377− , []
378− )
612+ makeGroups pairs =
613+ Map.toList (foldr add Map.empty pairs)
379614
380− D.Fixity _ _ _ ->
381− ( []
382− , []
383− )
615+ check (name, regions) =
616+ case regions of
617+ _ : region : _ ->
618+ Result.throw region (tag name)
384619
620+ _ ->
621+ return ()
622+ in
623+ F.traverse_ check (makeGroups names)
385624
386−-- UNBOUND TYPE VARIABLES
387625
388−checkDecl :: Bool -> D.ValidDecl -> Result.Result wrn Error.Error ()
389−checkDecl isRoot (A.A (region,_) decl) =
390− case decl of
391− D.Definition _ ->
392− return ()
393626
394− D.Datatype name boundVars ctors ->
395− case diff boundVars (concatMap freeVars (concatMap snd ctors)) of
396− (_, []) ->
397− return ()
627+-- UNBOUND TYPE VARIABLES
398628
399− (_, unbound) ->
400− Result.throw region
401− (Error.UnboundTypeVarsInUnion name boundVars unbound)
402629
403− D.TypeAlias name boundVars tipe ->
404− case diff boundVars (freeVars tipe) of
405− ([], []) ->
406− return ()
630+checkTypeVarsInUnion :: A.Commented (D.Union Type.Raw) -> Result wrn ()
631+checkTypeVarsInUnion (A.A (region,_) (D.Type name boundVars ctors)) =
632+ case diff boundVars (concatMap freeVars (concatMap snd ctors)) of
633+ (_, []) ->
634+ return ()
407635
408− ([], unbound) ->
409− Result.throw region
410− (Error.UnboundTypeVarsInAlias name boundVars unbound)
636+ (_, unbound) ->
637+ Result.throw region
638+ (Error.UnboundTypeVarsInUnion name boundVars unbound)
411639
412− (unused, []) ->
413− Result.throw region
414− (Error.UnusedTypeVarsInAlias name boundVars unused)
415640
416− (unused, unbound) ->
417− Result.throw region
418− (Error.MessyTypeVarsInAlias name boundVars unused unbound)
641+checkTypeVarsInAlias :: A.Commented (D.Alias Type.Raw) -> Result wrn ()
642+checkTypeVarsInAlias (A.A (region,_) (D.Type name boundVars tipe)) =
643+ case diff boundVars (freeVars tipe) of
644+ ([], []) ->
645+ return ()
419646
420− D.Port _ ->
421− if isRoot then
422− return ()
647+ ([], unbound) ->
648+ Result.throw region
649+ (Error.UnboundTypeVarsInAlias name boundVars unbound)
423650
424− else
425− Result.throw region Error.UnexpectedPort
651+ (unused, []) ->
652+ Result.throw region
653+ (Error.UnusedTypeVarsInAlias name boundVars unused)
426654
427− D.Fixity _ _ _ ->
428− return ()
655+ (unused, unbound) ->
656+ Result.throw region
657+ (Error.MessyTypeVarsInAlias name boundVars unused unbound)
429658
430659
431660diff :: [String] -> [A.Located String] -> ([String], [String])
@@ -442,23 +671,21 @@ diff left right =
442671 )
443672
444673
445−
446674freeVars :: Type.Raw -> [A.Located String]
447675freeVars (A.A region tipe) =
448− case tipe of
449− Type.RLambda t1 t2 ->
450− freeVars t1 ++ freeVars t2
451−
452− Type.RVar x ->
453− [A.A region x]
676+ case tipe of
677+ Type.RLambda t1 t2 ->
678+ freeVars t1 ++ freeVars t2
454679
455− Type.RType _ ->
456− []
680+ Type.RVar x ->
681+ [A.A region x]
457682
458− Type.RApp t ts ->
459− concatMap freeVars (t:ts)
683+ Type.RType _ ->
684+ []
460685
461− Type.RRecord fields ext ->
462− maybe [] freeVars ext
463− ++ concatMap (freeVars . snd) fields
686+ Type.RApp t ts ->
687+ concatMap freeVars (t:ts)
464688
689+ Type.RRecord fields ext ->
690+ maybe [] freeVars ext
691+ ++ concatMap (freeVars . snd) fields