d6cb2c8ce677ac7bdda5a374d5dc30eea780e2bc
[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 ( 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 ; tv_rdr_names <- extractHsTysRdrTyVars pats
672
673 ; var_names <- mapM (newTyVarNameRn mb_cls . L loc . unLoc) $
674 freeKiTyVarsAllVars tv_rdr_names
675 -- All the free vars of the family patterns
676 -- with a sensible binding location
677 ; ((pats', payload'), fvs)
678 <- bindLocalNamesFV var_names $
679 do { (pats', pat_fvs) <- rnLHsTypes (FamPatCtx tycon) pats
680 ; (payload', rhs_fvs) <- rnPayload doc payload
681
682 -- See Note [Renaming associated types]
683 ; let bad_tvs = case mb_cls of
684 Nothing -> []
685 Just (_,cls_tkvs) -> filter is_bad cls_tkvs
686 var_name_set = mkNameSet var_names
687
688 is_bad cls_tkv = cls_tkv `elemNameSet` rhs_fvs
689 && not (cls_tkv `elemNameSet` var_name_set)
690
691 ; unless (null bad_tvs) (badAssocRhs bad_tvs)
692 ; return ((pats', payload'), rhs_fvs `plusFV` pat_fvs) }
693
694 ; let all_fvs = fvs `addOneFV` unLoc tycon'
695 ; return (tycon',
696 HsIB { hsib_body = pats', hsib_vars = var_names },
697 payload',
698 all_fvs) }
699 -- type instance => use, hence addOneFV
700
701 rnTyFamInstDecl :: Maybe (Name, [Name])
702 -> TyFamInstDecl RdrName
703 -> RnM (TyFamInstDecl Name, FreeVars)
704 rnTyFamInstDecl mb_cls (TyFamInstDecl { tfid_eqn = L loc eqn })
705 = do { (eqn', fvs) <- rnTyFamInstEqn mb_cls eqn
706 ; return (TyFamInstDecl { tfid_eqn = L loc eqn'
707 , tfid_fvs = fvs }, fvs) }
708
709 rnTyFamInstEqn :: Maybe (Name, [Name])
710 -> TyFamInstEqn RdrName
711 -> RnM (TyFamInstEqn Name, FreeVars)
712 rnTyFamInstEqn mb_cls (TyFamEqn { tfe_tycon = tycon
713 , tfe_pats = pats
714 , tfe_rhs = rhs })
715 = do { (tycon', pats', rhs', fvs) <-
716 rnFamInstDecl (TySynCtx tycon) mb_cls tycon pats rhs rnTySyn
717 ; return (TyFamEqn { tfe_tycon = tycon'
718 , tfe_pats = pats'
719 , tfe_rhs = rhs' }, fvs) }
720
721 rnTyFamDefltEqn :: Name
722 -> TyFamDefltEqn RdrName
723 -> RnM (TyFamDefltEqn Name, FreeVars)
724 rnTyFamDefltEqn cls (TyFamEqn { tfe_tycon = tycon
725 , tfe_pats = tyvars
726 , tfe_rhs = rhs })
727 = bindHsQTyVars ctx (Just cls) [] tyvars $ \ tyvars' ->
728 do { tycon' <- lookupFamInstName (Just cls) tycon
729 ; (rhs', fvs) <- rnLHsType ctx rhs
730 ; return (TyFamEqn { tfe_tycon = tycon'
731 , tfe_pats = tyvars'
732 , tfe_rhs = rhs' }, fvs) }
733 where
734 ctx = TyFamilyCtx tycon
735
736 rnDataFamInstDecl :: Maybe (Name, [Name])
737 -> DataFamInstDecl RdrName
738 -> RnM (DataFamInstDecl Name, FreeVars)
739 rnDataFamInstDecl mb_cls (DataFamInstDecl { dfid_tycon = tycon
740 , dfid_pats = pats
741 , dfid_defn = defn })
742 = do { (tycon', pats', defn', fvs) <-
743 rnFamInstDecl (TyDataCtx tycon) mb_cls tycon pats defn rnDataDefn
744 ; return (DataFamInstDecl { dfid_tycon = tycon'
745 , dfid_pats = pats'
746 , dfid_defn = defn'
747 , dfid_fvs = fvs }, fvs) }
748
749 -- Renaming of the associated types in instances.
750
751 -- Rename associated type family decl in class
752 rnATDecls :: Name -- Class
753 -> [LFamilyDecl RdrName]
754 -> RnM ([LFamilyDecl Name], FreeVars)
755 rnATDecls cls at_decls
756 = rnList (rnFamDecl (Just cls)) at_decls
757
758 rnATInstDecls :: (Maybe (Name, [Name]) -> -- The function that renames
759 decl RdrName -> -- an instance. rnTyFamInstDecl
760 RnM (decl Name, FreeVars)) -- or rnDataFamInstDecl
761 -> Name -- Class
762 -> [Name]
763 -> [Located (decl RdrName)]
764 -> RnM ([Located (decl Name)], FreeVars)
765 -- Used for data and type family defaults in a class decl
766 -- and the family instance declarations in an instance
767 --
768 -- NB: We allow duplicate associated-type decls;
769 -- See Note [Associated type instances] in TcInstDcls
770 rnATInstDecls rnFun cls tv_ns at_insts
771 = rnList (rnFun (Just (cls, tv_ns))) at_insts
772 -- See Note [Renaming associated types]
773
774 {-
775 Note [Renaming associated types]
776 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
777 Check that the RHS of the decl mentions only type variables
778 bound on the LHS. For example, this is not ok
779 class C a b where
780 type F a x :: *
781 instance C (p,q) r where
782 type F (p,q) x = (x, r) -- BAD: mentions 'r'
783 c.f. Trac #5515
784
785 The same thing applies to kind variables, of course (Trac #7938, #9574):
786 class Funct f where
787 type Codomain f :: *
788 instance Funct ('KProxy :: KProxy o) where
789 type Codomain 'KProxy = NatTr (Proxy :: o -> *)
790 Here 'o' is mentioned on the RHS of the Codomain function, but
791 not on the LHS.
792
793 All this applies only for *instance* declarations. In *class*
794 declarations there is no RHS to worry about, and the class variables
795 can all be in scope (Trac #5862):
796 class Category (x :: k -> k -> *) where
797 type Ob x :: k -> Constraint
798 id :: Ob x a => x a a
799 (.) :: (Ob x a, Ob x b, Ob x c) => x b c -> x a b -> x a c
800 Here 'k' is in scope in the kind signature, just like 'x'.
801 -}
802
803
804 {-
805 *********************************************************
806 * *
807 \subsection{Stand-alone deriving declarations}
808 * *
809 *********************************************************
810 -}
811
812 rnSrcDerivDecl :: DerivDecl RdrName -> RnM (DerivDecl Name, FreeVars)
813 rnSrcDerivDecl (DerivDecl ty overlap)
814 = do { standalone_deriv_ok <- xoptM LangExt.StandaloneDeriving
815 ; unless standalone_deriv_ok (addErr standaloneDerivErr)
816 ; (ty', fvs) <- rnLHsInstType (text "In a deriving declaration") ty
817 ; return (DerivDecl ty' overlap, fvs) }
818
819 standaloneDerivErr :: SDoc
820 standaloneDerivErr
821 = hang (ptext (sLit "Illegal standalone deriving declaration"))
822 2 (ptext (sLit "Use StandaloneDeriving to enable this extension"))
823
824 {-
825 *********************************************************
826 * *
827 \subsection{Rules}
828 * *
829 *********************************************************
830 -}
831
832 rnHsRuleDecls :: RuleDecls RdrName -> RnM (RuleDecls Name, FreeVars)
833 rnHsRuleDecls (HsRules src rules)
834 = do { (rn_rules,fvs) <- rnList rnHsRuleDecl rules
835 ; return (HsRules src rn_rules,fvs) }
836
837 rnHsRuleDecl :: RuleDecl RdrName -> RnM (RuleDecl Name, FreeVars)
838 rnHsRuleDecl (HsRule rule_name act vars lhs _fv_lhs rhs _fv_rhs)
839 = do { let rdr_names_w_loc = map get_var vars
840 ; checkDupRdrNames rdr_names_w_loc
841 ; checkShadowedRdrNames rdr_names_w_loc
842 ; names <- newLocalBndrsRn rdr_names_w_loc
843 ; bindHsRuleVars (snd $ unLoc rule_name) vars names $ \ vars' ->
844 do { (lhs', fv_lhs') <- rnLExpr lhs
845 ; (rhs', fv_rhs') <- rnLExpr rhs
846 ; checkValidRule (snd $ unLoc rule_name) names lhs' fv_lhs'
847 ; return (HsRule rule_name act vars' lhs' fv_lhs' rhs' fv_rhs',
848 fv_lhs' `plusFV` fv_rhs') } }
849 where
850 get_var (L _ (RuleBndrSig v _)) = v
851 get_var (L _ (RuleBndr v)) = v
852
853 bindHsRuleVars :: RuleName -> [LRuleBndr RdrName] -> [Name]
854 -> ([LRuleBndr Name] -> RnM (a, FreeVars))
855 -> RnM (a, FreeVars)
856 bindHsRuleVars rule_name vars names thing_inside
857 = go vars names $ \ vars' ->
858 bindLocalNamesFV names (thing_inside vars')
859 where
860 doc = RuleCtx rule_name
861
862 go (L l (RuleBndr (L loc _)) : vars) (n : ns) thing_inside
863 = go vars ns $ \ vars' ->
864 thing_inside (L l (RuleBndr (L loc n)) : vars')
865
866 go (L l (RuleBndrSig (L loc _) bsig) : vars) (n : ns) thing_inside
867 = rnHsSigWcTypeScoped doc bsig $ \ bsig' ->
868 go vars ns $ \ vars' ->
869 thing_inside (L l (RuleBndrSig (L loc n) bsig') : vars')
870
871 go [] [] thing_inside = thing_inside []
872 go vars names _ = pprPanic "bindRuleVars" (ppr vars $$ ppr names)
873
874 {-
875 Note [Rule LHS validity checking]
876 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
877 Check the shape of a transformation rule LHS. Currently we only allow
878 LHSs of the form @(f e1 .. en)@, where @f@ is not one of the
879 @forall@'d variables.
880
881 We used restrict the form of the 'ei' to prevent you writing rules
882 with LHSs with a complicated desugaring (and hence unlikely to match);
883 (e.g. a case expression is not allowed: too elaborate.)
884
885 But there are legitimate non-trivial args ei, like sections and
886 lambdas. So it seems simmpler not to check at all, and that is why
887 check_e is commented out.
888 -}
889
890 checkValidRule :: FastString -> [Name] -> LHsExpr Name -> NameSet -> RnM ()
891 checkValidRule rule_name ids lhs' fv_lhs'
892 = do { -- Check for the form of the LHS
893 case (validRuleLhs ids lhs') of
894 Nothing -> return ()
895 Just bad -> failWithTc (badRuleLhsErr rule_name lhs' bad)
896
897 -- Check that LHS vars are all bound
898 ; let bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs')]
899 ; mapM_ (addErr . badRuleVar rule_name) bad_vars }
900
901 validRuleLhs :: [Name] -> LHsExpr Name -> Maybe (HsExpr Name)
902 -- Nothing => OK
903 -- Just e => Not ok, and e is the offending sub-expression
904 validRuleLhs foralls lhs
905 = checkl lhs
906 where
907 checkl (L _ e) = check e
908
909 check (OpApp e1 op _ e2) = checkl op `mplus` checkl_e e1 `mplus` checkl_e e2
910 check (HsApp e1 e2) = checkl e1 `mplus` checkl_e e2
911 check (HsVar (L _ v)) | v `notElem` foralls = Nothing
912 check other = Just other -- Failure
913
914 -- Check an argument
915 checkl_e (L _ _e) = Nothing -- Was (check_e e); see Note [Rule LHS validity checking]
916
917 {- Commented out; see Note [Rule LHS validity checking] above
918 check_e (HsVar v) = Nothing
919 check_e (HsPar e) = checkl_e e
920 check_e (HsLit e) = Nothing
921 check_e (HsOverLit e) = Nothing
922
923 check_e (OpApp e1 op _ e2) = checkl_e e1 `mplus` checkl_e op `mplus` checkl_e e2
924 check_e (HsApp e1 e2) = checkl_e e1 `mplus` checkl_e e2
925 check_e (NegApp e _) = checkl_e e
926 check_e (ExplicitList _ es) = checkl_es es
927 check_e other = Just other -- Fails
928
929 checkl_es es = foldr (mplus . checkl_e) Nothing es
930 -}
931
932 badRuleVar :: FastString -> Name -> SDoc
933 badRuleVar name var
934 = sep [ptext (sLit "Rule") <+> doubleQuotes (ftext name) <> colon,
935 ptext (sLit "Forall'd variable") <+> quotes (ppr var) <+>
936 ptext (sLit "does not appear on left hand side")]
937
938 badRuleLhsErr :: FastString -> LHsExpr Name -> HsExpr Name -> SDoc
939 badRuleLhsErr name lhs bad_e
940 = sep [ptext (sLit "Rule") <+> pprRuleName name <> colon,
941 nest 4 (vcat [err,
942 ptext (sLit "in left-hand side:") <+> ppr lhs])]
943 $$
944 ptext (sLit "LHS must be of form (f e1 .. en) where f is not forall'd")
945 where
946 err = case bad_e of
947 HsUnboundVar occ -> ptext (sLit "Not in scope:") <+> ppr occ
948 _ -> ptext (sLit "Illegal expression:") <+> ppr bad_e
949
950 {-
951 *********************************************************
952 * *
953 \subsection{Vectorisation declarations}
954 * *
955 *********************************************************
956 -}
957
958 rnHsVectDecl :: VectDecl RdrName -> RnM (VectDecl Name, FreeVars)
959 -- FIXME: For the moment, the right-hand side is restricted to be a variable as we cannot properly
960 -- typecheck a complex right-hand side without invoking 'vectType' from the vectoriser.
961 rnHsVectDecl (HsVect s var rhs@(L _ (HsVar _)))
962 = do { var' <- lookupLocatedOccRn var
963 ; (rhs', fv_rhs) <- rnLExpr rhs
964 ; return (HsVect s var' rhs', fv_rhs `addOneFV` unLoc var')
965 }
966 rnHsVectDecl (HsVect _ _var _rhs)
967 = failWith $ vcat
968 [ ptext (sLit "IMPLEMENTATION RESTRICTION: right-hand side of a VECTORISE pragma")
969 , ptext (sLit "must be an identifier")
970 ]
971 rnHsVectDecl (HsNoVect s var)
972 = do { var' <- lookupLocatedTopBndrRn var -- only applies to local (not imported) names
973 ; return (HsNoVect s var', unitFV (unLoc var'))
974 }
975 rnHsVectDecl (HsVectTypeIn s isScalar tycon Nothing)
976 = do { tycon' <- lookupLocatedOccRn tycon
977 ; return (HsVectTypeIn s isScalar tycon' Nothing, unitFV (unLoc tycon'))
978 }
979 rnHsVectDecl (HsVectTypeIn s isScalar tycon (Just rhs_tycon))
980 = do { tycon' <- lookupLocatedOccRn tycon
981 ; rhs_tycon' <- lookupLocatedOccRn rhs_tycon
982 ; return ( HsVectTypeIn s isScalar tycon' (Just rhs_tycon')
983 , mkFVs [unLoc tycon', unLoc rhs_tycon'])
984 }
985 rnHsVectDecl (HsVectTypeOut _ _ _)
986 = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectTypeOut'"
987 rnHsVectDecl (HsVectClassIn s cls)
988 = do { cls' <- lookupLocatedOccRn cls
989 ; return (HsVectClassIn s cls', unitFV (unLoc cls'))
990 }
991 rnHsVectDecl (HsVectClassOut _)
992 = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectClassOut'"
993 rnHsVectDecl (HsVectInstIn instTy)
994 = do { (instTy', fvs) <- rnLHsInstType (text "a VECTORISE pragma") instTy
995 ; return (HsVectInstIn instTy', fvs)
996 }
997 rnHsVectDecl (HsVectInstOut _)
998 = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectInstOut'"
999
1000 {-
1001 *********************************************************
1002 * *
1003 \subsection{Type, class and iface sig declarations}
1004 * *
1005 *********************************************************
1006
1007 @rnTyDecl@ uses the `global name function' to create a new type
1008 declaration in which local names have been replaced by their original
1009 names, reporting any unknown names.
1010
1011 Renaming type variables is a pain. Because they now contain uniques,
1012 it is necessary to pass in an association list which maps a parsed
1013 tyvar to its @Name@ representation.
1014 In some cases (type signatures of values),
1015 it is even necessary to go over the type first
1016 in order to get the set of tyvars used by it, make an assoc list,
1017 and then go over it again to rename the tyvars!
1018 However, we can also do some scoping checks at the same time.
1019
1020
1021 Note [Extra dependencies from .hs-boot files]
1022 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1023 Consider the following case:
1024
1025 A.hs-boot
1026 module A where
1027 data A1
1028
1029 B.hs
1030 module B where
1031 import {-# SOURCE #-} A
1032 type DisguisedA1 = A1
1033 data B1 = B1 DisguisedA1
1034
1035 A.hs
1036 module A where
1037 import B
1038 data A2 = A2 A1
1039 data A1 = A1 B1
1040
1041 Here A1 is really recursive (via B1), but we won't see that easily when
1042 doing dependency analysis when compiling A.hs
1043
1044 To handle this problem, we add a dependency
1045 - from every local declaration
1046 - to everything that comes from this module's .hs-boot file.
1047 In this case, we'll ad and edges
1048 - from A2 to A1 (but that edge is there already)
1049 - from A1 to A1 (which is new)
1050
1051 Well, not quite *every* declaration. Imagine module A
1052 above had another datatype declaration:
1053
1054 data A3 = A3 Int
1055
1056 Even though A3 has a dependency (on Int), all its dependencies are from things
1057 that live on other packages. Since we don't have mutual dependencies across
1058 packages, it is safe not to add the dependencies on the .hs-boot stuff to A2.
1059
1060 Hence function Name.thisPackageImport.
1061
1062 See also Note [Grouping of type and class declarations] in TcTyClsDecls.
1063 -}
1064
1065
1066 rnTyClDecls :: [TyClGroup RdrName]
1067 -> RnM ([TyClGroup Name], FreeVars)
1068 -- Rename the declarations and do depedency analysis on them
1069 rnTyClDecls tycl_ds
1070 = do { ds_w_fvs <- mapM (wrapLocFstM rnTyClDecl) (tyClGroupConcat tycl_ds)
1071 ; let decl_names = mkNameSet (map (tcdName . unLoc . fst) ds_w_fvs)
1072 ; role_annot_env <- rnRoleAnnots decl_names (concatMap group_roles tycl_ds)
1073 ; tcg_env <- getGblEnv
1074 ; let this_mod = tcg_mod tcg_env
1075 boot_info = tcg_self_boot tcg_env
1076
1077 add_boot_deps :: [(LTyClDecl Name, FreeVars)] -> [(LTyClDecl Name, FreeVars)]
1078 -- See Note [Extra dependencies from .hs-boot files]
1079 add_boot_deps ds_w_fvs
1080 = case boot_info of
1081 SelfBoot { sb_tcs = tcs } | not (isEmptyNameSet tcs)
1082 -> map (add_one tcs) ds_w_fvs
1083 _ -> ds_w_fvs
1084
1085 add_one :: NameSet -> (LTyClDecl Name, FreeVars) -> (LTyClDecl Name, FreeVars)
1086 add_one tcs pr@(decl,fvs)
1087 | has_local_imports fvs = (decl, fvs `plusFV` tcs)
1088 | otherwise = pr
1089
1090 has_local_imports fvs
1091 = foldNameSet ((||) . nameIsHomePackageImport this_mod)
1092 False fvs
1093
1094 ds_w_fvs' = add_boot_deps ds_w_fvs
1095
1096 sccs :: [SCC (LTyClDecl Name)]
1097 sccs = depAnalTyClDecls ds_w_fvs'
1098
1099 all_fvs = foldr (plusFV . snd) emptyFVs ds_w_fvs'
1100
1101 raw_groups = map flattenSCC sccs
1102 -- See Note [Role annotations in the renamer]
1103 (groups, orphan_roles)
1104 = foldr (\group (groups_acc, orphans_acc) ->
1105 let names = map (tcdName . unLoc) group
1106 roles = mapMaybe (lookupNameEnv orphans_acc) names
1107 orphans' = delListFromNameEnv orphans_acc names
1108 -- there doesn't seem to be an interface to
1109 -- do the above more efficiently
1110 in ( TyClGroup { group_tyclds = group
1111 , group_roles = roles } : groups_acc
1112 , orphans' )
1113 )
1114 ([], role_annot_env)
1115 raw_groups
1116
1117 ; mapM_ orphanRoleAnnotErr (nameEnvElts orphan_roles)
1118 ; traceRn (text "rnTycl" <+> (ppr ds_w_fvs $$ ppr sccs))
1119 ; return (groups, all_fvs) }
1120
1121 rnTyClDecl :: TyClDecl RdrName
1122 -> RnM (TyClDecl Name, FreeVars)
1123
1124 -- All flavours of type family declarations ("type family", "newtype family",
1125 -- and "data family"), both top level and (for an associated type)
1126 -- in a class decl
1127 rnTyClDecl (FamDecl { tcdFam = decl })
1128 = do { (decl', fvs) <- rnFamDecl Nothing decl
1129 ; return (FamDecl decl', fvs) }
1130
1131 rnTyClDecl (SynDecl { tcdLName = tycon, tcdTyVars = tyvars, tcdRhs = rhs })
1132 = do { tycon' <- lookupLocatedTopBndrRn tycon
1133 ; kvs <- freeKiTyVarsKindVars <$> extractHsTyRdrTyVars rhs
1134 ; let doc = TySynCtx tycon
1135 ; traceRn (text "rntycl-ty" <+> ppr tycon <+> ppr kvs)
1136 ; ((tyvars', rhs'), fvs) <- bindHsQTyVars doc Nothing kvs tyvars $
1137 \ tyvars' ->
1138 do { (rhs', fvs) <- rnTySyn doc rhs
1139 ; return ((tyvars', rhs'), fvs) }
1140 ; return (SynDecl { tcdLName = tycon', tcdTyVars = tyvars'
1141 , tcdRhs = rhs', tcdFVs = fvs }, fvs) }
1142
1143 -- "data", "newtype" declarations
1144 -- both top level and (for an associated type) in an instance decl
1145 rnTyClDecl (DataDecl { tcdLName = tycon, tcdTyVars = tyvars, tcdDataDefn = defn })
1146 = do { tycon' <- lookupLocatedTopBndrRn tycon
1147 ; kvs <- extractDataDefnKindVars defn
1148 ; let doc = TyDataCtx tycon
1149 ; traceRn (text "rntycl-data" <+> ppr tycon <+> ppr kvs)
1150 ; ((tyvars', defn'), fvs) <- bindHsQTyVars doc Nothing kvs tyvars $ \ tyvars' ->
1151 do { (defn', fvs) <- rnDataDefn doc defn
1152 ; return ((tyvars', defn'), fvs) }
1153 ; return (DataDecl { tcdLName = tycon', tcdTyVars = tyvars'
1154 , tcdDataDefn = defn', tcdFVs = fvs }, fvs) }
1155
1156 rnTyClDecl (ClassDecl { tcdCtxt = context, tcdLName = lcls,
1157 tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs,
1158 tcdMeths = mbinds, tcdATs = ats, tcdATDefs = at_defs,
1159 tcdDocs = docs})
1160 = do { lcls' <- lookupLocatedTopBndrRn lcls
1161 ; let cls' = unLoc lcls'
1162 kvs = [] -- No scoped kind vars except those in
1163 -- kind signatures on the tyvars
1164
1165 -- Tyvars scope over superclass context and method signatures
1166 ; ((tyvars', context', fds', ats'), stuff_fvs)
1167 <- bindHsQTyVars cls_doc Nothing kvs tyvars $ \ tyvars' -> do
1168 -- Checks for distinct tyvars
1169 { (context', cxt_fvs) <- rnContext cls_doc context
1170 ; fds' <- rnFds fds
1171 -- The fundeps have no free variables
1172 ; (ats', fv_ats) <- rnATDecls cls' ats
1173 ; let fvs = cxt_fvs `plusFV`
1174 fv_ats
1175 ; return ((tyvars', context', fds', ats'), fvs) }
1176
1177 ; (at_defs', fv_at_defs) <- rnList (rnTyFamDefltEqn cls') at_defs
1178
1179 -- No need to check for duplicate associated type decls
1180 -- since that is done by RnNames.extendGlobalRdrEnvRn
1181
1182 -- Check the signatures
1183 -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).
1184 ; let sig_rdr_names_w_locs = [op | L _ (ClassOpSig False ops _) <- sigs
1185 , op <- ops]
1186 ; checkDupRdrNames sig_rdr_names_w_locs
1187 -- Typechecker is responsible for checking that we only
1188 -- give default-method bindings for things in this class.
1189 -- The renamer *could* check this for class decls, but can't
1190 -- for instance decls.
1191
1192 -- The newLocals call is tiresome: given a generic class decl
1193 -- class C a where
1194 -- op :: a -> a
1195 -- op {| x+y |} (Inl a) = ...
1196 -- op {| x+y |} (Inr b) = ...
1197 -- op {| a*b |} (a*b) = ...
1198 -- we want to name both "x" tyvars with the same unique, so that they are
1199 -- easy to group together in the typechecker.
1200 ; (mbinds', sigs', meth_fvs)
1201 <- rnMethodBinds True cls' (hsAllLTyVarNames tyvars') mbinds sigs
1202 -- No need to check for duplicate method signatures
1203 -- since that is done by RnNames.extendGlobalRdrEnvRn
1204 -- and the methods are already in scope
1205
1206 -- Haddock docs
1207 ; docs' <- mapM (wrapLocM rnDocDecl) docs
1208
1209 ; let all_fvs = meth_fvs `plusFV` stuff_fvs `plusFV` fv_at_defs
1210 ; return (ClassDecl { tcdCtxt = context', tcdLName = lcls',
1211 tcdTyVars = tyvars', tcdFDs = fds', tcdSigs = sigs',
1212 tcdMeths = mbinds', tcdATs = ats', tcdATDefs = at_defs',
1213 tcdDocs = docs', tcdFVs = all_fvs },
1214 all_fvs ) }
1215 where
1216 cls_doc = ClassDeclCtx lcls
1217
1218 -- "type" and "type instance" declarations
1219 rnTySyn :: HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
1220 rnTySyn doc rhs = rnLHsType doc rhs
1221
1222 -- | Renames role annotations, returning them as the values in a NameEnv
1223 -- and checks for duplicate role annotations.
1224 -- It is quite convenient to do both of these in the same place.
1225 -- See also Note [Role annotations in the renamer]
1226 rnRoleAnnots :: NameSet -- ^ of the decls in this group
1227 -> [LRoleAnnotDecl RdrName]
1228 -> RnM (NameEnv (LRoleAnnotDecl Name))
1229 rnRoleAnnots decl_names role_annots
1230 = do { -- check for duplicates *before* renaming, to avoid lumping
1231 -- together all the unboundNames
1232 let (no_dups, dup_annots) = removeDups role_annots_cmp role_annots
1233 role_annots_cmp (L _ annot1) (L _ annot2)
1234 = roleAnnotDeclName annot1 `compare` roleAnnotDeclName annot2
1235 ; mapM_ dupRoleAnnotErr dup_annots
1236 ; role_annots' <- mapM (wrapLocM rn_role_annot1) no_dups
1237 -- some of the role annots will be unbound; we don't wish
1238 -- to include these
1239 ; return $ mkNameEnv [ (name, ra)
1240 | ra <- role_annots'
1241 , let name = roleAnnotDeclName (unLoc ra)
1242 , not (isUnboundName name) ] }
1243 where
1244 rn_role_annot1 (RoleAnnotDecl tycon roles)
1245 = do { -- the name is an *occurrence*, but look it up only in the
1246 -- decls defined in this group (see #10263)
1247 tycon' <- lookupSigCtxtOccRn (RoleAnnotCtxt decl_names)
1248 (text "role annotation")
1249 tycon
1250 ; return $ RoleAnnotDecl tycon' roles }
1251
1252 dupRoleAnnotErr :: [LRoleAnnotDecl RdrName] -> RnM ()
1253 dupRoleAnnotErr [] = panic "dupRoleAnnotErr"
1254 dupRoleAnnotErr list
1255 = addErrAt loc $
1256 hang (text "Duplicate role annotations for" <+>
1257 quotes (ppr $ roleAnnotDeclName first_decl) <> colon)
1258 2 (vcat $ map pp_role_annot sorted_list)
1259 where
1260 sorted_list = sortBy cmp_annot list
1261 (L loc first_decl : _) = sorted_list
1262
1263 pp_role_annot (L loc decl) = hang (ppr decl)
1264 4 (text "-- written at" <+> ppr loc)
1265
1266 cmp_annot (L loc1 _) (L loc2 _) = loc1 `compare` loc2
1267
1268 orphanRoleAnnotErr :: LRoleAnnotDecl Name -> RnM ()
1269 orphanRoleAnnotErr (L loc decl)
1270 = addErrAt loc $
1271 hang (text "Role annotation for a type previously declared:")
1272 2 (ppr decl) $$
1273 parens (text "The role annotation must be given where" <+>
1274 quotes (ppr $ roleAnnotDeclName decl) <+>
1275 text "is declared.")
1276
1277 rnDataDefn :: HsDocContext -> HsDataDefn RdrName -> RnM (HsDataDefn Name, FreeVars)
1278 rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType
1279 , dd_ctxt = context, dd_cons = condecls
1280 , dd_kindSig = sig, dd_derivs = derivs })
1281 = do { checkTc (h98_style || null (unLoc context))
1282 (badGadtStupidTheta doc)
1283
1284 ; (sig', sig_fvs) <- rnLHsMaybeKind doc sig
1285 ; (context', fvs1) <- rnContext doc context
1286 ; (derivs', fvs3) <- rn_derivs derivs
1287
1288 -- For the constructor declarations, drop the LocalRdrEnv
1289 -- in the GADT case, where the type variables in the declaration
1290 -- do not scope over the constructor signatures
1291 -- data T a where { T1 :: forall b. b-> b }
1292 ; let { zap_lcl_env | h98_style = \ thing -> thing
1293 | otherwise = setLocalRdrEnv emptyLocalRdrEnv }
1294 ; (condecls', con_fvs) <- zap_lcl_env $ rnConDecls condecls
1295 -- No need to check for duplicate constructor decls
1296 -- since that is done by RnNames.extendGlobalRdrEnvRn
1297
1298 ; let all_fvs = fvs1 `plusFV` fvs3 `plusFV`
1299 con_fvs `plusFV` sig_fvs
1300 ; return ( HsDataDefn { dd_ND = new_or_data, dd_cType = cType
1301 , dd_ctxt = context', dd_kindSig = sig'
1302 , dd_cons = condecls'
1303 , dd_derivs = derivs' }
1304 , all_fvs )
1305 }
1306 where
1307 h98_style = case condecls of -- Note [Stupid theta]
1308 L _ (ConDeclGADT {}) : _ -> False
1309 _ -> True
1310
1311 rn_derivs Nothing
1312 = return (Nothing, emptyFVs)
1313 rn_derivs (Just (L loc ds))
1314 = do { (ds', fvs) <- mapFvRn (rnHsSigType doc) ds
1315 ; return (Just (L loc ds'), fvs) }
1316
1317 badGadtStupidTheta :: HsDocContext -> SDoc
1318 badGadtStupidTheta _
1319 = vcat [ptext (sLit "No context is allowed on a GADT-style data declaration"),
1320 ptext (sLit "(You can put a context on each contructor, though.)")]
1321
1322 rnFamDecl :: Maybe Name -- Just cls => this FamilyDecl is nested
1323 -- inside an *class decl* for cls
1324 -- used for associated types
1325 -> FamilyDecl RdrName
1326 -> RnM (FamilyDecl Name, FreeVars)
1327 rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars
1328 , fdInfo = info, fdResultSig = res_sig
1329 , fdInjectivityAnn = injectivity })
1330 = do { tycon' <- lookupLocatedTopBndrRn tycon
1331 ; kvs <- extractRdrKindSigVars res_sig
1332 ; ((tyvars', res_sig', injectivity'), fv1) <-
1333 bindHsQTyVars doc mb_cls kvs tyvars $
1334 \ tyvars'@(HsQTvs { hsq_implicit = rn_kvs }) ->
1335 do { let rn_sig = rnFamResultSig doc rn_kvs
1336 ; (res_sig', fv_kind) <- wrapLocFstM rn_sig res_sig
1337 ; injectivity' <- traverse (rnInjectivityAnn tyvars' res_sig')
1338 injectivity
1339 ; return ( (tyvars', res_sig', injectivity') , fv_kind ) }
1340 ; (info', fv2) <- rn_info info
1341 ; return (FamilyDecl { fdLName = tycon', fdTyVars = tyvars'
1342 , fdInfo = info', fdResultSig = res_sig'
1343 , fdInjectivityAnn = injectivity' }
1344 , fv1 `plusFV` fv2) }
1345 where
1346 doc = TyFamilyCtx tycon
1347
1348 ----------------------
1349 rn_info (ClosedTypeFamily (Just eqns))
1350 = do { (eqns', fvs) <- rnList (rnTyFamInstEqn Nothing) eqns
1351 -- no class context,
1352 ; return (ClosedTypeFamily (Just eqns'), fvs) }
1353 rn_info (ClosedTypeFamily Nothing)
1354 = return (ClosedTypeFamily Nothing, emptyFVs)
1355 rn_info OpenTypeFamily = return (OpenTypeFamily, emptyFVs)
1356 rn_info DataFamily = return (DataFamily, emptyFVs)
1357
1358 rnFamResultSig :: HsDocContext
1359 -> [Name] -- kind variables already in scope
1360 -> FamilyResultSig RdrName
1361 -> RnM (FamilyResultSig Name, FreeVars)
1362 rnFamResultSig _ _ NoSig
1363 = return (NoSig, emptyFVs)
1364 rnFamResultSig doc _ (KindSig kind)
1365 = do { (rndKind, ftvs) <- rnLHsKind doc kind
1366 ; return (KindSig rndKind, ftvs) }
1367 rnFamResultSig doc kv_names (TyVarSig tvbndr)
1368 = do { -- `TyVarSig` tells us that user named the result of a type family by
1369 -- writing `= tyvar` or `= (tyvar :: kind)`. In such case we want to
1370 -- be sure that the supplied result name is not identical to an
1371 -- already in-scope type variable from an enclosing class.
1372 --
1373 -- Example of disallowed declaration:
1374 -- class C a b where
1375 -- type F b = a | a -> b
1376 rdr_env <- getLocalRdrEnv
1377 ; let resName = hsLTyVarName tvbndr
1378 ; when (resName `elemLocalRdrEnv` rdr_env) $
1379 addErrAt (getLoc tvbndr) $
1380 (hsep [ text "Type variable", quotes (ppr resName) <> comma
1381 , text "naming a type family result,"
1382 ] $$
1383 text "shadows an already bound type variable")
1384
1385 ; bindLHsTyVarBndr doc Nothing -- this might be a lie, but it's used for
1386 -- scoping checks that are irrelevant here
1387 (mkNameSet kv_names) emptyNameSet
1388 -- use of emptyNameSet here avoids
1389 -- redundant duplicate errors
1390 tvbndr $ \ _ tvbndr' ->
1391 return (TyVarSig tvbndr', unitFV (hsLTyVarName tvbndr')) }
1392
1393 -- Note [Renaming injectivity annotation]
1394 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1395 --
1396 -- During renaming of injectivity annotation we have to make several checks to
1397 -- make sure that it is well-formed. At the moment injectivity annotation
1398 -- consists of a single injectivity condition, so the terms "injectivity
1399 -- annotation" and "injectivity condition" might be used interchangeably. See
1400 -- Note [Injectivity annotation] for a detailed discussion of currently allowed
1401 -- injectivity annotations.
1402 --
1403 -- Checking LHS is simple because the only type variable allowed on the LHS of
1404 -- injectivity condition is the variable naming the result in type family head.
1405 -- Example of disallowed annotation:
1406 --
1407 -- type family Foo a b = r | b -> a
1408 --
1409 -- Verifying RHS of injectivity consists of checking that:
1410 --
1411 -- 1. only variables defined in type family head appear on the RHS (kind
1412 -- variables are also allowed). Example of disallowed annotation:
1413 --
1414 -- type family Foo a = r | r -> b
1415 --
1416 -- 2. for associated types the result variable does not shadow any of type
1417 -- class variables. Example of disallowed annotation:
1418 --
1419 -- class Foo a b where
1420 -- type F a = b | b -> a
1421 --
1422 -- Breaking any of these assumptions results in an error.
1423
1424 -- | Rename injectivity annotation. Note that injectivity annotation is just the
1425 -- part after the "|". Everything that appears before it is renamed in
1426 -- rnFamDecl.
1427 rnInjectivityAnn :: LHsQTyVars Name -- ^ Type variables declared in
1428 -- type family head
1429 -> LFamilyResultSig Name -- ^ Result signature
1430 -> LInjectivityAnn RdrName -- ^ Injectivity annotation
1431 -> RnM (LInjectivityAnn Name)
1432 rnInjectivityAnn tvBndrs (L _ (TyVarSig resTv))
1433 (L srcSpan (InjectivityAnn injFrom injTo))
1434 = do
1435 { (injDecl'@(L _ (InjectivityAnn injFrom' injTo')), noRnErrors)
1436 <- askNoErrs $
1437 bindLocalNames [hsLTyVarName resTv] $
1438 -- The return type variable scopes over the injectivity annotation
1439 -- e.g. type family F a = (r::*) | r -> a
1440 do { injFrom' <- rnLTyVar injFrom
1441 ; injTo' <- mapM rnLTyVar injTo
1442 ; return $ L srcSpan (InjectivityAnn injFrom' injTo') }
1443
1444 ; let tvNames = Set.fromList $ hsAllLTyVarNames tvBndrs
1445 resName = hsLTyVarName resTv
1446 -- See Note [Renaming injectivity annotation]
1447 lhsValid = EQ == (stableNameCmp resName (unLoc injFrom'))
1448 rhsValid = Set.fromList (map unLoc injTo') `Set.difference` tvNames
1449
1450 -- if renaming of type variables ended with errors (eg. there were
1451 -- not-in-scope variables) don't check the validity of injectivity
1452 -- annotation. This gives better error messages.
1453 ; when (noRnErrors && not lhsValid) $
1454 addErrAt (getLoc injFrom)
1455 ( vcat [ text $ "Incorrect type variable on the LHS of "
1456 ++ "injectivity condition"
1457 , nest 5
1458 ( vcat [ text "Expected :" <+> ppr resName
1459 , text "Actual :" <+> ppr injFrom ])])
1460
1461 ; when (noRnErrors && not (Set.null rhsValid)) $
1462 do { let errorVars = Set.toList rhsValid
1463 ; addErrAt srcSpan $ ( hsep
1464 [ text "Unknown type variable" <> plural errorVars
1465 , text "on the RHS of injectivity condition:"
1466 , interpp'SP errorVars ] ) }
1467
1468 ; return injDecl' }
1469
1470 -- We can only hit this case when the user writes injectivity annotation without
1471 -- naming the result:
1472 --
1473 -- type family F a | result -> a
1474 -- type family F a :: * | result -> a
1475 --
1476 -- So we rename injectivity annotation like we normally would except that
1477 -- this time we expect "result" to be reported not in scope by rnLTyVar.
1478 rnInjectivityAnn _ _ (L srcSpan (InjectivityAnn injFrom injTo)) =
1479 setSrcSpan srcSpan $ do
1480 (injDecl', _) <- askNoErrs $ do
1481 injFrom' <- rnLTyVar injFrom
1482 injTo' <- mapM rnLTyVar injTo
1483 return $ L srcSpan (InjectivityAnn injFrom' injTo')
1484 return $ injDecl'
1485
1486 {-
1487 Note [Stupid theta]
1488 ~~~~~~~~~~~~~~~~~~~
1489 Trac #3850 complains about a regression wrt 6.10 for
1490 data Show a => T a
1491 There is no reason not to allow the stupid theta if there are no data
1492 constructors. It's still stupid, but does no harm, and I don't want
1493 to cause programs to break unnecessarily (notably HList). So if there
1494 are no data constructors we allow h98_style = True
1495 -}
1496
1497 depAnalTyClDecls :: [(LTyClDecl Name, FreeVars)] -> [SCC (LTyClDecl Name)]
1498 -- See Note [Dependency analysis of type and class decls]
1499 depAnalTyClDecls ds_w_fvs
1500 = stronglyConnCompFromEdgedVertices edges
1501 where
1502 edges = [ (d, tcdName (unLoc d), map get_parent (nameSetElems fvs))
1503 | (d, fvs) <- ds_w_fvs ]
1504
1505 -- We also need to consider data constructor names since
1506 -- they may appear in types because of promotion.
1507 get_parent n = lookupNameEnv assoc_env n `orElse` n
1508
1509 assoc_env :: NameEnv Name -- Maps a data constructor back
1510 -- to its parent type constructor
1511 assoc_env = mkNameEnv $ concat assoc_env_list
1512 assoc_env_list = do
1513 (L _ d, _) <- ds_w_fvs
1514 case d of
1515 ClassDecl { tcdLName = L _ cls_name
1516 , tcdATs = ats }
1517 -> do L _ (FamilyDecl { fdLName = L _ fam_name }) <- ats
1518 return [(fam_name, cls_name)]
1519 DataDecl { tcdLName = L _ data_name
1520 , tcdDataDefn = HsDataDefn { dd_cons = cons } }
1521 -> do L _ dc <- cons
1522 return $ zip (map unLoc $ getConNames dc) (repeat data_name)
1523 _ -> []
1524
1525 {-
1526 Note [Dependency analysis of type and class decls]
1527 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1528 We need to do dependency analysis on type and class declarations
1529 else we get bad error messages. Consider
1530
1531 data T f a = MkT f a
1532 data S f a = MkS f (T f a)
1533
1534 This has a kind error, but the error message is better if you
1535 check T first, (fixing its kind) and *then* S. If you do kind
1536 inference together, you might get an error reported in S, which
1537 is jolly confusing. See Trac #4875
1538
1539 Note [Role annotations in the renamer]
1540 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1541 We must ensure that a type's role annotation is put in the same group as the
1542 proper type declaration. This is because role annotations are needed during
1543 type-checking when creating the type's TyCon. So, rnRoleAnnots builds a
1544 NameEnv (LRoleAnnotDecl Name) that maps a name to a role annotation for that
1545 type, if any. Then, this map can be used to add the role annotations to the
1546 groups after dependency analysis.
1547
1548 This process checks for duplicate role annotations, where we must be careful
1549 to do the check *before* renaming to avoid calling all unbound names duplicates
1550 of one another.
1551
1552 The renaming process, as usual, might identify and report errors for unbound
1553 names. We exclude the annotations for unbound names in the annotation
1554 environment to avoid spurious errors for orphaned annotations.
1555
1556 We then (in rnTyClDecls) do a check for orphan role annotations (role
1557 annotations without an accompanying type decl). The check works by folding
1558 over raw_groups (of type [[TyClDecl Name]]), selecting out the relevant
1559 role declarations for each group, as well as diminishing the annotation
1560 environment. After the fold is complete, anything left over in the name
1561 environment must be an orphan, and errors are generated.
1562
1563 An earlier version of this algorithm short-cut the orphan check by renaming
1564 only with names declared in this module. But, this check is insufficient in
1565 the case of staged module compilation (Template Haskell, GHCi).
1566 See #8485. With the new lookup process (which includes types declared in other
1567 modules), we get better error messages, too.
1568
1569 *********************************************************
1570 * *
1571 \subsection{Support code for type/data declarations}
1572 * *
1573 *********************************************************
1574 -}
1575
1576 ---------------
1577 badAssocRhs :: [Name] -> RnM ()
1578 badAssocRhs ns
1579 = addErr (hang (ptext (sLit "The RHS of an associated type declaration mentions")
1580 <+> pprWithCommas (quotes . ppr) ns)
1581 2 (ptext (sLit "All such variables must be bound on the LHS")))
1582
1583 -----------------
1584 rnConDecls :: [LConDecl RdrName] -> RnM ([LConDecl Name], FreeVars)
1585 rnConDecls = mapFvRn (wrapLocFstM rnConDecl)
1586
1587 rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name, FreeVars)
1588 rnConDecl decl@(ConDeclH98 { con_name = name, con_qvars = qtvs
1589 , con_cxt = mcxt, con_details = details
1590 , con_doc = mb_doc })
1591 = do { _ <- addLocM checkConName name
1592 ; new_name <- lookupLocatedTopBndrRn name
1593 ; let doc = ConDeclCtx [new_name]
1594 ; mb_doc' <- rnMbLHsDoc mb_doc
1595 ; (kvs, qtvs') <- get_con_qtvs (hsConDeclArgTys details)
1596
1597 ; bindHsQTyVars doc Nothing kvs qtvs' $ \new_tyvars -> do
1598 { (new_context, fvs1) <- case mcxt of
1599 Nothing -> return (Nothing,emptyFVs)
1600 Just lcxt -> do { (lctx',fvs) <- rnContext doc lcxt
1601 ; return (Just lctx',fvs) }
1602 ; (new_details, fvs2) <- rnConDeclDetails (unLoc new_name) doc details
1603 ; let (new_details',fvs3) = (new_details,emptyFVs)
1604 ; traceRn (text "rnConDecl" <+> ppr name <+> vcat
1605 [ text "free_kvs:" <+> ppr kvs
1606 , text "qtvs:" <+> ppr qtvs
1607 , text "qtvs':" <+> ppr qtvs' ])
1608 ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3
1609 ; warnUnusedForAlls (inHsDocContext doc) (hsQTvExplicit new_tyvars) all_fvs
1610 ; let new_tyvars' = case qtvs of
1611 Nothing -> Nothing
1612 Just _ -> Just new_tyvars
1613 ; return (decl { con_name = new_name, con_qvars = new_tyvars'
1614 , con_cxt = new_context, con_details = new_details'
1615 , con_doc = mb_doc' },
1616 all_fvs) }}
1617 where
1618 cxt = maybe [] unLoc mcxt
1619 get_rdr_tvs tys = extractHsTysRdrTyVars (cxt ++ tys)
1620
1621 get_con_qtvs :: [LHsType RdrName]
1622 -> RnM ([Located RdrName], LHsQTyVars RdrName)
1623 get_con_qtvs arg_tys
1624 | Just tvs <- qtvs -- data T = forall a. MkT (a -> a)
1625 = do { free_vars <- get_rdr_tvs arg_tys
1626 ; return (freeKiTyVarsKindVars free_vars, tvs) }
1627 | otherwise -- data T = MkT (a -> a)
1628 = return ([], mkHsQTvs [])
1629
1630 rnConDecl decl@(ConDeclGADT { con_names = names, con_type = ty
1631 , con_doc = mb_doc })
1632 = do { mapM_ (addLocM checkConName) names
1633 ; new_names <- mapM lookupLocatedTopBndrRn names
1634 ; let doc = ConDeclCtx new_names
1635 ; mb_doc' <- rnMbLHsDoc mb_doc
1636
1637 ; (ty', fvs) <- rnHsSigType doc ty
1638 ; traceRn (text "rnConDecl" <+> ppr names <+> vcat
1639 [ text "fvs:" <+> ppr fvs ])
1640 ; return (decl { con_names = new_names, con_type = ty'
1641 , con_doc = mb_doc' },
1642 fvs) }
1643
1644 rnConDeclDetails
1645 :: Name
1646 -> HsDocContext
1647 -> HsConDetails (LHsType RdrName) (Located [LConDeclField RdrName])
1648 -> RnM (HsConDetails (LHsType Name) (Located [LConDeclField Name]), FreeVars)
1649 rnConDeclDetails _ doc (PrefixCon tys)
1650 = do { (new_tys, fvs) <- rnLHsTypes doc tys
1651 ; return (PrefixCon new_tys, fvs) }
1652
1653 rnConDeclDetails _ doc (InfixCon ty1 ty2)
1654 = do { (new_ty1, fvs1) <- rnLHsType doc ty1
1655 ; (new_ty2, fvs2) <- rnLHsType doc ty2
1656 ; return (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2) }
1657
1658 rnConDeclDetails con doc (RecCon (L l fields))
1659 = do { fls <- lookupConstructorFields con
1660 ; (new_fields, fvs) <- rnConDeclFields fls doc fields
1661 -- No need to check for duplicate fields
1662 -- since that is done by RnNames.extendGlobalRdrEnvRn
1663 ; return (RecCon (L l new_fields), fvs) }
1664
1665 -------------------------------------------------
1666
1667 -- | Brings pattern synonym names and also pattern synonym selectors
1668 -- from record pattern synonyms into scope.
1669 extendPatSynEnv :: HsValBinds RdrName -> MiniFixityEnv
1670 -> ([Name] -> TcRnIf TcGblEnv TcLclEnv a) -> TcM a
1671 extendPatSynEnv val_decls local_fix_env thing = do {
1672 names_with_fls <- new_ps val_decls
1673 ; let pat_syn_bndrs =
1674 concat [name: map flSelector fields | (name, fields) <- names_with_fls]
1675 ; let avails = map patSynAvail pat_syn_bndrs
1676 ; (gbl_env, lcl_env) <-
1677 extendGlobalRdrEnvRn avails local_fix_env
1678
1679
1680 ; let field_env' = extendNameEnvList (tcg_field_env gbl_env) names_with_fls
1681 final_gbl_env = gbl_env { tcg_field_env = field_env' }
1682 ; setEnvs (final_gbl_env, lcl_env) (thing pat_syn_bndrs) }
1683 where
1684 new_ps :: HsValBinds RdrName -> TcM [(Name, [FieldLabel])]
1685 new_ps (ValBindsIn binds _) = foldrBagM new_ps' [] binds
1686 new_ps _ = panic "new_ps"
1687
1688 new_ps' :: LHsBindLR RdrName RdrName
1689 -> [(Name, [FieldLabel])]
1690 -> TcM [(Name, [FieldLabel])]
1691 new_ps' bind names
1692 | L bind_loc (PatSynBind (PSB { psb_id = L _ n
1693 , psb_args = RecordPatSyn as })) <- bind
1694 = do
1695 bnd_name <- newTopSrcBinder (L bind_loc n)
1696 let rnames = map recordPatSynSelectorId as
1697 mkFieldOcc :: Located RdrName -> LFieldOcc RdrName
1698 mkFieldOcc (L l name) = L l (FieldOcc (L l name) PlaceHolder)
1699 field_occs = map mkFieldOcc rnames
1700 flds <- mapM (newRecordSelector False [bnd_name]) field_occs
1701 return ((bnd_name, flds): names)
1702 | L bind_loc (PatSynBind (PSB { psb_id = L _ n})) <- bind
1703 = do
1704 bnd_name <- newTopSrcBinder (L bind_loc n)
1705 return ((bnd_name, []): names)
1706 | otherwise
1707 = return names
1708
1709 {-
1710 *********************************************************
1711 * *
1712 \subsection{Support code to rename types}
1713 * *
1714 *********************************************************
1715 -}
1716
1717 rnFds :: [Located (FunDep (Located RdrName))]
1718 -> RnM [Located (FunDep (Located Name))]
1719 rnFds fds
1720 = mapM (wrapLocM rn_fds) fds
1721 where
1722 rn_fds (tys1, tys2)
1723 = do { tys1' <- rnHsTyVars tys1
1724 ; tys2' <- rnHsTyVars tys2
1725 ; return (tys1', tys2') }
1726
1727 rnHsTyVars :: [Located RdrName] -> RnM [Located Name]
1728 rnHsTyVars tvs = mapM rnHsTyVar tvs
1729
1730 rnHsTyVar :: Located RdrName -> RnM (Located Name)
1731 rnHsTyVar (L l tyvar) = do
1732 tyvar' <- lookupOccRn tyvar
1733 return (L l tyvar')
1734
1735 {-
1736 *********************************************************
1737 * *
1738 findSplice
1739 * *
1740 *********************************************************
1741
1742 This code marches down the declarations, looking for the first
1743 Template Haskell splice. As it does so it
1744 a) groups the declarations into a HsGroup
1745 b) runs any top-level quasi-quotes
1746 -}
1747
1748 findSplice :: [LHsDecl RdrName] -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName]))
1749 findSplice ds = addl emptyRdrGroup ds
1750
1751 addl :: HsGroup RdrName -> [LHsDecl RdrName]
1752 -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName]))
1753 -- This stuff reverses the declarations (again) but it doesn't matter
1754 addl gp [] = return (gp, Nothing)
1755 addl gp (L l d : ds) = add gp l d ds
1756
1757
1758 add :: HsGroup RdrName -> SrcSpan -> HsDecl RdrName -> [LHsDecl RdrName]
1759 -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName]))
1760
1761 -- #10047: Declaration QuasiQuoters are expanded immediately, without
1762 -- causing a group split
1763 add gp _ (SpliceD (SpliceDecl (L _ qq@HsQuasiQuote{}) _)) ds
1764 = do { (ds', _) <- rnTopSpliceDecls qq
1765 ; addl gp (ds' ++ ds)
1766 }
1767
1768 add gp loc (SpliceD splice@(SpliceDecl _ flag)) ds
1769 = do { -- We've found a top-level splice. If it is an *implicit* one
1770 -- (i.e. a naked top level expression)
1771 case flag of
1772 ExplicitSplice -> return ()
1773 ImplicitSplice -> do { th_on <- xoptM LangExt.TemplateHaskell
1774 ; unless th_on $ setSrcSpan loc $
1775 failWith badImplicitSplice }
1776
1777 ; return (gp, Just (splice, ds)) }
1778 where
1779 badImplicitSplice = ptext (sLit "Parse error: naked expression at top level")
1780 $$ ptext (sLit "Perhaps you intended to use TemplateHaskell")
1781
1782 -- Class declarations: pull out the fixity signatures to the top
1783 add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD d) ds
1784 | isClassDecl d
1785 = let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in
1786 addl (gp { hs_tyclds = add_tycld (L l d) ts, hs_fixds = fsigs ++ fs}) ds
1787 | otherwise
1788 = addl (gp { hs_tyclds = add_tycld (L l d) ts }) ds
1789
1790 -- Signatures: fixity sigs go a different place than all others
1791 add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds
1792 = addl (gp {hs_fixds = L l f : ts}) ds
1793 add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds
1794 = addl (gp {hs_valds = add_sig (L l d) ts}) ds
1795
1796 -- Value declarations: use add_bind
1797 add gp@(HsGroup {hs_valds = ts}) l (ValD d) ds
1798 = addl (gp { hs_valds = add_bind (L l d) ts }) ds
1799
1800 -- Role annotations: added to the TyClGroup
1801 add gp@(HsGroup {hs_tyclds = ts}) l (RoleAnnotD d) ds
1802 = addl (gp { hs_tyclds = add_role_annot (L l d) ts }) ds
1803
1804 -- The rest are routine
1805 add gp@(HsGroup {hs_instds = ts}) l (InstD d) ds
1806 = addl (gp { hs_instds = L l d : ts }) ds
1807 add gp@(HsGroup {hs_derivds = ts}) l (DerivD d) ds
1808 = addl (gp { hs_derivds = L l d : ts }) ds
1809 add gp@(HsGroup {hs_defds = ts}) l (DefD d) ds
1810 = addl (gp { hs_defds = L l d : ts }) ds
1811 add gp@(HsGroup {hs_fords = ts}) l (ForD d) ds
1812 = addl (gp { hs_fords = L l d : ts }) ds
1813 add gp@(HsGroup {hs_warnds = ts}) l (WarningD d) ds
1814 = addl (gp { hs_warnds = L l d : ts }) ds
1815 add gp@(HsGroup {hs_annds = ts}) l (AnnD d) ds
1816 = addl (gp { hs_annds = L l d : ts }) ds
1817 add gp@(HsGroup {hs_ruleds = ts}) l (RuleD d) ds
1818 = addl (gp { hs_ruleds = L l d : ts }) ds
1819 add gp@(HsGroup {hs_vects = ts}) l (VectD d) ds
1820 = addl (gp { hs_vects = L l d : ts }) ds
1821 add gp l (DocD d) ds
1822 = addl (gp { hs_docs = (L l d) : (hs_docs gp) }) ds
1823
1824 add_tycld :: LTyClDecl a -> [TyClGroup a] -> [TyClGroup a]
1825 add_tycld d [] = [TyClGroup { group_tyclds = [d], group_roles = [] }]
1826 add_tycld d (ds@(TyClGroup { group_tyclds = tyclds }):dss)
1827 = ds { group_tyclds = d : tyclds } : dss
1828
1829 add_role_annot :: LRoleAnnotDecl a -> [TyClGroup a] -> [TyClGroup a]
1830 add_role_annot d [] = [TyClGroup { group_tyclds = [], group_roles = [d] }]
1831 add_role_annot d (tycls@(TyClGroup { group_roles = roles }) : rest)
1832 = tycls { group_roles = d : roles } : rest
1833
1834 add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a
1835 add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs
1836 add_bind _ (ValBindsOut {}) = panic "RdrHsSyn:add_bind"
1837
1838 add_sig :: LSig a -> HsValBinds a -> HsValBinds a
1839 add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs)
1840 add_sig _ (ValBindsOut {}) = panic "RdrHsSyn:add_sig"