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