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