Warn about unused type variables in type families
[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, ScopedTypeVariables #-}
8
9 module RnSource (
10 rnSrcDecls, addTcgDUs, findSplice
11 ) where
12
13 #include "HsVersions.h"
14
15 import {-# SOURCE #-} RnExpr( rnLExpr )
16 import {-# SOURCE #-} RnSplice ( rnSpliceDecl, rnTopSpliceDecls )
17
18 import HsSyn
19 import FieldLabel
20 import RdrName
21 import RnTypes
22 import RnBinds
23 import RnEnv
24 import RnNames
25 import RnHsDoc ( rnHsDoc, rnMbLHsDoc )
26 import TcAnnotations ( annCtxt )
27 import TcRnMonad
28
29 import ForeignCall ( CCallTarget(..) )
30 import Module
31 import HscTypes ( Warnings(..), plusWarns )
32 import Class ( FunDep )
33 import PrelNames ( applicativeClassName, pureAName, thenAName
34 , monadClassName, returnMName, thenMName
35 , semigroupClassName, sappendName
36 , monoidClassName, mappendName
37 )
38 import Name
39 import NameSet
40 import NameEnv
41 import Avail
42 import Outputable
43 import Bag
44 import BasicTypes ( RuleName, pprRuleName )
45 import FastString
46 import SrcLoc
47 import DynFlags
48 import HscTypes ( HscEnv, hsc_dflags )
49 import ListSetOps ( findDupsEq, removeDups )
50 import Digraph ( SCC, flattenSCC, stronglyConnCompFromEdgedVertices )
51 import qualified GHC.LanguageExtensions as LangExt
52
53 import Control.Monad
54 import Data.List ( (\\), nubBy, sortBy )
55 import Maybes( orElse, mapMaybe )
56 import qualified Data.Set as Set ( difference, fromList, toList, null )
57 #if __GLASGOW_HASKELL__ < 709
58 import Data.Traversable (traverse)
59 #endif
60
61 {-
62 @rnSourceDecl@ `renames' declarations.
63 It simultaneously performs dependency analysis and precedence parsing.
64 It also does the following error checks:
65 \begin{enumerate}
66 \item
67 Checks that tyvars are used properly. This includes checking
68 for undefined tyvars, and tyvars in contexts that are ambiguous.
69 (Some of this checking has now been moved to module @TcMonoType@,
70 since we don't have functional dependency information at this point.)
71 \item
72 Checks that all variable occurrences are defined.
73 \item
74 Checks the @(..)@ etc constraints in the export list.
75 \end{enumerate}
76 -}
77
78 -- Brings the binders of the group into scope in the appropriate places;
79 -- does NOT assume that anything is in scope already
80 rnSrcDecls :: HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name)
81 -- Rename a top-level HsGroup; used for normal source files *and* hs-boot files
82 rnSrcDecls group@(HsGroup { hs_valds = val_decls,
83 hs_splcds = splice_decls,
84 hs_tyclds = tycl_decls,
85 hs_instds = inst_decls,
86 hs_derivds = deriv_decls,
87 hs_fixds = fix_decls,
88 hs_warnds = warn_decls,
89 hs_annds = ann_decls,
90 hs_fords = foreign_decls,
91 hs_defds = default_decls,
92 hs_ruleds = rule_decls,
93 hs_vects = vect_decls,
94 hs_docs = docs })
95 = do {
96 -- (A) Process the fixity declarations, creating a mapping from
97 -- FastStrings to FixItems.
98 -- Also checks for duplicates.
99 local_fix_env <- makeMiniFixityEnv fix_decls ;
100
101 -- (B) Bring top level binders (and their fixities) into scope,
102 -- *except* for the value bindings, which get done in step (D)
103 -- with collectHsIdBinders. However *do* include
104 --
105 -- * Class ops, data constructors, and record fields,
106 -- because they do not have value declarations.
107 -- Aso step (C) depends on datacons and record fields
108 --
109 -- * For hs-boot files, include the value signatures
110 -- Again, they have no value declarations
111 --
112 (tc_envs, tc_bndrs) <- getLocalNonValBinders local_fix_env group ;
113
114
115 setEnvs tc_envs $ do {
116
117 failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations
118
119 -- (D1) Bring pattern synonyms into scope.
120 -- Need to do this before (D2) because rnTopBindsLHS
121 -- looks up those pattern synonyms (Trac #9889)
122
123 extendPatSynEnv val_decls local_fix_env $ \pat_syn_bndrs -> do {
124
125 -- (D2) Rename the left-hand sides of the value bindings.
126 -- This depends on everything from (B) being in scope,
127 -- and on (C) for resolving record wild cards.
128 -- It uses the fixity env from (A) to bind fixities for view patterns.
129 new_lhs <- rnTopBindsLHS local_fix_env val_decls ;
130
131 -- Bind the LHSes (and their fixities) in the global rdr environment
132 let { id_bndrs = collectHsIdBinders new_lhs } ; -- Excludes pattern-synonym binders
133 -- They are already in scope
134 traceRn (text "rnSrcDecls" <+> ppr id_bndrs) ;
135 tc_envs <- extendGlobalRdrEnvRn (map avail id_bndrs) local_fix_env ;
136 traceRn (text "D2" <+> ppr (tcg_rdr_env (fst tc_envs)));
137 setEnvs tc_envs $ do {
138
139 -- Now everything is in scope, as the remaining renaming assumes.
140
141 -- (E) Rename type and class decls
142 -- (note that value LHSes need to be in scope for default methods)
143 --
144 -- You might think that we could build proper def/use information
145 -- for type and class declarations, but they can be involved
146 -- in mutual recursion across modules, and we only do the SCC
147 -- analysis for them in the type checker.
148 -- So we content ourselves with gathering uses only; that
149 -- means we'll only report a declaration as unused if it isn't
150 -- mentioned at all. Ah well.
151 traceRn (text "Start rnTyClDecls") ;
152 (rn_tycl_decls, src_fvs1) <- rnTyClDecls tycl_decls ;
153
154 -- (F) Rename Value declarations right-hand sides
155 traceRn (text "Start rnmono") ;
156 let { val_bndr_set = mkNameSet id_bndrs `unionNameSet` mkNameSet pat_syn_bndrs } ;
157 (rn_val_decls, bind_dus) <- rnTopBindsRHS val_bndr_set new_lhs ;
158 traceRn (text "finish rnmono" <+> ppr rn_val_decls) ;
159
160 -- (G) Rename Fixity and deprecations
161
162 -- Rename fixity declarations and error if we try to
163 -- fix something from another module (duplicates were checked in (A))
164 let { all_bndrs = tc_bndrs `unionNameSet` val_bndr_set } ;
165 rn_fix_decls <- rnSrcFixityDecls all_bndrs fix_decls ;
166
167 -- Rename deprec decls;
168 -- check for duplicates and ensure that deprecated things are defined locally
169 -- at the moment, we don't keep these around past renaming
170 rn_warns <- rnSrcWarnDecls all_bndrs warn_decls ;
171
172 -- (H) Rename Everything else
173
174 (rn_inst_decls, src_fvs2) <- rnList rnSrcInstDecl inst_decls ;
175 (rn_rule_decls, src_fvs3) <- setXOptM LangExt.ScopedTypeVariables $
176 rnList rnHsRuleDecls rule_decls ;
177 -- Inside RULES, scoped type variables are on
178 (rn_vect_decls, src_fvs4) <- rnList rnHsVectDecl vect_decls ;
179 (rn_foreign_decls, src_fvs5) <- rnList rnHsForeignDecl foreign_decls ;
180 (rn_ann_decls, src_fvs6) <- rnList rnAnnDecl ann_decls ;
181 (rn_default_decls, src_fvs7) <- rnList rnDefaultDecl default_decls ;
182 (rn_deriv_decls, src_fvs8) <- rnList rnSrcDerivDecl deriv_decls ;
183 (rn_splice_decls, src_fvs9) <- rnList rnSpliceDecl splice_decls ;
184 -- Haddock docs; no free vars
185 rn_docs <- mapM (wrapLocM rnDocDecl) docs ;
186
187 last_tcg_env <- getGblEnv ;
188 -- (I) Compute the results and return
189 let {rn_group = HsGroup { hs_valds = rn_val_decls,
190 hs_splcds = rn_splice_decls,
191 hs_tyclds = rn_tycl_decls,
192 hs_instds = rn_inst_decls,
193 hs_derivds = rn_deriv_decls,
194 hs_fixds = rn_fix_decls,
195 hs_warnds = [], -- warns are returned in the tcg_env
196 -- (see below) not in the HsGroup
197 hs_fords = rn_foreign_decls,
198 hs_annds = rn_ann_decls,
199 hs_defds = rn_default_decls,
200 hs_ruleds = rn_rule_decls,
201 hs_vects = rn_vect_decls,
202 hs_docs = rn_docs } ;
203
204 tcf_bndrs = hsTyClForeignBinders rn_tycl_decls rn_inst_decls rn_foreign_decls ;
205 other_def = (Just (mkNameSet tcf_bndrs), emptyNameSet) ;
206 other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs3, src_fvs4,
207 src_fvs5, src_fvs6, src_fvs7, src_fvs8,
208 src_fvs9] ;
209 -- It is tiresome to gather the binders from type and class decls
210
211 src_dus = [other_def] `plusDU` bind_dus `plusDU` usesOnly other_fvs ;
212 -- Instance decls may have occurrences of things bound in bind_dus
213 -- so we must put other_fvs last
214
215 final_tcg_env = let tcg_env' = (last_tcg_env `addTcgDUs` src_dus)
216 in -- we return the deprecs in the env, not in the HsGroup above
217 tcg_env' { tcg_warns = tcg_warns tcg_env' `plusWarns` rn_warns };
218 } ;
219 traceRn (text "last" <+> ppr (tcg_rdr_env final_tcg_env)) ;
220 traceRn (text "finish rnSrc" <+> ppr rn_group) ;
221 traceRn (text "finish Dus" <+> ppr src_dus ) ;
222 return (final_tcg_env, rn_group)
223 }}}}
224
225 addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv
226 -- This function could be defined lower down in the module hierarchy,
227 -- but there doesn't seem anywhere very logical to put it.
228 addTcgDUs tcg_env dus = tcg_env { tcg_dus = tcg_dus tcg_env `plusDU` dus }
229
230 rnList :: (a -> RnM (b, FreeVars)) -> [Located a] -> RnM ([Located b], FreeVars)
231 rnList f xs = mapFvRn (wrapLocFstM f) xs
232
233 {-
234 *********************************************************
235 * *
236 HsDoc stuff
237 * *
238 *********************************************************
239 -}
240
241 rnDocDecl :: DocDecl -> RnM DocDecl
242 rnDocDecl (DocCommentNext doc) = do
243 rn_doc <- rnHsDoc doc
244 return (DocCommentNext rn_doc)
245 rnDocDecl (DocCommentPrev doc) = do
246 rn_doc <- rnHsDoc doc
247 return (DocCommentPrev rn_doc)
248 rnDocDecl (DocCommentNamed str doc) = do
249 rn_doc <- rnHsDoc doc
250 return (DocCommentNamed str rn_doc)
251 rnDocDecl (DocGroup lev doc) = do
252 rn_doc <- rnHsDoc doc
253 return (DocGroup lev rn_doc)
254
255 {-
256 *********************************************************
257 * *
258 Source-code fixity declarations
259 * *
260 *********************************************************
261 -}
262
263 rnSrcFixityDecls :: NameSet -> [LFixitySig RdrName] -> RnM [LFixitySig Name]
264 -- Rename the fixity decls, so we can put
265 -- the renamed decls in the renamed syntax tree
266 -- Errors if the thing being fixed is not defined locally.
267 --
268 -- The returned FixitySigs are not actually used for anything,
269 -- except perhaps the GHCi API
270 rnSrcFixityDecls bndr_set fix_decls
271 = do fix_decls <- mapM rn_decl fix_decls
272 return (concat fix_decls)
273 where
274 sig_ctxt = TopSigCtxt bndr_set
275
276 rn_decl :: LFixitySig RdrName -> RnM [LFixitySig Name]
277 -- GHC extension: look up both the tycon and data con
278 -- for con-like things; hence returning a list
279 -- If neither are in scope, report an error; otherwise
280 -- return a fixity sig for each (slightly odd)
281 rn_decl (L loc (FixitySig fnames fixity))
282 = do names <- mapM lookup_one fnames
283 return [ L loc (FixitySig name fixity)
284 | name <- names ]
285
286 lookup_one :: Located RdrName -> RnM [Located Name]
287 lookup_one (L name_loc rdr_name)
288 = setSrcSpan name_loc $
289 -- this lookup will fail if the definition isn't local
290 do names <- lookupLocalTcNames sig_ctxt what rdr_name
291 return [ L name_loc name | (_, name) <- names ]
292 what = ptext (sLit "fixity signature")
293
294 {-
295 *********************************************************
296 * *
297 Source-code deprecations declarations
298 * *
299 *********************************************************
300
301 Check that the deprecated names are defined, are defined locally, and
302 that there are no duplicate deprecations.
303
304 It's only imported deprecations, dealt with in RnIfaces, that we
305 gather them together.
306 -}
307
308 -- checks that the deprecations are defined locally, and that there are no duplicates
309 rnSrcWarnDecls :: NameSet -> [LWarnDecls RdrName] -> RnM Warnings
310 rnSrcWarnDecls _ []
311 = return NoWarnings
312
313 rnSrcWarnDecls bndr_set decls'
314 = do { -- check for duplicates
315 ; mapM_ (\ dups -> let (L loc rdr:lrdr':_) = dups
316 in addErrAt loc (dupWarnDecl lrdr' rdr))
317 warn_rdr_dups
318 ; pairs_s <- mapM (addLocM rn_deprec) decls
319 ; return (WarnSome ((concat pairs_s))) }
320 where
321 decls = concatMap (\(L _ d) -> wd_warnings d) decls'
322
323 sig_ctxt = TopSigCtxt bndr_set
324
325 rn_deprec (Warning rdr_names txt)
326 -- ensures that the names are defined locally
327 = do { names <- concatMapM (lookupLocalTcNames sig_ctxt what . unLoc)
328 rdr_names
329 ; return [(rdrNameOcc rdr, txt) | (rdr, _) <- names] }
330
331 what = ptext (sLit "deprecation")
332
333 warn_rdr_dups = findDupRdrNames $ concatMap (\(L _ (Warning ns _)) -> ns)
334 decls
335
336 findDupRdrNames :: [Located RdrName] -> [[Located RdrName]]
337 findDupRdrNames = findDupsEq (\ x -> \ y -> rdrNameOcc (unLoc x) == rdrNameOcc (unLoc y))
338
339 -- look for duplicates among the OccNames;
340 -- we check that the names are defined above
341 -- invt: the lists returned by findDupsEq always have at least two elements
342
343 dupWarnDecl :: Located RdrName -> RdrName -> SDoc
344 -- Located RdrName -> DeprecDecl RdrName -> SDoc
345 dupWarnDecl (L loc _) rdr_name
346 = vcat [ptext (sLit "Multiple warning declarations for") <+> quotes (ppr rdr_name),
347 ptext (sLit "also at ") <+> ppr loc]
348
349 {-
350 *********************************************************
351 * *
352 \subsection{Annotation declarations}
353 * *
354 *********************************************************
355 -}
356
357 rnAnnDecl :: AnnDecl RdrName -> RnM (AnnDecl Name, FreeVars)
358 rnAnnDecl ann@(HsAnnotation s provenance expr)
359 = addErrCtxt (annCtxt ann) $
360 do { (provenance', provenance_fvs) <- rnAnnProvenance provenance
361 ; (expr', expr_fvs) <- setStage (Splice Untyped) $
362 rnLExpr expr
363 ; return (HsAnnotation s provenance' expr',
364 provenance_fvs `plusFV` expr_fvs) }
365
366 rnAnnProvenance :: AnnProvenance RdrName -> RnM (AnnProvenance Name, FreeVars)
367 rnAnnProvenance provenance = do
368 provenance' <- traverse lookupTopBndrRn provenance
369 return (provenance', maybe emptyFVs unitFV (annProvenanceName_maybe provenance'))
370
371 {-
372 *********************************************************
373 * *
374 \subsection{Default declarations}
375 * *
376 *********************************************************
377 -}
378
379 rnDefaultDecl :: DefaultDecl RdrName -> RnM (DefaultDecl Name, FreeVars)
380 rnDefaultDecl (DefaultDecl tys)
381 = do { (tys', fvs) <- rnLHsTypes doc_str tys
382 ; return (DefaultDecl tys', fvs) }
383 where
384 doc_str = DefaultDeclCtx
385
386 {-
387 *********************************************************
388 * *
389 \subsection{Foreign declarations}
390 * *
391 *********************************************************
392 -}
393
394 rnHsForeignDecl :: ForeignDecl RdrName -> RnM (ForeignDecl Name, FreeVars)
395 rnHsForeignDecl (ForeignImport { fd_name = name, fd_sig_ty = ty, fd_fi = spec })
396 = do { topEnv :: HscEnv <- getTopEnv
397 ; name' <- lookupLocatedTopBndrRn name
398 ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) ty
399
400 -- Mark any PackageTarget style imports as coming from the current package
401 ; let unitId = thisPackage $ hsc_dflags topEnv
402 spec' = patchForeignImport unitId spec
403
404 ; return (ForeignImport { fd_name = name', fd_sig_ty = ty'
405 , fd_co = noForeignImportCoercionYet
406 , fd_fi = spec' }, fvs) }
407
408 rnHsForeignDecl (ForeignExport { fd_name = name, fd_sig_ty = ty, fd_fe = spec })
409 = do { name' <- lookupLocatedOccRn name
410 ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) ty
411 ; return (ForeignExport { fd_name = name', fd_sig_ty = ty'
412 , fd_co = noForeignExportCoercionYet
413 , fd_fe = spec }
414 , fvs `addOneFV` unLoc name') }
415 -- NB: a foreign export is an *occurrence site* for name, so
416 -- we add it to the free-variable list. It might, for example,
417 -- be imported from another module
418
419 -- | For Windows DLLs we need to know what packages imported symbols are from
420 -- to generate correct calls. Imported symbols are tagged with the current
421 -- package, so if they get inlined across a package boundry we'll still
422 -- know where they're from.
423 --
424 patchForeignImport :: UnitId -> ForeignImport -> ForeignImport
425 patchForeignImport unitId (CImport cconv safety fs spec src)
426 = CImport cconv safety fs (patchCImportSpec unitId spec) src
427
428 patchCImportSpec :: UnitId -> CImportSpec -> CImportSpec
429 patchCImportSpec unitId spec
430 = case spec of
431 CFunction callTarget -> CFunction $ patchCCallTarget unitId callTarget
432 _ -> spec
433
434 patchCCallTarget :: UnitId -> CCallTarget -> CCallTarget
435 patchCCallTarget unitId callTarget =
436 case callTarget of
437 StaticTarget src label Nothing isFun
438 -> StaticTarget src label (Just unitId) isFun
439 _ -> callTarget
440
441 {-
442 *********************************************************
443 * *
444 \subsection{Instance declarations}
445 * *
446 *********************************************************
447 -}
448
449 rnSrcInstDecl :: InstDecl RdrName -> RnM (InstDecl Name, FreeVars)
450 rnSrcInstDecl (TyFamInstD { tfid_inst = tfi })
451 = do { (tfi', fvs) <- rnTyFamInstDecl Nothing tfi
452 ; return (TyFamInstD { tfid_inst = tfi' }, fvs) }
453
454 rnSrcInstDecl (DataFamInstD { dfid_inst = dfi })
455 = do { (dfi', fvs) <- rnDataFamInstDecl Nothing dfi
456 ; return (DataFamInstD { dfid_inst = dfi' }, fvs) }
457
458 rnSrcInstDecl (ClsInstD { cid_inst = cid })
459 = do { (cid', fvs) <- rnClsInstDecl cid
460 ; return (ClsInstD { cid_inst = cid' }, fvs) }
461
462 -- | Warn about non-canonical typeclass instance declarations
463 --
464 -- A "non-canonical" instance definition can occur for instances of a
465 -- class which redundantly defines an operation its superclass
466 -- provides as well (c.f. `return`/`pure`). In such cases, a canonical
467 -- instance is one where the subclass inherits its method
468 -- implementation from its superclass instance (usually the subclass
469 -- has a default method implementation to that effect). Consequently,
470 -- a non-canonical instance occurs when this is not the case.
471 --
472 -- See also descriptions of 'checkCanonicalMonadInstances' and
473 -- 'checkCanonicalMonoidInstances'
474 checkCanonicalInstances :: Name -> LHsSigType Name -> LHsBinds Name -> RnM ()
475 checkCanonicalInstances cls poly_ty mbinds = do
476 whenWOptM Opt_WarnNonCanonicalMonadInstances
477 checkCanonicalMonadInstances
478
479 whenWOptM Opt_WarnNonCanonicalMonoidInstances
480 checkCanonicalMonoidInstances
481
482 where
483 -- | Warn about unsound/non-canonical 'Applicative'/'Monad' instance
484 -- declarations. Specifically, the following conditions are verified:
485 --
486 -- In 'Monad' instances declarations:
487 --
488 -- * If 'return' is overridden it must be canonical (i.e. @return = pure@)
489 -- * If '(>>)' is overridden it must be canonical (i.e. @(>>) = (*>)@)
490 --
491 -- In 'Applicative' instance declarations:
492 --
493 -- * Warn if 'pure' is defined backwards (i.e. @pure = return@).
494 -- * Warn if '(*>)' is defined backwards (i.e. @(*>) = (>>)@).
495 --
496 checkCanonicalMonadInstances
497 | cls == applicativeClassName = do
498 forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do
499 case mbind of
500 FunBind { fun_id = L _ name, fun_matches = mg }
501 | name == pureAName, isAliasMG mg == Just returnMName
502 -> addWarnNonCanonicalMethod1 "pure" "return"
503
504 | name == thenAName, isAliasMG mg == Just thenMName
505 -> addWarnNonCanonicalMethod1 "(*>)" "(>>)"
506
507 _ -> return ()
508
509 | cls == monadClassName = do
510 forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do
511 case mbind of
512 FunBind { fun_id = L _ name, fun_matches = mg }
513 | name == returnMName, isAliasMG mg /= Just pureAName
514 -> addWarnNonCanonicalMethod2 "return" "pure"
515
516 | name == thenMName, isAliasMG mg /= Just thenAName
517 -> addWarnNonCanonicalMethod2 "(>>)" "(*>)"
518
519 _ -> return ()
520
521 | otherwise = return ()
522
523 -- | Check whether Monoid(mappend) is defined in terms of
524 -- Semigroup((<>)) (and not the other way round). Specifically,
525 -- the following conditions are verified:
526 --
527 -- In 'Monoid' instances declarations:
528 --
529 -- * If 'mappend' is overridden it must be canonical
530 -- (i.e. @mappend = (<>)@)
531 --
532 -- In 'Semigroup' instance declarations:
533 --
534 -- * Warn if '(<>)' is defined backwards (i.e. @(<>) = mappend@).
535 --
536 checkCanonicalMonoidInstances
537 | cls == semigroupClassName = do
538 forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do
539 case mbind of
540 FunBind { fun_id = L _ name, fun_matches = mg }
541 | name == sappendName, isAliasMG mg == Just mappendName
542 -> addWarnNonCanonicalMethod1 "(<>)" "mappend"
543
544 _ -> return ()
545
546 | cls == monoidClassName = do
547 forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do
548 case mbind of
549 FunBind { fun_id = L _ name, fun_matches = mg }
550 | name == mappendName, isAliasMG mg /= Just sappendName
551 -> addWarnNonCanonicalMethod2NoDefault "mappend" "(<>)"
552
553 _ -> return ()
554
555 | otherwise = return ()
556
557 -- | test whether MatchGroup represents a trivial \"lhsName = rhsName\"
558 -- binding, and return @Just rhsName@ if this is the case
559 isAliasMG :: MatchGroup Name (LHsExpr Name) -> Maybe Name
560 isAliasMG MG {mg_alts = L _ [L _ (Match { m_pats = [], m_grhss = grhss })]}
561 | GRHSs [L _ (GRHS [] body)] lbinds <- grhss
562 , L _ EmptyLocalBinds <- lbinds
563 , L _ (HsVar (L _ rhsName)) <- body = Just rhsName
564 isAliasMG _ = Nothing
565
566 -- got "lhs = rhs" but expected something different
567 addWarnNonCanonicalMethod1 lhs rhs = do
568 addWarn $ vcat [ text "Noncanonical" <+>
569 quotes (text (lhs ++ " = " ++ rhs)) <+>
570 text "definition detected"
571 , instDeclCtxt1 poly_ty
572 , text "Move definition from" <+>
573 quotes (text rhs) <+>
574 text "to" <+> quotes (text lhs)
575 ]
576
577 -- expected "lhs = rhs" but got something else
578 addWarnNonCanonicalMethod2 lhs rhs = do
579 addWarn $ vcat [ text "Noncanonical" <+>
580 quotes (text lhs) <+>
581 text "definition detected"
582 , instDeclCtxt1 poly_ty
583 , text "Either remove definition for" <+>
584 quotes (text lhs) <+> text "or define as" <+>
585 quotes (text (lhs ++ " = " ++ rhs))
586 ]
587
588 -- like above, but method has no default impl
589 addWarnNonCanonicalMethod2NoDefault lhs rhs = do
590 addWarn $ vcat [ text "Noncanonical" <+>
591 quotes (text lhs) <+>
592 text "definition detected"
593 , instDeclCtxt1 poly_ty
594 , text "Define as" <+>
595 quotes (text (lhs ++ " = " ++ rhs))
596 ]
597
598 -- stolen from TcInstDcls
599 instDeclCtxt1 :: LHsSigType Name -> SDoc
600 instDeclCtxt1 hs_inst_ty
601 | (_, _, head_ty) <- splitLHsInstDeclTy hs_inst_ty
602 = inst_decl_ctxt (ppr head_ty)
603
604 inst_decl_ctxt :: SDoc -> SDoc
605 inst_decl_ctxt doc = hang (ptext (sLit "in the instance declaration for"))
606 2 (quotes doc <> text ".")
607
608
609 rnClsInstDecl :: ClsInstDecl RdrName -> RnM (ClsInstDecl Name, FreeVars)
610 rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds
611 , cid_sigs = uprags, cid_tyfam_insts = ats
612 , cid_overlap_mode = oflag
613 , cid_datafam_insts = adts })
614 = do { (inst_ty', inst_fvs) <- rnLHsInstType (text "an instance declaration") inst_ty
615 ; let (ktv_names, _, head_ty') = splitLHsInstDeclTy inst_ty'
616 ; let cls = case hsTyGetAppHead_maybe head_ty' of
617 Nothing -> mkUnboundName (mkTcOccFS (fsLit "<class>"))
618 Just (L _ cls, _) -> cls
619 -- rnLHsInstType has added an error message
620 -- if hsTyGetAppHead_maybe fails
621
622 -- Rename the bindings
623 -- The typechecker (not the renamer) checks that all
624 -- the bindings are for the right class
625 -- (Slightly strangely) when scoped type variables are on, the
626 -- forall-d tyvars scope over the method bindings too
627 ; (mbinds', uprags', meth_fvs) <- rnMethodBinds False cls ktv_names mbinds uprags
628
629 ; checkCanonicalInstances cls inst_ty' mbinds'
630
631 -- Rename the associated types, and type signatures
632 -- Both need to have the instance type variables in scope
633 ; traceRn (text "rnSrcInstDecl" <+> ppr inst_ty' $$ ppr ktv_names)
634 ; ((ats', adts'), more_fvs)
635 <- extendTyVarEnvFVRn ktv_names $
636 do { (ats', at_fvs) <- rnATInstDecls rnTyFamInstDecl cls ktv_names ats
637 ; (adts', adt_fvs) <- rnATInstDecls rnDataFamInstDecl cls ktv_names adts
638 ; return ( (ats', adts'), at_fvs `plusFV` adt_fvs) }
639
640 ; let all_fvs = meth_fvs `plusFV` more_fvs
641 `plusFV` inst_fvs
642 ; return (ClsInstDecl { cid_poly_ty = inst_ty', cid_binds = mbinds'
643 , cid_sigs = uprags', cid_tyfam_insts = ats'
644 , cid_overlap_mode = oflag
645 , cid_datafam_insts = adts' },
646 all_fvs) }
647 -- We return the renamed associated data type declarations so
648 -- that they can be entered into the list of type declarations
649 -- for the binding group, but we also keep a copy in the instance.
650 -- The latter is needed for well-formedness checks in the type
651 -- checker (eg, to ensure that all ATs of the instance actually
652 -- receive a declaration).
653 -- NB: Even the copies in the instance declaration carry copies of
654 -- the instance context after renaming. This is a bit
655 -- strange, but should not matter (and it would be more work
656 -- to remove the context).
657
658 rnFamInstDecl :: HsDocContext
659 -> Maybe (Name, [Name])
660 -> Located RdrName
661 -> HsTyPats RdrName
662 -> rhs
663 -> (HsDocContext -> rhs -> RnM (rhs', FreeVars))
664 -> RnM (Located Name, HsTyPats Name, rhs', FreeVars)
665 rnFamInstDecl doc mb_cls tycon (HsIB { hsib_body = pats }) payload rnPayload
666 = do { tycon' <- lookupFamInstName (fmap fst mb_cls) tycon
667 ; let loc = case pats of
668 [] -> pprPanic "rnFamInstDecl" (ppr tycon)
669 (L loc _ : []) -> loc
670 (L loc _ : ps) -> combineSrcSpans loc (getLoc (last ps))
671 -- Duplicates are needed to warn about unused type variables
672 -- See Note [Wild cards in family instances] in TcTyClsDecls
673 ; tv_rdr_names_all <- extractHsTysRdrTyVarsDups pats
674 ; let tv_rdr_names = rmDupsInRdrTyVars tv_rdr_names_all
675 tv_rdr_dups = nubBy eqLocated
676 (freeKiTyVarsTypeVars tv_rdr_names_all
677 \\ freeKiTyVarsTypeVars tv_rdr_names)
678
679 ; var_names <- mapM (newTyVarNameRn mb_cls . L loc . unLoc) $
680 freeKiTyVarsAllVars tv_rdr_names
681 -- All the free vars of the family patterns
682 -- with a sensible binding location
683 ; ((pats', payload'), fvs)
684 <- bindLocalNamesFV var_names $
685 do { (pats', pat_fvs) <- rnLHsTypes (FamPatCtx tycon) pats
686 ; (payload', rhs_fvs) <- rnPayload doc payload
687
688 ; tv_nms_dups <- mapM (lookupOccRn . unLoc) tv_rdr_dups
689 ; let tv_nms_used = extendNameSetList rhs_fvs tv_nms_dups
690 ; warnUnusedMatches var_names tv_nms_used
691
692 -- See Note [Renaming associated types]
693 ; let bad_tvs = case mb_cls of
694 Nothing -> []
695 Just (_,cls_tkvs) -> filter is_bad cls_tkvs
696 var_name_set = mkNameSet var_names
697
698 is_bad cls_tkv = cls_tkv `elemNameSet` rhs_fvs
699 && not (cls_tkv `elemNameSet` var_name_set)
700
701 ; unless (null bad_tvs) (badAssocRhs bad_tvs)
702 ; return ((pats', payload'), rhs_fvs `plusFV` pat_fvs) }
703
704 ; let all_fvs = fvs `addOneFV` unLoc tycon'
705 ; return (tycon',
706 HsIB { hsib_body = pats', hsib_vars = var_names },
707 payload',
708 all_fvs) }
709 -- type instance => use, hence addOneFV
710
711 rnTyFamInstDecl :: Maybe (Name, [Name])
712 -> TyFamInstDecl RdrName
713 -> RnM (TyFamInstDecl Name, FreeVars)
714 rnTyFamInstDecl mb_cls (TyFamInstDecl { tfid_eqn = L loc eqn })
715 = do { (eqn', fvs) <- rnTyFamInstEqn mb_cls eqn
716 ; return (TyFamInstDecl { tfid_eqn = L loc eqn'
717 , tfid_fvs = fvs }, fvs) }
718
719 rnTyFamInstEqn :: Maybe (Name, [Name])
720 -> TyFamInstEqn RdrName
721 -> RnM (TyFamInstEqn Name, FreeVars)
722 rnTyFamInstEqn mb_cls (TyFamEqn { tfe_tycon = tycon
723 , tfe_pats = pats
724 , tfe_rhs = rhs })
725 = do { (tycon', pats', rhs', fvs) <-
726 rnFamInstDecl (TySynCtx tycon) mb_cls tycon pats rhs rnTySyn
727 ; return (TyFamEqn { tfe_tycon = tycon'
728 , tfe_pats = pats'
729 , tfe_rhs = rhs' }, fvs) }
730
731 rnTyFamDefltEqn :: Name
732 -> TyFamDefltEqn RdrName
733 -> RnM (TyFamDefltEqn Name, FreeVars)
734 rnTyFamDefltEqn cls (TyFamEqn { tfe_tycon = tycon
735 , tfe_pats = tyvars
736 , tfe_rhs = rhs })
737 = bindHsQTyVars ctx (Just cls) [] tyvars $ \ tyvars' ->
738 do { tycon' <- lookupFamInstName (Just cls) tycon
739 ; (rhs', fvs) <- rnLHsType ctx rhs
740 ; return (TyFamEqn { tfe_tycon = tycon'
741 , tfe_pats = tyvars'
742 , tfe_rhs = rhs' }, fvs) }
743 where
744 ctx = TyFamilyCtx tycon
745
746 rnDataFamInstDecl :: Maybe (Name, [Name])
747 -> DataFamInstDecl RdrName
748 -> RnM (DataFamInstDecl Name, FreeVars)
749 rnDataFamInstDecl mb_cls (DataFamInstDecl { dfid_tycon = tycon
750 , dfid_pats = pats
751 , dfid_defn = defn })
752 = do { (tycon', pats', defn', fvs) <-
753 rnFamInstDecl (TyDataCtx tycon) mb_cls tycon pats defn rnDataDefn
754 ; return (DataFamInstDecl { dfid_tycon = tycon'
755 , dfid_pats = pats'
756 , dfid_defn = defn'
757 , dfid_fvs = fvs }, fvs) }
758
759 -- Renaming of the associated types in instances.
760
761 -- Rename associated type family decl in class
762 rnATDecls :: Name -- Class
763 -> [LFamilyDecl RdrName]
764 -> RnM ([LFamilyDecl Name], FreeVars)
765 rnATDecls cls at_decls
766 = rnList (rnFamDecl (Just cls)) at_decls
767
768 rnATInstDecls :: (Maybe (Name, [Name]) -> -- The function that renames
769 decl RdrName -> -- an instance. rnTyFamInstDecl
770 RnM (decl Name, FreeVars)) -- or rnDataFamInstDecl
771 -> Name -- Class
772 -> [Name]
773 -> [Located (decl RdrName)]
774 -> RnM ([Located (decl Name)], FreeVars)
775 -- Used for data and type family defaults in a class decl
776 -- and the family instance declarations in an instance
777 --
778 -- NB: We allow duplicate associated-type decls;
779 -- See Note [Associated type instances] in TcInstDcls
780 rnATInstDecls rnFun cls tv_ns at_insts
781 = rnList (rnFun (Just (cls, tv_ns))) at_insts
782 -- See Note [Renaming associated types]
783
784 {-
785 Note [Renaming associated types]
786 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
787 Check that the RHS of the decl mentions only type variables
788 bound on the LHS. For example, this is not ok
789 class C a b where
790 type F a x :: *
791 instance C (p,q) r where
792 type F (p,q) x = (x, r) -- BAD: mentions 'r'
793 c.f. Trac #5515
794
795 The same thing applies to kind variables, of course (Trac #7938, #9574):
796 class Funct f where
797 type Codomain f :: *
798 instance Funct ('KProxy :: KProxy o) where
799 type Codomain 'KProxy = NatTr (Proxy :: o -> *)
800 Here 'o' is mentioned on the RHS of the Codomain function, but
801 not on the LHS.
802
803 All this applies only for *instance* declarations. In *class*
804 declarations there is no RHS to worry about, and the class variables
805 can all be in scope (Trac #5862):
806 class Category (x :: k -> k -> *) where
807 type Ob x :: k -> Constraint
808 id :: Ob x a => x a a
809 (.) :: (Ob x a, Ob x b, Ob x c) => x b c -> x a b -> x a c
810 Here 'k' is in scope in the kind signature, just like 'x'.
811 -}
812
813
814 {-
815 *********************************************************
816 * *
817 \subsection{Stand-alone deriving declarations}
818 * *
819 *********************************************************
820 -}
821
822 rnSrcDerivDecl :: DerivDecl RdrName -> RnM (DerivDecl Name, FreeVars)
823 rnSrcDerivDecl (DerivDecl ty overlap)
824 = do { standalone_deriv_ok <- xoptM LangExt.StandaloneDeriving
825 ; unless standalone_deriv_ok (addErr standaloneDerivErr)
826 ; (ty', fvs) <- rnLHsInstType (text "In a deriving declaration") ty
827 ; return (DerivDecl ty' overlap, fvs) }
828
829 standaloneDerivErr :: SDoc
830 standaloneDerivErr
831 = hang (ptext (sLit "Illegal standalone deriving declaration"))
832 2 (ptext (sLit "Use StandaloneDeriving to enable this extension"))
833
834 {-
835 *********************************************************
836 * *
837 \subsection{Rules}
838 * *
839 *********************************************************
840 -}
841
842 rnHsRuleDecls :: RuleDecls RdrName -> RnM (RuleDecls Name, FreeVars)
843 rnHsRuleDecls (HsRules src rules)
844 = do { (rn_rules,fvs) <- rnList rnHsRuleDecl rules
845 ; return (HsRules src rn_rules,fvs) }
846
847 rnHsRuleDecl :: RuleDecl RdrName -> RnM (RuleDecl Name, FreeVars)
848 rnHsRuleDecl (HsRule rule_name act vars lhs _fv_lhs rhs _fv_rhs)
849 = do { let rdr_names_w_loc = map get_var vars
850 ; checkDupRdrNames rdr_names_w_loc
851 ; checkShadowedRdrNames rdr_names_w_loc
852 ; names <- newLocalBndrsRn rdr_names_w_loc
853 ; bindHsRuleVars (snd $ unLoc rule_name) vars names $ \ vars' ->
854 do { (lhs', fv_lhs') <- rnLExpr lhs
855 ; (rhs', fv_rhs') <- rnLExpr rhs
856 ; checkValidRule (snd $ unLoc rule_name) names lhs' fv_lhs'
857 ; return (HsRule rule_name act vars' lhs' fv_lhs' rhs' fv_rhs',
858 fv_lhs' `plusFV` fv_rhs') } }
859 where
860 get_var (L _ (RuleBndrSig v _)) = v
861 get_var (L _ (RuleBndr v)) = v
862
863 bindHsRuleVars :: RuleName -> [LRuleBndr RdrName] -> [Name]
864 -> ([LRuleBndr Name] -> RnM (a, FreeVars))
865 -> RnM (a, FreeVars)
866 bindHsRuleVars rule_name vars names thing_inside
867 = go vars names $ \ vars' ->
868 bindLocalNamesFV names (thing_inside vars')
869 where
870 doc = RuleCtx rule_name
871
872 go (L l (RuleBndr (L loc _)) : vars) (n : ns) thing_inside
873 = go vars ns $ \ vars' ->
874 thing_inside (L l (RuleBndr (L loc n)) : vars')
875
876 go (L l (RuleBndrSig (L loc _) bsig) : vars) (n : ns) thing_inside
877 = rnHsSigWcTypeScoped doc bsig $ \ bsig' ->
878 go vars ns $ \ vars' ->
879 thing_inside (L l (RuleBndrSig (L loc n) bsig') : vars')
880
881 go [] [] thing_inside = thing_inside []
882 go vars names _ = pprPanic "bindRuleVars" (ppr vars $$ ppr names)
883
884 {-
885 Note [Rule LHS validity checking]
886 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
887 Check the shape of a transformation rule LHS. Currently we only allow
888 LHSs of the form @(f e1 .. en)@, where @f@ is not one of the
889 @forall@'d variables.
890
891 We used restrict the form of the 'ei' to prevent you writing rules
892 with LHSs with a complicated desugaring (and hence unlikely to match);
893 (e.g. a case expression is not allowed: too elaborate.)
894
895 But there are legitimate non-trivial args ei, like sections and
896 lambdas. So it seems simmpler not to check at all, and that is why
897 check_e is commented out.
898 -}
899
900 checkValidRule :: FastString -> [Name] -> LHsExpr Name -> NameSet -> RnM ()
901 checkValidRule rule_name ids lhs' fv_lhs'
902 = do { -- Check for the form of the LHS
903 case (validRuleLhs ids lhs') of
904 Nothing -> return ()
905 Just bad -> failWithTc (badRuleLhsErr rule_name lhs' bad)
906
907 -- Check that LHS vars are all bound
908 ; let bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs')]
909 ; mapM_ (addErr . badRuleVar rule_name) bad_vars }
910
911 validRuleLhs :: [Name] -> LHsExpr Name -> Maybe (HsExpr Name)
912 -- Nothing => OK
913 -- Just e => Not ok, and e is the offending sub-expression
914 validRuleLhs foralls lhs
915 = checkl lhs
916 where
917 checkl (L _ e) = check e
918
919 check (OpApp e1 op _ e2) = checkl op `mplus` checkl_e e1 `mplus` checkl_e e2
920 check (HsApp e1 e2) = checkl e1 `mplus` checkl_e e2
921 check (HsVar (L _ v)) | v `notElem` foralls = Nothing
922 check other = Just other -- Failure
923
924 -- Check an argument
925 checkl_e (L _ _e) = Nothing -- Was (check_e e); see Note [Rule LHS validity checking]
926
927 {- Commented out; see Note [Rule LHS validity checking] above
928 check_e (HsVar v) = Nothing
929 check_e (HsPar e) = checkl_e e
930 check_e (HsLit e) = Nothing
931 check_e (HsOverLit e) = Nothing
932
933 check_e (OpApp e1 op _ e2) = checkl_e e1 `mplus` checkl_e op `mplus` checkl_e e2
934 check_e (HsApp e1 e2) = checkl_e e1 `mplus` checkl_e e2
935 check_e (NegApp e _) = checkl_e e
936 check_e (ExplicitList _ es) = checkl_es es
937 check_e other = Just other -- Fails
938
939 checkl_es es = foldr (mplus . checkl_e) Nothing es
940 -}
941
942 badRuleVar :: FastString -> Name -> SDoc
943 badRuleVar name var
944 = sep [ptext (sLit "Rule") <+> doubleQuotes (ftext name) <> colon,
945 ptext (sLit "Forall'd variable") <+> quotes (ppr var) <+>
946 ptext (sLit "does not appear on left hand side")]
947
948 badRuleLhsErr :: FastString -> LHsExpr Name -> HsExpr Name -> SDoc
949 badRuleLhsErr name lhs bad_e
950 = sep [ptext (sLit "Rule") <+> pprRuleName name <> colon,
951 nest 4 (vcat [err,
952 ptext (sLit "in left-hand side:") <+> ppr lhs])]
953 $$
954 ptext (sLit "LHS must be of form (f e1 .. en) where f is not forall'd")
955 where
956 err = case bad_e of
957 HsUnboundVar occ -> ptext (sLit "Not in scope:") <+> ppr occ
958 _ -> ptext (sLit "Illegal expression:") <+> ppr bad_e
959
960 {-
961 *********************************************************
962 * *
963 \subsection{Vectorisation declarations}
964 * *
965 *********************************************************
966 -}
967
968 rnHsVectDecl :: VectDecl RdrName -> RnM (VectDecl Name, FreeVars)
969 -- FIXME: For the moment, the right-hand side is restricted to be a variable as we cannot properly
970 -- typecheck a complex right-hand side without invoking 'vectType' from the vectoriser.
971 rnHsVectDecl (HsVect s var rhs@(L _ (HsVar _)))
972 = do { var' <- lookupLocatedOccRn var
973 ; (rhs', fv_rhs) <- rnLExpr rhs
974 ; return (HsVect s var' rhs', fv_rhs `addOneFV` unLoc var')
975 }
976 rnHsVectDecl (HsVect _ _var _rhs)
977 = failWith $ vcat
978 [ ptext (sLit "IMPLEMENTATION RESTRICTION: right-hand side of a VECTORISE pragma")
979 , ptext (sLit "must be an identifier")
980 ]
981 rnHsVectDecl (HsNoVect s var)
982 = do { var' <- lookupLocatedTopBndrRn var -- only applies to local (not imported) names
983 ; return (HsNoVect s var', unitFV (unLoc var'))
984 }
985 rnHsVectDecl (HsVectTypeIn s isScalar tycon Nothing)
986 = do { tycon' <- lookupLocatedOccRn tycon
987 ; return (HsVectTypeIn s isScalar tycon' Nothing, unitFV (unLoc tycon'))
988 }
989 rnHsVectDecl (HsVectTypeIn s isScalar tycon (Just rhs_tycon))
990 = do { tycon' <- lookupLocatedOccRn tycon
991 ; rhs_tycon' <- lookupLocatedOccRn rhs_tycon
992 ; return ( HsVectTypeIn s isScalar tycon' (Just rhs_tycon')
993 , mkFVs [unLoc tycon', unLoc rhs_tycon'])
994 }
995 rnHsVectDecl (HsVectTypeOut _ _ _)
996 = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectTypeOut'"
997 rnHsVectDecl (HsVectClassIn s cls)
998 = do { cls' <- lookupLocatedOccRn cls
999 ; return (HsVectClassIn s cls', unitFV (unLoc cls'))
1000 }
1001 rnHsVectDecl (HsVectClassOut _)
1002 = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectClassOut'"
1003 rnHsVectDecl (HsVectInstIn instTy)
1004 = do { (instTy', fvs) <- rnLHsInstType (text "a VECTORISE pragma") instTy
1005 ; return (HsVectInstIn instTy', fvs)
1006 }
1007 rnHsVectDecl (HsVectInstOut _)
1008 = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectInstOut'"
1009
1010 {-
1011 *********************************************************
1012 * *
1013 \subsection{Type, class and iface sig declarations}
1014 * *
1015 *********************************************************
1016
1017 @rnTyDecl@ uses the `global name function' to create a new type
1018 declaration in which local names have been replaced by their original
1019 names, reporting any unknown names.
1020
1021 Renaming type variables is a pain. Because they now contain uniques,
1022 it is necessary to pass in an association list which maps a parsed
1023 tyvar to its @Name@ representation.
1024 In some cases (type signatures of values),
1025 it is even necessary to go over the type first
1026 in order to get the set of tyvars used by it, make an assoc list,
1027 and then go over it again to rename the tyvars!
1028 However, we can also do some scoping checks at the same time.
1029
1030
1031 Note [Extra dependencies from .hs-boot files]
1032 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1033 Consider the following case:
1034
1035 A.hs-boot
1036 module A where
1037 data A1
1038
1039 B.hs
1040 module B where
1041 import {-# SOURCE #-} A
1042 type DisguisedA1 = A1
1043 data B1 = B1 DisguisedA1
1044
1045 A.hs
1046 module A where
1047 import B
1048 data A2 = A2 A1
1049 data A1 = A1 B1
1050
1051 Here A1 is really recursive (via B1), but we won't see that easily when
1052 doing dependency analysis when compiling A.hs
1053
1054 To handle this problem, we add a dependency
1055 - from every local declaration
1056 - to everything that comes from this module's .hs-boot file.
1057 In this case, we'll ad and edges
1058 - from A2 to A1 (but that edge is there already)
1059 - from A1 to A1 (which is new)
1060
1061 Well, not quite *every* declaration. Imagine module A
1062 above had another datatype declaration:
1063
1064 data A3 = A3 Int
1065
1066 Even though A3 has a dependency (on Int), all its dependencies are from things
1067 that live on other packages. Since we don't have mutual dependencies across
1068 packages, it is safe not to add the dependencies on the .hs-boot stuff to A2.
1069
1070 Hence function Name.thisPackageImport.
1071
1072 See also Note [Grouping of type and class declarations] in TcTyClsDecls.
1073 -}
1074
1075
1076 rnTyClDecls :: [TyClGroup RdrName]
1077 -> RnM ([TyClGroup Name], FreeVars)
1078 -- Rename the declarations and do depedency analysis on them
1079 rnTyClDecls tycl_ds
1080 = do { ds_w_fvs <- mapM (wrapLocFstM rnTyClDecl) (tyClGroupConcat tycl_ds)
1081 ; let decl_names = mkNameSet (map (tcdName . unLoc . fst) ds_w_fvs)
1082 ; role_annot_env <- rnRoleAnnots decl_names (concatMap group_roles tycl_ds)
1083 ; tcg_env <- getGblEnv
1084 ; let this_mod = tcg_mod tcg_env
1085 boot_info = tcg_self_boot tcg_env
1086
1087 add_boot_deps :: [(LTyClDecl Name, FreeVars)] -> [(LTyClDecl Name, FreeVars)]
1088 -- See Note [Extra dependencies from .hs-boot files]
1089 add_boot_deps ds_w_fvs
1090 = case boot_info of
1091 SelfBoot { sb_tcs = tcs } | not (isEmptyNameSet tcs)
1092 -> map (add_one tcs) ds_w_fvs
1093 _ -> ds_w_fvs
1094
1095 add_one :: NameSet -> (LTyClDecl Name, FreeVars) -> (LTyClDecl Name, FreeVars)
1096 add_one tcs pr@(decl,fvs)
1097 | has_local_imports fvs = (decl, fvs `plusFV` tcs)
1098 | otherwise = pr
1099
1100 has_local_imports fvs
1101 = foldNameSet ((||) . nameIsHomePackageImport this_mod)
1102 False fvs
1103
1104 ds_w_fvs' = add_boot_deps ds_w_fvs
1105
1106 sccs :: [SCC (LTyClDecl Name)]
1107 sccs = depAnalTyClDecls ds_w_fvs'
1108
1109 all_fvs = foldr (plusFV . snd) emptyFVs ds_w_fvs'
1110
1111 raw_groups = map flattenSCC sccs
1112 -- See Note [Role annotations in the renamer]
1113 (groups, orphan_roles)
1114 = foldr (\group (groups_acc, orphans_acc) ->
1115 let names = map (tcdName . unLoc) group
1116 roles = mapMaybe (lookupNameEnv orphans_acc) names
1117 orphans' = delListFromNameEnv orphans_acc names
1118 -- there doesn't seem to be an interface to
1119 -- do the above more efficiently
1120 in ( TyClGroup { group_tyclds = group
1121 , group_roles = roles } : groups_acc
1122 , orphans' )
1123 )
1124 ([], role_annot_env)
1125 raw_groups
1126
1127 ; mapM_ orphanRoleAnnotErr (nameEnvElts orphan_roles)
1128 ; traceRn (text "rnTycl" <+> (ppr ds_w_fvs $$ ppr sccs))
1129 ; return (groups, all_fvs) }
1130
1131 rnTyClDecl :: TyClDecl RdrName
1132 -> RnM (TyClDecl Name, FreeVars)
1133
1134 -- All flavours of type family declarations ("type family", "newtype family",
1135 -- and "data family"), both top level and (for an associated type)
1136 -- in a class decl
1137 rnTyClDecl (FamDecl { tcdFam = decl })
1138 = do { (decl', fvs) <- rnFamDecl Nothing decl
1139 ; return (FamDecl decl', fvs) }
1140
1141 rnTyClDecl (SynDecl { tcdLName = tycon, tcdTyVars = tyvars, tcdRhs = rhs })
1142 = do { tycon' <- lookupLocatedTopBndrRn tycon
1143 ; kvs <- freeKiTyVarsKindVars <$> extractHsTyRdrTyVars rhs
1144 ; let doc = TySynCtx tycon
1145 ; traceRn (text "rntycl-ty" <+> ppr tycon <+> ppr kvs)
1146 ; ((tyvars', rhs'), fvs) <- bindHsQTyVars doc Nothing kvs tyvars $
1147 \ tyvars' ->
1148 do { (rhs', fvs) <- rnTySyn doc rhs
1149 ; return ((tyvars', rhs'), fvs) }
1150 ; return (SynDecl { tcdLName = tycon', tcdTyVars = tyvars'
1151 , tcdRhs = rhs', tcdFVs = fvs }, fvs) }
1152
1153 -- "data", "newtype" declarations
1154 -- both top level and (for an associated type) in an instance decl
1155 rnTyClDecl (DataDecl { tcdLName = tycon, tcdTyVars = tyvars, tcdDataDefn = defn })
1156 = do { tycon' <- lookupLocatedTopBndrRn tycon
1157 ; kvs <- extractDataDefnKindVars defn
1158 ; let doc = TyDataCtx tycon
1159 ; traceRn (text "rntycl-data" <+> ppr tycon <+> ppr kvs)
1160 ; ((tyvars', defn'), fvs) <- bindHsQTyVars doc Nothing kvs tyvars $ \ tyvars' ->
1161 do { (defn', fvs) <- rnDataDefn doc defn
1162 ; return ((tyvars', defn'), fvs) }
1163 ; return (DataDecl { tcdLName = tycon', tcdTyVars = tyvars'
1164 , tcdDataDefn = defn', tcdFVs = fvs }, fvs) }
1165
1166 rnTyClDecl (ClassDecl { tcdCtxt = context, tcdLName = lcls,
1167 tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs,
1168 tcdMeths = mbinds, tcdATs = ats, tcdATDefs = at_defs,
1169 tcdDocs = docs})
1170 = do { lcls' <- lookupLocatedTopBndrRn lcls
1171 ; let cls' = unLoc lcls'
1172 kvs = [] -- No scoped kind vars except those in
1173 -- kind signatures on the tyvars
1174
1175 -- Tyvars scope over superclass context and method signatures
1176 ; ((tyvars', context', fds', ats'), stuff_fvs)
1177 <- bindHsQTyVars cls_doc Nothing kvs tyvars $ \ tyvars' -> do
1178 -- Checks for distinct tyvars
1179 { (context', cxt_fvs) <- rnContext cls_doc context
1180 ; fds' <- rnFds fds
1181 -- The fundeps have no free variables
1182 ; (ats', fv_ats) <- rnATDecls cls' ats
1183 ; let fvs = cxt_fvs `plusFV`
1184 fv_ats
1185 ; return ((tyvars', context', fds', ats'), fvs) }
1186
1187 ; (at_defs', fv_at_defs) <- rnList (rnTyFamDefltEqn cls') at_defs
1188
1189 -- No need to check for duplicate associated type decls
1190 -- since that is done by RnNames.extendGlobalRdrEnvRn
1191
1192 -- Check the signatures
1193 -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).
1194 ; let sig_rdr_names_w_locs = [op | L _ (ClassOpSig False ops _) <- sigs
1195 , op <- ops]
1196 ; checkDupRdrNames sig_rdr_names_w_locs
1197 -- Typechecker is responsible for checking that we only
1198 -- give default-method bindings for things in this class.
1199 -- The renamer *could* check this for class decls, but can't
1200 -- for instance decls.
1201
1202 -- The newLocals call is tiresome: given a generic class decl
1203 -- class C a where
1204 -- op :: a -> a
1205 -- op {| x+y |} (Inl a) = ...
1206 -- op {| x+y |} (Inr b) = ...
1207 -- op {| a*b |} (a*b) = ...
1208 -- we want to name both "x" tyvars with the same unique, so that they are
1209 -- easy to group together in the typechecker.
1210 ; (mbinds', sigs', meth_fvs)
1211 <- rnMethodBinds True cls' (hsAllLTyVarNames tyvars') mbinds sigs
1212 -- No need to check for duplicate method signatures
1213 -- since that is done by RnNames.extendGlobalRdrEnvRn
1214 -- and the methods are already in scope
1215
1216 -- Haddock docs
1217 ; docs' <- mapM (wrapLocM rnDocDecl) docs
1218
1219 ; let all_fvs = meth_fvs `plusFV` stuff_fvs `plusFV` fv_at_defs
1220 ; return (ClassDecl { tcdCtxt = context', tcdLName = lcls',
1221 tcdTyVars = tyvars', tcdFDs = fds', tcdSigs = sigs',
1222 tcdMeths = mbinds', tcdATs = ats', tcdATDefs = at_defs',
1223 tcdDocs = docs', tcdFVs = all_fvs },
1224 all_fvs ) }
1225 where
1226 cls_doc = ClassDeclCtx lcls
1227
1228 -- "type" and "type instance" declarations
1229 rnTySyn :: HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
1230 rnTySyn doc rhs = rnLHsType doc rhs
1231
1232 -- | Renames role annotations, returning them as the values in a NameEnv
1233 -- and checks for duplicate role annotations.
1234 -- It is quite convenient to do both of these in the same place.
1235 -- See also Note [Role annotations in the renamer]
1236 rnRoleAnnots :: NameSet -- ^ of the decls in this group
1237 -> [LRoleAnnotDecl RdrName]
1238 -> RnM (NameEnv (LRoleAnnotDecl Name))
1239 rnRoleAnnots decl_names role_annots
1240 = do { -- check for duplicates *before* renaming, to avoid lumping
1241 -- together all the unboundNames
1242 let (no_dups, dup_annots) = removeDups role_annots_cmp role_annots
1243 role_annots_cmp (L _ annot1) (L _ annot2)
1244 = roleAnnotDeclName annot1 `compare` roleAnnotDeclName annot2
1245 ; mapM_ dupRoleAnnotErr dup_annots
1246 ; role_annots' <- mapM (wrapLocM rn_role_annot1) no_dups
1247 -- some of the role annots will be unbound; we don't wish
1248 -- to include these
1249 ; return $ mkNameEnv [ (name, ra)
1250 | ra <- role_annots'
1251 , let name = roleAnnotDeclName (unLoc ra)
1252 , not (isUnboundName name) ] }
1253 where
1254 rn_role_annot1 (RoleAnnotDecl tycon roles)
1255 = do { -- the name is an *occurrence*, but look it up only in the
1256 -- decls defined in this group (see #10263)
1257 tycon' <- lookupSigCtxtOccRn (RoleAnnotCtxt decl_names)
1258 (text "role annotation")
1259 tycon
1260 ; return $ RoleAnnotDecl tycon' roles }
1261
1262 dupRoleAnnotErr :: [LRoleAnnotDecl RdrName] -> RnM ()
1263 dupRoleAnnotErr [] = panic "dupRoleAnnotErr"
1264 dupRoleAnnotErr list
1265 = addErrAt loc $
1266 hang (text "Duplicate role annotations for" <+>
1267 quotes (ppr $ roleAnnotDeclName first_decl) <> colon)
1268 2 (vcat $ map pp_role_annot sorted_list)
1269 where
1270 sorted_list = sortBy cmp_annot list
1271 (L loc first_decl : _) = sorted_list
1272
1273 pp_role_annot (L loc decl) = hang (ppr decl)
1274 4 (text "-- written at" <+> ppr loc)
1275
1276 cmp_annot (L loc1 _) (L loc2 _) = loc1 `compare` loc2
1277
1278 orphanRoleAnnotErr :: LRoleAnnotDecl Name -> RnM ()
1279 orphanRoleAnnotErr (L loc decl)
1280 = addErrAt loc $
1281 hang (text "Role annotation for a type previously declared:")
1282 2 (ppr decl) $$
1283 parens (text "The role annotation must be given where" <+>
1284 quotes (ppr $ roleAnnotDeclName decl) <+>
1285 text "is declared.")
1286
1287 rnDataDefn :: HsDocContext -> HsDataDefn RdrName -> RnM (HsDataDefn Name, FreeVars)
1288 rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType
1289 , dd_ctxt = context, dd_cons = condecls
1290 , dd_kindSig = sig, dd_derivs = derivs })
1291 = do { checkTc (h98_style || null (unLoc context))
1292 (badGadtStupidTheta doc)
1293
1294 ; (sig', sig_fvs) <- rnLHsMaybeKind doc sig
1295 ; (context', fvs1) <- rnContext doc context
1296 ; (derivs', fvs3) <- rn_derivs derivs
1297
1298 -- For the constructor declarations, drop the LocalRdrEnv
1299 -- in the GADT case, where the type variables in the declaration
1300 -- do not scope over the constructor signatures
1301 -- data T a where { T1 :: forall b. b-> b }
1302 ; let { zap_lcl_env | h98_style = \ thing -> thing
1303 | otherwise = setLocalRdrEnv emptyLocalRdrEnv }
1304 ; (condecls', con_fvs) <- zap_lcl_env $ rnConDecls condecls
1305 -- No need to check for duplicate constructor decls
1306 -- since that is done by RnNames.extendGlobalRdrEnvRn
1307
1308 ; let all_fvs = fvs1 `plusFV` fvs3 `plusFV`
1309 con_fvs `plusFV` sig_fvs
1310 ; return ( HsDataDefn { dd_ND = new_or_data, dd_cType = cType
1311 , dd_ctxt = context', dd_kindSig = sig'
1312 , dd_cons = condecls'
1313 , dd_derivs = derivs' }
1314 , all_fvs )
1315 }
1316 where
1317 h98_style = case condecls of -- Note [Stupid theta]
1318 L _ (ConDeclGADT {}) : _ -> False
1319 _ -> True
1320
1321 rn_derivs Nothing
1322 = return (Nothing, emptyFVs)
1323 rn_derivs (Just (L loc ds))
1324 = do { (ds', fvs) <- mapFvRn (rnHsSigType doc) ds
1325 ; return (Just (L loc ds'), fvs) }
1326
1327 badGadtStupidTheta :: HsDocContext -> SDoc
1328 badGadtStupidTheta _
1329 = vcat [ptext (sLit "No context is allowed on a GADT-style data declaration"),
1330 ptext (sLit "(You can put a context on each contructor, though.)")]
1331
1332 rnFamDecl :: Maybe Name -- Just cls => this FamilyDecl is nested
1333 -- inside an *class decl* for cls
1334 -- used for associated types
1335 -> FamilyDecl RdrName
1336 -> RnM (FamilyDecl Name, FreeVars)
1337 rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars
1338 , fdInfo = info, fdResultSig = res_sig
1339 , fdInjectivityAnn = injectivity })
1340 = do { tycon' <- lookupLocatedTopBndrRn tycon
1341 ; kvs <- extractRdrKindSigVars res_sig
1342 ; ((tyvars', res_sig', injectivity'), fv1) <-
1343 bindHsQTyVars doc mb_cls kvs tyvars $
1344 \ tyvars'@(HsQTvs { hsq_implicit = rn_kvs }) ->
1345 do { let rn_sig = rnFamResultSig doc rn_kvs
1346 ; (res_sig', fv_kind) <- wrapLocFstM rn_sig res_sig
1347 ; injectivity' <- traverse (rnInjectivityAnn tyvars' res_sig')
1348 injectivity
1349 ; return ( (tyvars', res_sig', injectivity') , fv_kind ) }
1350 ; (info', fv2) <- rn_info info
1351 ; return (FamilyDecl { fdLName = tycon', fdTyVars = tyvars'
1352 , fdInfo = info', fdResultSig = res_sig'
1353 , fdInjectivityAnn = injectivity' }
1354 , fv1 `plusFV` fv2) }
1355 where
1356 doc = TyFamilyCtx tycon
1357
1358 ----------------------
1359 rn_info (ClosedTypeFamily (Just eqns))
1360 = do { (eqns', fvs) <- rnList (rnTyFamInstEqn Nothing) eqns
1361 -- no class context,
1362 ; return (ClosedTypeFamily (Just eqns'), fvs) }
1363 rn_info (ClosedTypeFamily Nothing)
1364 = return (ClosedTypeFamily Nothing, emptyFVs)
1365 rn_info OpenTypeFamily = return (OpenTypeFamily, emptyFVs)
1366 rn_info DataFamily = return (DataFamily, emptyFVs)
1367
1368 rnFamResultSig :: HsDocContext
1369 -> [Name] -- kind variables already in scope
1370 -> FamilyResultSig RdrName
1371 -> RnM (FamilyResultSig Name, FreeVars)
1372 rnFamResultSig _ _ NoSig
1373 = return (NoSig, emptyFVs)
1374 rnFamResultSig doc _ (KindSig kind)
1375 = do { (rndKind, ftvs) <- rnLHsKind doc kind
1376 ; return (KindSig rndKind, ftvs) }
1377 rnFamResultSig doc kv_names (TyVarSig tvbndr)
1378 = do { -- `TyVarSig` tells us that user named the result of a type family by
1379 -- writing `= tyvar` or `= (tyvar :: kind)`. In such case we want to
1380 -- be sure that the supplied result name is not identical to an
1381 -- already in-scope type variable from an enclosing class.
1382 --
1383 -- Example of disallowed declaration:
1384 -- class C a b where
1385 -- type F b = a | a -> b
1386 rdr_env <- getLocalRdrEnv
1387 ; let resName = hsLTyVarName tvbndr
1388 ; when (resName `elemLocalRdrEnv` rdr_env) $
1389 addErrAt (getLoc tvbndr) $
1390 (hsep [ text "Type variable", quotes (ppr resName) <> comma
1391 , text "naming a type family result,"
1392 ] $$
1393 text "shadows an already bound type variable")
1394
1395 ; bindLHsTyVarBndr doc Nothing -- this might be a lie, but it's used for
1396 -- scoping checks that are irrelevant here
1397 (mkNameSet kv_names) emptyNameSet
1398 -- use of emptyNameSet here avoids
1399 -- redundant duplicate errors
1400 tvbndr $ \ _ tvbndr' ->
1401 return (TyVarSig tvbndr', unitFV (hsLTyVarName tvbndr')) }
1402
1403 -- Note [Renaming injectivity annotation]
1404 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1405 --
1406 -- During renaming of injectivity annotation we have to make several checks to
1407 -- make sure that it is well-formed. At the moment injectivity annotation
1408 -- consists of a single injectivity condition, so the terms "injectivity
1409 -- annotation" and "injectivity condition" might be used interchangeably. See
1410 -- Note [Injectivity annotation] for a detailed discussion of currently allowed
1411 -- injectivity annotations.
1412 --
1413 -- Checking LHS is simple because the only type variable allowed on the LHS of
1414 -- injectivity condition is the variable naming the result in type family head.
1415 -- Example of disallowed annotation:
1416 --
1417 -- type family Foo a b = r | b -> a
1418 --
1419 -- Verifying RHS of injectivity consists of checking that:
1420 --
1421 -- 1. only variables defined in type family head appear on the RHS (kind
1422 -- variables are also allowed). Example of disallowed annotation:
1423 --
1424 -- type family Foo a = r | r -> b
1425 --
1426 -- 2. for associated types the result variable does not shadow any of type
1427 -- class variables. Example of disallowed annotation:
1428 --
1429 -- class Foo a b where
1430 -- type F a = b | b -> a
1431 --
1432 -- Breaking any of these assumptions results in an error.
1433
1434 -- | Rename injectivity annotation. Note that injectivity annotation is just the
1435 -- part after the "|". Everything that appears before it is renamed in
1436 -- rnFamDecl.
1437 rnInjectivityAnn :: LHsQTyVars Name -- ^ Type variables declared in
1438 -- type family head
1439 -> LFamilyResultSig Name -- ^ Result signature
1440 -> LInjectivityAnn RdrName -- ^ Injectivity annotation
1441 -> RnM (LInjectivityAnn Name)
1442 rnInjectivityAnn tvBndrs (L _ (TyVarSig resTv))
1443 (L srcSpan (InjectivityAnn injFrom injTo))
1444 = do
1445 { (injDecl'@(L _ (InjectivityAnn injFrom' injTo')), noRnErrors)
1446 <- askNoErrs $
1447 bindLocalNames [hsLTyVarName resTv] $
1448 -- The return type variable scopes over the injectivity annotation
1449 -- e.g. type family F a = (r::*) | r -> a
1450 do { injFrom' <- rnLTyVar injFrom
1451 ; injTo' <- mapM rnLTyVar injTo
1452 ; return $ L srcSpan (InjectivityAnn injFrom' injTo') }
1453
1454 ; let tvNames = Set.fromList $ hsAllLTyVarNames tvBndrs
1455 resName = hsLTyVarName resTv
1456 -- See Note [Renaming injectivity annotation]
1457 lhsValid = EQ == (stableNameCmp resName (unLoc injFrom'))
1458 rhsValid = Set.fromList (map unLoc injTo') `Set.difference` tvNames
1459
1460 -- if renaming of type variables ended with errors (eg. there were
1461 -- not-in-scope variables) don't check the validity of injectivity
1462 -- annotation. This gives better error messages.
1463 ; when (noRnErrors && not lhsValid) $
1464 addErrAt (getLoc injFrom)
1465 ( vcat [ text $ "Incorrect type variable on the LHS of "
1466 ++ "injectivity condition"
1467 , nest 5
1468 ( vcat [ text "Expected :" <+> ppr resName
1469 , text "Actual :" <+> ppr injFrom ])])
1470
1471 ; when (noRnErrors && not (Set.null rhsValid)) $
1472 do { let errorVars = Set.toList rhsValid
1473 ; addErrAt srcSpan $ ( hsep
1474 [ text "Unknown type variable" <> plural errorVars
1475 , text "on the RHS of injectivity condition:"
1476 , interpp'SP errorVars ] ) }
1477
1478 ; return injDecl' }
1479
1480 -- We can only hit this case when the user writes injectivity annotation without
1481 -- naming the result:
1482 --
1483 -- type family F a | result -> a
1484 -- type family F a :: * | result -> a
1485 --
1486 -- So we rename injectivity annotation like we normally would except that
1487 -- this time we expect "result" to be reported not in scope by rnLTyVar.
1488 rnInjectivityAnn _ _ (L srcSpan (InjectivityAnn injFrom injTo)) =
1489 setSrcSpan srcSpan $ do
1490 (injDecl', _) <- askNoErrs $ do
1491 injFrom' <- rnLTyVar injFrom
1492 injTo' <- mapM rnLTyVar injTo
1493 return $ L srcSpan (InjectivityAnn injFrom' injTo')
1494 return $ injDecl'
1495
1496 {-
1497 Note [Stupid theta]
1498 ~~~~~~~~~~~~~~~~~~~
1499 Trac #3850 complains about a regression wrt 6.10 for
1500 data Show a => T a
1501 There is no reason not to allow the stupid theta if there are no data
1502 constructors. It's still stupid, but does no harm, and I don't want
1503 to cause programs to break unnecessarily (notably HList). So if there
1504 are no data constructors we allow h98_style = True
1505 -}
1506
1507 depAnalTyClDecls :: [(LTyClDecl Name, FreeVars)] -> [SCC (LTyClDecl Name)]
1508 -- See Note [Dependency analysis of type and class decls]
1509 depAnalTyClDecls ds_w_fvs
1510 = stronglyConnCompFromEdgedVertices edges
1511 where
1512 edges = [ (d, tcdName (unLoc d), map get_parent (nameSetElems fvs))
1513 | (d, fvs) <- ds_w_fvs ]
1514
1515 -- We also need to consider data constructor names since
1516 -- they may appear in types because of promotion.
1517 get_parent n = lookupNameEnv assoc_env n `orElse` n
1518
1519 assoc_env :: NameEnv Name -- Maps a data constructor back
1520 -- to its parent type constructor
1521 assoc_env = mkNameEnv $ concat assoc_env_list
1522 assoc_env_list = do
1523 (L _ d, _) <- ds_w_fvs
1524 case d of
1525 ClassDecl { tcdLName = L _ cls_name
1526 , tcdATs = ats }
1527 -> do L _ (FamilyDecl { fdLName = L _ fam_name }) <- ats
1528 return [(fam_name, cls_name)]
1529 DataDecl { tcdLName = L _ data_name
1530 , tcdDataDefn = HsDataDefn { dd_cons = cons } }
1531 -> do L _ dc <- cons
1532 return $ zip (map unLoc $ getConNames dc) (repeat data_name)
1533 _ -> []
1534
1535 {-
1536 Note [Dependency analysis of type and class decls]
1537 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1538 We need to do dependency analysis on type and class declarations
1539 else we get bad error messages. Consider
1540
1541 data T f a = MkT f a
1542 data S f a = MkS f (T f a)
1543
1544 This has a kind error, but the error message is better if you
1545 check T first, (fixing its kind) and *then* S. If you do kind
1546 inference together, you might get an error reported in S, which
1547 is jolly confusing. See Trac #4875
1548
1549 Note [Role annotations in the renamer]
1550 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1551 We must ensure that a type's role annotation is put in the same group as the
1552 proper type declaration. This is because role annotations are needed during
1553 type-checking when creating the type's TyCon. So, rnRoleAnnots builds a
1554 NameEnv (LRoleAnnotDecl Name) that maps a name to a role annotation for that
1555 type, if any. Then, this map can be used to add the role annotations to the
1556 groups after dependency analysis.
1557
1558 This process checks for duplicate role annotations, where we must be careful
1559 to do the check *before* renaming to avoid calling all unbound names duplicates
1560 of one another.
1561
1562 The renaming process, as usual, might identify and report errors for unbound
1563 names. We exclude the annotations for unbound names in the annotation
1564 environment to avoid spurious errors for orphaned annotations.
1565
1566 We then (in rnTyClDecls) do a check for orphan role annotations (role
1567 annotations without an accompanying type decl). The check works by folding
1568 over raw_groups (of type [[TyClDecl Name]]), selecting out the relevant
1569 role declarations for each group, as well as diminishing the annotation
1570 environment. After the fold is complete, anything left over in the name
1571 environment must be an orphan, and errors are generated.
1572
1573 An earlier version of this algorithm short-cut the orphan check by renaming
1574 only with names declared in this module. But, this check is insufficient in
1575 the case of staged module compilation (Template Haskell, GHCi).
1576 See #8485. With the new lookup process (which includes types declared in other
1577 modules), we get better error messages, too.
1578
1579 *********************************************************
1580 * *
1581 \subsection{Support code for type/data declarations}
1582 * *
1583 *********************************************************
1584 -}
1585
1586 ---------------
1587 badAssocRhs :: [Name] -> RnM ()
1588 badAssocRhs ns
1589 = addErr (hang (ptext (sLit "The RHS of an associated type declaration mentions")
1590 <+> pprWithCommas (quotes . ppr) ns)
1591 2 (ptext (sLit "All such variables must be bound on the LHS")))
1592
1593 -----------------
1594 rnConDecls :: [LConDecl RdrName] -> RnM ([LConDecl Name], FreeVars)
1595 rnConDecls = mapFvRn (wrapLocFstM rnConDecl)
1596
1597 rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name, FreeVars)
1598 rnConDecl decl@(ConDeclH98 { con_name = name, con_qvars = qtvs
1599 , con_cxt = mcxt, con_details = details
1600 , con_doc = mb_doc })
1601 = do { _ <- addLocM checkConName name
1602 ; new_name <- lookupLocatedTopBndrRn name
1603 ; let doc = ConDeclCtx [new_name]
1604 ; mb_doc' <- rnMbLHsDoc mb_doc
1605 ; (kvs, qtvs') <- get_con_qtvs (hsConDeclArgTys details)
1606
1607 ; bindHsQTyVars doc Nothing kvs qtvs' $ \new_tyvars -> do
1608 { (new_context, fvs1) <- case mcxt of
1609 Nothing -> return (Nothing,emptyFVs)
1610 Just lcxt -> do { (lctx',fvs) <- rnContext doc lcxt
1611 ; return (Just lctx',fvs) }
1612 ; (new_details, fvs2) <- rnConDeclDetails (unLoc new_name) doc details
1613 ; let (new_details',fvs3) = (new_details,emptyFVs)
1614 ; traceRn (text "rnConDecl" <+> ppr name <+> vcat
1615 [ text "free_kvs:" <+> ppr kvs
1616 , text "qtvs:" <+> ppr qtvs
1617 , text "qtvs':" <+> ppr qtvs' ])
1618 ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3
1619 ; warnUnusedForAlls (inHsDocContext doc) (hsQTvExplicit new_tyvars) all_fvs
1620 ; let new_tyvars' = case qtvs of
1621 Nothing -> Nothing
1622 Just _ -> Just new_tyvars
1623 ; return (decl { con_name = new_name, con_qvars = new_tyvars'
1624 , con_cxt = new_context, con_details = new_details'
1625 , con_doc = mb_doc' },
1626 all_fvs) }}
1627 where
1628 cxt = maybe [] unLoc mcxt
1629 get_rdr_tvs tys = extractHsTysRdrTyVars (cxt ++ tys)
1630
1631 get_con_qtvs :: [LHsType RdrName]
1632 -> RnM ([Located RdrName], LHsQTyVars RdrName)
1633 get_con_qtvs arg_tys
1634 | Just tvs <- qtvs -- data T = forall a. MkT (a -> a)
1635 = do { free_vars <- get_rdr_tvs arg_tys
1636 ; return (freeKiTyVarsKindVars free_vars, tvs) }
1637 | otherwise -- data T = MkT (a -> a)
1638 = return ([], mkHsQTvs [])
1639
1640 rnConDecl decl@(ConDeclGADT { con_names = names, con_type = ty
1641 , con_doc = mb_doc })
1642 = do { mapM_ (addLocM checkConName) names
1643 ; new_names <- mapM lookupLocatedTopBndrRn names
1644 ; let doc = ConDeclCtx new_names
1645 ; mb_doc' <- rnMbLHsDoc mb_doc
1646
1647 ; (ty', fvs) <- rnHsSigType doc ty
1648 ; traceRn (text "rnConDecl" <+> ppr names <+> vcat
1649 [ text "fvs:" <+> ppr fvs ])
1650 ; return (decl { con_names = new_names, con_type = ty'
1651 , con_doc = mb_doc' },
1652 fvs) }
1653
1654 rnConDeclDetails
1655 :: Name
1656 -> HsDocContext
1657 -> HsConDetails (LHsType RdrName) (Located [LConDeclField RdrName])
1658 -> RnM (HsConDetails (LHsType Name) (Located [LConDeclField Name]), FreeVars)
1659 rnConDeclDetails _ doc (PrefixCon tys)
1660 = do { (new_tys, fvs) <- rnLHsTypes doc tys
1661 ; return (PrefixCon new_tys, fvs) }
1662
1663 rnConDeclDetails _ doc (InfixCon ty1 ty2)
1664 = do { (new_ty1, fvs1) <- rnLHsType doc ty1
1665 ; (new_ty2, fvs2) <- rnLHsType doc ty2
1666 ; return (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2) }
1667
1668 rnConDeclDetails con doc (RecCon (L l fields))
1669 = do { fls <- lookupConstructorFields con
1670 ; (new_fields, fvs) <- rnConDeclFields fls doc fields
1671 -- No need to check for duplicate fields
1672 -- since that is done by RnNames.extendGlobalRdrEnvRn
1673 ; return (RecCon (L l new_fields), fvs) }
1674
1675 -------------------------------------------------
1676
1677 -- | Brings pattern synonym names and also pattern synonym selectors
1678 -- from record pattern synonyms into scope.
1679 extendPatSynEnv :: HsValBinds RdrName -> MiniFixityEnv
1680 -> ([Name] -> TcRnIf TcGblEnv TcLclEnv a) -> TcM a
1681 extendPatSynEnv val_decls local_fix_env thing = do {
1682 names_with_fls <- new_ps val_decls
1683 ; let pat_syn_bndrs =
1684 concat [name: map flSelector fields | (name, fields) <- names_with_fls]
1685 ; let avails = map patSynAvail pat_syn_bndrs
1686 ; (gbl_env, lcl_env) <-
1687 extendGlobalRdrEnvRn avails local_fix_env
1688
1689
1690 ; let field_env' = extendNameEnvList (tcg_field_env gbl_env) names_with_fls
1691 final_gbl_env = gbl_env { tcg_field_env = field_env' }
1692 ; setEnvs (final_gbl_env, lcl_env) (thing pat_syn_bndrs) }
1693 where
1694 new_ps :: HsValBinds RdrName -> TcM [(Name, [FieldLabel])]
1695 new_ps (ValBindsIn binds _) = foldrBagM new_ps' [] binds
1696 new_ps _ = panic "new_ps"
1697
1698 new_ps' :: LHsBindLR RdrName RdrName
1699 -> [(Name, [FieldLabel])]
1700 -> TcM [(Name, [FieldLabel])]
1701 new_ps' bind names
1702 | L bind_loc (PatSynBind (PSB { psb_id = L _ n
1703 , psb_args = RecordPatSyn as })) <- bind
1704 = do
1705 bnd_name <- newTopSrcBinder (L bind_loc n)
1706 let rnames = map recordPatSynSelectorId as
1707 mkFieldOcc :: Located RdrName -> LFieldOcc RdrName
1708 mkFieldOcc (L l name) = L l (FieldOcc (L l name) PlaceHolder)
1709 field_occs = map mkFieldOcc rnames
1710 flds <- mapM (newRecordSelector False [bnd_name]) field_occs
1711 return ((bnd_name, flds): names)
1712 | L bind_loc (PatSynBind (PSB { psb_id = L _ n})) <- bind
1713 = do
1714 bnd_name <- newTopSrcBinder (L bind_loc n)
1715 return ((bnd_name, []): names)
1716 | otherwise
1717 = return names
1718
1719 {-
1720 *********************************************************
1721 * *
1722 \subsection{Support code to rename types}
1723 * *
1724 *********************************************************
1725 -}
1726
1727 rnFds :: [Located (FunDep (Located RdrName))]
1728 -> RnM [Located (FunDep (Located Name))]
1729 rnFds fds
1730 = mapM (wrapLocM rn_fds) fds
1731 where
1732 rn_fds (tys1, tys2)
1733 = do { tys1' <- rnHsTyVars tys1
1734 ; tys2' <- rnHsTyVars tys2
1735 ; return (tys1', tys2') }
1736
1737 rnHsTyVars :: [Located RdrName] -> RnM [Located Name]
1738 rnHsTyVars tvs = mapM rnHsTyVar tvs
1739
1740 rnHsTyVar :: Located RdrName -> RnM (Located Name)
1741 rnHsTyVar (L l tyvar) = do
1742 tyvar' <- lookupOccRn tyvar
1743 return (L l tyvar')
1744
1745 {-
1746 *********************************************************
1747 * *
1748 findSplice
1749 * *
1750 *********************************************************
1751
1752 This code marches down the declarations, looking for the first
1753 Template Haskell splice. As it does so it
1754 a) groups the declarations into a HsGroup
1755 b) runs any top-level quasi-quotes
1756 -}
1757
1758 findSplice :: [LHsDecl RdrName] -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName]))
1759 findSplice ds = addl emptyRdrGroup ds
1760
1761 addl :: HsGroup RdrName -> [LHsDecl RdrName]
1762 -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName]))
1763 -- This stuff reverses the declarations (again) but it doesn't matter
1764 addl gp [] = return (gp, Nothing)
1765 addl gp (L l d : ds) = add gp l d ds
1766
1767
1768 add :: HsGroup RdrName -> SrcSpan -> HsDecl RdrName -> [LHsDecl RdrName]
1769 -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName]))
1770
1771 -- #10047: Declaration QuasiQuoters are expanded immediately, without
1772 -- causing a group split
1773 add gp _ (SpliceD (SpliceDecl (L _ qq@HsQuasiQuote{}) _)) ds
1774 = do { (ds', _) <- rnTopSpliceDecls qq
1775 ; addl gp (ds' ++ ds)
1776 }
1777
1778 add gp loc (SpliceD splice@(SpliceDecl _ flag)) ds
1779 = do { -- We've found a top-level splice. If it is an *implicit* one
1780 -- (i.e. a naked top level expression)
1781 case flag of
1782 ExplicitSplice -> return ()
1783 ImplicitSplice -> do { th_on <- xoptM LangExt.TemplateHaskell
1784 ; unless th_on $ setSrcSpan loc $
1785 failWith badImplicitSplice }
1786
1787 ; return (gp, Just (splice, ds)) }
1788 where
1789 badImplicitSplice = ptext (sLit "Parse error: naked expression at top level")
1790 $$ ptext (sLit "Perhaps you intended to use TemplateHaskell")
1791
1792 -- Class declarations: pull out the fixity signatures to the top
1793 add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD d) ds
1794 | isClassDecl d
1795 = let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in
1796 addl (gp { hs_tyclds = add_tycld (L l d) ts, hs_fixds = fsigs ++ fs}) ds
1797 | otherwise
1798 = addl (gp { hs_tyclds = add_tycld (L l d) ts }) ds
1799
1800 -- Signatures: fixity sigs go a different place than all others
1801 add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds
1802 = addl (gp {hs_fixds = L l f : ts}) ds
1803 add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds
1804 = addl (gp {hs_valds = add_sig (L l d) ts}) ds
1805
1806 -- Value declarations: use add_bind
1807 add gp@(HsGroup {hs_valds = ts}) l (ValD d) ds
1808 = addl (gp { hs_valds = add_bind (L l d) ts }) ds
1809
1810 -- Role annotations: added to the TyClGroup
1811 add gp@(HsGroup {hs_tyclds = ts}) l (RoleAnnotD d) ds
1812 = addl (gp { hs_tyclds = add_role_annot (L l d) ts }) ds
1813
1814 -- The rest are routine
1815 add gp@(HsGroup {hs_instds = ts}) l (InstD d) ds
1816 = addl (gp { hs_instds = L l d : ts }) ds
1817 add gp@(HsGroup {hs_derivds = ts}) l (DerivD d) ds
1818 = addl (gp { hs_derivds = L l d : ts }) ds
1819 add gp@(HsGroup {hs_defds = ts}) l (DefD d) ds
1820 = addl (gp { hs_defds = L l d : ts }) ds
1821 add gp@(HsGroup {hs_fords = ts}) l (ForD d) ds
1822 = addl (gp { hs_fords = L l d : ts }) ds
1823 add gp@(HsGroup {hs_warnds = ts}) l (WarningD d) ds
1824 = addl (gp { hs_warnds = L l d : ts }) ds
1825 add gp@(HsGroup {hs_annds = ts}) l (AnnD d) ds
1826 = addl (gp { hs_annds = L l d : ts }) ds
1827 add gp@(HsGroup {hs_ruleds = ts}) l (RuleD d) ds
1828 = addl (gp { hs_ruleds = L l d : ts }) ds
1829 add gp@(HsGroup {hs_vects = ts}) l (VectD d) ds
1830 = addl (gp { hs_vects = L l d : ts }) ds
1831 add gp l (DocD d) ds
1832 = addl (gp { hs_docs = (L l d) : (hs_docs gp) }) ds
1833
1834 add_tycld :: LTyClDecl a -> [TyClGroup a] -> [TyClGroup a]
1835 add_tycld d [] = [TyClGroup { group_tyclds = [d], group_roles = [] }]
1836 add_tycld d (ds@(TyClGroup { group_tyclds = tyclds }):dss)
1837 = ds { group_tyclds = d : tyclds } : dss
1838
1839 add_role_annot :: LRoleAnnotDecl a -> [TyClGroup a] -> [TyClGroup a]
1840 add_role_annot d [] = [TyClGroup { group_tyclds = [], group_roles = [d] }]
1841 add_role_annot d (tycls@(TyClGroup { group_roles = roles }) : rest)
1842 = tycls { group_roles = d : roles } : rest
1843
1844 add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a
1845 add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs
1846 add_bind _ (ValBindsOut {}) = panic "RdrHsSyn:add_bind"
1847
1848 add_sig :: LSig a -> HsValBinds a -> HsValBinds a
1849 add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs)
1850 add_sig _ (ValBindsOut {}) = panic "RdrHsSyn:add_sig"