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