never executed always true always false
1
2 {-# LANGUAGE FlexibleContexts #-}
3 {-# LANGUAGE ScopedTypeVariables #-}
4 {-# LANGUAGE TypeFamilies #-}
5
6 {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
7 {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
8
9 {-
10 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
11
12 Main pass of renamer
13 -}
14
15 module GHC.Rename.Module (
16 rnSrcDecls, addTcgDUs, findSplice
17 ) where
18
19 import GHC.Prelude
20
21 import {-# SOURCE #-} GHC.Rename.Expr( rnLExpr )
22 import {-# SOURCE #-} GHC.Rename.Splice ( rnSpliceDecl, rnTopSpliceDecls )
23
24 import GHC.Hs
25 import GHC.Types.Error
26 import GHC.Types.FieldLabel
27 import GHC.Types.Name.Reader
28 import GHC.Rename.HsType
29 import GHC.Rename.Bind
30 import GHC.Rename.Env
31 import GHC.Rename.Utils ( HsDocContext(..), mapFvRn, bindLocalNames
32 , checkDupRdrNamesN, bindLocalNamesFV
33 , checkShadowedRdrNames, warnUnusedTypePatterns
34 , newLocalBndrsRn
35 , withHsDocContext, noNestedForallsContextsErr
36 , addNoNestedForallsContextsErr, checkInferredVars )
37 import GHC.Rename.Unbound ( mkUnboundName, notInScopeErr, WhereLooking(WL_Global) )
38 import GHC.Rename.Names
39 import GHC.Tc.Errors.Types
40 import GHC.Tc.Gen.Annotation ( annCtxt )
41 import GHC.Tc.Utils.Monad
42
43 import GHC.Types.ForeignCall ( CCallTarget(..) )
44 import GHC.Unit
45 import GHC.Unit.Module.Warnings
46 import GHC.Builtin.Names( applicativeClassName, pureAName, thenAName
47 , monadClassName, returnMName, thenMName
48 , semigroupClassName, sappendName
49 , monoidClassName, mappendName
50 )
51 import GHC.Types.Name
52 import GHC.Types.Name.Set
53 import GHC.Types.Name.Env
54 import GHC.Types.Avail
55 import GHC.Utils.Outputable
56 import GHC.Data.Bag
57 import GHC.Types.Basic ( pprRuleName, TypeOrKind(..) )
58 import GHC.Data.FastString
59 import GHC.Types.SrcLoc as SrcLoc
60 import GHC.Driver.Session
61 import GHC.Utils.Misc ( lengthExceeds, partitionWith )
62 import GHC.Utils.Panic
63 import GHC.Driver.Env ( HscEnv(..), hsc_home_unit)
64 import GHC.Data.List.SetOps ( findDupsEq, removeDups, equivClasses )
65 import GHC.Data.Graph.Directed ( SCC, flattenSCC, flattenSCCs, Node(..)
66 , stronglyConnCompFromEdgedVerticesUniq )
67 import GHC.Types.Unique.Set
68 import GHC.Data.OrdList
69 import qualified GHC.LanguageExtensions as LangExt
70
71 import Control.Monad
72 import Control.Arrow ( first )
73 import Data.List ( mapAccumL )
74 import qualified Data.List.NonEmpty as NE
75 import Data.List.NonEmpty ( NonEmpty(..) )
76 import Data.Maybe ( isNothing, fromMaybe, mapMaybe )
77 import qualified Data.Set as Set ( difference, fromList, toList, null )
78 import Data.Function ( on )
79
80 {- | @rnSourceDecl@ "renames" declarations.
81 It simultaneously performs dependency analysis and precedence parsing.
82 It also does the following error checks:
83
84 * Checks that tyvars are used properly. This includes checking
85 for undefined tyvars, and tyvars in contexts that are ambiguous.
86 (Some of this checking has now been moved to module @TcMonoType@,
87 since we don't have functional dependency information at this point.)
88
89 * Checks that all variable occurrences are defined.
90
91 * Checks the @(..)@ etc constraints in the export list.
92
93 Brings the binders of the group into scope in the appropriate places;
94 does NOT assume that anything is in scope already
95 -}
96 rnSrcDecls :: HsGroup GhcPs -> RnM (TcGblEnv, HsGroup GhcRn)
97 -- Rename a top-level HsGroup; used for normal source files *and* hs-boot files
98 rnSrcDecls group@(HsGroup { hs_valds = val_decls,
99 hs_splcds = splice_decls,
100 hs_tyclds = tycl_decls,
101 hs_derivds = deriv_decls,
102 hs_fixds = fix_decls,
103 hs_warnds = warn_decls,
104 hs_annds = ann_decls,
105 hs_fords = foreign_decls,
106 hs_defds = default_decls,
107 hs_ruleds = rule_decls,
108 hs_docs = docs })
109 = do {
110 -- (A) Process the top-level fixity declarations, creating a mapping from
111 -- FastStrings to FixItems. Also checks for duplicates.
112 -- See Note [Top-level fixity signatures in an HsGroup] in GHC.Hs.Decls
113 local_fix_env <- makeMiniFixityEnv $ hsGroupTopLevelFixitySigs group ;
114
115 -- (B) Bring top level binders (and their fixities) into scope,
116 -- *except* for the value bindings, which get done in step (D)
117 -- with collectHsIdBinders. However *do* include
118 --
119 -- * Class ops, data constructors, and record fields,
120 -- because they do not have value declarations.
121 --
122 -- * For hs-boot files, include the value signatures
123 -- Again, they have no value declarations
124 --
125 (tc_envs, tc_bndrs) <- getLocalNonValBinders local_fix_env group ;
126
127
128 setEnvs tc_envs $ do {
129
130 failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations
131
132 -- (D1) Bring pattern synonyms into scope.
133 -- Need to do this before (D2) because rnTopBindsLHS
134 -- looks up those pattern synonyms (#9889)
135
136 dup_fields_ok <- xopt_DuplicateRecordFields <$> getDynFlags ;
137 has_sel <- xopt_FieldSelectors <$> getDynFlags ;
138 extendPatSynEnv dup_fields_ok has_sel val_decls local_fix_env $ \pat_syn_bndrs -> do {
139
140 -- (D2) Rename the left-hand sides of the value bindings.
141 -- This depends on everything from (B) being in scope.
142 -- It uses the fixity env from (A) to bind fixities for view patterns.
143
144 -- We need to throw an error on such value bindings when in a boot file.
145 is_boot <- tcIsHsBootOrSig ;
146 new_lhs <- if is_boot
147 then rnTopBindsLHSBoot local_fix_env val_decls
148 else rnTopBindsLHS local_fix_env val_decls ;
149
150 -- Bind the LHSes (and their fixities) in the global rdr environment
151 let { id_bndrs = collectHsIdBinders CollNoDictBinders new_lhs } ;
152 -- Excludes pattern-synonym binders
153 -- They are already in scope
154 traceRn "rnSrcDecls" (ppr id_bndrs) ;
155 tc_envs <- extendGlobalRdrEnvRn (map avail id_bndrs) local_fix_env ;
156 setEnvs tc_envs $ do {
157
158 -- Now everything is in scope, as the remaining renaming assumes.
159
160 -- (E) Rename type and class decls
161 -- (note that value LHSes need to be in scope for default methods)
162 --
163 -- You might think that we could build proper def/use information
164 -- for type and class declarations, but they can be involved
165 -- in mutual recursion across modules, and we only do the SCC
166 -- analysis for them in the type checker.
167 -- So we content ourselves with gathering uses only; that
168 -- means we'll only report a declaration as unused if it isn't
169 -- mentioned at all. Ah well.
170 traceRn "Start rnTyClDecls" (ppr tycl_decls) ;
171 (rn_tycl_decls, src_fvs1) <- rnTyClDecls tycl_decls ;
172
173 -- (F) Rename Value declarations right-hand sides
174 traceRn "Start rnmono" empty ;
175 let { val_bndr_set = mkNameSet id_bndrs `unionNameSet` mkNameSet pat_syn_bndrs } ;
176 (rn_val_decls, bind_dus) <- if is_boot
177 -- For an hs-boot, use tc_bndrs (which collects how we're renamed
178 -- signatures), since val_bndr_set is empty (there are no x = ...
179 -- bindings in an hs-boot.)
180 then rnTopBindsBoot tc_bndrs new_lhs
181 else rnValBindsRHS (TopSigCtxt val_bndr_set) new_lhs ;
182 traceRn "finish rnmono" (ppr rn_val_decls) ;
183
184 -- (G) Rename Fixity and deprecations
185
186 -- Rename fixity declarations and error if we try to
187 -- fix something from another module (duplicates were checked in (A))
188 let { all_bndrs = tc_bndrs `unionNameSet` val_bndr_set } ;
189 rn_fix_decls <- mapM (mapM (rnSrcFixityDecl (TopSigCtxt all_bndrs)))
190 fix_decls ;
191
192 -- Rename deprec decls;
193 -- check for duplicates and ensure that deprecated things are defined locally
194 -- at the moment, we don't keep these around past renaming
195 rn_warns <- rnSrcWarnDecls all_bndrs warn_decls ;
196
197 -- (H) Rename Everything else
198
199 (rn_rule_decls, src_fvs2) <- setXOptM LangExt.ScopedTypeVariables $
200 rnList rnHsRuleDecls rule_decls ;
201 -- Inside RULES, scoped type variables are on
202 (rn_foreign_decls, src_fvs3) <- rnList rnHsForeignDecl foreign_decls ;
203 (rn_ann_decls, src_fvs4) <- rnList rnAnnDecl ann_decls ;
204 (rn_default_decls, src_fvs5) <- rnList rnDefaultDecl default_decls ;
205 (rn_deriv_decls, src_fvs6) <- rnList rnSrcDerivDecl deriv_decls ;
206 (rn_splice_decls, src_fvs7) <- rnList rnSpliceDecl splice_decls ;
207
208 last_tcg_env <- getGblEnv ;
209 -- (I) Compute the results and return
210 let {rn_group = HsGroup { hs_ext = noExtField,
211 hs_valds = rn_val_decls,
212 hs_splcds = rn_splice_decls,
213 hs_tyclds = rn_tycl_decls,
214 hs_derivds = rn_deriv_decls,
215 hs_fixds = rn_fix_decls,
216 hs_warnds = [], -- warns are returned in the tcg_env
217 -- (see below) not in the HsGroup
218 hs_fords = rn_foreign_decls,
219 hs_annds = rn_ann_decls,
220 hs_defds = rn_default_decls,
221 hs_ruleds = rn_rule_decls,
222 hs_docs = docs } ;
223
224 tcf_bndrs = hsTyClForeignBinders rn_tycl_decls rn_foreign_decls ;
225 other_def = (Just (mkNameSet tcf_bndrs), emptyNameSet) ;
226 other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs3, src_fvs4,
227 src_fvs5, src_fvs6, src_fvs7] ;
228 -- It is tiresome to gather the binders from type and class decls
229
230 src_dus = unitOL other_def `plusDU` bind_dus `plusDU` usesOnly other_fvs ;
231 -- Instance decls may have occurrences of things bound in bind_dus
232 -- so we must put other_fvs last
233
234 final_tcg_env = let tcg_env' = (last_tcg_env `addTcgDUs` src_dus)
235 in -- we return the deprecs in the env, not in the HsGroup above
236 tcg_env' { tcg_warns = tcg_warns tcg_env' `plusWarns` rn_warns };
237 } ;
238 traceRn "finish rnSrc" (ppr rn_group) ;
239 traceRn "finish Dus" (ppr src_dus ) ;
240 return (final_tcg_env, rn_group)
241 }}}}
242
243 addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv
244 -- This function could be defined lower down in the module hierarchy,
245 -- but there doesn't seem anywhere very logical to put it.
246 addTcgDUs tcg_env dus = tcg_env { tcg_dus = tcg_dus tcg_env `plusDU` dus }
247
248 rnList :: (a -> RnM (b, FreeVars)) -> [LocatedA a] -> RnM ([LocatedA b], FreeVars)
249 rnList f xs = mapFvRn (wrapLocFstMA f) xs
250
251 {-
252 *********************************************************
253 * *
254 Source-code deprecations declarations
255 * *
256 *********************************************************
257
258 Check that the deprecated names are defined, are defined locally, and
259 that there are no duplicate deprecations.
260
261 It's only imported deprecations, dealt with in RnIfaces, that we
262 gather them together.
263 -}
264
265 -- checks that the deprecations are defined locally, and that there are no duplicates
266 rnSrcWarnDecls :: NameSet -> [LWarnDecls GhcPs] -> RnM Warnings
267 rnSrcWarnDecls _ []
268 = return NoWarnings
269
270 rnSrcWarnDecls bndr_set decls'
271 = do { -- check for duplicates
272 ; mapM_ (\ dups -> let ((L loc rdr) :| (lrdr':_)) = dups
273 in addErrAt (locA loc) (TcRnDuplicateWarningDecls lrdr' rdr))
274 warn_rdr_dups
275 ; pairs_s <- mapM (addLocMA rn_deprec) decls
276 ; return (WarnSome ((concat pairs_s))) }
277 where
278 decls = concatMap (wd_warnings . unLoc) decls'
279
280 sig_ctxt = TopSigCtxt bndr_set
281
282 rn_deprec (Warning _ rdr_names txt)
283 -- ensures that the names are defined locally
284 = do { names <- concatMapM (lookupLocalTcNames sig_ctxt what . unLoc)
285 rdr_names
286 ; return [(rdrNameOcc rdr, txt) | (rdr, _) <- names] }
287
288 what = text "deprecation"
289
290 warn_rdr_dups = findDupRdrNames
291 $ concatMap (\(L _ (Warning _ ns _)) -> ns) decls
292
293 findDupRdrNames :: [LocatedN RdrName] -> [NonEmpty (LocatedN RdrName)]
294 findDupRdrNames = findDupsEq (\ x -> \ y -> rdrNameOcc (unLoc x) == rdrNameOcc (unLoc y))
295
296 -- look for duplicates among the OccNames;
297 -- we check that the names are defined above
298 -- invt: the lists returned by findDupsEq always have at least two elements
299
300 {-
301 *********************************************************
302 * *
303 \subsection{Annotation declarations}
304 * *
305 *********************************************************
306 -}
307
308 rnAnnDecl :: AnnDecl GhcPs -> RnM (AnnDecl GhcRn, FreeVars)
309 rnAnnDecl ann@(HsAnnotation _ s provenance expr)
310 = addErrCtxt (annCtxt ann) $
311 do { (provenance', provenance_fvs) <- rnAnnProvenance provenance
312 ; (expr', expr_fvs) <- setStage (Splice Untyped) $
313 rnLExpr expr
314 ; return (HsAnnotation noAnn s provenance' expr',
315 provenance_fvs `plusFV` expr_fvs) }
316
317 rnAnnProvenance :: AnnProvenance GhcPs
318 -> RnM (AnnProvenance GhcRn, FreeVars)
319 rnAnnProvenance provenance = do
320 provenance' <- case provenance of
321 ValueAnnProvenance n -> ValueAnnProvenance
322 <$> lookupLocatedTopBndrRnN n
323 TypeAnnProvenance n -> TypeAnnProvenance
324 <$> lookupLocatedTopConstructorRnN n
325 ModuleAnnProvenance -> return ModuleAnnProvenance
326 return (provenance', maybe emptyFVs unitFV (annProvenanceName_maybe provenance'))
327
328 {-
329 *********************************************************
330 * *
331 \subsection{Default declarations}
332 * *
333 *********************************************************
334 -}
335
336 rnDefaultDecl :: DefaultDecl GhcPs -> RnM (DefaultDecl GhcRn, FreeVars)
337 rnDefaultDecl (DefaultDecl _ tys)
338 = do { (tys', fvs) <- rnLHsTypes doc_str tys
339 ; return (DefaultDecl noExtField tys', fvs) }
340 where
341 doc_str = DefaultDeclCtx
342
343 {-
344 *********************************************************
345 * *
346 \subsection{Foreign declarations}
347 * *
348 *********************************************************
349 -}
350
351 rnHsForeignDecl :: ForeignDecl GhcPs -> RnM (ForeignDecl GhcRn, FreeVars)
352 rnHsForeignDecl (ForeignImport { fd_name = name, fd_sig_ty = ty, fd_fi = spec })
353 = do { topEnv :: HscEnv <- getTopEnv
354 ; name' <- lookupLocatedTopBndrRnN name
355 ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) TypeLevel ty
356
357 -- Mark any PackageTarget style imports as coming from the current package
358 ; let home_unit = hsc_home_unit topEnv
359 spec' = patchForeignImport (homeUnitAsUnit home_unit) spec
360
361 ; return (ForeignImport { fd_i_ext = noExtField
362 , fd_name = name', fd_sig_ty = ty'
363 , fd_fi = spec' }, fvs) }
364
365 rnHsForeignDecl (ForeignExport { fd_name = name, fd_sig_ty = ty, fd_fe = spec })
366 = do { name' <- lookupLocatedOccRn name
367 ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) TypeLevel ty
368 ; return (ForeignExport { fd_e_ext = noExtField
369 , fd_name = name', fd_sig_ty = ty'
370 , fd_fe = spec }
371 , fvs `addOneFV` unLoc name') }
372 -- NB: a foreign export is an *occurrence site* for name, so
373 -- we add it to the free-variable list. It might, for example,
374 -- be imported from another module
375
376 -- | For Windows DLLs we need to know what packages imported symbols are from
377 -- to generate correct calls. Imported symbols are tagged with the current
378 -- package, so if they get inlined across a package boundary we'll still
379 -- know where they're from.
380 --
381 patchForeignImport :: Unit -> ForeignImport -> ForeignImport
382 patchForeignImport unit (CImport cconv safety fs spec src)
383 = CImport cconv safety fs (patchCImportSpec unit spec) src
384
385 patchCImportSpec :: Unit -> CImportSpec -> CImportSpec
386 patchCImportSpec unit spec
387 = case spec of
388 CFunction callTarget -> CFunction $ patchCCallTarget unit callTarget
389 _ -> spec
390
391 patchCCallTarget :: Unit -> CCallTarget -> CCallTarget
392 patchCCallTarget unit callTarget =
393 case callTarget of
394 StaticTarget src label Nothing isFun
395 -> StaticTarget src label (Just unit) isFun
396 _ -> callTarget
397
398 {-
399 *********************************************************
400 * *
401 \subsection{Instance declarations}
402 * *
403 *********************************************************
404 -}
405
406 rnSrcInstDecl :: InstDecl GhcPs -> RnM (InstDecl GhcRn, FreeVars)
407 rnSrcInstDecl (TyFamInstD { tfid_inst = tfi })
408 = do { (tfi', fvs) <- rnTyFamInstDecl (NonAssocTyFamEqn NotClosedTyFam) tfi
409 ; return (TyFamInstD { tfid_ext = noExtField, tfid_inst = tfi' }, fvs) }
410
411 rnSrcInstDecl (DataFamInstD { dfid_inst = dfi })
412 = do { (dfi', fvs) <- rnDataFamInstDecl (NonAssocTyFamEqn NotClosedTyFam) dfi
413 ; return (DataFamInstD { dfid_ext = noExtField, dfid_inst = dfi' }, fvs) }
414
415 rnSrcInstDecl (ClsInstD { cid_inst = cid })
416 = do { traceRn "rnSrcIstDecl {" (ppr cid)
417 ; (cid', fvs) <- rnClsInstDecl cid
418 ; traceRn "rnSrcIstDecl end }" empty
419 ; return (ClsInstD { cid_d_ext = noExtField, cid_inst = cid' }, fvs) }
420
421 -- | Warn about non-canonical typeclass instance declarations
422 --
423 -- A "non-canonical" instance definition can occur for instances of a
424 -- class which redundantly defines an operation its superclass
425 -- provides as well (c.f. `return`/`pure`). In such cases, a canonical
426 -- instance is one where the subclass inherits its method
427 -- implementation from its superclass instance (usually the subclass
428 -- has a default method implementation to that effect). Consequently,
429 -- a non-canonical instance occurs when this is not the case.
430 --
431 -- See also descriptions of 'checkCanonicalMonadInstances' and
432 -- 'checkCanonicalMonoidInstances'
433 checkCanonicalInstances :: Name -> LHsSigType GhcRn -> LHsBinds GhcRn -> RnM ()
434 checkCanonicalInstances cls poly_ty mbinds = do
435 whenWOptM Opt_WarnNonCanonicalMonadInstances
436 $ checkCanonicalMonadInstances
437 "https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/monad-of-no-return"
438
439 whenWOptM Opt_WarnNonCanonicalMonoidInstances
440 $ checkCanonicalMonoidInstances
441 "https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/semigroup-monoid"
442
443 where
444 -- | Warn about unsound/non-canonical 'Applicative'/'Monad' instance
445 -- declarations. Specifically, the following conditions are verified:
446 --
447 -- In 'Monad' instances declarations:
448 --
449 -- * If 'return' is overridden it must be canonical (i.e. @return = pure@)
450 -- * If '(>>)' is overridden it must be canonical (i.e. @(>>) = (*>)@)
451 --
452 -- In 'Applicative' instance declarations:
453 --
454 -- * Warn if 'pure' is defined backwards (i.e. @pure = return@).
455 -- * Warn if '(*>)' is defined backwards (i.e. @(*>) = (>>)@).
456 --
457 checkCanonicalMonadInstances refURL
458 | cls == applicativeClassName =
459 forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpanA loc $
460 case mbind of
461 FunBind { fun_id = L _ name
462 , fun_matches = mg }
463 | name == pureAName, isAliasMG mg == Just returnMName
464 -> addWarnNonCanonicalMethod1 refURL
465 Opt_WarnNonCanonicalMonadInstances "pure" "return"
466
467 | name == thenAName, isAliasMG mg == Just thenMName
468 -> addWarnNonCanonicalMethod1 refURL
469 Opt_WarnNonCanonicalMonadInstances "(*>)" "(>>)"
470
471 _ -> return ()
472
473 | cls == monadClassName =
474 forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpanA loc $
475 case mbind of
476 FunBind { fun_id = L _ name
477 , fun_matches = mg }
478 | name == returnMName, isAliasMG mg /= Just pureAName
479 -> addWarnNonCanonicalMethod2 refURL
480 Opt_WarnNonCanonicalMonadInstances "return" "pure"
481
482 | name == thenMName, isAliasMG mg /= Just thenAName
483 -> addWarnNonCanonicalMethod2 refURL
484 Opt_WarnNonCanonicalMonadInstances "(>>)" "(*>)"
485
486 _ -> return ()
487
488 | otherwise = return ()
489
490 -- | Check whether Monoid(mappend) is defined in terms of
491 -- Semigroup((<>)) (and not the other way round). Specifically,
492 -- the following conditions are verified:
493 --
494 -- In 'Monoid' instances declarations:
495 --
496 -- * If 'mappend' is overridden it must be canonical
497 -- (i.e. @mappend = (<>)@)
498 --
499 -- In 'Semigroup' instance declarations:
500 --
501 -- * Warn if '(<>)' is defined backwards (i.e. @(<>) = mappend@).
502 --
503 checkCanonicalMonoidInstances refURL
504 | cls == semigroupClassName =
505 forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpanA loc $
506 case mbind of
507 FunBind { fun_id = L _ name
508 , fun_matches = mg }
509 | name == sappendName, isAliasMG mg == Just mappendName
510 -> addWarnNonCanonicalMethod1 refURL
511 Opt_WarnNonCanonicalMonoidInstances "(<>)" "mappend"
512
513 _ -> return ()
514
515 | cls == monoidClassName =
516 forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpanA loc $
517 case mbind of
518 FunBind { fun_id = L _ name
519 , fun_matches = mg }
520 | name == mappendName, isAliasMG mg /= Just sappendName
521 -> addWarnNonCanonicalMethod2 refURL
522 Opt_WarnNonCanonicalMonoidInstances
523 "mappend" "(<>)"
524
525 _ -> return ()
526
527 | otherwise = return ()
528
529 -- | test whether MatchGroup represents a trivial \"lhsName = rhsName\"
530 -- binding, and return @Just rhsName@ if this is the case
531 isAliasMG :: MatchGroup GhcRn (LHsExpr GhcRn) -> Maybe Name
532 isAliasMG MG {mg_alts = (L _ [L _ (Match { m_pats = []
533 , m_grhss = grhss })])}
534 | GRHSs _ [L _ (GRHS _ [] body)] lbinds <- grhss
535 , EmptyLocalBinds _ <- lbinds
536 , HsVar _ lrhsName <- unLoc body = Just (unLoc lrhsName)
537 isAliasMG _ = Nothing
538
539 -- got "lhs = rhs" but expected something different
540 addWarnNonCanonicalMethod1 refURL flag lhs rhs = do
541 let dia = TcRnUnknownMessage $
542 mkPlainDiagnostic (WarningWithFlag flag) noHints $
543 vcat [ text "Noncanonical" <+>
544 quotes (text (lhs ++ " = " ++ rhs)) <+>
545 text "definition detected"
546 , instDeclCtxt1 poly_ty
547 , text "Move definition from" <+>
548 quotes (text rhs) <+>
549 text "to" <+> quotes (text lhs)
550 , text "See also:" <+>
551 text refURL
552 ]
553 addDiagnostic dia
554
555 -- expected "lhs = rhs" but got something else
556 addWarnNonCanonicalMethod2 refURL flag lhs rhs = do
557 let dia = TcRnUnknownMessage $
558 mkPlainDiagnostic (WarningWithFlag flag) noHints $
559 vcat [ text "Noncanonical" <+>
560 quotes (text lhs) <+>
561 text "definition detected"
562 , instDeclCtxt1 poly_ty
563 , quotes (text lhs) <+>
564 text "will eventually be removed in favour of" <+>
565 quotes (text rhs)
566 , text "Either remove definition for" <+>
567 quotes (text lhs) <+> text "(recommended)" <+>
568 text "or define as" <+>
569 quotes (text (lhs ++ " = " ++ rhs))
570 , text "See also:" <+>
571 text refURL
572 ]
573 addDiagnostic dia
574
575 -- stolen from GHC.Tc.TyCl.Instance
576 instDeclCtxt1 :: LHsSigType GhcRn -> SDoc
577 instDeclCtxt1 hs_inst_ty
578 = inst_decl_ctxt (ppr (getLHsInstDeclHead hs_inst_ty))
579
580 inst_decl_ctxt :: SDoc -> SDoc
581 inst_decl_ctxt doc = hang (text "in the instance declaration for")
582 2 (quotes doc <> text ".")
583
584
585 rnClsInstDecl :: ClsInstDecl GhcPs -> RnM (ClsInstDecl GhcRn, FreeVars)
586 rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds
587 , cid_sigs = uprags, cid_tyfam_insts = ats
588 , cid_overlap_mode = oflag
589 , cid_datafam_insts = adts })
590 = do { checkInferredVars ctxt inf_err inst_ty
591 ; (inst_ty', inst_fvs) <- rnHsSigType ctxt TypeLevel inst_ty
592 ; let (ktv_names, _, head_ty') = splitLHsInstDeclTy inst_ty'
593 -- Check if there are any nested `forall`s or contexts, which are
594 -- illegal in the type of an instance declaration (see
595 -- Note [No nested foralls or contexts in instance types] in
596 -- GHC.Hs.Type)...
597 mb_nested_msg = noNestedForallsContextsErr
598 (text "Instance head") head_ty'
599 -- ...then check if the instance head is actually headed by a
600 -- class type constructor...
601 eith_cls = case hsTyGetAppHead_maybe head_ty' of
602 Just (L _ cls) -> Right cls
603 Nothing -> Left
604 ( getLocA head_ty'
605 , hang (text "Illegal head of an instance declaration:"
606 <+> quotes (ppr head_ty'))
607 2 (vcat [ text "Instance heads must be of the form"
608 , nest 2 $ text "C ty_1 ... ty_n"
609 , text "where" <+> quotes (char 'C')
610 <+> text "is a class"
611 ])
612 )
613 -- ...finally, attempt to retrieve the class type constructor, failing
614 -- with an error message if there isn't one. To avoid excessive
615 -- amounts of error messages, we will only report one of the errors
616 -- from mb_nested_msg or eith_cls at a time.
617 ; cls <- case (mb_nested_msg, eith_cls) of
618 (Nothing, Right cls) -> pure cls
619 (Just err1, _) -> bail_out err1
620 (_, Left err2) -> bail_out err2
621
622 -- Rename the bindings
623 -- The typechecker (not the renamer) checks that all
624 -- the bindings are for the right class
625 -- (Slightly strangely) when scoped type variables are on, the
626 -- forall-d tyvars scope over the method bindings too
627 ; (mbinds', uprags', meth_fvs) <- rnMethodBinds False cls ktv_names mbinds uprags
628
629 ; checkCanonicalInstances cls inst_ty' mbinds'
630
631 -- Rename the associated types, and type signatures
632 -- Both need to have the instance type variables in scope
633 ; traceRn "rnSrcInstDecl" (ppr inst_ty' $$ ppr ktv_names)
634 ; ((ats', adts'), more_fvs)
635 <- bindLocalNamesFV ktv_names $
636 do { (ats', at_fvs) <- rnATInstDecls rnTyFamInstDecl cls ktv_names ats
637 ; (adts', adt_fvs) <- rnATInstDecls rnDataFamInstDecl cls ktv_names adts
638 ; return ( (ats', adts'), at_fvs `plusFV` adt_fvs) }
639
640 ; let all_fvs = meth_fvs `plusFV` more_fvs
641 `plusFV` inst_fvs
642 ; return (ClsInstDecl { cid_ext = noExtField
643 , cid_poly_ty = inst_ty', cid_binds = mbinds'
644 , cid_sigs = uprags', cid_tyfam_insts = ats'
645 , cid_overlap_mode = oflag
646 , cid_datafam_insts = adts' },
647 all_fvs) }
648 -- We return the renamed associated data type declarations so
649 -- that they can be entered into the list of type declarations
650 -- for the binding group, but we also keep a copy in the instance.
651 -- The latter is needed for well-formedness checks in the type
652 -- checker (eg, to ensure that all ATs of the instance actually
653 -- receive a declaration).
654 -- NB: Even the copies in the instance declaration carry copies of
655 -- the instance context after renaming. This is a bit
656 -- strange, but should not matter (and it would be more work
657 -- to remove the context).
658 where
659 ctxt = GenericCtx $ text "an instance declaration"
660 inf_err = Just (text "Inferred type variables are not allowed")
661
662 -- The instance is malformed. We'd still like to make *some* progress
663 -- (rather than failing outright), so we report an error and continue for
664 -- as long as we can. Importantly, this error should be thrown before we
665 -- reach the typechecker, lest we encounter different errors that are
666 -- hopelessly confusing (such as the one in #16114).
667 bail_out (l, err_msg) = do
668 addErrAt l $ TcRnUnknownMessage $ mkPlainError noHints (withHsDocContext ctxt err_msg)
669 pure $ mkUnboundName (mkTcOccFS (fsLit "<class>"))
670
671 rnFamEqn :: HsDocContext
672 -> AssocTyFamInfo
673 -> FreeKiTyVars
674 -- ^ Additional kind variables to implicitly bind if there is no
675 -- explicit forall. (See the comments on @all_imp_vars@ below for a
676 -- more detailed explanation.)
677 -> FamEqn GhcPs rhs
678 -> (HsDocContext -> rhs -> RnM (rhs', FreeVars))
679 -> RnM (FamEqn GhcRn rhs', FreeVars)
680 rnFamEqn doc atfi extra_kvars
681 (FamEqn { feqn_tycon = tycon
682 , feqn_bndrs = outer_bndrs
683 , feqn_pats = pats
684 , feqn_fixity = fixity
685 , feqn_rhs = payload }) rn_payload
686 = do { tycon' <- lookupFamInstName mb_cls tycon
687
688 -- all_imp_vars represent the implicitly bound type variables. This is
689 -- empty if we have an explicit `forall` (see
690 -- Note [forall-or-nothing rule] in GHC.Hs.Type), which means
691 -- ignoring:
692 --
693 -- - pat_kity_vars, the free variables mentioned in the type patterns
694 -- on the LHS of the equation, and
695 -- - extra_kvars, which is one of the following:
696 -- * For type family instances, extra_kvars are the free kind
697 -- variables mentioned in an outermost kind signature on the RHS
698 -- of the equation.
699 -- (See Note [Implicit quantification in type synonyms] in
700 -- GHC.Rename.HsType.)
701 -- * For data family instances, extra_kvars are the free kind
702 -- variables mentioned in the explicit return kind, if one is
703 -- provided. (e.g., the `k` in `data instance T :: k -> Type`).
704 --
705 -- Some examples:
706 --
707 -- @
708 -- type family F a b
709 -- type instance forall a b c. F [(a, b)] c = a -> b -> c
710 -- -- all_imp_vars = []
711 -- type instance F [(a, b)] c = a -> b -> c
712 -- -- all_imp_vars = [a, b, c]
713 --
714 -- type family G :: Maybe a
715 -- type instance forall a. G = (Nothing :: Maybe a)
716 -- -- all_imp_vars = []
717 -- type instance G = (Nothing :: Maybe a)
718 -- -- all_imp_vars = [a]
719 --
720 -- data family H :: k -> Type
721 -- data instance forall k. H :: k -> Type where ...
722 -- -- all_imp_vars = []
723 -- data instance H :: k -> Type where ...
724 -- -- all_imp_vars = [k]
725 -- @
726 --
727 -- For associated type family instances, exclude the type variables
728 -- bound by the instance head with filterInScopeM (#19649).
729 ; all_imp_vars <- filterInScopeM $ pat_kity_vars ++ extra_kvars
730
731 ; bindHsOuterTyVarBndrs doc mb_cls all_imp_vars outer_bndrs $ \rn_outer_bndrs ->
732 do { (pats', pat_fvs) <- rnLHsTypeArgs (FamPatCtx tycon) pats
733 ; (payload', rhs_fvs) <- rn_payload doc payload
734
735 -- Report unused binders on the LHS
736 -- See Note [Unused type variables in family instances]
737 ; let -- The SrcSpan that bindHsOuterFamEqnTyVarBndrs will attach to each
738 -- implicitly bound type variable Name in outer_bndrs' will
739 -- span the entire type family instance, which will be reflected in
740 -- -Wunused-type-patterns warnings. We can be a little more precise
741 -- than that by pointing to the LHS of the instance instead, which
742 -- is what lhs_loc corresponds to.
743 rn_outer_bndrs' = mapHsOuterImplicit (map (`setNameLoc` lhs_loc))
744 rn_outer_bndrs
745
746 groups :: [NonEmpty (LocatedN RdrName)]
747 groups = equivClasses cmpLocated pat_kity_vars
748 ; nms_dups <- mapM (lookupOccRn . unLoc) $
749 [ tv | (tv :| (_:_)) <- groups ]
750 -- Add to the used variables
751 -- a) any variables that appear *more than once* on the LHS
752 -- e.g. F a Int a = Bool
753 -- b) for associated instances, the variables
754 -- of the instance decl. See
755 -- Note [Unused type variables in family instances]
756 ; let nms_used = extendNameSetList rhs_fvs $
757 nms_dups {- (a) -} ++ inst_head_tvs {- (b) -}
758 all_nms = hsOuterTyVarNames rn_outer_bndrs'
759 ; warnUnusedTypePatterns all_nms nms_used
760
761 -- For associated family instances, if a type variable from the
762 -- parent instance declaration is mentioned on the RHS of the
763 -- associated family instance but not bound on the LHS, then reject
764 -- that type variable as being out of scope.
765 -- See Note [Renaming associated types].
766 -- Per that Note, the LHS type variables consist of:
767 --
768 -- - The variables mentioned in the instance's type patterns
769 -- (pat_fvs), and
770 --
771 -- - The variables mentioned in an outermost kind signature on the
772 -- RHS. This is a subset of `rhs_fvs`. To compute it, we look up
773 -- each RdrName in `extra_kvars` to find its corresponding Name in
774 -- the LocalRdrEnv.
775 ; extra_kvar_nms <- mapMaybeM (lookupLocalOccRn_maybe . unLoc) extra_kvars
776 ; let lhs_bound_vars = pat_fvs `extendNameSetList` extra_kvar_nms
777 improperly_scoped cls_tkv =
778 cls_tkv `elemNameSet` rhs_fvs
779 -- Mentioned on the RHS...
780 && not (cls_tkv `elemNameSet` lhs_bound_vars)
781 -- ...but not bound on the LHS.
782 bad_tvs = filter improperly_scoped inst_head_tvs
783 ; unless (null bad_tvs) (badAssocRhs bad_tvs)
784
785 ; let eqn_fvs = rhs_fvs `plusFV` pat_fvs
786 -- See Note [Type family equations and occurrences]
787 all_fvs = case atfi of
788 NonAssocTyFamEqn ClosedTyFam
789 -> eqn_fvs
790 _ -> eqn_fvs `addOneFV` unLoc tycon'
791
792 ; return (FamEqn { feqn_ext = noAnn
793 , feqn_tycon = tycon'
794 -- Note [Wildcards in family instances]
795 , feqn_bndrs = rn_outer_bndrs'
796 , feqn_pats = pats'
797 , feqn_fixity = fixity
798 , feqn_rhs = payload' },
799 all_fvs) } }
800 where
801 -- The parent class, if we are dealing with an associated type family
802 -- instance.
803 mb_cls = case atfi of
804 NonAssocTyFamEqn _ -> Nothing
805 AssocTyFamDeflt cls -> Just cls
806 AssocTyFamInst cls _ -> Just cls
807
808 -- The type variables from the instance head, if we are dealing with an
809 -- associated type family instance.
810 inst_head_tvs = case atfi of
811 NonAssocTyFamEqn _ -> []
812 AssocTyFamDeflt _ -> []
813 AssocTyFamInst _ inst_head_tvs -> inst_head_tvs
814
815 pat_kity_vars = extractHsTyArgRdrKiTyVars pats
816 -- It is crucial that extractHsTyArgRdrKiTyVars return
817 -- duplicate occurrences, since they're needed to help
818 -- determine unused binders on the LHS.
819
820 -- The SrcSpan of the LHS of the instance. For example, lhs_loc would be
821 -- the highlighted part in the example below:
822 --
823 -- type instance F a b c = Either a b
824 -- ^^^^^
825 lhs_loc = case map lhsTypeArgSrcSpan pats ++ map getLocA extra_kvars of
826 [] -> panic "rnFamEqn.lhs_loc"
827 [loc] -> loc
828 (loc:locs) -> loc `combineSrcSpans` last locs
829
830 badAssocRhs :: [Name] -> RnM ()
831 badAssocRhs ns
832 = addErr $ TcRnUnknownMessage $ mkPlainError noHints $
833 (hang (text "The RHS of an associated type declaration mentions"
834 <+> text "out-of-scope variable" <> plural ns
835 <+> pprWithCommas (quotes . ppr) ns)
836 2 (text "All such variables must be bound on the LHS"))
837
838 rnTyFamInstDecl :: AssocTyFamInfo
839 -> TyFamInstDecl GhcPs
840 -> RnM (TyFamInstDecl GhcRn, FreeVars)
841 rnTyFamInstDecl atfi (TyFamInstDecl { tfid_xtn = x, tfid_eqn = eqn })
842 = do { (eqn', fvs) <- rnTyFamInstEqn atfi eqn
843 ; return (TyFamInstDecl { tfid_xtn = x, tfid_eqn = eqn' }, fvs) }
844
845 -- | Tracks whether we are renaming:
846 --
847 -- 1. A type family equation that is not associated
848 -- with a parent type class ('NonAssocTyFamEqn'). Examples:
849 --
850 -- @
851 -- type family F a
852 -- type instance F Int = Bool -- NonAssocTyFamEqn NotClosed
853 --
854 -- type family G a where
855 -- G Int = Bool -- NonAssocTyFamEqn Closed
856 -- @
857 --
858 -- 2. An associated type family default declaration ('AssocTyFamDeflt').
859 -- Example:
860 --
861 -- @
862 -- class C a where
863 -- type A a
864 -- type instance A a = a -> a -- AssocTyFamDeflt C
865 -- @
866 --
867 -- 3. An associated type family instance declaration ('AssocTyFamInst').
868 -- Example:
869 --
870 -- @
871 -- instance C a => C [a] where
872 -- type A [a] = Bool -- AssocTyFamInst C [a]
873 -- @
874 data AssocTyFamInfo
875 = NonAssocTyFamEqn
876 ClosedTyFamInfo -- Is this a closed type family?
877 | AssocTyFamDeflt
878 Name -- Name of the parent class
879 | AssocTyFamInst
880 Name -- Name of the parent class
881 [Name] -- Names of the tyvars of the parent instance decl
882
883 -- | Tracks whether we are renaming an equation in a closed type family
884 -- equation ('ClosedTyFam') or not ('NotClosedTyFam').
885 data ClosedTyFamInfo
886 = NotClosedTyFam
887 | ClosedTyFam
888
889 rnTyFamInstEqn :: AssocTyFamInfo
890 -> TyFamInstEqn GhcPs
891 -> RnM (TyFamInstEqn GhcRn, FreeVars)
892 rnTyFamInstEqn atfi eqn@(FamEqn { feqn_tycon = tycon, feqn_rhs = rhs })
893 = rnFamEqn (TySynCtx tycon) atfi extra_kvs eqn rnTySyn
894 where
895 extra_kvs = extractHsTyRdrTyVarsKindVars rhs
896
897 rnTyFamDefltDecl :: Name
898 -> TyFamDefltDecl GhcPs
899 -> RnM (TyFamDefltDecl GhcRn, FreeVars)
900 rnTyFamDefltDecl cls = rnTyFamInstDecl (AssocTyFamDeflt cls)
901
902 rnDataFamInstDecl :: AssocTyFamInfo
903 -> DataFamInstDecl GhcPs
904 -> RnM (DataFamInstDecl GhcRn, FreeVars)
905 rnDataFamInstDecl atfi (DataFamInstDecl { dfid_eqn =
906 eqn@(FamEqn { feqn_tycon = tycon
907 , feqn_rhs = rhs })})
908 = do { let extra_kvs = extractDataDefnKindVars rhs
909 ; (eqn', fvs) <-
910 rnFamEqn (TyDataCtx tycon) atfi extra_kvs eqn rnDataDefn
911 ; return (DataFamInstDecl { dfid_eqn = eqn' }, fvs) }
912
913 -- Renaming of the associated types in instances.
914
915 -- Rename associated type family decl in class
916 rnATDecls :: Name -- Class
917 -> [LFamilyDecl GhcPs]
918 -> RnM ([LFamilyDecl GhcRn], FreeVars)
919 rnATDecls cls at_decls
920 = rnList (rnFamDecl (Just cls)) at_decls
921
922 rnATInstDecls :: (AssocTyFamInfo -> -- The function that renames
923 decl GhcPs -> -- an instance. rnTyFamInstDecl
924 RnM (decl GhcRn, FreeVars)) -- or rnDataFamInstDecl
925 -> Name -- Class
926 -> [Name]
927 -> [LocatedA (decl GhcPs)]
928 -> RnM ([LocatedA (decl GhcRn)], FreeVars)
929 -- Used for data and type family defaults in a class decl
930 -- and the family instance declarations in an instance
931 --
932 -- NB: We allow duplicate associated-type decls;
933 -- See Note [Associated type instances] in GHC.Tc.TyCl.Instance
934 rnATInstDecls rnFun cls tv_ns at_insts
935 = rnList (rnFun (AssocTyFamInst cls tv_ns)) at_insts
936 -- See Note [Renaming associated types]
937
938 {- Note [Wildcards in family instances]
939 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
940 Wild cards can be used in type/data family instance declarations to indicate
941 that the name of a type variable doesn't matter. Each wild card will be
942 replaced with a new unique type variable. For instance:
943
944 type family F a b :: *
945 type instance F Int _ = Int
946
947 is the same as
948
949 type family F a b :: *
950 type instance F Int b = Int
951
952 This is implemented as follows: Unnamed wildcards remain unchanged after
953 the renamer, and then given fresh meta-variables during typechecking, and
954 it is handled pretty much the same way as the ones in partial type signatures.
955 We however don't want to emit hole constraints on wildcards in family
956 instances, so we turn on PartialTypeSignatures and turn off warning flag to
957 let typechecker know this.
958 See related Note [Wildcards in visible kind application] in GHC.Tc.Gen.HsType
959
960 Note [Unused type variables in family instances]
961 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
962 When the flag -fwarn-unused-type-patterns is on, the compiler reports
963 warnings about unused type variables in type-family instances. A
964 tpye variable is considered used (i.e. cannot be turned into a wildcard)
965 when
966
967 * it occurs on the RHS of the family instance
968 e.g. type instance F a b = a -- a is used on the RHS
969
970 * it occurs multiple times in the patterns on the LHS
971 e.g. type instance F a a = Int -- a appears more than once on LHS
972
973 * it is one of the instance-decl variables, for associated types
974 e.g. instance C (a,b) where
975 type T (a,b) = a
976 Here the type pattern in the type instance must be the same as that
977 for the class instance, so
978 type T (a,_) = a
979 would be rejected. So we should not complain about an unused variable b
980
981 As usual, the warnings are not reported for type variables with names
982 beginning with an underscore.
983
984 Extra-constraints wild cards are not supported in type/data family
985 instance declarations.
986
987 Relevant tickets: #3699, #10586, #10982 and #11451.
988
989 Note [Renaming associated types]
990 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
991 When renaming a type/data family instance, be it top-level or associated with
992 a class, we must check that all of the type variables mentioned on the RHS are
993 properly scoped. Specifically, the rule is this:
994
995 Every variable mentioned on the RHS of a type instance declaration
996 (whether associated or not) must be either
997 * Mentioned on the LHS, or
998 * Mentioned in an outermost kind signature on the RHS
999 (see Note [Implicit quantification in type synonyms])
1000
1001 Here is a simple example of something we should reject:
1002
1003 class C a b where
1004 type F a x
1005 instance C Int Bool where
1006 type F Int x = z
1007
1008 Here, `z` is mentioned on the RHS of the associated instance without being
1009 mentioned on the LHS, nor is `z` mentioned in an outermost kind signature. The
1010 renamer will reject `z` as being out of scope without much fuss.
1011
1012 Things get slightly trickier when the instance header itself binds type
1013 variables. Consider this example (adapted from #5515):
1014
1015 instance C (p,q) z where
1016 type F (p,q) x = (x, z)
1017
1018 According to the rule above, this instance is improperly scoped. However, due
1019 to the way GHC's renamer works, `z` is /technically/ in scope, as GHC will
1020 always bring type variables from an instance header into scope over the
1021 associated type family instances. As a result, the renamer won't simply reject
1022 the `z` as being out of scope (like it would for the `type F Int x = z`
1023 example) unless further action is taken. It is important to reject this sort of
1024 thing in the renamer, because if it is allowed to make it through to the
1025 typechecker, unexpected shenanigans can occur (see #18021 for examples).
1026
1027 To prevent these sorts of shenanigans, we reject programs like the one above
1028 with an extra validity check in rnFamEqn. For each type variable bound in the
1029 parent instance head, we check if it is mentioned on the RHS of the associated
1030 family instance but not bound on the LHS. If any of the instance-head-bound
1031 variables meet these criteria, we throw an error.
1032 (See rnFamEqn.improperly_scoped for how this is implemented.)
1033
1034 Some additional wrinkles:
1035
1036 * This Note only applies to *instance* declarations. In *class* declarations
1037 there is no RHS to worry about, and the class variables can all be in scope
1038 (#5862):
1039
1040 class Category (x :: k -> k -> *) where
1041 type Ob x :: k -> Constraint
1042 id :: Ob x a => x a a
1043 (.) :: (Ob x a, Ob x b, Ob x c) => x b c -> x a b -> x a c
1044
1045 Here 'k' is in scope in the kind signature, just like 'x'.
1046
1047 * Although type family equations can bind type variables with explicit foralls,
1048 it need not be the case that all variables that appear on the RHS must be
1049 bound by a forall. For instance, the following is acceptable:
1050
1051 class C4 a where
1052 type T4 a b
1053 instance C4 (Maybe a) where
1054 type forall b. T4 (Maybe a) b = Either a b
1055
1056 Even though `a` is not bound by the forall, this is still accepted because `a`
1057 was previously bound by the `instance C4 (Maybe a)` part. (see #16116).
1058
1059 * In addition to the validity check in rnFamEqn.improperly_scoped, there is an
1060 additional check in GHC.Tc.Validity.checkFamPatBinders that checks each family
1061 instance equation for type variables used on the RHS but not bound on the
1062 LHS. This is not made redundant by rmFamEqn.improperly_scoped, as there are
1063 programs that each check will reject that the other check will not catch:
1064
1065 - checkValidFamPats is used on all forms of family instances, whereas
1066 rmFamEqn.improperly_scoped only checks associated family instances. Since
1067 checkFamPatBinders occurs after typechecking, it can catch programs that
1068 introduce dodgy scoping by way of type synonyms (see #7536), which is
1069 impractical to accomplish in the renamer.
1070 - rnFamEqn.improperly_scoped catches some programs that, if allowed to escape
1071 the renamer, would accidentally be accepted by the typechecker. Here is one
1072 such program (#18021):
1073
1074 class C5 a where
1075 data family D a
1076
1077 instance forall a. C5 Int where
1078 data instance D Int = MkD a
1079
1080 If this is not rejected in the renamer, the typechecker would treat this
1081 program as though the `a` were existentially quantified, like so:
1082
1083 data instance D Int = forall a. MkD a
1084
1085 This is likely not what the user intended!
1086
1087 Here is another such program (#9574):
1088
1089 class Funct f where
1090 type Codomain f
1091 instance Funct ('KProxy :: KProxy o) where
1092 type Codomain 'KProxy = NatTr (Proxy :: o -> Type)
1093
1094 Where:
1095
1096 data Proxy (a :: k) = Proxy
1097 data KProxy (t :: Type) = KProxy
1098 data NatTr (c :: o -> Type)
1099
1100 Note that the `o` in the `Codomain 'KProxy` instance should be considered
1101 improperly scoped. It does not meet the criteria for being explicitly
1102 quantified, as it is not mentioned by name on the LHS, nor does it meet the
1103 criteria for being implicitly quantified, as it is used in a RHS kind
1104 signature that is not outermost (see Note [Implicit quantification in type
1105 synonyms]). However, `o` /is/ bound by the instance header, so if this
1106 program is not rejected by the renamer, the typechecker would treat it as
1107 though you had written this:
1108
1109 instance Funct ('KProxy :: KProxy o) where
1110 type Codomain ('KProxy @o) = NatTr (Proxy :: o -> Type)
1111
1112 Although this is a valid program, it's probably a stretch too far to turn
1113 `type Codomain 'KProxy = ...` into `type Codomain ('KProxy @o) = ...` here.
1114 If the user really wants the latter, it is simple enough to communicate
1115 their intent by mentioning `o` on the LHS by name.
1116
1117 Note [Type family equations and occurrences]
1118 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1119 In most data/type family equations, the type family name used in the equation
1120 is treated as an occurrence. For example:
1121
1122 module A where
1123 type family F a
1124
1125 module B () where
1126 import B (F)
1127 type instance F Int = Bool
1128
1129 We do not want to warn about `F` being unused in the module `B`, as the
1130 instance constitutes a use site for `F`. The exception to this rule is closed
1131 type families, whose equations constitute a definition, not occurrences. For
1132 example:
1133
1134 module C () where
1135 type family CF a where
1136 CF Char = Float
1137
1138 Here, we /do/ want to warn that `CF` is unused in the module `C`, as it is
1139 defined but not used (#18470).
1140
1141 GHC accomplishes this in rnFamEqn when determining the set of free
1142 variables to return at the end. If renaming a data family or open type family
1143 equation, we add the name of the type family constructor to the set of returned
1144 free variables to ensure that the name is marked as an occurrence. If renaming
1145 a closed type family equation, we avoid adding the type family constructor name
1146 to the free variables. This is quite simple, but it is not a perfect solution.
1147 Consider this example:
1148
1149 module X () where
1150 type family F a where
1151 F Int = Bool
1152 F Double = F Int
1153
1154 At present, GHC will treat any use of a type family constructor on the RHS of a
1155 type family equation as an occurrence. Since `F` is used on the RHS of the
1156 second equation of `F`, it is treated as an occurrence, causing `F` not to be
1157 warned about. This is not ideal, since `F` isn't exported—it really /should/
1158 cause a warning to be emitted. There is some discussion in #10089/#12920 about
1159 how this limitation might be overcome, but until then, we stick to the
1160 simplistic solution above, as it fixes the egregious bug in #18470.
1161 -}
1162
1163
1164 {-
1165 *********************************************************
1166 * *
1167 \subsection{Stand-alone deriving declarations}
1168 * *
1169 *********************************************************
1170 -}
1171
1172 rnSrcDerivDecl :: DerivDecl GhcPs -> RnM (DerivDecl GhcRn, FreeVars)
1173 rnSrcDerivDecl (DerivDecl _ ty mds overlap)
1174 = do { standalone_deriv_ok <- xoptM LangExt.StandaloneDeriving
1175 ; unless standalone_deriv_ok (addErr standaloneDerivErr)
1176 ; checkInferredVars ctxt inf_err nowc_ty
1177 ; (mds', ty', fvs) <- rnLDerivStrategy ctxt mds $ rnHsSigWcType ctxt ty
1178 -- Check if there are any nested `forall`s or contexts, which are
1179 -- illegal in the type of an instance declaration (see
1180 -- Note [No nested foralls or contexts in instance types] in
1181 -- GHC.Hs.Type).
1182 ; addNoNestedForallsContextsErr ctxt
1183 (text "Standalone-derived instance head")
1184 (getLHsInstDeclHead $ dropWildCards ty')
1185 ; warnNoDerivStrat mds' loc
1186 ; return (DerivDecl noAnn ty' mds' overlap, fvs) }
1187 where
1188 ctxt = DerivDeclCtx
1189 inf_err = Just (text "Inferred type variables are not allowed")
1190 loc = getLocA nowc_ty
1191 nowc_ty = dropWildCards ty
1192
1193 standaloneDerivErr :: TcRnMessage
1194 standaloneDerivErr
1195 = TcRnUnknownMessage $ mkPlainError noHints $
1196 hang (text "Illegal standalone deriving declaration")
1197 2 (text "Use StandaloneDeriving to enable this extension")
1198
1199 {-
1200 *********************************************************
1201 * *
1202 \subsection{Rules}
1203 * *
1204 *********************************************************
1205 -}
1206
1207 rnHsRuleDecls :: RuleDecls GhcPs -> RnM (RuleDecls GhcRn, FreeVars)
1208 rnHsRuleDecls (HsRules { rds_src = src
1209 , rds_rules = rules })
1210 = do { (rn_rules,fvs) <- rnList rnHsRuleDecl rules
1211 ; return (HsRules { rds_ext = noExtField
1212 , rds_src = src
1213 , rds_rules = rn_rules }, fvs) }
1214
1215 rnHsRuleDecl :: RuleDecl GhcPs -> RnM (RuleDecl GhcRn, FreeVars)
1216 rnHsRuleDecl (HsRule { rd_name = rule_name
1217 , rd_act = act
1218 , rd_tyvs = tyvs
1219 , rd_tmvs = tmvs
1220 , rd_lhs = lhs
1221 , rd_rhs = rhs })
1222 = do { let rdr_names_w_loc = map (get_var . unLoc) tmvs
1223 ; checkDupRdrNamesN rdr_names_w_loc
1224 ; checkShadowedRdrNames rdr_names_w_loc
1225 ; names <- newLocalBndrsRn rdr_names_w_loc
1226 ; let doc = RuleCtx (snd $ unLoc rule_name)
1227 ; bindRuleTyVars doc tyvs $ \ tyvs' ->
1228 bindRuleTmVars doc tyvs' tmvs names $ \ tmvs' ->
1229 do { (lhs', fv_lhs') <- rnLExpr lhs
1230 ; (rhs', fv_rhs') <- rnLExpr rhs
1231 ; checkValidRule (snd $ unLoc rule_name) names lhs' fv_lhs'
1232 ; return (HsRule { rd_ext = HsRuleRn fv_lhs' fv_rhs'
1233 , rd_name = rule_name
1234 , rd_act = act
1235 , rd_tyvs = tyvs'
1236 , rd_tmvs = tmvs'
1237 , rd_lhs = lhs'
1238 , rd_rhs = rhs' }, fv_lhs' `plusFV` fv_rhs') } }
1239 where
1240 get_var :: RuleBndr GhcPs -> LocatedN RdrName
1241 get_var (RuleBndrSig _ v _) = v
1242 get_var (RuleBndr _ v) = v
1243
1244 bindRuleTmVars :: HsDocContext -> Maybe ty_bndrs
1245 -> [LRuleBndr GhcPs] -> [Name]
1246 -> ([LRuleBndr GhcRn] -> RnM (a, FreeVars))
1247 -> RnM (a, FreeVars)
1248 bindRuleTmVars doc tyvs vars names thing_inside
1249 = go vars names $ \ vars' ->
1250 bindLocalNamesFV names (thing_inside vars')
1251 where
1252 go ((L l (RuleBndr _ (L loc _))) : vars) (n : ns) thing_inside
1253 = go vars ns $ \ vars' ->
1254 thing_inside (L l (RuleBndr noAnn (L loc n)) : vars')
1255
1256 go ((L l (RuleBndrSig _ (L loc _) bsig)) : vars)
1257 (n : ns) thing_inside
1258 = rnHsPatSigType bind_free_tvs doc bsig $ \ bsig' ->
1259 go vars ns $ \ vars' ->
1260 thing_inside (L l (RuleBndrSig noAnn (L loc n) bsig') : vars')
1261
1262 go [] [] thing_inside = thing_inside []
1263 go vars names _ = pprPanic "bindRuleVars" (ppr vars $$ ppr names)
1264
1265 bind_free_tvs = case tyvs of Nothing -> AlwaysBind
1266 Just _ -> NeverBind
1267
1268 bindRuleTyVars :: HsDocContext -> Maybe [LHsTyVarBndr () GhcPs]
1269 -> (Maybe [LHsTyVarBndr () GhcRn] -> RnM (b, FreeVars))
1270 -> RnM (b, FreeVars)
1271 bindRuleTyVars doc (Just bndrs) thing_inside
1272 = bindLHsTyVarBndrs doc WarnUnusedForalls Nothing bndrs (thing_inside . Just)
1273 bindRuleTyVars _ _ thing_inside = thing_inside Nothing
1274
1275 {-
1276 Note [Rule LHS validity checking]
1277 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1278 Check the shape of a rewrite rule LHS. Currently we only allow
1279 LHSs of the form @(f e1 .. en)@, where @f@ is not one of the
1280 @forall@'d variables.
1281
1282 We used restrict the form of the 'ei' to prevent you writing rules
1283 with LHSs with a complicated desugaring (and hence unlikely to match);
1284 (e.g. a case expression is not allowed: too elaborate.)
1285
1286 But there are legitimate non-trivial args ei, like sections and
1287 lambdas. So it seems simmpler not to check at all, and that is why
1288 check_e is commented out.
1289 -}
1290
1291 checkValidRule :: FastString -> [Name] -> LHsExpr GhcRn -> NameSet -> RnM ()
1292 checkValidRule rule_name ids lhs' fv_lhs'
1293 = do { -- Check for the form of the LHS
1294 case (validRuleLhs ids lhs') of
1295 Nothing -> return ()
1296 Just bad -> failWithTc (badRuleLhsErr rule_name lhs' bad)
1297
1298 -- Check that LHS vars are all bound
1299 ; let bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs')]
1300 ; mapM_ (addErr . badRuleVar rule_name) bad_vars }
1301
1302 validRuleLhs :: [Name] -> LHsExpr GhcRn -> Maybe (HsExpr GhcRn)
1303 -- Nothing => OK
1304 -- Just e => Not ok, and e is the offending sub-expression
1305 validRuleLhs foralls lhs
1306 = checkl lhs
1307 where
1308 checkl = check . unLoc
1309
1310 check (OpApp _ e1 op e2) = checkl op `mplus` checkl_e e1
1311 `mplus` checkl_e e2
1312 check (HsApp _ e1 e2) = checkl e1 `mplus` checkl_e e2
1313 check (HsAppType _ e _) = checkl e
1314 check (HsVar _ lv)
1315 | (unLoc lv) `notElem` foralls = Nothing
1316 check other = Just other -- Failure
1317
1318 -- Check an argument
1319 checkl_e _ = Nothing
1320 -- Was (check_e e); see Note [Rule LHS validity checking]
1321
1322 {- Commented out; see Note [Rule LHS validity checking] above
1323 check_e (HsVar v) = Nothing
1324 check_e (HsPar e) = checkl_e e
1325 check_e (HsLit e) = Nothing
1326 check_e (HsOverLit e) = Nothing
1327
1328 check_e (OpApp e1 op _ e2) = checkl_e e1 `mplus` checkl_e op `mplus` checkl_e e2
1329 check_e (HsApp e1 e2) = checkl_e e1 `mplus` checkl_e e2
1330 check_e (NegApp e _) = checkl_e e
1331 check_e (ExplicitList _ es) = checkl_es es
1332 check_e other = Just other -- Fails
1333
1334 checkl_es es = foldr (mplus . checkl_e) Nothing es
1335 -}
1336
1337 badRuleVar :: FastString -> Name -> TcRnMessage
1338 badRuleVar name var
1339 = TcRnUnknownMessage $ mkPlainError noHints $
1340 sep [text "Rule" <+> doubleQuotes (ftext name) <> colon,
1341 text "Forall'd variable" <+> quotes (ppr var) <+>
1342 text "does not appear on left hand side"]
1343
1344 badRuleLhsErr :: FastString -> LHsExpr GhcRn -> HsExpr GhcRn -> TcRnMessage
1345 badRuleLhsErr name lhs bad_e
1346 = TcRnUnknownMessage $ mkPlainError noHints $
1347 sep [text "Rule" <+> pprRuleName name <> colon,
1348 nest 2 (vcat [err,
1349 text "in left-hand side:" <+> ppr lhs])]
1350 $$
1351 text "LHS must be of form (f e1 .. en) where f is not forall'd"
1352 where
1353 err = case bad_e of
1354 HsUnboundVar _ uv -> notInScopeErr WL_Global (mkRdrUnqual uv)
1355 _ -> text "Illegal expression:" <+> ppr bad_e
1356
1357 {- **************************************************************
1358 * *
1359 Renaming type, class, instance and role declarations
1360 * *
1361 *****************************************************************
1362
1363 @rnTyDecl@ uses the `global name function' to create a new type
1364 declaration in which local names have been replaced by their original
1365 names, reporting any unknown names.
1366
1367 Renaming type variables is a pain. Because they now contain uniques,
1368 it is necessary to pass in an association list which maps a parsed
1369 tyvar to its @Name@ representation.
1370 In some cases (type signatures of values),
1371 it is even necessary to go over the type first
1372 in order to get the set of tyvars used by it, make an assoc list,
1373 and then go over it again to rename the tyvars!
1374 However, we can also do some scoping checks at the same time.
1375
1376 Note [Dependency analysis of type, class, and instance decls]
1377 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1378 A TyClGroup represents a strongly connected components of
1379 type/class/instance decls, together with the role annotations for the
1380 type/class declarations. The renamer uses strongly connected
1381 comoponent analysis to build these groups. We do this for a number of
1382 reasons:
1383
1384 * Improve kind error messages. Consider
1385
1386 data T f a = MkT f a
1387 data S f a = MkS f (T f a)
1388
1389 This has a kind error, but the error message is better if you
1390 check T first, (fixing its kind) and *then* S. If you do kind
1391 inference together, you might get an error reported in S, which
1392 is jolly confusing. See #4875
1393
1394
1395 * Increase kind polymorphism. See GHC.Tc.TyCl
1396 Note [Grouping of type and class declarations]
1397
1398 Why do the instance declarations participate? At least two reasons
1399
1400 * Consider (#11348)
1401
1402 type family F a
1403 type instance F Int = Bool
1404
1405 data R = MkR (F Int)
1406
1407 type Foo = 'MkR 'True
1408
1409 For Foo to kind-check we need to know that (F Int) ~ Bool. But we won't
1410 know that unless we've looked at the type instance declaration for F
1411 before kind-checking Foo.
1412
1413 * Another example is this (#3990).
1414
1415 data family Complex a
1416 data instance Complex Double = CD {-# UNPACK #-} !Double
1417 {-# UNPACK #-} !Double
1418
1419 data T = T {-# UNPACK #-} !(Complex Double)
1420
1421 Here, to generate the right kind of unpacked implementation for T,
1422 we must have access to the 'data instance' declaration.
1423
1424 * Things become more complicated when we introduce transitive
1425 dependencies through imported definitions, like in this scenario:
1426
1427 A.hs
1428 type family Closed (t :: Type) :: Type where
1429 Closed t = Open t
1430
1431 type family Open (t :: Type) :: Type
1432
1433 B.hs
1434 data Q where
1435 Q :: Closed Bool -> Q
1436
1437 type instance Open Int = Bool
1438
1439 type S = 'Q 'True
1440
1441 Somehow, we must ensure that the instance Open Int = Bool is checked before
1442 the type synonym S. While we know that S depends upon 'Q depends upon Closed,
1443 we have no idea that Closed depends upon Open!
1444
1445 To accommodate for these situations, we ensure that an instance is checked
1446 before every @TyClDecl@ on which it does not depend. That's to say, instances
1447 are checked as early as possible in @tcTyAndClassDecls@.
1448
1449 ------------------------------------
1450 So much for WHY. What about HOW? It's pretty easy:
1451
1452 (1) Rename the type/class, instance, and role declarations
1453 individually
1454
1455 (2) Do strongly-connected component analysis of the type/class decls,
1456 We'll make a TyClGroup for each SCC
1457
1458 In this step we treat a reference to a (promoted) data constructor
1459 K as a dependency on its parent type. Thus
1460 data T = K1 | K2
1461 data S = MkS (Proxy 'K1)
1462 Here S depends on 'K1 and hence on its parent T.
1463
1464 In this step we ignore instances; see
1465 Note [No dependencies on data instances]
1466
1467 (3) Attach roles to the appropriate SCC
1468
1469 (4) Attach instances to the appropriate SCC.
1470 We add an instance decl to SCC when:
1471 all its free types/classes are bound in this SCC or earlier ones
1472
1473 (5) We make an initial TyClGroup, with empty group_tyclds, for any
1474 (orphan) instances that affect only imported types/classes
1475
1476 Steps (3) and (4) are done by the (mapAccumL mk_group) call.
1477
1478 Note [No dependencies on data instances]
1479 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1480 Consider this
1481 data family D a
1482 data instance D Int = D1
1483 data S = MkS (Proxy 'D1)
1484
1485 Here the declaration of S depends on the /data instance/ declaration
1486 for 'D Int'. That makes things a lot more complicated, especially
1487 if the data instance is an associated type of an enclosing class instance.
1488 (And the class instance might have several associated type instances
1489 with different dependency structure!)
1490
1491 Ugh. For now we simply don't allow promotion of data constructors for
1492 data instances. See Note [AFamDataCon: not promoting data family
1493 constructors] in GHC.Tc.Utils.Env
1494 -}
1495
1496
1497 rnTyClDecls :: [TyClGroup GhcPs]
1498 -> RnM ([TyClGroup GhcRn], FreeVars)
1499 -- Rename the declarations and do dependency analysis on them
1500 rnTyClDecls tycl_ds
1501 = do { -- Rename the type/class, instance, and role declaraations
1502 ; tycls_w_fvs <- mapM (wrapLocFstMA rnTyClDecl) (tyClGroupTyClDecls tycl_ds)
1503 ; let tc_names = mkNameSet (map (tcdName . unLoc . fst) tycls_w_fvs)
1504 ; kisigs_w_fvs <- rnStandaloneKindSignatures tc_names (tyClGroupKindSigs tycl_ds)
1505 ; instds_w_fvs <- mapM (wrapLocFstMA rnSrcInstDecl) (tyClGroupInstDecls tycl_ds)
1506 ; role_annots <- rnRoleAnnots tc_names (tyClGroupRoleDecls tycl_ds)
1507
1508 -- Do SCC analysis on the type/class decls
1509 ; rdr_env <- getGlobalRdrEnv
1510 ; let tycl_sccs = depAnalTyClDecls rdr_env kisig_fv_env tycls_w_fvs
1511 role_annot_env = mkRoleAnnotEnv role_annots
1512 (kisig_env, kisig_fv_env) = mkKindSig_fv_env kisigs_w_fvs
1513
1514 inst_ds_map = mkInstDeclFreeVarsMap rdr_env tc_names instds_w_fvs
1515 (init_inst_ds, rest_inst_ds) = getInsts [] inst_ds_map
1516
1517 first_group
1518 | null init_inst_ds = []
1519 | otherwise = [TyClGroup { group_ext = noExtField
1520 , group_tyclds = []
1521 , group_kisigs = []
1522 , group_roles = []
1523 , group_instds = init_inst_ds }]
1524
1525 (final_inst_ds, groups)
1526 = mapAccumL (mk_group role_annot_env kisig_env) rest_inst_ds tycl_sccs
1527
1528 all_fvs = foldr (plusFV . snd) emptyFVs tycls_w_fvs `plusFV`
1529 foldr (plusFV . snd) emptyFVs instds_w_fvs `plusFV`
1530 foldr (plusFV . snd) emptyFVs kisigs_w_fvs
1531
1532 all_groups = first_group ++ groups
1533
1534 ; massertPpr (null final_inst_ds)
1535 (ppr instds_w_fvs
1536 $$ ppr inst_ds_map
1537 $$ ppr (flattenSCCs tycl_sccs)
1538 $$ ppr final_inst_ds)
1539
1540 ; traceRn "rnTycl dependency analysis made groups" (ppr all_groups)
1541 ; return (all_groups, all_fvs) }
1542 where
1543 mk_group :: RoleAnnotEnv
1544 -> KindSigEnv
1545 -> InstDeclFreeVarsMap
1546 -> SCC (LTyClDecl GhcRn)
1547 -> (InstDeclFreeVarsMap, TyClGroup GhcRn)
1548 mk_group role_env kisig_env inst_map scc
1549 = (inst_map', group)
1550 where
1551 tycl_ds = flattenSCC scc
1552 bndrs = map (tcdName . unLoc) tycl_ds
1553 roles = getRoleAnnots bndrs role_env
1554 kisigs = getKindSigs bndrs kisig_env
1555 (inst_ds, inst_map') = getInsts bndrs inst_map
1556 group = TyClGroup { group_ext = noExtField
1557 , group_tyclds = tycl_ds
1558 , group_kisigs = kisigs
1559 , group_roles = roles
1560 , group_instds = inst_ds }
1561
1562 -- | Free variables of standalone kind signatures.
1563 newtype KindSig_FV_Env = KindSig_FV_Env (NameEnv FreeVars)
1564
1565 lookupKindSig_FV_Env :: KindSig_FV_Env -> Name -> FreeVars
1566 lookupKindSig_FV_Env (KindSig_FV_Env e) name
1567 = fromMaybe emptyFVs (lookupNameEnv e name)
1568
1569 -- | Standalone kind signatures.
1570 type KindSigEnv = NameEnv (LStandaloneKindSig GhcRn)
1571
1572 mkKindSig_fv_env :: [(LStandaloneKindSig GhcRn, FreeVars)] -> (KindSigEnv, KindSig_FV_Env)
1573 mkKindSig_fv_env kisigs_w_fvs = (kisig_env, kisig_fv_env)
1574 where
1575 kisig_env = mapNameEnv fst compound_env
1576 kisig_fv_env = KindSig_FV_Env (mapNameEnv snd compound_env)
1577 compound_env :: NameEnv (LStandaloneKindSig GhcRn, FreeVars)
1578 = mkNameEnvWith (standaloneKindSigName . unLoc . fst) kisigs_w_fvs
1579
1580 getKindSigs :: [Name] -> KindSigEnv -> [LStandaloneKindSig GhcRn]
1581 getKindSigs bndrs kisig_env = mapMaybe (lookupNameEnv kisig_env) bndrs
1582
1583 rnStandaloneKindSignatures
1584 :: NameSet -- names of types and classes in the current TyClGroup
1585 -> [LStandaloneKindSig GhcPs]
1586 -> RnM [(LStandaloneKindSig GhcRn, FreeVars)]
1587 rnStandaloneKindSignatures tc_names kisigs
1588 = do { let (no_dups, dup_kisigs) = removeDups (compare `on` get_name) kisigs
1589 get_name = standaloneKindSigName . unLoc
1590 ; mapM_ dupKindSig_Err dup_kisigs
1591 ; mapM (wrapLocFstMA (rnStandaloneKindSignature tc_names)) no_dups
1592 }
1593
1594 rnStandaloneKindSignature
1595 :: NameSet -- names of types and classes in the current TyClGroup
1596 -> StandaloneKindSig GhcPs
1597 -> RnM (StandaloneKindSig GhcRn, FreeVars)
1598 rnStandaloneKindSignature tc_names (StandaloneKindSig _ v ki)
1599 = do { standalone_ki_sig_ok <- xoptM LangExt.StandaloneKindSignatures
1600 ; unless standalone_ki_sig_ok $ addErr standaloneKiSigErr
1601 ; new_v <- lookupSigCtxtOccRnN (TopSigCtxt tc_names) (text "standalone kind signature") v
1602 ; let doc = StandaloneKindSigCtx (ppr v)
1603 ; (new_ki, fvs) <- rnHsSigType doc KindLevel ki
1604 ; return (StandaloneKindSig noExtField new_v new_ki, fvs)
1605 }
1606 where
1607 standaloneKiSigErr :: TcRnMessage
1608 standaloneKiSigErr = TcRnUnknownMessage $ mkPlainError noHints $
1609 hang (text "Illegal standalone kind signature")
1610 2 (text "Did you mean to enable StandaloneKindSignatures?")
1611
1612 depAnalTyClDecls :: GlobalRdrEnv
1613 -> KindSig_FV_Env
1614 -> [(LTyClDecl GhcRn, FreeVars)]
1615 -> [SCC (LTyClDecl GhcRn)]
1616 -- See Note [Dependency analysis of type, class, and instance decls]
1617 depAnalTyClDecls rdr_env kisig_fv_env ds_w_fvs
1618 = stronglyConnCompFromEdgedVerticesUniq edges
1619 where
1620 edges :: [ Node Name (LTyClDecl GhcRn) ]
1621 edges = [ DigraphNode d name (map (getParent rdr_env) (nonDetEltsUniqSet deps))
1622 | (d, fvs) <- ds_w_fvs,
1623 let { name = tcdName (unLoc d)
1624 ; kisig_fvs = lookupKindSig_FV_Env kisig_fv_env name
1625 ; deps = fvs `plusFV` kisig_fvs
1626 }
1627 ]
1628 -- It's OK to use nonDetEltsUFM here as
1629 -- stronglyConnCompFromEdgedVertices is still deterministic
1630 -- even if the edges are in nondeterministic order as explained
1631 -- in Note [Deterministic SCC] in GHC.Data.Graph.Directed.
1632
1633 toParents :: GlobalRdrEnv -> NameSet -> NameSet
1634 toParents rdr_env ns
1635 = nonDetStrictFoldUniqSet add emptyNameSet ns
1636 -- It's OK to use a non-deterministic fold because we immediately forget the
1637 -- ordering by creating a set
1638 where
1639 add n s = extendNameSet s (getParent rdr_env n)
1640
1641 getParent :: GlobalRdrEnv -> Name -> Name
1642 getParent rdr_env n
1643 = case lookupGRE_Name rdr_env n of
1644 Just gre -> case gre_par gre of
1645 ParentIs { par_is = p } -> p
1646 _ -> n
1647 Nothing -> n
1648
1649
1650 {- ******************************************************
1651 * *
1652 Role annotations
1653 * *
1654 ****************************************************** -}
1655
1656 -- | Renames role annotations, returning them as the values in a NameEnv
1657 -- and checks for duplicate role annotations.
1658 -- It is quite convenient to do both of these in the same place.
1659 -- See also Note [Role annotations in the renamer]
1660 rnRoleAnnots :: NameSet
1661 -> [LRoleAnnotDecl GhcPs]
1662 -> RnM [LRoleAnnotDecl GhcRn]
1663 rnRoleAnnots tc_names role_annots
1664 = do { -- Check for duplicates *before* renaming, to avoid
1665 -- lumping together all the unboundNames
1666 let (no_dups, dup_annots) = removeDups (compare `on` get_name) role_annots
1667 get_name = roleAnnotDeclName . unLoc
1668 ; mapM_ dupRoleAnnotErr dup_annots
1669 ; mapM (wrapLocMA rn_role_annot1) no_dups }
1670 where
1671 rn_role_annot1 (RoleAnnotDecl _ tycon roles)
1672 = do { -- the name is an *occurrence*, but look it up only in the
1673 -- decls defined in this group (see #10263)
1674 tycon' <- lookupSigCtxtOccRnN (RoleAnnotCtxt tc_names)
1675 (text "role annotation")
1676 tycon
1677 ; return $ RoleAnnotDecl noExtField tycon' roles }
1678
1679 dupRoleAnnotErr :: NonEmpty (LRoleAnnotDecl GhcPs) -> RnM ()
1680 dupRoleAnnotErr list
1681 = addErrAt (locA loc) $ TcRnUnknownMessage $ mkPlainError noHints $
1682 hang (text "Duplicate role annotations for" <+>
1683 quotes (ppr $ roleAnnotDeclName first_decl) <> colon)
1684 2 (vcat $ map pp_role_annot $ NE.toList sorted_list)
1685 where
1686 sorted_list = NE.sortBy cmp_loc list
1687 ((L loc first_decl) :| _) = sorted_list
1688
1689 pp_role_annot (L loc decl) = hang (ppr decl)
1690 4 (text "-- written at" <+> ppr (locA loc))
1691
1692 cmp_loc = SrcLoc.leftmost_smallest `on` getLocA
1693
1694 dupKindSig_Err :: NonEmpty (LStandaloneKindSig GhcPs) -> RnM ()
1695 dupKindSig_Err list
1696 = addErrAt (locA loc) $ TcRnUnknownMessage $ mkPlainError noHints $
1697 hang (text "Duplicate standalone kind signatures for" <+>
1698 quotes (ppr $ standaloneKindSigName first_decl) <> colon)
1699 2 (vcat $ map pp_kisig $ NE.toList sorted_list)
1700 where
1701 sorted_list = NE.sortBy cmp_loc list
1702 ((L loc first_decl) :| _) = sorted_list
1703
1704 pp_kisig (L loc decl) =
1705 hang (ppr decl) 4 (text "-- written at" <+> ppr (locA loc))
1706
1707 cmp_loc = SrcLoc.leftmost_smallest `on` getLocA
1708
1709 {- Note [Role annotations in the renamer]
1710 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1711 We must ensure that a type's role annotation is put in the same group as the
1712 proper type declaration. This is because role annotations are needed during
1713 type-checking when creating the type's TyCon. So, rnRoleAnnots builds a
1714 NameEnv (LRoleAnnotDecl Name) that maps a name to a role annotation for that
1715 type, if any. Then, this map can be used to add the role annotations to the
1716 groups after dependency analysis.
1717
1718 This process checks for duplicate role annotations, where we must be careful
1719 to do the check *before* renaming to avoid calling all unbound names duplicates
1720 of one another.
1721
1722 The renaming process, as usual, might identify and report errors for unbound
1723 names. This is done by using lookupSigCtxtOccRn in rnRoleAnnots (using
1724 lookupGlobalOccRn led to #8485).
1725 -}
1726
1727
1728 {- ******************************************************
1729 * *
1730 Dependency info for instances
1731 * *
1732 ****************************************************** -}
1733
1734 ----------------------------------------------------------
1735 -- | 'InstDeclFreeVarsMap is an association of an
1736 -- @InstDecl@ with @FreeVars@. The @FreeVars@ are
1737 -- the tycon names that are both
1738 -- a) free in the instance declaration
1739 -- b) bound by this group of type/class/instance decls
1740 type InstDeclFreeVarsMap = [(LInstDecl GhcRn, FreeVars)]
1741
1742 -- | Construct an @InstDeclFreeVarsMap@ by eliminating any @Name@s from the
1743 -- @FreeVars@ which are *not* the binders of a @TyClDecl@.
1744 mkInstDeclFreeVarsMap :: GlobalRdrEnv
1745 -> NameSet
1746 -> [(LInstDecl GhcRn, FreeVars)]
1747 -> InstDeclFreeVarsMap
1748 mkInstDeclFreeVarsMap rdr_env tycl_bndrs inst_ds_fvs
1749 = [ (inst_decl, toParents rdr_env fvs `intersectFVs` tycl_bndrs)
1750 | (inst_decl, fvs) <- inst_ds_fvs ]
1751
1752 -- | Get the @LInstDecl@s which have empty @FreeVars@ sets, and the
1753 -- @InstDeclFreeVarsMap@ with these entries removed.
1754 -- We call (getInsts tcs instd_map) when we've completed the declarations
1755 -- for 'tcs'. The call returns (inst_decls, instd_map'), where
1756 -- inst_decls are the instance declarations all of
1757 -- whose free vars are now defined
1758 -- instd_map' is the inst-decl map with 'tcs' removed from
1759 -- the free-var set
1760 getInsts :: [Name] -> InstDeclFreeVarsMap
1761 -> ([LInstDecl GhcRn], InstDeclFreeVarsMap)
1762 getInsts bndrs inst_decl_map
1763 = partitionWith pick_me inst_decl_map
1764 where
1765 pick_me :: (LInstDecl GhcRn, FreeVars)
1766 -> Either (LInstDecl GhcRn) (LInstDecl GhcRn, FreeVars)
1767 pick_me (decl, fvs)
1768 | isEmptyNameSet depleted_fvs = Left decl
1769 | otherwise = Right (decl, depleted_fvs)
1770 where
1771 depleted_fvs = delFVs bndrs fvs
1772
1773 {- ******************************************************
1774 * *
1775 Renaming a type or class declaration
1776 * *
1777 ****************************************************** -}
1778
1779 rnTyClDecl :: TyClDecl GhcPs
1780 -> RnM (TyClDecl GhcRn, FreeVars)
1781
1782 -- All flavours of top-level type family declarations ("type family", "newtype
1783 -- family", and "data family")
1784 rnTyClDecl (FamDecl { tcdFam = fam })
1785 = do { (fam', fvs) <- rnFamDecl Nothing fam
1786 ; return (FamDecl noExtField fam', fvs) }
1787
1788 rnTyClDecl (SynDecl { tcdLName = tycon, tcdTyVars = tyvars,
1789 tcdFixity = fixity, tcdRhs = rhs })
1790 = do { tycon' <- lookupLocatedTopConstructorRnN tycon
1791 ; let kvs = extractHsTyRdrTyVarsKindVars rhs
1792 doc = TySynCtx tycon
1793 ; traceRn "rntycl-ty" (ppr tycon <+> ppr kvs)
1794 ; bindHsQTyVars doc Nothing kvs tyvars $ \ tyvars' _ ->
1795 do { (rhs', fvs) <- rnTySyn doc rhs
1796 ; return (SynDecl { tcdLName = tycon', tcdTyVars = tyvars'
1797 , tcdFixity = fixity
1798 , tcdRhs = rhs', tcdSExt = fvs }, fvs) } }
1799
1800 -- "data", "newtype" declarations
1801 rnTyClDecl (DataDecl
1802 { tcdLName = tycon, tcdTyVars = tyvars,
1803 tcdFixity = fixity,
1804 tcdDataDefn = defn@HsDataDefn{ dd_ND = new_or_data
1805 , dd_kindSig = kind_sig} })
1806 = do { tycon' <- lookupLocatedTopConstructorRnN tycon
1807 ; let kvs = extractDataDefnKindVars defn
1808 doc = TyDataCtx tycon
1809 ; traceRn "rntycl-data" (ppr tycon <+> ppr kvs)
1810 ; bindHsQTyVars doc Nothing kvs tyvars $ \ tyvars' no_rhs_kvs ->
1811 do { (defn', fvs) <- rnDataDefn doc defn
1812 ; cusk <- data_decl_has_cusk tyvars' new_or_data no_rhs_kvs kind_sig
1813 ; let rn_info = DataDeclRn { tcdDataCusk = cusk
1814 , tcdFVs = fvs }
1815 ; traceRn "rndata" (ppr tycon <+> ppr cusk <+> ppr no_rhs_kvs)
1816 ; return (DataDecl { tcdLName = tycon'
1817 , tcdTyVars = tyvars'
1818 , tcdFixity = fixity
1819 , tcdDataDefn = defn'
1820 , tcdDExt = rn_info }, fvs) } }
1821
1822 rnTyClDecl (ClassDecl { tcdCtxt = context, tcdLName = lcls,
1823 tcdTyVars = tyvars, tcdFixity = fixity,
1824 tcdFDs = fds, tcdSigs = sigs,
1825 tcdMeths = mbinds, tcdATs = ats, tcdATDefs = at_defs,
1826 tcdDocs = docs})
1827 = do { lcls' <- lookupLocatedTopConstructorRnN lcls
1828 ; let cls' = unLoc lcls'
1829 kvs = [] -- No scoped kind vars except those in
1830 -- kind signatures on the tyvars
1831
1832 -- Tyvars scope over superclass context and method signatures
1833 ; ((tyvars', context', fds', ats'), stuff_fvs)
1834 <- bindHsQTyVars cls_doc Nothing kvs tyvars $ \ tyvars' _ -> do
1835 -- Checks for distinct tyvars
1836 { (context', cxt_fvs) <- rnMaybeContext cls_doc context
1837 ; fds' <- rnFds fds
1838 -- The fundeps have no free variables
1839 ; (ats', fv_ats) <- rnATDecls cls' ats
1840 ; let fvs = cxt_fvs `plusFV`
1841 fv_ats
1842 ; return ((tyvars', context', fds', ats'), fvs) }
1843
1844 ; (at_defs', fv_at_defs) <- rnList (rnTyFamDefltDecl cls') at_defs
1845
1846 -- No need to check for duplicate associated type decls
1847 -- since that is done by GHC.Rename.Names.extendGlobalRdrEnvRn
1848
1849 -- Check the signatures
1850 -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).
1851 ; let sig_rdr_names_w_locs =
1852 [op | L _ (ClassOpSig _ False ops _) <- sigs
1853 , op <- ops]
1854 ; checkDupRdrNamesN sig_rdr_names_w_locs
1855 -- Typechecker is responsible for checking that we only
1856 -- give default-method bindings for things in this class.
1857 -- The renamer *could* check this for class decls, but can't
1858 -- for instance decls.
1859
1860 -- The newLocals call is tiresome: given a generic class decl
1861 -- class C a where
1862 -- op :: a -> a
1863 -- op {| x+y |} (Inl a) = ...
1864 -- op {| x+y |} (Inr b) = ...
1865 -- op {| a*b |} (a*b) = ...
1866 -- we want to name both "x" tyvars with the same unique, so that they are
1867 -- easy to group together in the typechecker.
1868 ; (mbinds', sigs', meth_fvs)
1869 <- rnMethodBinds True cls' (hsAllLTyVarNames tyvars') mbinds sigs
1870 -- No need to check for duplicate method signatures
1871 -- since that is done by GHC.Rename.Names.extendGlobalRdrEnvRn
1872 -- and the methods are already in scope
1873
1874 ; let all_fvs = meth_fvs `plusFV` stuff_fvs `plusFV` fv_at_defs
1875 ; return (ClassDecl { tcdCtxt = context', tcdLName = lcls',
1876 tcdTyVars = tyvars', tcdFixity = fixity,
1877 tcdFDs = fds', tcdSigs = sigs',
1878 tcdMeths = mbinds', tcdATs = ats', tcdATDefs = at_defs',
1879 tcdDocs = docs, tcdCExt = all_fvs },
1880 all_fvs ) }
1881 where
1882 cls_doc = ClassDeclCtx lcls
1883
1884 -- Does the data type declaration include a CUSK?
1885 data_decl_has_cusk :: LHsQTyVars (GhcPass p) -> NewOrData -> Bool -> Maybe (LHsKind (GhcPass p')) -> RnM Bool
1886 data_decl_has_cusk tyvars new_or_data no_rhs_kvs kind_sig = do
1887 { -- See Note [Unlifted Newtypes and CUSKs], and for a broader
1888 -- picture, see Note [Implementation of UnliftedNewtypes].
1889 ; unlifted_newtypes <- xoptM LangExt.UnliftedNewtypes
1890 ; let non_cusk_newtype
1891 | NewType <- new_or_data =
1892 unlifted_newtypes && isNothing kind_sig
1893 | otherwise = False
1894 -- See Note [CUSKs: complete user-supplied kind signatures] in GHC.Hs.Decls
1895 ; return $ hsTvbAllKinded tyvars && no_rhs_kvs && not non_cusk_newtype
1896 }
1897
1898 {- Note [Unlifted Newtypes and CUSKs]
1899 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1900 When unlifted newtypes are enabled, a newtype must have a kind signature
1901 in order to be considered have a CUSK. This is because the flow of
1902 kind inference works differently. Consider:
1903
1904 newtype Foo = FooC Int
1905
1906 When UnliftedNewtypes is disabled, we decide that Foo has kind
1907 `TYPE 'LiftedRep` without looking inside the data constructor. So, we
1908 can say that Foo has a CUSK. However, when UnliftedNewtypes is enabled,
1909 we fill in the kind of Foo as a metavar that gets solved by unification
1910 with the kind of the field inside FooC (that is, Int, whose kind is
1911 `TYPE 'LiftedRep`). But since we have to look inside the data constructors
1912 to figure out the kind signature of Foo, it does not have a CUSK.
1913
1914 See Note [Implementation of UnliftedNewtypes] for where this fits in to
1915 the broader picture of UnliftedNewtypes.
1916 -}
1917
1918 -- "type" and "type instance" declarations
1919 rnTySyn :: HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
1920 rnTySyn doc rhs = rnLHsType doc rhs
1921
1922 rnDataDefn :: HsDocContext -> HsDataDefn GhcPs
1923 -> RnM (HsDataDefn GhcRn, FreeVars)
1924 rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType
1925 , dd_ctxt = context, dd_cons = condecls
1926 , dd_kindSig = m_sig, dd_derivs = derivs })
1927 = do { checkTc (h98_style || null (fromMaybeContext context))
1928 (badGadtStupidTheta doc)
1929
1930 ; (m_sig', sig_fvs) <- case m_sig of
1931 Just sig -> first Just <$> rnLHsKind doc sig
1932 Nothing -> return (Nothing, emptyFVs)
1933 ; (context', fvs1) <- rnMaybeContext doc context
1934 ; (derivs', fvs3) <- rn_derivs derivs
1935
1936 -- For the constructor declarations, drop the LocalRdrEnv
1937 -- in the GADT case, where the type variables in the declaration
1938 -- do not scope over the constructor signatures
1939 -- data T a where { T1 :: forall b. b-> b }
1940 ; let { zap_lcl_env | h98_style = \ thing -> thing
1941 | otherwise = setLocalRdrEnv emptyLocalRdrEnv }
1942 ; (condecls', con_fvs) <- zap_lcl_env $ rnConDecls condecls
1943 -- No need to check for duplicate constructor decls
1944 -- since that is done by GHC.Rename.Names.extendGlobalRdrEnvRn
1945
1946 ; let all_fvs = fvs1 `plusFV` fvs3 `plusFV`
1947 con_fvs `plusFV` sig_fvs
1948 ; return ( HsDataDefn { dd_ext = noExtField
1949 , dd_ND = new_or_data, dd_cType = cType
1950 , dd_ctxt = context', dd_kindSig = m_sig'
1951 , dd_cons = condecls'
1952 , dd_derivs = derivs' }
1953 , all_fvs )
1954 }
1955 where
1956 h98_style = case condecls of -- Note [Stupid theta]
1957 (L _ (ConDeclGADT {})) : _ -> False
1958 _ -> True
1959
1960 rn_derivs ds
1961 = do { deriv_strats_ok <- xoptM LangExt.DerivingStrategies
1962 ; failIfTc (lengthExceeds ds 1 && not deriv_strats_ok)
1963 multipleDerivClausesErr
1964 ; (ds', fvs) <- mapFvRn (rnLHsDerivingClause doc) ds
1965 ; return (ds', fvs) }
1966
1967 warnNoDerivStrat :: Maybe (LDerivStrategy GhcRn)
1968 -> SrcSpan
1969 -> RnM ()
1970 warnNoDerivStrat mds loc
1971 = do { dyn_flags <- getDynFlags
1972 ; case mds of
1973 Nothing ->
1974 let dia = TcRnUnknownMessage $
1975 mkPlainDiagnostic (WarningWithFlag Opt_WarnMissingDerivingStrategies) noHints $
1976 (if xopt LangExt.DerivingStrategies dyn_flags
1977 then no_strat_warning
1978 else no_strat_warning $+$ deriv_strat_nenabled
1979 )
1980 in addDiagnosticAt loc dia
1981 _ -> pure ()
1982 }
1983 where
1984 no_strat_warning :: SDoc
1985 no_strat_warning = text "No deriving strategy specified. Did you want stock"
1986 <> text ", newtype, or anyclass?"
1987 deriv_strat_nenabled :: SDoc
1988 deriv_strat_nenabled = text "Use DerivingStrategies to specify a strategy."
1989
1990 rnLHsDerivingClause :: HsDocContext -> LHsDerivingClause GhcPs
1991 -> RnM (LHsDerivingClause GhcRn, FreeVars)
1992 rnLHsDerivingClause doc
1993 (L loc (HsDerivingClause
1994 { deriv_clause_ext = noExtField
1995 , deriv_clause_strategy = dcs
1996 , deriv_clause_tys = dct }))
1997 = do { (dcs', dct', fvs)
1998 <- rnLDerivStrategy doc dcs $ rn_deriv_clause_tys dct
1999 ; warnNoDerivStrat dcs' (locA loc)
2000 ; pure ( L loc (HsDerivingClause { deriv_clause_ext = noExtField
2001 , deriv_clause_strategy = dcs'
2002 , deriv_clause_tys = dct' })
2003 , fvs ) }
2004 where
2005 rn_deriv_clause_tys :: LDerivClauseTys GhcPs
2006 -> RnM (LDerivClauseTys GhcRn, FreeVars)
2007 rn_deriv_clause_tys (L l dct) = case dct of
2008 DctSingle x ty -> do
2009 (ty', fvs) <- rn_clause_pred ty
2010 pure (L l (DctSingle x ty'), fvs)
2011 DctMulti x tys -> do
2012 (tys', fvs) <- mapFvRn rn_clause_pred tys
2013 pure (L l (DctMulti x tys'), fvs)
2014
2015 rn_clause_pred :: LHsSigType GhcPs -> RnM (LHsSigType GhcRn, FreeVars)
2016 rn_clause_pred pred_ty = do
2017 let inf_err = Just (text "Inferred type variables are not allowed")
2018 checkInferredVars doc inf_err pred_ty
2019 ret@(pred_ty', _) <- rnHsSigType doc TypeLevel pred_ty
2020 -- Check if there are any nested `forall`s, which are illegal in a
2021 -- `deriving` clause.
2022 -- See Note [No nested foralls or contexts in instance types]
2023 -- (Wrinkle: Derived instances) in GHC.Hs.Type.
2024 addNoNestedForallsContextsErr doc (text "Derived class type")
2025 (getLHsInstDeclHead pred_ty')
2026 pure ret
2027
2028 rnLDerivStrategy :: forall a.
2029 HsDocContext
2030 -> Maybe (LDerivStrategy GhcPs)
2031 -> RnM (a, FreeVars)
2032 -> RnM (Maybe (LDerivStrategy GhcRn), a, FreeVars)
2033 rnLDerivStrategy doc mds thing_inside
2034 = case mds of
2035 Nothing -> boring_case Nothing
2036 Just (L loc ds) ->
2037 setSrcSpanA loc $ do
2038 (ds', thing, fvs) <- rn_deriv_strat ds
2039 pure (Just (L loc ds'), thing, fvs)
2040 where
2041 rn_deriv_strat :: DerivStrategy GhcPs
2042 -> RnM (DerivStrategy GhcRn, a, FreeVars)
2043 rn_deriv_strat ds = do
2044 let extNeeded :: LangExt.Extension
2045 extNeeded
2046 | ViaStrategy{} <- ds
2047 = LangExt.DerivingVia
2048 | otherwise
2049 = LangExt.DerivingStrategies
2050
2051 unlessXOptM extNeeded $
2052 failWith $ illegalDerivStrategyErr ds
2053
2054 case ds of
2055 StockStrategy _ -> boring_case (StockStrategy noExtField)
2056 AnyclassStrategy _ -> boring_case (AnyclassStrategy noExtField)
2057 NewtypeStrategy _ -> boring_case (NewtypeStrategy noExtField)
2058 ViaStrategy (XViaStrategyPs _ via_ty) ->
2059 do checkInferredVars doc inf_err via_ty
2060 (via_ty', fvs1) <- rnHsSigType doc TypeLevel via_ty
2061 let HsSig { sig_bndrs = via_outer_bndrs
2062 , sig_body = via_body } = unLoc via_ty'
2063 via_tvs = hsOuterTyVarNames via_outer_bndrs
2064 -- Check if there are any nested `forall`s, which are illegal in a
2065 -- `via` type.
2066 -- See Note [No nested foralls or contexts in instance types]
2067 -- (Wrinkle: Derived instances) in GHC.Hs.Type.
2068 addNoNestedForallsContextsErr doc
2069 (quotes (text "via") <+> text "type") via_body
2070 (thing, fvs2) <- bindLocalNamesFV via_tvs thing_inside
2071 pure (ViaStrategy via_ty', thing, fvs1 `plusFV` fvs2)
2072
2073 inf_err = Just (text "Inferred type variables are not allowed")
2074
2075 boring_case :: ds -> RnM (ds, a, FreeVars)
2076 boring_case ds = do
2077 (thing, fvs) <- thing_inside
2078 pure (ds, thing, fvs)
2079
2080 badGadtStupidTheta :: HsDocContext -> TcRnMessage
2081 badGadtStupidTheta _
2082 = TcRnUnknownMessage $ mkPlainError noHints $
2083 vcat [text "No context is allowed on a GADT-style data declaration",
2084 text "(You can put a context on each constructor, though.)"]
2085
2086 illegalDerivStrategyErr :: DerivStrategy GhcPs -> TcRnMessage
2087 illegalDerivStrategyErr ds
2088 = TcRnUnknownMessage $ mkPlainError noHints $
2089 vcat [ text "Illegal deriving strategy" <> colon <+> derivStrategyName ds
2090 , text enableStrategy ]
2091
2092 where
2093 enableStrategy :: String
2094 enableStrategy
2095 | ViaStrategy{} <- ds
2096 = "Use DerivingVia to enable this extension"
2097 | otherwise
2098 = "Use DerivingStrategies to enable this extension"
2099
2100 multipleDerivClausesErr :: TcRnMessage
2101 multipleDerivClausesErr
2102 = TcRnUnknownMessage $ mkPlainError noHints $
2103 vcat [ text "Illegal use of multiple, consecutive deriving clauses"
2104 , text "Use DerivingStrategies to allow this" ]
2105
2106 rnFamDecl :: Maybe Name -- Just cls => this FamilyDecl is nested
2107 -- inside an *class decl* for cls
2108 -- used for associated types
2109 -> FamilyDecl GhcPs
2110 -> RnM (FamilyDecl GhcRn, FreeVars)
2111 rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars
2112 , fdTopLevel = toplevel
2113 , fdFixity = fixity
2114 , fdInfo = info, fdResultSig = res_sig
2115 , fdInjectivityAnn = injectivity })
2116 = do { tycon' <- lookupLocatedTopConstructorRnN tycon
2117 ; ((tyvars', res_sig', injectivity'), fv1) <-
2118 bindHsQTyVars doc mb_cls kvs tyvars $ \ tyvars' _ ->
2119 do { let rn_sig = rnFamResultSig doc
2120 ; (res_sig', fv_kind) <- wrapLocFstMA rn_sig res_sig
2121 ; injectivity' <- traverse (rnInjectivityAnn tyvars' res_sig')
2122 injectivity
2123 ; return ( (tyvars', res_sig', injectivity') , fv_kind ) }
2124 ; (info', fv2) <- rn_info info
2125 ; return (FamilyDecl { fdExt = noAnn
2126 , fdLName = tycon', fdTyVars = tyvars'
2127 , fdTopLevel = toplevel
2128 , fdFixity = fixity
2129 , fdInfo = info', fdResultSig = res_sig'
2130 , fdInjectivityAnn = injectivity' }
2131 , fv1 `plusFV` fv2) }
2132 where
2133 doc = TyFamilyCtx tycon
2134 kvs = extractRdrKindSigVars res_sig
2135
2136 ----------------------
2137 rn_info :: FamilyInfo GhcPs -> RnM (FamilyInfo GhcRn, FreeVars)
2138 rn_info (ClosedTypeFamily (Just eqns))
2139 = do { (eqns', fvs)
2140 <- rnList (rnTyFamInstEqn (NonAssocTyFamEqn ClosedTyFam)) eqns
2141 -- no class context
2142 ; return (ClosedTypeFamily (Just eqns'), fvs) }
2143 rn_info (ClosedTypeFamily Nothing)
2144 = return (ClosedTypeFamily Nothing, emptyFVs)
2145 rn_info OpenTypeFamily = return (OpenTypeFamily, emptyFVs)
2146 rn_info DataFamily = return (DataFamily, emptyFVs)
2147
2148 rnFamResultSig :: HsDocContext
2149 -> FamilyResultSig GhcPs
2150 -> RnM (FamilyResultSig GhcRn, FreeVars)
2151 rnFamResultSig _ (NoSig _)
2152 = return (NoSig noExtField, emptyFVs)
2153 rnFamResultSig doc (KindSig _ kind)
2154 = do { (rndKind, ftvs) <- rnLHsKind doc kind
2155 ; return (KindSig noExtField rndKind, ftvs) }
2156 rnFamResultSig doc (TyVarSig _ tvbndr)
2157 = do { -- `TyVarSig` tells us that user named the result of a type family by
2158 -- writing `= tyvar` or `= (tyvar :: kind)`. In such case we want to
2159 -- be sure that the supplied result name is not identical to an
2160 -- already in-scope type variable from an enclosing class.
2161 --
2162 -- Example of disallowed declaration:
2163 -- class C a b where
2164 -- type F b = a | a -> b
2165 rdr_env <- getLocalRdrEnv
2166 ; let resName = hsLTyVarName tvbndr
2167 ; when (resName `elemLocalRdrEnv` rdr_env) $
2168 addErrAt (getLocA tvbndr) $ TcRnUnknownMessage $ mkPlainError noHints $
2169 (hsep [ text "Type variable", quotes (ppr resName) <> comma
2170 , text "naming a type family result,"
2171 ] $$
2172 text "shadows an already bound type variable")
2173
2174 ; bindLHsTyVarBndr doc Nothing -- This might be a lie, but it's used for
2175 -- scoping checks that are irrelevant here
2176 tvbndr $ \ tvbndr' ->
2177 return (TyVarSig noExtField tvbndr', unitFV (hsLTyVarName tvbndr')) }
2178
2179 -- Note [Renaming injectivity annotation]
2180 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2181 --
2182 -- During renaming of injectivity annotation we have to make several checks to
2183 -- make sure that it is well-formed. At the moment injectivity annotation
2184 -- consists of a single injectivity condition, so the terms "injectivity
2185 -- annotation" and "injectivity condition" might be used interchangeably. See
2186 -- Note [Injectivity annotation] for a detailed discussion of currently allowed
2187 -- injectivity annotations.
2188 --
2189 -- Checking LHS is simple because the only type variable allowed on the LHS of
2190 -- injectivity condition is the variable naming the result in type family head.
2191 -- Example of disallowed annotation:
2192 --
2193 -- type family Foo a b = r | b -> a
2194 --
2195 -- Verifying RHS of injectivity consists of checking that:
2196 --
2197 -- 1. only variables defined in type family head appear on the RHS (kind
2198 -- variables are also allowed). Example of disallowed annotation:
2199 --
2200 -- type family Foo a = r | r -> b
2201 --
2202 -- 2. for associated types the result variable does not shadow any of type
2203 -- class variables. Example of disallowed annotation:
2204 --
2205 -- class Foo a b where
2206 -- type F a = b | b -> a
2207 --
2208 -- Breaking any of these assumptions results in an error.
2209
2210 -- | Rename injectivity annotation. Note that injectivity annotation is just the
2211 -- part after the "|". Everything that appears before it is renamed in
2212 -- rnFamDecl.
2213 rnInjectivityAnn :: LHsQTyVars GhcRn -- ^ Type variables declared in
2214 -- type family head
2215 -> LFamilyResultSig GhcRn -- ^ Result signature
2216 -> LInjectivityAnn GhcPs -- ^ Injectivity annotation
2217 -> RnM (LInjectivityAnn GhcRn)
2218 rnInjectivityAnn tvBndrs (L _ (TyVarSig _ resTv))
2219 (L srcSpan (InjectivityAnn x injFrom injTo))
2220 = do
2221 { (injDecl'@(L _ (InjectivityAnn _ injFrom' injTo')), noRnErrors)
2222 <- askNoErrs $
2223 bindLocalNames [hsLTyVarName resTv] $
2224 -- The return type variable scopes over the injectivity annotation
2225 -- e.g. type family F a = (r::*) | r -> a
2226 do { injFrom' <- rnLTyVar injFrom
2227 ; injTo' <- mapM rnLTyVar injTo
2228 -- Note: srcSpan is unchanged, but typechecker gets
2229 -- confused, l2l call makes it happy
2230 ; return $ L (l2l srcSpan) (InjectivityAnn x injFrom' injTo') }
2231
2232 ; let tvNames = Set.fromList $ hsAllLTyVarNames tvBndrs
2233 resName = hsLTyVarName resTv
2234 -- See Note [Renaming injectivity annotation]
2235 lhsValid = EQ == (stableNameCmp resName (unLoc injFrom'))
2236 rhsValid = Set.fromList (map unLoc injTo') `Set.difference` tvNames
2237
2238 -- if renaming of type variables ended with errors (eg. there were
2239 -- not-in-scope variables) don't check the validity of injectivity
2240 -- annotation. This gives better error messages.
2241 ; when (noRnErrors && not lhsValid) $
2242 addErrAt (getLocA injFrom) $ TcRnUnknownMessage $ mkPlainError noHints $
2243 ( vcat [ text $ "Incorrect type variable on the LHS of "
2244 ++ "injectivity condition"
2245 , nest 5
2246 ( vcat [ text "Expected :" <+> ppr resName
2247 , text "Actual :" <+> ppr injFrom ])])
2248
2249 ; when (noRnErrors && not (Set.null rhsValid)) $
2250 do { let errorVars = Set.toList rhsValid
2251 ; addErrAt (locA srcSpan) $ TcRnUnknownMessage $ mkPlainError noHints $
2252 ( hsep
2253 [ text "Unknown type variable" <> plural errorVars
2254 , text "on the RHS of injectivity condition:"
2255 , interpp'SP errorVars ] ) }
2256
2257 ; return injDecl' }
2258
2259 -- We can only hit this case when the user writes injectivity annotation without
2260 -- naming the result:
2261 --
2262 -- type family F a | result -> a
2263 -- type family F a :: * | result -> a
2264 --
2265 -- So we rename injectivity annotation like we normally would except that
2266 -- this time we expect "result" to be reported not in scope by rnLTyVar.
2267 rnInjectivityAnn _ _ (L srcSpan (InjectivityAnn x injFrom injTo)) =
2268 setSrcSpanA srcSpan $ do
2269 (injDecl', _) <- askNoErrs $ do
2270 injFrom' <- rnLTyVar injFrom
2271 injTo' <- mapM rnLTyVar injTo
2272 return $ L srcSpan (InjectivityAnn x injFrom' injTo')
2273 return $ injDecl'
2274
2275 {-
2276 Note [Stupid theta]
2277 ~~~~~~~~~~~~~~~~~~~
2278 #3850 complains about a regression wrt 6.10 for
2279 data Show a => T a
2280 There is no reason not to allow the stupid theta if there are no data
2281 constructors. It's still stupid, but does no harm, and I don't want
2282 to cause programs to break unnecessarily (notably HList). So if there
2283 are no data constructors we allow h98_style = True
2284 -}
2285
2286
2287 {- *****************************************************
2288 * *
2289 Support code for type/data declarations
2290 * *
2291 ***************************************************** -}
2292
2293 -----------------
2294 rnConDecls :: [LConDecl GhcPs] -> RnM ([LConDecl GhcRn], FreeVars)
2295 rnConDecls = mapFvRn (wrapLocFstMA rnConDecl)
2296
2297 rnConDecl :: ConDecl GhcPs -> RnM (ConDecl GhcRn, FreeVars)
2298 rnConDecl decl@(ConDeclH98 { con_name = name, con_ex_tvs = ex_tvs
2299 , con_mb_cxt = mcxt, con_args = args
2300 , con_doc = mb_doc, con_forall = forall })
2301 = do { _ <- addLocMA checkConName name
2302 ; new_name <- lookupLocatedTopConstructorRnN name
2303
2304 -- We bind no implicit binders here; this is just like
2305 -- a nested HsForAllTy. E.g. consider
2306 -- data T a = forall (b::k). MkT (...)
2307 -- The 'k' will already be in scope from the bindHsQTyVars
2308 -- for the data decl itself. So we'll get
2309 -- data T {k} a = ...
2310 -- And indeed we may later discover (a::k). But that's the
2311 -- scoping we get. So no implicit binders at the existential forall
2312
2313 ; let ctxt = ConDeclCtx [new_name]
2314 ; bindLHsTyVarBndrs ctxt WarnUnusedForalls
2315 Nothing ex_tvs $ \ new_ex_tvs ->
2316 do { (new_context, fvs1) <- rnMbContext ctxt mcxt
2317 ; (new_args, fvs2) <- rnConDeclH98Details (unLoc new_name) ctxt args
2318 ; let all_fvs = fvs1 `plusFV` fvs2
2319 ; traceRn "rnConDecl (ConDeclH98)" (ppr name <+> vcat
2320 [ text "ex_tvs:" <+> ppr ex_tvs
2321 , text "new_ex_dqtvs':" <+> ppr new_ex_tvs ])
2322
2323 ; return (decl { con_ext = noAnn
2324 , con_name = new_name, con_ex_tvs = new_ex_tvs
2325 , con_mb_cxt = new_context, con_args = new_args
2326 , con_doc = mb_doc
2327 , con_forall = forall }, -- Remove when #18311 is fixed
2328 all_fvs) }}
2329
2330 rnConDecl (ConDeclGADT { con_names = names
2331 , con_bndrs = L l outer_bndrs
2332 , con_mb_cxt = mcxt
2333 , con_g_args = args
2334 , con_res_ty = res_ty
2335 , con_doc = mb_doc })
2336 = do { mapM_ (addLocMA checkConName) names
2337 ; new_names <- mapM (lookupLocatedTopConstructorRnN) names
2338
2339 ; let -- We must ensure that we extract the free tkvs in left-to-right
2340 -- order of their appearance in the constructor type.
2341 -- That order governs the order the implicitly-quantified type
2342 -- variable, and hence the order needed for visible type application
2343 -- See #14808.
2344 implicit_bndrs =
2345 extractHsOuterTvBndrs outer_bndrs $
2346 extractHsTysRdrTyVars (hsConDeclTheta mcxt) $
2347 extractConDeclGADTDetailsTyVars args $
2348 extractHsTysRdrTyVars [res_ty] []
2349
2350 ; let ctxt = ConDeclCtx new_names
2351
2352 ; bindHsOuterTyVarBndrs ctxt Nothing implicit_bndrs outer_bndrs $ \outer_bndrs' ->
2353 do { (new_cxt, fvs1) <- rnMbContext ctxt mcxt
2354 ; (new_args, fvs2) <- rnConDeclGADTDetails (unLoc (head new_names)) ctxt args
2355 ; (new_res_ty, fvs3) <- rnLHsType ctxt res_ty
2356
2357 -- Ensure that there are no nested `forall`s or contexts, per
2358 -- Note [GADT abstract syntax] (Wrinkle: No nested foralls or contexts)
2359 -- in GHC.Hs.Type.
2360 ; addNoNestedForallsContextsErr ctxt
2361 (text "GADT constructor type signature") new_res_ty
2362
2363 ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3
2364
2365 ; traceRn "rnConDecl (ConDeclGADT)"
2366 (ppr names $$ ppr outer_bndrs')
2367 ; return (ConDeclGADT { con_g_ext = noAnn, con_names = new_names
2368 , con_bndrs = L l outer_bndrs', con_mb_cxt = new_cxt
2369 , con_g_args = new_args, con_res_ty = new_res_ty
2370 , con_doc = mb_doc },
2371 all_fvs) } }
2372
2373 rnMbContext :: HsDocContext -> Maybe (LHsContext GhcPs)
2374 -> RnM (Maybe (LHsContext GhcRn), FreeVars)
2375 rnMbContext _ Nothing = return (Nothing, emptyFVs)
2376 rnMbContext doc cxt = do { (ctx',fvs) <- rnMaybeContext doc cxt
2377 ; return (ctx',fvs) }
2378
2379 rnConDeclH98Details ::
2380 Name
2381 -> HsDocContext
2382 -> HsConDeclH98Details GhcPs
2383 -> RnM (HsConDeclH98Details GhcRn, FreeVars)
2384 rnConDeclH98Details _ doc (PrefixCon _ tys)
2385 = do { (new_tys, fvs) <- mapFvRn (rnScaledLHsType doc) tys
2386 ; return (PrefixCon noTypeArgs new_tys, fvs) }
2387 rnConDeclH98Details _ doc (InfixCon ty1 ty2)
2388 = do { (new_ty1, fvs1) <- rnScaledLHsType doc ty1
2389 ; (new_ty2, fvs2) <- rnScaledLHsType doc ty2
2390 ; return (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2) }
2391 rnConDeclH98Details con doc (RecCon flds)
2392 = do { (new_flds, fvs) <- rnRecConDeclFields con doc flds
2393 ; return (RecCon new_flds, fvs) }
2394
2395 rnConDeclGADTDetails ::
2396 Name
2397 -> HsDocContext
2398 -> HsConDeclGADTDetails GhcPs
2399 -> RnM (HsConDeclGADTDetails GhcRn, FreeVars)
2400 rnConDeclGADTDetails _ doc (PrefixConGADT tys)
2401 = do { (new_tys, fvs) <- mapFvRn (rnScaledLHsType doc) tys
2402 ; return (PrefixConGADT new_tys, fvs) }
2403 rnConDeclGADTDetails con doc (RecConGADT flds arr)
2404 = do { (new_flds, fvs) <- rnRecConDeclFields con doc flds
2405 ; return (RecConGADT new_flds arr, fvs) }
2406
2407 rnRecConDeclFields ::
2408 Name
2409 -> HsDocContext
2410 -> LocatedL [LConDeclField GhcPs]
2411 -> RnM (LocatedL [LConDeclField GhcRn], FreeVars)
2412 rnRecConDeclFields con doc (L l fields)
2413 = do { fls <- lookupConstructorFields con
2414 ; (new_fields, fvs) <- rnConDeclFields doc fls fields
2415 -- No need to check for duplicate fields
2416 -- since that is done by GHC.Rename.Names.extendGlobalRdrEnvRn
2417 ; pure (L l new_fields, fvs) }
2418
2419 -------------------------------------------------
2420
2421 -- | Brings pattern synonym names and also pattern synonym selectors
2422 -- from record pattern synonyms into scope.
2423 extendPatSynEnv :: DuplicateRecordFields -> FieldSelectors -> HsValBinds GhcPs -> MiniFixityEnv
2424 -> ([Name] -> TcRnIf TcGblEnv TcLclEnv a) -> TcM a
2425 extendPatSynEnv dup_fields_ok has_sel val_decls local_fix_env thing = do {
2426 names_with_fls <- new_ps val_decls
2427 ; let pat_syn_bndrs = concat [ name: map flSelector fields
2428 | (name, fields) <- names_with_fls ]
2429 ; let avails = map avail (map fst names_with_fls)
2430 ++ map availField (concatMap snd names_with_fls)
2431 ; (gbl_env, lcl_env) <- extendGlobalRdrEnvRn avails local_fix_env
2432
2433 ; let field_env' = extendNameEnvList (tcg_field_env gbl_env) names_with_fls
2434 final_gbl_env = gbl_env { tcg_field_env = field_env' }
2435 ; setEnvs (final_gbl_env, lcl_env) (thing pat_syn_bndrs) }
2436 where
2437 new_ps :: HsValBinds GhcPs -> TcM [(Name, [FieldLabel])]
2438 new_ps (ValBinds _ binds _) = foldrM new_ps' [] binds
2439 new_ps _ = panic "new_ps"
2440
2441 new_ps' :: LHsBindLR GhcPs GhcPs
2442 -> [(Name, [FieldLabel])]
2443 -> TcM [(Name, [FieldLabel])]
2444 new_ps' bind names
2445 | (L bind_loc (PatSynBind _ (PSB { psb_id = L _ n
2446 , psb_args = RecCon as }))) <- bind
2447 = do
2448 bnd_name <- newTopSrcBinder (L (l2l bind_loc) n)
2449 let field_occs = map ((\ f -> L (noAnnSrcSpan $ getLocA (foLabel f)) f) . recordPatSynField) as
2450 flds <- mapM (newRecordSelector dup_fields_ok has_sel [bnd_name]) field_occs
2451 return ((bnd_name, flds): names)
2452 | L bind_loc (PatSynBind _ (PSB { psb_id = L _ n})) <- bind
2453 = do
2454 bnd_name <- newTopSrcBinder (L (la2na bind_loc) n)
2455 return ((bnd_name, []): names)
2456 | otherwise
2457 = return names
2458
2459 {-
2460 *********************************************************
2461 * *
2462 \subsection{Support code to rename types}
2463 * *
2464 *********************************************************
2465 -}
2466
2467 rnFds :: [LHsFunDep GhcPs] -> RnM [LHsFunDep GhcRn]
2468 rnFds fds
2469 = mapM (wrapLocMA rn_fds) fds
2470 where
2471 rn_fds :: FunDep GhcPs -> RnM (FunDep GhcRn)
2472 rn_fds (FunDep x tys1 tys2)
2473 = do { tys1' <- rnHsTyVars tys1
2474 ; tys2' <- rnHsTyVars tys2
2475 ; return (FunDep x tys1' tys2') }
2476
2477 rnHsTyVars :: [LocatedN RdrName] -> RnM [LocatedN Name]
2478 rnHsTyVars tvs = mapM rnHsTyVar tvs
2479
2480 rnHsTyVar :: LocatedN RdrName -> RnM (LocatedN Name)
2481 rnHsTyVar (L l tyvar) = do
2482 tyvar' <- lookupOccRn tyvar
2483 return (L l tyvar')
2484
2485 {-
2486 *********************************************************
2487 * *
2488 findSplice
2489 * *
2490 *********************************************************
2491
2492 This code marches down the declarations, looking for the first
2493 Template Haskell splice. As it does so it
2494 a) groups the declarations into a HsGroup
2495 b) runs any top-level quasi-quotes
2496 -}
2497
2498 findSplice :: [LHsDecl GhcPs]
2499 -> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
2500 findSplice ds = addl emptyRdrGroup ds
2501
2502 addl :: HsGroup GhcPs -> [LHsDecl GhcPs]
2503 -> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
2504 -- This stuff reverses the declarations (again) but it doesn't matter
2505 addl gp [] = return (gp, Nothing)
2506 addl gp (L l d : ds) = add gp l d ds
2507
2508
2509 add :: HsGroup GhcPs -> SrcSpanAnnA -> HsDecl GhcPs -> [LHsDecl GhcPs]
2510 -> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
2511
2512 -- #10047: Declaration QuasiQuoters are expanded immediately, without
2513 -- causing a group split
2514 add gp _ (SpliceD _ (SpliceDecl _ (L _ qq@HsQuasiQuote{}) _)) ds
2515 = do { (ds', _) <- rnTopSpliceDecls qq
2516 ; addl gp (ds' ++ ds)
2517 }
2518
2519 add gp loc (SpliceD _ splice@(SpliceDecl _ _ flag)) ds
2520 = do { -- We've found a top-level splice. If it is an *implicit* one
2521 -- (i.e. a naked top level expression)
2522 case flag of
2523 ExplicitSplice -> return ()
2524 ImplicitSplice -> do { th_on <- xoptM LangExt.TemplateHaskell
2525 ; unless th_on $ setSrcSpan (locA loc) $
2526 failWith badImplicitSplice }
2527
2528 ; return (gp, Just (splice, ds)) }
2529 where
2530 badImplicitSplice :: TcRnMessage
2531 badImplicitSplice = TcRnUnknownMessage $ mkPlainError noHints $
2532 text "Parse error: module header, import declaration"
2533 $$ text "or top-level declaration expected."
2534 -- The compiler should suggest the above, and not using
2535 -- TemplateHaskell since the former suggestion is more
2536 -- relevant to the larger base of users.
2537 -- See #12146 for discussion.
2538
2539 -- Class declarations: added to the TyClGroup
2540 add gp@(HsGroup {hs_tyclds = ts}) l (TyClD _ d) ds
2541 = addl (gp { hs_tyclds = add_tycld (L l d) ts }) ds
2542
2543 -- Signatures: fixity sigs go a different place than all others
2544 add gp@(HsGroup {hs_fixds = ts}) l (SigD _ (FixSig _ f)) ds
2545 = addl (gp {hs_fixds = L l f : ts}) ds
2546
2547 -- Standalone kind signatures: added to the TyClGroup
2548 add gp@(HsGroup {hs_tyclds = ts}) l (KindSigD _ s) ds
2549 = addl (gp {hs_tyclds = add_kisig (L l s) ts}) ds
2550
2551 add gp@(HsGroup {hs_valds = ts}) l (SigD _ d) ds
2552 = addl (gp {hs_valds = add_sig (L l d) ts}) ds
2553
2554 -- Value declarations: use add_bind
2555 add gp@(HsGroup {hs_valds = ts}) l (ValD _ d) ds
2556 = addl (gp { hs_valds = add_bind (L l d) ts }) ds
2557
2558 -- Role annotations: added to the TyClGroup
2559 add gp@(HsGroup {hs_tyclds = ts}) l (RoleAnnotD _ d) ds
2560 = addl (gp { hs_tyclds = add_role_annot (L l d) ts }) ds
2561
2562 -- NB instance declarations go into TyClGroups. We throw them into the first
2563 -- group, just as we do for the TyClD case. The renamer will go on to group
2564 -- and order them later.
2565 add gp@(HsGroup {hs_tyclds = ts}) l (InstD _ d) ds
2566 = addl (gp { hs_tyclds = add_instd (L l d) ts }) ds
2567
2568 -- The rest are routine
2569 add gp@(HsGroup {hs_derivds = ts}) l (DerivD _ d) ds
2570 = addl (gp { hs_derivds = L l d : ts }) ds
2571 add gp@(HsGroup {hs_defds = ts}) l (DefD _ d) ds
2572 = addl (gp { hs_defds = L l d : ts }) ds
2573 add gp@(HsGroup {hs_fords = ts}) l (ForD _ d) ds
2574 = addl (gp { hs_fords = L l d : ts }) ds
2575 add gp@(HsGroup {hs_warnds = ts}) l (WarningD _ d) ds
2576 = addl (gp { hs_warnds = L l d : ts }) ds
2577 add gp@(HsGroup {hs_annds = ts}) l (AnnD _ d) ds
2578 = addl (gp { hs_annds = L l d : ts }) ds
2579 add gp@(HsGroup {hs_ruleds = ts}) l (RuleD _ d) ds
2580 = addl (gp { hs_ruleds = L l d : ts }) ds
2581 add gp l (DocD _ d) ds
2582 = addl (gp { hs_docs = (L l d) : (hs_docs gp) }) ds
2583
2584 add_tycld :: LTyClDecl (GhcPass p) -> [TyClGroup (GhcPass p)]
2585 -> [TyClGroup (GhcPass p)]
2586 add_tycld d [] = [TyClGroup { group_ext = noExtField
2587 , group_tyclds = [d]
2588 , group_kisigs = []
2589 , group_roles = []
2590 , group_instds = []
2591 }
2592 ]
2593 add_tycld d (ds@(TyClGroup { group_tyclds = tyclds }):dss)
2594 = ds { group_tyclds = d : tyclds } : dss
2595
2596 add_instd :: LInstDecl (GhcPass p) -> [TyClGroup (GhcPass p)]
2597 -> [TyClGroup (GhcPass p)]
2598 add_instd d [] = [TyClGroup { group_ext = noExtField
2599 , group_tyclds = []
2600 , group_kisigs = []
2601 , group_roles = []
2602 , group_instds = [d]
2603 }
2604 ]
2605 add_instd d (ds@(TyClGroup { group_instds = instds }):dss)
2606 = ds { group_instds = d : instds } : dss
2607
2608 add_role_annot :: LRoleAnnotDecl (GhcPass p) -> [TyClGroup (GhcPass p)]
2609 -> [TyClGroup (GhcPass p)]
2610 add_role_annot d [] = [TyClGroup { group_ext = noExtField
2611 , group_tyclds = []
2612 , group_kisigs = []
2613 , group_roles = [d]
2614 , group_instds = []
2615 }
2616 ]
2617 add_role_annot d (tycls@(TyClGroup { group_roles = roles }) : rest)
2618 = tycls { group_roles = d : roles } : rest
2619
2620 add_kisig :: LStandaloneKindSig (GhcPass p)
2621 -> [TyClGroup (GhcPass p)] -> [TyClGroup (GhcPass p)]
2622 add_kisig d [] = [TyClGroup { group_ext = noExtField
2623 , group_tyclds = []
2624 , group_kisigs = [d]
2625 , group_roles = []
2626 , group_instds = []
2627 }
2628 ]
2629 add_kisig d (tycls@(TyClGroup { group_kisigs = kisigs }) : rest)
2630 = tycls { group_kisigs = d : kisigs } : rest
2631
2632 add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a
2633 add_bind b (ValBinds x bs sigs) = ValBinds x (bs `snocBag` b) sigs
2634 add_bind _ (XValBindsLR {}) = panic "GHC.Rename.Module.add_bind"
2635
2636 add_sig :: LSig (GhcPass a) -> HsValBinds (GhcPass a) -> HsValBinds (GhcPass a)
2637 add_sig s (ValBinds x bs sigs) = ValBinds x bs (s:sigs)
2638 add_sig _ (XValBindsLR {}) = panic "GHC.Rename.Module.add_sig"