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