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