30915d58b75cf2748a8c0a03796a5741bbbb60c8
[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 ( DerivStrategy, RuleName, pprRuleName )
46 import FastString
47 import SrcLoc
48 import DynFlags
49 import Util ( debugIsOn, lengthExceeds, partitionWith )
50 import HscTypes ( HscEnv, hsc_dflags )
51 import ListSetOps ( findDupsEq, removeDups, equivClasses )
52 import Digraph ( SCC, flattenSCC, flattenSCCs
53 , stronglyConnCompFromEdgedVerticesUniq )
54 import UniqSet
55 import qualified GHC.LanguageExtensions as LangExt
56
57 import Control.Monad
58 import Control.Arrow ( first )
59 import Data.List ( sortBy, mapAccumL )
60 import Data.Maybe ( isJust )
61 import qualified Data.Set as Set ( difference, fromList, toList, null )
62
63 {- | @rnSourceDecl@ "renames" declarations.
64 It simultaneously performs dependency analysis and precedence parsing.
65 It also does the following error checks:
66
67 * Checks that tyvars are used properly. This includes checking
68 for undefined tyvars, and tyvars in contexts that are ambiguous.
69 (Some of this checking has now been moved to module @TcMonoType@,
70 since we don't have functional dependency information at this point.)
71
72 * Checks that all variable occurrences are defined.
73
74 * Checks the @(..)@ etc constraints in the export list.
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 -}
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_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 "rnSrcDecls" (ppr id_bndrs) ;
133 tc_envs <- extendGlobalRdrEnvRn (map avail id_bndrs) local_fix_env ;
134 traceRn "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 "Start rnTyClDecls" (ppr tycl_decls) ;
150 (rn_tycl_decls, src_fvs1) <- rnTyClDecls tycl_decls ;
151
152 -- (F) Rename Value declarations right-hand sides
153 traceRn "Start rnmono" empty ;
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 "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_rule_decls, src_fvs2) <- setXOptM LangExt.ScopedTypeVariables $
179 rnList rnHsRuleDecls rule_decls ;
180 -- Inside RULES, scoped type variables are on
181 (rn_vect_decls, src_fvs3) <- rnList rnHsVectDecl vect_decls ;
182 (rn_foreign_decls, src_fvs4) <- rnList rnHsForeignDecl foreign_decls ;
183 (rn_ann_decls, src_fvs5) <- rnList rnAnnDecl ann_decls ;
184 (rn_default_decls, src_fvs6) <- rnList rnDefaultDecl default_decls ;
185 (rn_deriv_decls, src_fvs7) <- rnList rnSrcDerivDecl deriv_decls ;
186 (rn_splice_decls, src_fvs8) <- rnList rnSpliceDecl splice_decls ;
187 -- Haddock docs; no free vars
188 rn_docs <- mapM (wrapLocM rnDocDecl) docs ;
189
190 last_tcg_env <- getGblEnv ;
191 -- (I) Compute the results and return
192 let {rn_group = HsGroup { hs_valds = rn_val_decls,
193 hs_splcds = rn_splice_decls,
194 hs_tyclds = rn_tycl_decls,
195 hs_derivds = rn_deriv_decls,
196 hs_fixds = rn_fix_decls,
197 hs_warnds = [], -- warns are returned in the tcg_env
198 -- (see below) not in the HsGroup
199 hs_fords = rn_foreign_decls,
200 hs_annds = rn_ann_decls,
201 hs_defds = rn_default_decls,
202 hs_ruleds = rn_rule_decls,
203 hs_vects = rn_vect_decls,
204 hs_docs = rn_docs } ;
205
206 tcf_bndrs = hsTyClForeignBinders rn_tycl_decls rn_foreign_decls ;
207 other_def = (Just (mkNameSet tcf_bndrs), emptyNameSet) ;
208 other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs3, src_fvs4, src_fvs5,
209 src_fvs6, src_fvs7, src_fvs8] ;
210 -- It is tiresome to gather the binders from type and class decls
211
212 src_dus = [other_def] `plusDU` bind_dus `plusDU` usesOnly other_fvs ;
213 -- Instance decls may have occurrences of things bound in bind_dus
214 -- so we must put other_fvs last
215
216 final_tcg_env = let tcg_env' = (last_tcg_env `addTcgDUs` src_dus)
217 in -- we return the deprecs in the env, not in the HsGroup above
218 tcg_env' { tcg_warns = tcg_warns tcg_env' `plusWarns` rn_warns };
219 } ;
220 traceRn "last" (ppr (tcg_rdr_env final_tcg_env)) ;
221 traceRn "finish rnSrc" (ppr rn_group) ;
222 traceRn "finish Dus" (ppr src_dus ) ;
223 return (final_tcg_env, rn_group)
224 }}}}
225
226 addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv
227 -- This function could be defined lower down in the module hierarchy,
228 -- but there doesn't seem anywhere very logical to put it.
229 addTcgDUs tcg_env dus = tcg_env { tcg_dus = tcg_dus tcg_env `plusDU` dus }
230
231 rnList :: (a -> RnM (b, FreeVars)) -> [Located a] -> RnM ([Located b], FreeVars)
232 rnList f xs = mapFvRn (wrapLocFstM f) xs
233
234 {-
235 *********************************************************
236 * *
237 HsDoc stuff
238 * *
239 *********************************************************
240 -}
241
242 rnDocDecl :: DocDecl -> RnM DocDecl
243 rnDocDecl (DocCommentNext doc) = do
244 rn_doc <- rnHsDoc doc
245 return (DocCommentNext rn_doc)
246 rnDocDecl (DocCommentPrev doc) = do
247 rn_doc <- rnHsDoc doc
248 return (DocCommentPrev rn_doc)
249 rnDocDecl (DocCommentNamed str doc) = do
250 rn_doc <- rnHsDoc doc
251 return (DocCommentNamed str rn_doc)
252 rnDocDecl (DocGroup lev doc) = do
253 rn_doc <- rnHsDoc doc
254 return (DocGroup lev rn_doc)
255
256 {-
257 *********************************************************
258 * *
259 Source-code fixity declarations
260 * *
261 *********************************************************
262 -}
263
264 rnSrcFixityDecls :: NameSet -> [LFixitySig RdrName] -> RnM [LFixitySig Name]
265 -- Rename the fixity decls, so we can put
266 -- the renamed decls in the renamed syntax tree
267 -- Errors if the thing being fixed is not defined locally.
268 --
269 -- The returned FixitySigs are not actually used for anything,
270 -- except perhaps the GHCi API
271 rnSrcFixityDecls bndr_set fix_decls
272 = do fix_decls <- mapM rn_decl fix_decls
273 return (concat fix_decls)
274 where
275 sig_ctxt = TopSigCtxt bndr_set
276
277 rn_decl :: LFixitySig RdrName -> RnM [LFixitySig Name]
278 -- GHC extension: look up both the tycon and data con
279 -- for con-like things; hence returning a list
280 -- If neither are in scope, report an error; otherwise
281 -- return a fixity sig for each (slightly odd)
282 rn_decl (L loc (FixitySig fnames fixity))
283 = do names <- mapM lookup_one fnames
284 return [ L loc (FixitySig name fixity)
285 | name <- names ]
286
287 lookup_one :: Located RdrName -> RnM [Located Name]
288 lookup_one (L name_loc rdr_name)
289 = setSrcSpan name_loc $
290 -- this lookup will fail if the definition isn't local
291 do names <- lookupLocalTcNames sig_ctxt what rdr_name
292 return [ L name_loc name | (_, name) <- names ]
293 what = text "fixity signature"
294
295 {-
296 *********************************************************
297 * *
298 Source-code deprecations declarations
299 * *
300 *********************************************************
301
302 Check that the deprecated names are defined, are defined locally, and
303 that there are no duplicate deprecations.
304
305 It's only imported deprecations, dealt with in RnIfaces, that we
306 gather them together.
307 -}
308
309 -- checks that the deprecations are defined locally, and that there are no duplicates
310 rnSrcWarnDecls :: NameSet -> [LWarnDecls RdrName] -> RnM Warnings
311 rnSrcWarnDecls _ []
312 = return NoWarnings
313
314 rnSrcWarnDecls bndr_set decls'
315 = do { -- check for duplicates
316 ; mapM_ (\ dups -> let (L loc rdr:lrdr':_) = dups
317 in addErrAt loc (dupWarnDecl lrdr' rdr))
318 warn_rdr_dups
319 ; pairs_s <- mapM (addLocM rn_deprec) decls
320 ; return (WarnSome ((concat pairs_s))) }
321 where
322 decls = concatMap (\(L _ d) -> wd_warnings d) decls'
323
324 sig_ctxt = TopSigCtxt bndr_set
325
326 rn_deprec (Warning rdr_names txt)
327 -- ensures that the names are defined locally
328 = do { names <- concatMapM (lookupLocalTcNames sig_ctxt what . unLoc)
329 rdr_names
330 ; return [(rdrNameOcc rdr, txt) | (rdr, _) <- names] }
331
332 what = text "deprecation"
333
334 warn_rdr_dups = findDupRdrNames $ concatMap (\(L _ (Warning ns _)) -> ns)
335 decls
336
337 findDupRdrNames :: [Located RdrName] -> [[Located RdrName]]
338 findDupRdrNames = findDupsEq (\ x -> \ y -> rdrNameOcc (unLoc x) == rdrNameOcc (unLoc y))
339
340 -- look for duplicates among the OccNames;
341 -- we check that the names are defined above
342 -- invt: the lists returned by findDupsEq always have at least two elements
343
344 dupWarnDecl :: Located RdrName -> RdrName -> SDoc
345 -- Located RdrName -> DeprecDecl RdrName -> SDoc
346 dupWarnDecl (L loc _) rdr_name
347 = vcat [text "Multiple warning declarations for" <+> quotes (ppr rdr_name),
348 text "also at " <+> ppr loc]
349
350 {-
351 *********************************************************
352 * *
353 \subsection{Annotation declarations}
354 * *
355 *********************************************************
356 -}
357
358 rnAnnDecl :: AnnDecl RdrName -> RnM (AnnDecl Name, FreeVars)
359 rnAnnDecl ann@(HsAnnotation s provenance expr)
360 = addErrCtxt (annCtxt ann) $
361 do { (provenance', provenance_fvs) <- rnAnnProvenance provenance
362 ; (expr', expr_fvs) <- setStage (Splice Untyped) $
363 rnLExpr expr
364 ; return (HsAnnotation s provenance' expr',
365 provenance_fvs `plusFV` expr_fvs) }
366
367 rnAnnProvenance :: AnnProvenance RdrName -> RnM (AnnProvenance Name, FreeVars)
368 rnAnnProvenance provenance = do
369 provenance' <- traverse lookupTopBndrRn provenance
370 return (provenance', maybe emptyFVs unitFV (annProvenanceName_maybe provenance'))
371
372 {-
373 *********************************************************
374 * *
375 \subsection{Default declarations}
376 * *
377 *********************************************************
378 -}
379
380 rnDefaultDecl :: DefaultDecl RdrName -> RnM (DefaultDecl Name, FreeVars)
381 rnDefaultDecl (DefaultDecl tys)
382 = do { (tys', fvs) <- rnLHsTypes doc_str tys
383 ; return (DefaultDecl tys', fvs) }
384 where
385 doc_str = DefaultDeclCtx
386
387 {-
388 *********************************************************
389 * *
390 \subsection{Foreign declarations}
391 * *
392 *********************************************************
393 -}
394
395 rnHsForeignDecl :: ForeignDecl RdrName -> RnM (ForeignDecl Name, FreeVars)
396 rnHsForeignDecl (ForeignImport { fd_name = name, fd_sig_ty = ty, fd_fi = spec })
397 = do { topEnv :: HscEnv <- getTopEnv
398 ; name' <- lookupLocatedTopBndrRn name
399 ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) ty
400
401 -- Mark any PackageTarget style imports as coming from the current package
402 ; let unitId = thisPackage $ hsc_dflags topEnv
403 spec' = patchForeignImport unitId spec
404
405 ; return (ForeignImport { fd_name = name', fd_sig_ty = ty'
406 , fd_co = noForeignImportCoercionYet
407 , fd_fi = spec' }, fvs) }
408
409 rnHsForeignDecl (ForeignExport { fd_name = name, fd_sig_ty = ty, fd_fe = spec })
410 = do { name' <- lookupLocatedOccRn name
411 ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) ty
412 ; return (ForeignExport { fd_name = name', fd_sig_ty = ty'
413 , fd_co = noForeignExportCoercionYet
414 , fd_fe = spec }
415 , fvs `addOneFV` unLoc name') }
416 -- NB: a foreign export is an *occurrence site* for name, so
417 -- we add it to the free-variable list. It might, for example,
418 -- be imported from another module
419
420 -- | For Windows DLLs we need to know what packages imported symbols are from
421 -- to generate correct calls. Imported symbols are tagged with the current
422 -- package, so if they get inlined across a package boundry we'll still
423 -- know where they're from.
424 --
425 patchForeignImport :: UnitId -> ForeignImport -> ForeignImport
426 patchForeignImport unitId (CImport cconv safety fs spec src)
427 = CImport cconv safety fs (patchCImportSpec unitId spec) src
428
429 patchCImportSpec :: UnitId -> CImportSpec -> CImportSpec
430 patchCImportSpec unitId spec
431 = case spec of
432 CFunction callTarget -> CFunction $ patchCCallTarget unitId callTarget
433 _ -> spec
434
435 patchCCallTarget :: UnitId -> CCallTarget -> CCallTarget
436 patchCCallTarget unitId callTarget =
437 case callTarget of
438 StaticTarget src label Nothing isFun
439 -> StaticTarget src label (Just unitId) isFun
440 _ -> callTarget
441
442 {-
443 *********************************************************
444 * *
445 \subsection{Instance declarations}
446 * *
447 *********************************************************
448 -}
449
450 rnSrcInstDecl :: InstDecl RdrName -> RnM (InstDecl Name, FreeVars)
451 rnSrcInstDecl (TyFamInstD { tfid_inst = tfi })
452 = do { (tfi', fvs) <- rnTyFamInstDecl Nothing tfi
453 ; return (TyFamInstD { tfid_inst = tfi' }, fvs) }
454
455 rnSrcInstDecl (DataFamInstD { dfid_inst = dfi })
456 = do { (dfi', fvs) <- rnDataFamInstDecl Nothing dfi
457 ; return (DataFamInstD { dfid_inst = dfi' }, fvs) }
458
459 rnSrcInstDecl (ClsInstD { cid_inst = cid })
460 = do { (cid', fvs) <- rnClsInstDecl cid
461 ; return (ClsInstD { cid_inst = cid' }, fvs) }
462
463 -- | Warn about non-canonical typeclass instance declarations
464 --
465 -- A "non-canonical" instance definition can occur for instances of a
466 -- class which redundantly defines an operation its superclass
467 -- provides as well (c.f. `return`/`pure`). In such cases, a canonical
468 -- instance is one where the subclass inherits its method
469 -- implementation from its superclass instance (usually the subclass
470 -- has a default method implementation to that effect). Consequently,
471 -- a non-canonical instance occurs when this is not the case.
472 --
473 -- See also descriptions of 'checkCanonicalMonadInstances' and
474 -- 'checkCanonicalMonoidInstances'
475 checkCanonicalInstances :: Name -> LHsSigType Name -> LHsBinds Name -> RnM ()
476 checkCanonicalInstances cls poly_ty mbinds = do
477 whenWOptM Opt_WarnNonCanonicalMonadInstances
478 checkCanonicalMonadInstances
479
480 whenWOptM Opt_WarnNonCanonicalMonadFailInstances
481 checkCanonicalMonadFailInstances
482
483 whenWOptM Opt_WarnNonCanonicalMonoidInstances
484 checkCanonicalMonoidInstances
485
486 where
487 -- | Warn about unsound/non-canonical 'Applicative'/'Monad' instance
488 -- declarations. Specifically, the following conditions are verified:
489 --
490 -- In 'Monad' instances declarations:
491 --
492 -- * If 'return' is overridden it must be canonical (i.e. @return = pure@)
493 -- * If '(>>)' is overridden it must be canonical (i.e. @(>>) = (*>)@)
494 --
495 -- In 'Applicative' instance declarations:
496 --
497 -- * Warn if 'pure' is defined backwards (i.e. @pure = return@).
498 -- * Warn if '(*>)' is defined backwards (i.e. @(*>) = (>>)@).
499 --
500 checkCanonicalMonadInstances
501 | cls == applicativeClassName = do
502 forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do
503 case mbind of
504 FunBind { fun_id = L _ name, fun_matches = mg }
505 | name == pureAName, isAliasMG mg == Just returnMName
506 -> addWarnNonCanonicalMethod1
507 Opt_WarnNonCanonicalMonadInstances "pure" "return"
508
509 | name == thenAName, isAliasMG mg == Just thenMName
510 -> addWarnNonCanonicalMethod1
511 Opt_WarnNonCanonicalMonadInstances "(*>)" "(>>)"
512
513 _ -> return ()
514
515 | cls == monadClassName = do
516 forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do
517 case mbind of
518 FunBind { fun_id = L _ name, fun_matches = mg }
519 | name == returnMName, isAliasMG mg /= Just pureAName
520 -> addWarnNonCanonicalMethod2
521 Opt_WarnNonCanonicalMonadInstances "return" "pure"
522
523 | name == thenMName, isAliasMG mg /= Just thenAName
524 -> addWarnNonCanonicalMethod2
525 Opt_WarnNonCanonicalMonadInstances "(>>)" "(*>)"
526
527 _ -> return ()
528
529 | otherwise = return ()
530
531 -- | Warn about unsound/non-canonical 'Monad'/'MonadFail' instance
532 -- declarations. Specifically, the following conditions are verified:
533 --
534 -- In 'Monad' instances declarations:
535 --
536 -- * If 'fail' is overridden it must be canonical
537 -- (i.e. @fail = Control.Monad.Fail.fail@)
538 --
539 -- In 'MonadFail' instance declarations:
540 --
541 -- * Warn if 'fail' is defined backwards
542 -- (i.e. @fail = Control.Monad.fail@).
543 --
544 checkCanonicalMonadFailInstances
545 | cls == monadFailClassName = 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 == failMName, isAliasMG mg == Just failMName_preMFP
550 -> addWarnNonCanonicalMethod1
551 Opt_WarnNonCanonicalMonadFailInstances "fail"
552 "Control.Monad.fail"
553
554 _ -> return ()
555
556 | cls == monadClassName = do
557 forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do
558 case mbind of
559 FunBind { fun_id = L _ name, fun_matches = mg }
560 | name == failMName_preMFP, isAliasMG mg /= Just failMName
561 -> addWarnNonCanonicalMethod2
562 Opt_WarnNonCanonicalMonadFailInstances "fail"
563 "Control.Monad.Fail.fail"
564 _ -> return ()
565
566 | otherwise = return ()
567
568 -- | Check whether Monoid(mappend) is defined in terms of
569 -- Semigroup((<>)) (and not the other way round). Specifically,
570 -- the following conditions are verified:
571 --
572 -- In 'Monoid' instances declarations:
573 --
574 -- * If 'mappend' is overridden it must be canonical
575 -- (i.e. @mappend = (<>)@)
576 --
577 -- In 'Semigroup' instance declarations:
578 --
579 -- * Warn if '(<>)' is defined backwards (i.e. @(<>) = mappend@).
580 --
581 checkCanonicalMonoidInstances
582 | cls == semigroupClassName = do
583 forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do
584 case mbind of
585 FunBind { fun_id = L _ name, fun_matches = mg }
586 | name == sappendName, isAliasMG mg == Just mappendName
587 -> addWarnNonCanonicalMethod1
588 Opt_WarnNonCanonicalMonoidInstances "(<>)" "mappend"
589
590 _ -> return ()
591
592 | cls == monoidClassName = do
593 forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do
594 case mbind of
595 FunBind { fun_id = L _ name, fun_matches = mg }
596 | name == mappendName, isAliasMG mg /= Just sappendName
597 -> addWarnNonCanonicalMethod2NoDefault
598 Opt_WarnNonCanonicalMonoidInstances "mappend" "(<>)"
599
600 _ -> return ()
601
602 | otherwise = return ()
603
604 -- | test whether MatchGroup represents a trivial \"lhsName = rhsName\"
605 -- binding, and return @Just rhsName@ if this is the case
606 isAliasMG :: MatchGroup Name (LHsExpr Name) -> Maybe Name
607 isAliasMG MG {mg_alts = L _ [L _ (Match { m_pats = [], m_grhss = grhss })]}
608 | GRHSs [L _ (GRHS [] body)] lbinds <- grhss
609 , L _ EmptyLocalBinds <- lbinds
610 , L _ (HsVar (L _ rhsName)) <- body = Just rhsName
611 isAliasMG _ = Nothing
612
613 -- got "lhs = rhs" but expected something different
614 addWarnNonCanonicalMethod1 flag lhs rhs = do
615 addWarn (Reason flag) $ vcat
616 [ text "Noncanonical" <+>
617 quotes (text (lhs ++ " = " ++ rhs)) <+>
618 text "definition detected"
619 , instDeclCtxt1 poly_ty
620 , text "Move definition from" <+>
621 quotes (text rhs) <+>
622 text "to" <+> quotes (text lhs)
623 ]
624
625 -- expected "lhs = rhs" but got something else
626 addWarnNonCanonicalMethod2 flag lhs rhs = do
627 addWarn (Reason flag) $ vcat
628 [ text "Noncanonical" <+>
629 quotes (text lhs) <+>
630 text "definition detected"
631 , instDeclCtxt1 poly_ty
632 , text "Either remove definition for" <+>
633 quotes (text lhs) <+> text "or define as" <+>
634 quotes (text (lhs ++ " = " ++ rhs))
635 ]
636
637 -- like above, but method has no default impl
638 addWarnNonCanonicalMethod2NoDefault flag lhs rhs = do
639 addWarn (Reason flag) $ vcat
640 [ text "Noncanonical" <+>
641 quotes (text lhs) <+>
642 text "definition detected"
643 , instDeclCtxt1 poly_ty
644 , text "Define as" <+>
645 quotes (text (lhs ++ " = " ++ rhs))
646 ]
647
648 -- stolen from TcInstDcls
649 instDeclCtxt1 :: LHsSigType Name -> SDoc
650 instDeclCtxt1 hs_inst_ty
651 = inst_decl_ctxt (ppr (getLHsInstDeclHead hs_inst_ty))
652
653 inst_decl_ctxt :: SDoc -> SDoc
654 inst_decl_ctxt doc = hang (text "in the instance declaration for")
655 2 (quotes doc <> text ".")
656
657
658 rnClsInstDecl :: ClsInstDecl RdrName -> RnM (ClsInstDecl Name, FreeVars)
659 rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds
660 , cid_sigs = uprags, cid_tyfam_insts = ats
661 , cid_overlap_mode = oflag
662 , cid_datafam_insts = adts })
663 = do { (inst_ty', inst_fvs) <- rnLHsInstType (text "an instance declaration") inst_ty
664 ; let (ktv_names, _, head_ty') = splitLHsInstDeclTy inst_ty'
665 ; let cls = case hsTyGetAppHead_maybe head_ty' of
666 Nothing -> mkUnboundName (mkTcOccFS (fsLit "<class>"))
667 Just (L _ cls, _) -> cls
668 -- rnLHsInstType has added an error message
669 -- if hsTyGetAppHead_maybe fails
670
671 -- Rename the bindings
672 -- The typechecker (not the renamer) checks that all
673 -- the bindings are for the right class
674 -- (Slightly strangely) when scoped type variables are on, the
675 -- forall-d tyvars scope over the method bindings too
676 ; (mbinds', uprags', meth_fvs) <- rnMethodBinds False cls ktv_names mbinds uprags
677
678 ; checkCanonicalInstances cls inst_ty' mbinds'
679
680 -- Rename the associated types, and type signatures
681 -- Both need to have the instance type variables in scope
682 ; traceRn "rnSrcInstDecl" (ppr inst_ty' $$ ppr ktv_names)
683 ; ((ats', adts'), more_fvs)
684 <- extendTyVarEnvFVRn ktv_names $
685 do { (ats', at_fvs) <- rnATInstDecls rnTyFamInstDecl cls ktv_names ats
686 ; (adts', adt_fvs) <- rnATInstDecls rnDataFamInstDecl cls ktv_names adts
687 ; return ( (ats', adts'), at_fvs `plusFV` adt_fvs) }
688
689 ; let all_fvs = meth_fvs `plusFV` more_fvs
690 `plusFV` inst_fvs
691 ; return (ClsInstDecl { cid_poly_ty = inst_ty', cid_binds = mbinds'
692 , cid_sigs = uprags', cid_tyfam_insts = ats'
693 , cid_overlap_mode = oflag
694 , cid_datafam_insts = adts' },
695 all_fvs) }
696 -- We return the renamed associated data type declarations so
697 -- that they can be entered into the list of type declarations
698 -- for the binding group, but we also keep a copy in the instance.
699 -- The latter is needed for well-formedness checks in the type
700 -- checker (eg, to ensure that all ATs of the instance actually
701 -- receive a declaration).
702 -- NB: Even the copies in the instance declaration carry copies of
703 -- the instance context after renaming. This is a bit
704 -- strange, but should not matter (and it would be more work
705 -- to remove the context).
706
707 rnFamInstDecl :: HsDocContext
708 -> Maybe (Name, [Name]) -- Nothing => not associated
709 -- Just (cls,tvs) => associated,
710 -- and gives class and tyvars of the
711 -- parent instance delc
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
746 -- a) any variables that appear *more than once* on the LHS
747 -- e.g. F a Int a = Bool
748 -- b) for associated instances, the variables
749 -- of the instance decl. See
750 -- Note [Unused type variables in family instances]
751 ; let tv_nms_used = extendNameSetList rhs_fvs $
752 inst_tvs ++ tv_nms_dups
753 inst_tvs = case mb_cls of
754 Nothing -> []
755 Just (_, inst_tvs) -> inst_tvs
756 ; warnUnusedTypePatterns var_names tv_nms_used
757
758 -- See Note [Renaming associated types]
759 ; let bad_tvs = case mb_cls of
760 Nothing -> []
761 Just (_,cls_tkvs) -> filter is_bad cls_tkvs
762 var_name_set = mkNameSet var_names
763
764 is_bad cls_tkv = cls_tkv `elemNameSet` rhs_fvs
765 && not (cls_tkv `elemNameSet` var_name_set)
766 ; unless (null bad_tvs) (badAssocRhs bad_tvs)
767
768 ; return ((pats', payload'), rhs_fvs `plusFV` pat_fvs) }
769
770 ; let anon_wcs = concatMap collectAnonWildCards pats'
771 all_ibs = anon_wcs ++ var_names
772 -- all_ibs: include anonymous wildcards in the implicit
773 -- binders In a type pattern they behave just like any
774 -- other type variable except for being anoymous. See
775 -- Note [Wildcards in family instances]
776 all_fvs = fvs `addOneFV` unLoc tycon'
777
778 ; return (tycon',
779 HsIB { hsib_body = pats'
780 , hsib_vars = all_ibs
781 , hsib_closed = True },
782 payload',
783 all_fvs) }
784 -- type instance => use, hence addOneFV
785
786 rnTyFamInstDecl :: Maybe (Name, [Name])
787 -> TyFamInstDecl RdrName
788 -> RnM (TyFamInstDecl Name, FreeVars)
789 rnTyFamInstDecl mb_cls (TyFamInstDecl { tfid_eqn = L loc eqn })
790 = do { (eqn', fvs) <- rnTyFamInstEqn mb_cls eqn
791 ; return (TyFamInstDecl { tfid_eqn = L loc eqn'
792 , tfid_fvs = fvs }, fvs) }
793
794 rnTyFamInstEqn :: Maybe (Name, [Name])
795 -> TyFamInstEqn RdrName
796 -> RnM (TyFamInstEqn Name, FreeVars)
797 rnTyFamInstEqn mb_cls (TyFamEqn { tfe_tycon = tycon
798 , tfe_pats = pats
799 , tfe_fixity = fixity
800 , tfe_rhs = rhs })
801 = do { (tycon', pats', rhs', fvs) <-
802 rnFamInstDecl (TySynCtx tycon) mb_cls tycon pats rhs rnTySyn
803 ; return (TyFamEqn { tfe_tycon = tycon'
804 , tfe_pats = pats'
805 , tfe_fixity = fixity
806 , tfe_rhs = rhs' }, fvs) }
807
808 rnTyFamDefltEqn :: Name
809 -> TyFamDefltEqn RdrName
810 -> RnM (TyFamDefltEqn Name, FreeVars)
811 rnTyFamDefltEqn cls (TyFamEqn { tfe_tycon = tycon
812 , tfe_pats = tyvars
813 , tfe_fixity = fixity
814 , tfe_rhs = rhs })
815 = bindHsQTyVars ctx Nothing (Just cls) [] tyvars $ \ tyvars' _ ->
816 do { tycon' <- lookupFamInstName (Just cls) tycon
817 ; (rhs', fvs) <- rnLHsType ctx rhs
818 ; return (TyFamEqn { tfe_tycon = tycon'
819 , tfe_pats = tyvars'
820 , tfe_fixity = fixity
821 , tfe_rhs = rhs' }, fvs) }
822 where
823 ctx = TyFamilyCtx tycon
824
825 rnDataFamInstDecl :: Maybe (Name, [Name])
826 -> DataFamInstDecl RdrName
827 -> RnM (DataFamInstDecl Name, FreeVars)
828 rnDataFamInstDecl mb_cls (DataFamInstDecl { dfid_tycon = tycon
829 , dfid_pats = pats
830 , dfid_fixity = fixity
831 , dfid_defn = defn })
832 = do { (tycon', pats', (defn', _), fvs) <-
833 rnFamInstDecl (TyDataCtx tycon) mb_cls tycon pats defn rnDataDefn
834 ; return (DataFamInstDecl { dfid_tycon = tycon'
835 , dfid_pats = pats'
836 , dfid_fixity = fixity
837 , dfid_defn = defn'
838 , dfid_fvs = fvs }, fvs) }
839
840 -- Renaming of the associated types in instances.
841
842 -- Rename associated type family decl in class
843 rnATDecls :: Name -- Class
844 -> [LFamilyDecl RdrName]
845 -> RnM ([LFamilyDecl Name], FreeVars)
846 rnATDecls cls at_decls
847 = rnList (rnFamDecl (Just cls)) at_decls
848
849 rnATInstDecls :: (Maybe (Name, [Name]) -> -- The function that renames
850 decl RdrName -> -- an instance. rnTyFamInstDecl
851 RnM (decl Name, FreeVars)) -- or rnDataFamInstDecl
852 -> Name -- Class
853 -> [Name]
854 -> [Located (decl RdrName)]
855 -> RnM ([Located (decl Name)], FreeVars)
856 -- Used for data and type family defaults in a class decl
857 -- and the family instance declarations in an instance
858 --
859 -- NB: We allow duplicate associated-type decls;
860 -- See Note [Associated type instances] in TcInstDcls
861 rnATInstDecls rnFun cls tv_ns at_insts
862 = rnList (rnFun (Just (cls, tv_ns))) at_insts
863 -- See Note [Renaming associated types]
864
865 {- Note [Wildcards in family instances]
866 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
867 Wild cards can be used in type/data family instance declarations to indicate
868 that the name of a type variable doesn't matter. Each wild card will be
869 replaced with a new unique type variable. For instance:
870
871 type family F a b :: *
872 type instance F Int _ = Int
873
874 is the same as
875
876 type family F a b :: *
877 type instance F Int b = Int
878
879 This is implemented as follows: during renaming anonymous wild cards
880 '_' are given freshly generated names. These names are collected after
881 renaming (rnFamInstDecl) and used to make new type variables during
882 type checking (tc_fam_ty_pats). One should not confuse these wild
883 cards with the ones from partial type signatures. The latter generate
884 fresh meta-variables whereas the former generate fresh skolems.
885
886 Note [Unused type variables in family instances]
887 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
888 When the flag -fwarn-unused-type-patterns is on, the compiler reports
889 warnings about unused type variables in type-family instances. A
890 tpye variable is considered used (i.e. cannot be turned into a wildcard)
891 when
892
893 * it occurs on the RHS of the family instance
894 e.g. type instance F a b = a -- a is used on the RHS
895
896 * it occurs multiple times in the patterns on the LHS
897 e.g. type instance F a a = Int -- a appears more than once on LHS
898
899 * it is one of the instance-decl variables, for associated types
900 e.g. instance C (a,b) where
901 type T (a,b) = a
902 Here the type pattern in the type instance must be the same as that
903 for the class instance, so
904 type T (a,_) = a
905 would be rejected. So we should not complain about an unused variable b
906
907 As usual, the warnings are not reported for for type variables with names
908 beginning with an underscore.
909
910 Extra-constraints wild cards are not supported in type/data family
911 instance declarations.
912
913 Relevant tickets: #3699, #10586, #10982 and #11451.
914
915 Note [Renaming associated types]
916 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
917 Check that the RHS of the decl mentions only type variables
918 bound on the LHS. For example, this is not ok
919 class C a b where
920 type F a x :: *
921 instance C (p,q) r where
922 type F (p,q) x = (x, r) -- BAD: mentions 'r'
923 c.f. Trac #5515
924
925 The same thing applies to kind variables, of course (Trac #7938, #9574):
926 class Funct f where
927 type Codomain f :: *
928 instance Funct ('KProxy :: KProxy o) where
929 type Codomain 'KProxy = NatTr (Proxy :: o -> *)
930 Here 'o' is mentioned on the RHS of the Codomain function, but
931 not on the LHS.
932
933 All this applies only for *instance* declarations. In *class*
934 declarations there is no RHS to worry about, and the class variables
935 can all be in scope (Trac #5862):
936 class Category (x :: k -> k -> *) where
937 type Ob x :: k -> Constraint
938 id :: Ob x a => x a a
939 (.) :: (Ob x a, Ob x b, Ob x c) => x b c -> x a b -> x a c
940 Here 'k' is in scope in the kind signature, just like 'x'.
941 -}
942
943
944 {-
945 *********************************************************
946 * *
947 \subsection{Stand-alone deriving declarations}
948 * *
949 *********************************************************
950 -}
951
952 rnSrcDerivDecl :: DerivDecl RdrName -> RnM (DerivDecl Name, FreeVars)
953 rnSrcDerivDecl (DerivDecl ty deriv_strat overlap)
954 = do { standalone_deriv_ok <- xoptM LangExt.StandaloneDeriving
955 ; deriv_strats_ok <- xoptM LangExt.DerivingStrategies
956 ; unless standalone_deriv_ok (addErr standaloneDerivErr)
957 ; failIfTc (isJust deriv_strat && not deriv_strats_ok) $
958 illegalDerivStrategyErr $ fmap unLoc deriv_strat
959 ; (ty', fvs) <- rnLHsInstType (text "In a deriving declaration") ty
960 ; return (DerivDecl ty' deriv_strat overlap, fvs) }
961
962 standaloneDerivErr :: SDoc
963 standaloneDerivErr
964 = hang (text "Illegal standalone deriving declaration")
965 2 (text "Use StandaloneDeriving to enable this extension")
966
967 {-
968 *********************************************************
969 * *
970 \subsection{Rules}
971 * *
972 *********************************************************
973 -}
974
975 rnHsRuleDecls :: RuleDecls RdrName -> RnM (RuleDecls Name, FreeVars)
976 rnHsRuleDecls (HsRules src rules)
977 = do { (rn_rules,fvs) <- rnList rnHsRuleDecl rules
978 ; return (HsRules src rn_rules,fvs) }
979
980 rnHsRuleDecl :: RuleDecl RdrName -> RnM (RuleDecl Name, FreeVars)
981 rnHsRuleDecl (HsRule rule_name act vars lhs _fv_lhs rhs _fv_rhs)
982 = do { let rdr_names_w_loc = map get_var vars
983 ; checkDupRdrNames rdr_names_w_loc
984 ; checkShadowedRdrNames rdr_names_w_loc
985 ; names <- newLocalBndrsRn rdr_names_w_loc
986 ; bindHsRuleVars (snd $ unLoc rule_name) vars names $ \ vars' ->
987 do { (lhs', fv_lhs') <- rnLExpr lhs
988 ; (rhs', fv_rhs') <- rnLExpr rhs
989 ; checkValidRule (snd $ unLoc rule_name) names lhs' fv_lhs'
990 ; return (HsRule rule_name act vars' lhs' fv_lhs' rhs' fv_rhs',
991 fv_lhs' `plusFV` fv_rhs') } }
992 where
993 get_var (L _ (RuleBndrSig v _)) = v
994 get_var (L _ (RuleBndr v)) = v
995
996 bindHsRuleVars :: RuleName -> [LRuleBndr RdrName] -> [Name]
997 -> ([LRuleBndr Name] -> RnM (a, FreeVars))
998 -> RnM (a, FreeVars)
999 bindHsRuleVars rule_name vars names thing_inside
1000 = go vars names $ \ vars' ->
1001 bindLocalNamesFV names (thing_inside vars')
1002 where
1003 doc = RuleCtx rule_name
1004
1005 go (L l (RuleBndr (L loc _)) : vars) (n : ns) thing_inside
1006 = go vars ns $ \ vars' ->
1007 thing_inside (L l (RuleBndr (L loc n)) : vars')
1008
1009 go (L l (RuleBndrSig (L loc _) bsig) : vars) (n : ns) thing_inside
1010 = rnHsSigWcTypeScoped doc bsig $ \ bsig' ->
1011 go vars ns $ \ vars' ->
1012 thing_inside (L l (RuleBndrSig (L loc n) bsig') : vars')
1013
1014 go [] [] thing_inside = thing_inside []
1015 go vars names _ = pprPanic "bindRuleVars" (ppr vars $$ ppr names)
1016
1017 {-
1018 Note [Rule LHS validity checking]
1019 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1020 Check the shape of a transformation rule LHS. Currently we only allow
1021 LHSs of the form @(f e1 .. en)@, where @f@ is not one of the
1022 @forall@'d variables.
1023
1024 We used restrict the form of the 'ei' to prevent you writing rules
1025 with LHSs with a complicated desugaring (and hence unlikely to match);
1026 (e.g. a case expression is not allowed: too elaborate.)
1027
1028 But there are legitimate non-trivial args ei, like sections and
1029 lambdas. So it seems simmpler not to check at all, and that is why
1030 check_e is commented out.
1031 -}
1032
1033 checkValidRule :: FastString -> [Name] -> LHsExpr Name -> NameSet -> RnM ()
1034 checkValidRule rule_name ids lhs' fv_lhs'
1035 = do { -- Check for the form of the LHS
1036 case (validRuleLhs ids lhs') of
1037 Nothing -> return ()
1038 Just bad -> failWithTc (badRuleLhsErr rule_name lhs' bad)
1039
1040 -- Check that LHS vars are all bound
1041 ; let bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs')]
1042 ; mapM_ (addErr . badRuleVar rule_name) bad_vars }
1043
1044 validRuleLhs :: [Name] -> LHsExpr Name -> Maybe (HsExpr Name)
1045 -- Nothing => OK
1046 -- Just e => Not ok, and e is the offending sub-expression
1047 validRuleLhs foralls lhs
1048 = checkl lhs
1049 where
1050 checkl (L _ e) = check e
1051
1052 check (OpApp e1 op _ e2) = checkl op `mplus` checkl_e e1 `mplus` checkl_e e2
1053 check (HsApp e1 e2) = checkl e1 `mplus` checkl_e e2
1054 check (HsAppType e _) = checkl e
1055 check (HsVar (L _ v)) | v `notElem` foralls = Nothing
1056 check other = Just other -- Failure
1057
1058 -- Check an argument
1059 checkl_e (L _ _e) = Nothing -- Was (check_e e); see Note [Rule LHS validity checking]
1060
1061 {- Commented out; see Note [Rule LHS validity checking] above
1062 check_e (HsVar v) = Nothing
1063 check_e (HsPar e) = checkl_e e
1064 check_e (HsLit e) = Nothing
1065 check_e (HsOverLit e) = Nothing
1066
1067 check_e (OpApp e1 op _ e2) = checkl_e e1 `mplus` checkl_e op `mplus` checkl_e e2
1068 check_e (HsApp e1 e2) = checkl_e e1 `mplus` checkl_e e2
1069 check_e (NegApp e _) = checkl_e e
1070 check_e (ExplicitList _ es) = checkl_es es
1071 check_e other = Just other -- Fails
1072
1073 checkl_es es = foldr (mplus . checkl_e) Nothing es
1074 -}
1075
1076 badRuleVar :: FastString -> Name -> SDoc
1077 badRuleVar name var
1078 = sep [text "Rule" <+> doubleQuotes (ftext name) <> colon,
1079 text "Forall'd variable" <+> quotes (ppr var) <+>
1080 text "does not appear on left hand side"]
1081
1082 badRuleLhsErr :: FastString -> LHsExpr Name -> HsExpr Name -> SDoc
1083 badRuleLhsErr name lhs bad_e
1084 = sep [text "Rule" <+> pprRuleName name <> colon,
1085 nest 4 (vcat [err,
1086 text "in left-hand side:" <+> ppr lhs])]
1087 $$
1088 text "LHS must be of form (f e1 .. en) where f is not forall'd"
1089 where
1090 err = case bad_e of
1091 HsUnboundVar uv -> text "Not in scope:" <+> ppr uv
1092 _ -> text "Illegal expression:" <+> ppr bad_e
1093
1094 {-
1095 *********************************************************
1096 * *
1097 \subsection{Vectorisation declarations}
1098 * *
1099 *********************************************************
1100 -}
1101
1102 rnHsVectDecl :: VectDecl RdrName -> RnM (VectDecl Name, FreeVars)
1103 -- FIXME: For the moment, the right-hand side is restricted to be a variable as we cannot properly
1104 -- typecheck a complex right-hand side without invoking 'vectType' from the vectoriser.
1105 rnHsVectDecl (HsVect s var rhs@(L _ (HsVar _)))
1106 = do { var' <- lookupLocatedOccRn var
1107 ; (rhs', fv_rhs) <- rnLExpr rhs
1108 ; return (HsVect s var' rhs', fv_rhs `addOneFV` unLoc var')
1109 }
1110 rnHsVectDecl (HsVect _ _var _rhs)
1111 = failWith $ vcat
1112 [ text "IMPLEMENTATION RESTRICTION: right-hand side of a VECTORISE pragma"
1113 , text "must be an identifier"
1114 ]
1115 rnHsVectDecl (HsNoVect s var)
1116 = do { var' <- lookupLocatedTopBndrRn var -- only applies to local (not imported) names
1117 ; return (HsNoVect s var', unitFV (unLoc var'))
1118 }
1119 rnHsVectDecl (HsVectTypeIn s isScalar tycon Nothing)
1120 = do { tycon' <- lookupLocatedOccRn tycon
1121 ; return (HsVectTypeIn s isScalar tycon' Nothing, unitFV (unLoc tycon'))
1122 }
1123 rnHsVectDecl (HsVectTypeIn s isScalar tycon (Just rhs_tycon))
1124 = do { tycon' <- lookupLocatedOccRn tycon
1125 ; rhs_tycon' <- lookupLocatedOccRn rhs_tycon
1126 ; return ( HsVectTypeIn s isScalar tycon' (Just rhs_tycon')
1127 , mkFVs [unLoc tycon', unLoc rhs_tycon'])
1128 }
1129 rnHsVectDecl (HsVectTypeOut _ _ _)
1130 = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectTypeOut'"
1131 rnHsVectDecl (HsVectClassIn s cls)
1132 = do { cls' <- lookupLocatedOccRn cls
1133 ; return (HsVectClassIn s cls', unitFV (unLoc cls'))
1134 }
1135 rnHsVectDecl (HsVectClassOut _)
1136 = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectClassOut'"
1137 rnHsVectDecl (HsVectInstIn instTy)
1138 = do { (instTy', fvs) <- rnLHsInstType (text "a VECTORISE pragma") instTy
1139 ; return (HsVectInstIn instTy', fvs)
1140 }
1141 rnHsVectDecl (HsVectInstOut _)
1142 = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectInstOut'"
1143
1144 {- **************************************************************
1145 * *
1146 Renaming type, class, instance and role declarations
1147 * *
1148 *****************************************************************
1149
1150 @rnTyDecl@ uses the `global name function' to create a new type
1151 declaration in which local names have been replaced by their original
1152 names, reporting any unknown names.
1153
1154 Renaming type variables is a pain. Because they now contain uniques,
1155 it is necessary to pass in an association list which maps a parsed
1156 tyvar to its @Name@ representation.
1157 In some cases (type signatures of values),
1158 it is even necessary to go over the type first
1159 in order to get the set of tyvars used by it, make an assoc list,
1160 and then go over it again to rename the tyvars!
1161 However, we can also do some scoping checks at the same time.
1162
1163 Note [Dependency analysis of type, class, and instance decls]
1164 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1165 A TyClGroup represents a strongly connected components of
1166 type/class/instance decls, together with the role annotations for the
1167 type/class declarations. The renamer uses strongly connected
1168 comoponent analysis to build these groups. We do this for a number of
1169 reasons:
1170
1171 * Improve kind error messages. Consider
1172
1173 data T f a = MkT f a
1174 data S f a = MkS f (T f a)
1175
1176 This has a kind error, but the error message is better if you
1177 check T first, (fixing its kind) and *then* S. If you do kind
1178 inference together, you might get an error reported in S, which
1179 is jolly confusing. See Trac #4875
1180
1181
1182 * Increase kind polymorphism. See TcTyClsDecls
1183 Note [Grouping of type and class declarations]
1184
1185 Why do the instance declarations participate? At least two reasons
1186
1187 * Consider (Trac #11348)
1188
1189 type family F a
1190 type instance F Int = Bool
1191
1192 data R = MkR (F Int)
1193
1194 type Foo = 'MkR 'True
1195
1196 For Foo to kind-check we need to know that (F Int) ~ Bool. But we won't
1197 know that unless we've looked at the type instance declaration for F
1198 before kind-checking Foo.
1199
1200 * Another example is this (Trac #3990).
1201
1202 data family Complex a
1203 data instance Complex Double = CD {-# UNPACK #-} !Double
1204 {-# UNPACK #-} !Double
1205
1206 data T = T {-# UNPACK #-} !(Complex Double)
1207
1208 Here, to generate the right kind of unpacked implementation for T,
1209 we must have access to the 'data instance' declaration.
1210
1211 * Things become more complicated when we introduce transitive
1212 dependencies through imported definitions, like in this scenario:
1213
1214 A.hs
1215 type family Closed (t :: Type) :: Type where
1216 Closed t = Open t
1217
1218 type family Open (t :: Type) :: Type
1219
1220 B.hs
1221 data Q where
1222 Q :: Closed Bool -> Q
1223
1224 type instance Open Int = Bool
1225
1226 type S = 'Q 'True
1227
1228 Somehow, we must ensure that the instance Open Int = Bool is checked before
1229 the type synonym S. While we know that S depends upon 'Q depends upon Closed,
1230 we have no idea that Closed depends upon Open!
1231
1232 To accomodate for these situations, we ensure that an instance is checked
1233 before every @TyClDecl@ on which it does not depend. That's to say, instances
1234 are checked as early as possible in @tcTyAndClassDecls@.
1235
1236 ------------------------------------
1237 So much for WHY. What about HOW? It's pretty easy:
1238
1239 (1) Rename the type/class, instance, and role declarations
1240 individually
1241
1242 (2) Do strongly-connected component analysis of the type/class decls,
1243 We'll make a TyClGroup for each SCC
1244
1245 In this step we treat a reference to a (promoted) data constructor
1246 K as a dependency on its parent type. Thus
1247 data T = K1 | K2
1248 data S = MkS (Proxy 'K1)
1249 Here S depends on 'K1 and hence on its parent T.
1250
1251 In this step we ignore instances; see
1252 Note [No dependencies on data instances]
1253
1254 (3) Attach roles to the appropriate SCC
1255
1256 (4) Attach instances to the appropriate SCC.
1257 We add an instance decl to SCC when:
1258 all its free types/classes are bound in this SCC or earlier ones
1259
1260 (5) We make an initial TyClGroup, with empty group_tyclds, for any
1261 (orphan) instances that affect only imported types/classes
1262
1263 Steps (3) and (4) are done by the (mapAccumL mk_group) call.
1264
1265 Note [No dependencies on data instances]
1266 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1267 Consider this
1268 data family D a
1269 data instance D Int = D1
1270 data S = MkS (Proxy 'D1)
1271
1272 Here the declaration of S depends on the /data instance/ declaration
1273 for 'D Int'. That makes things a lot more complicated, especially
1274 if the data instance is an associated type of an enclosing class instance.
1275 (And the class instance might have several associated type instances
1276 with different dependency structure!)
1277
1278 Ugh. For now we simply don't allow promotion of data constructors for
1279 data instances. See Note [AFamDataCon: not promoting data family
1280 constructors] in TcEnv
1281 -}
1282
1283
1284 rnTyClDecls :: [TyClGroup RdrName]
1285 -> RnM ([TyClGroup Name], FreeVars)
1286 -- Rename the declarations and do dependency analysis on them
1287 rnTyClDecls tycl_ds
1288 = do { -- Rename the type/class, instance, and role declaraations
1289 tycls_w_fvs <- mapM (wrapLocFstM rnTyClDecl)
1290 (tyClGroupTyClDecls tycl_ds)
1291 ; let tc_names = mkNameSet (map (tcdName . unLoc . fst) tycls_w_fvs)
1292
1293 ; instds_w_fvs <- mapM (wrapLocFstM rnSrcInstDecl) (tyClGroupInstDecls tycl_ds)
1294 ; role_annots <- rnRoleAnnots tc_names (tyClGroupRoleDecls tycl_ds)
1295
1296 ; tycls_w_fvs <- addBootDeps tycls_w_fvs
1297 -- TBD must add_boot_deps to instds_w_fvs?
1298
1299 -- Do SCC analysis on the type/class decls
1300 ; rdr_env <- getGlobalRdrEnv
1301 ; let tycl_sccs = depAnalTyClDecls rdr_env tycls_w_fvs
1302 role_annot_env = mkRoleAnnotEnv role_annots
1303
1304 inst_ds_map = mkInstDeclFreeVarsMap rdr_env tc_names instds_w_fvs
1305 (init_inst_ds, rest_inst_ds) = getInsts [] inst_ds_map
1306
1307 first_group
1308 | null init_inst_ds = []
1309 | otherwise = [TyClGroup { group_tyclds = []
1310 , group_roles = []
1311 , group_instds = init_inst_ds }]
1312
1313 ((final_inst_ds, orphan_roles), groups)
1314 = mapAccumL mk_group (rest_inst_ds, role_annot_env) tycl_sccs
1315
1316
1317 all_fvs = plusFV (foldr (plusFV . snd) emptyFVs tycls_w_fvs)
1318 (foldr (plusFV . snd) emptyFVs instds_w_fvs)
1319
1320 all_groups = first_group ++ groups
1321
1322 ; ASSERT2( null final_inst_ds, ppr instds_w_fvs $$ ppr inst_ds_map
1323 $$ ppr (flattenSCCs tycl_sccs) $$ ppr final_inst_ds )
1324 mapM_ orphanRoleAnnotErr (nameEnvElts orphan_roles)
1325
1326 ; traceRn "rnTycl dependency analysis made groups" (ppr all_groups)
1327 ; return (all_groups, all_fvs) }
1328 where
1329 mk_group :: (InstDeclFreeVarsMap, RoleAnnotEnv)
1330 -> SCC (LTyClDecl Name)
1331 -> ( (InstDeclFreeVarsMap, RoleAnnotEnv)
1332 , TyClGroup Name )
1333 mk_group (inst_map, role_env) scc
1334 = ((inst_map', role_env'), group)
1335 where
1336 tycl_ds = flattenSCC scc
1337 bndrs = map (tcdName . unLoc) tycl_ds
1338 (inst_ds, inst_map') = getInsts bndrs inst_map
1339 (roles, role_env') = getRoleAnnots bndrs role_env
1340 group = TyClGroup { group_tyclds = tycl_ds
1341 , group_roles = roles
1342 , group_instds = inst_ds }
1343
1344
1345 depAnalTyClDecls :: GlobalRdrEnv
1346 -> [(LTyClDecl Name, FreeVars)]
1347 -> [SCC (LTyClDecl Name)]
1348 -- See Note [Dependency analysis of type, class, and instance decls]
1349 depAnalTyClDecls rdr_env ds_w_fvs
1350 = stronglyConnCompFromEdgedVerticesUniq edges
1351 where
1352 edges = [ (d, tcdName (unLoc d), map (getParent rdr_env) (nonDetEltsUniqSet fvs))
1353 | (d, fvs) <- ds_w_fvs ]
1354 -- It's OK to use nonDetEltsUFM here as
1355 -- stronglyConnCompFromEdgedVertices is still deterministic
1356 -- even if the edges are in nondeterministic order as explained
1357 -- in Note [Deterministic SCC] in Digraph.
1358
1359 toParents :: GlobalRdrEnv -> NameSet -> NameSet
1360 toParents rdr_env ns
1361 = nonDetFoldUniqSet add emptyNameSet ns
1362 -- It's OK to use nonDetFoldUFM because we immediately forget the
1363 -- ordering by creating a set
1364 where
1365 add n s = extendNameSet s (getParent rdr_env n)
1366
1367 getParent :: GlobalRdrEnv -> Name -> Name
1368 getParent rdr_env n
1369 = case lookupGRE_Name rdr_env n of
1370 Just gre -> case gre_par gre of
1371 ParentIs { par_is = p } -> p
1372 FldParent { par_is = p } -> p
1373 _ -> n
1374 Nothing -> n
1375
1376
1377 {- Note [Extra dependencies from .hs-boot files]
1378 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1379 This is a long story, so buckle in.
1380
1381 **Dependencies via hs-boot files are not obvious.** Consider the following case:
1382
1383 A.hs-boot
1384 module A where
1385 data A1
1386
1387 B.hs
1388 module B where
1389 import {-# SOURCE #-} A
1390 type B1 = A1
1391
1392 A.hs
1393 module A where
1394 import B
1395 data A2 = MkA2 B1
1396 data A1 = MkA1 A2
1397
1398 Here A2 is really recursive (via B1), but we won't see that easily when
1399 doing dependency analysis when compiling A.hs. When we look at A2,
1400 we see that its free variables are simply B1, but without (recursively) digging
1401 into the definition of B1 will we see that it actually refers to A1 via an
1402 hs-boot file.
1403
1404 **Recursive declarations, even those broken by an hs-boot file, need to
1405 be type-checked together.** Whenever we refer to a declaration via
1406 an hs-boot file, we must be careful not to force the TyThing too early:
1407 ala Note [Tying the knot] if we force the TyThing before we have
1408 defined it ourselves in the local type environment, GHC will error.
1409
1410 Conservatively, then, it would make sense that we to typecheck A1
1411 and A2 from the previous example together, because the two types are
1412 truly mutually recursive through B1.
1413
1414 If we are being clever, we might observe that while kind-checking
1415 A2, we don't actually need to force the TyThing for A1: B1
1416 independently records its kind, so there is no need to go "deeper".
1417 But then we are in an uncomfortable situation where we have
1418 constructed a TyThing for A2 before we have checked A1, and we
1419 have to be absolutely certain we don't force it too deeply until
1420 we get around to kind checking A1, which could be for a very long
1421 time.
1422
1423 Indeed, with datatype promotion, we may very well need to look
1424 at the type of MkA2 before we have kind-checked A1: consider,
1425
1426 data T = MkT (Proxy 'MkA2)
1427
1428 To promote MkA2, we need to lift its type to the kind level.
1429 We never tested this, but it seems likely A1 would get poked
1430 at this point.
1431
1432 **Here's what we do instead.** So it is expedient for us to
1433 make sure A1 and A2 are kind checked together in a loop.
1434 To ensure that our dependency analysis can catch this,
1435 we add a dependency:
1436
1437 - from every local declaration
1438 - to everything that comes from this module's .hs-boot file
1439 (this is gotten from sb_tcs in the SelfBootInfo).
1440
1441 In this case, we'll add an edges
1442
1443 - from A1 to A2 (but that edge is there already)
1444 - from A2 to A1 (which is new)
1445
1446 Well, not quite *every* declaration. Imagine module A
1447 above had another datatype declaration:
1448
1449 data A3 = A3 Int
1450
1451 Even though A3 has a dependency (on Int), all its dependencies are from things
1452 that live on other packages. Since we don't have mutual dependencies across
1453 packages, it is safe not to add the dependencies on the .hs-boot stuff to A2.
1454
1455 Hence function nameIsHomePackageImport.
1456
1457 Note that this is fairly conservative: it essentially implies that
1458 EVERY type declaration in this modules hs-boot file will be kind-checked
1459 together in one giant loop (and furthermore makes every other type
1460 in the module depend on this loop). This is perhaps less than ideal, because
1461 the larger a recursive group, the less polymorphism available (we
1462 cannot infer a type to be polymorphically instantiated while we
1463 are inferring its kind), but no one has hollered about this (yet!)
1464 -}
1465
1466 addBootDeps :: [(LTyClDecl Name, FreeVars)] -> RnM [(LTyClDecl Name, FreeVars)]
1467 -- See Note [Extra dependencies from .hs-boot files]
1468 addBootDeps ds_w_fvs
1469 = do { tcg_env <- getGblEnv
1470 ; let this_mod = tcg_mod tcg_env
1471 boot_info = tcg_self_boot tcg_env
1472
1473 add_boot_deps :: [(LTyClDecl Name, FreeVars)] -> [(LTyClDecl Name, FreeVars)]
1474 add_boot_deps ds_w_fvs
1475 = case boot_info of
1476 SelfBoot { sb_tcs = tcs } | not (isEmptyNameSet tcs)
1477 -> map (add_one tcs) ds_w_fvs
1478 _ -> ds_w_fvs
1479
1480 add_one :: NameSet -> (LTyClDecl Name, FreeVars) -> (LTyClDecl Name, FreeVars)
1481 add_one tcs pr@(decl,fvs)
1482 | has_local_imports fvs = (decl, fvs `plusFV` tcs)
1483 | otherwise = pr
1484
1485 has_local_imports fvs
1486 = nameSetAny (nameIsHomePackageImport this_mod) fvs
1487 ; return (add_boot_deps ds_w_fvs) }
1488
1489
1490
1491 {- ******************************************************
1492 * *
1493 Role annotations
1494 * *
1495 ****************************************************** -}
1496
1497 -- | Renames role annotations, returning them as the values in a NameEnv
1498 -- and checks for duplicate role annotations.
1499 -- It is quite convenient to do both of these in the same place.
1500 -- See also Note [Role annotations in the renamer]
1501 rnRoleAnnots :: NameSet
1502 -> [LRoleAnnotDecl RdrName]
1503 -> RnM [LRoleAnnotDecl Name]
1504 rnRoleAnnots tc_names role_annots
1505 = do { -- Check for duplicates *before* renaming, to avoid
1506 -- lumping together all the unboundNames
1507 let (no_dups, dup_annots) = removeDups role_annots_cmp role_annots
1508 role_annots_cmp (L _ annot1) (L _ annot2)
1509 = roleAnnotDeclName annot1 `compare` roleAnnotDeclName annot2
1510 ; mapM_ dupRoleAnnotErr dup_annots
1511 ; mapM (wrapLocM rn_role_annot1) no_dups }
1512 where
1513 rn_role_annot1 (RoleAnnotDecl tycon roles)
1514 = do { -- the name is an *occurrence*, but look it up only in the
1515 -- decls defined in this group (see #10263)
1516 tycon' <- lookupSigCtxtOccRn (RoleAnnotCtxt tc_names)
1517 (text "role annotation")
1518 tycon
1519 ; return $ RoleAnnotDecl tycon' roles }
1520
1521 dupRoleAnnotErr :: [LRoleAnnotDecl RdrName] -> RnM ()
1522 dupRoleAnnotErr [] = panic "dupRoleAnnotErr"
1523 dupRoleAnnotErr list
1524 = addErrAt loc $
1525 hang (text "Duplicate role annotations for" <+>
1526 quotes (ppr $ roleAnnotDeclName first_decl) <> colon)
1527 2 (vcat $ map pp_role_annot sorted_list)
1528 where
1529 sorted_list = sortBy cmp_annot list
1530 (L loc first_decl : _) = sorted_list
1531
1532 pp_role_annot (L loc decl) = hang (ppr decl)
1533 4 (text "-- written at" <+> ppr loc)
1534
1535 cmp_annot (L loc1 _) (L loc2 _) = loc1 `compare` loc2
1536
1537 orphanRoleAnnotErr :: LRoleAnnotDecl Name -> RnM ()
1538 orphanRoleAnnotErr (L loc decl)
1539 = addErrAt loc $
1540 hang (text "Role annotation for a type previously declared:")
1541 2 (ppr decl) $$
1542 parens (text "The role annotation must be given where" <+>
1543 quotes (ppr $ roleAnnotDeclName decl) <+>
1544 text "is declared.")
1545
1546
1547 {- Note [Role annotations in the renamer]
1548 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1549 We must ensure that a type's role annotation is put in the same group as the
1550 proper type declaration. This is because role annotations are needed during
1551 type-checking when creating the type's TyCon. So, rnRoleAnnots builds a
1552 NameEnv (LRoleAnnotDecl Name) that maps a name to a role annotation for that
1553 type, if any. Then, this map can be used to add the role annotations to the
1554 groups after dependency analysis.
1555
1556 This process checks for duplicate role annotations, where we must be careful
1557 to do the check *before* renaming to avoid calling all unbound names duplicates
1558 of one another.
1559
1560 The renaming process, as usual, might identify and report errors for unbound
1561 names. We exclude the annotations for unbound names in the annotation
1562 environment to avoid spurious errors for orphaned annotations.
1563
1564 We then (in rnTyClDecls) do a check for orphan role annotations (role
1565 annotations without an accompanying type decl). The check works by folding
1566 over components (of type [[Either (TyClDecl Name) (InstDecl Name)]]), selecting
1567 out the relevant role declarations for each group, as well as diminishing the
1568 annotation environment. After the fold is complete, anything left over in the
1569 name environment must be an orphan, and errors are generated.
1570
1571 An earlier version of this algorithm short-cut the orphan check by renaming
1572 only with names declared in this module. But, this check is insufficient in
1573 the case of staged module compilation (Template Haskell, GHCi).
1574 See #8485. With the new lookup process (which includes types declared in other
1575 modules), we get better error messages, too.
1576 -}
1577
1578
1579 {- ******************************************************
1580 * *
1581 Dependency info for instances
1582 * *
1583 ****************************************************** -}
1584
1585 ----------------------------------------------------------
1586 -- | 'InstDeclFreeVarsMap is an association of an
1587 -- @InstDecl@ with @FreeVars@. The @FreeVars@ are
1588 -- the tycon names that are both
1589 -- a) free in the instance declaration
1590 -- b) bound by this group of type/class/instance decls
1591 type InstDeclFreeVarsMap = [(LInstDecl Name, FreeVars)]
1592
1593 -- | Construct an @InstDeclFreeVarsMap@ by eliminating any @Name@s from the
1594 -- @FreeVars@ which are *not* the binders of a @TyClDecl@.
1595 mkInstDeclFreeVarsMap :: GlobalRdrEnv
1596 -> NameSet
1597 -> [(LInstDecl Name, FreeVars)]
1598 -> InstDeclFreeVarsMap
1599 mkInstDeclFreeVarsMap rdr_env tycl_bndrs inst_ds_fvs
1600 = [ (inst_decl, toParents rdr_env fvs `intersectFVs` tycl_bndrs)
1601 | (inst_decl, fvs) <- inst_ds_fvs ]
1602
1603 -- | Get the @LInstDecl@s which have empty @FreeVars@ sets, and the
1604 -- @InstDeclFreeVarsMap@ with these entries removed.
1605 -- We call (getInsts tcs instd_map) when we've completed the declarations
1606 -- for 'tcs'. The call returns (inst_decls, instd_map'), where
1607 -- inst_decls are the instance declarations all of
1608 -- whose free vars are now defined
1609 -- instd_map' is the inst-decl map with 'tcs' removed from
1610 -- the free-var set
1611 getInsts :: [Name] -> InstDeclFreeVarsMap -> ([LInstDecl Name], InstDeclFreeVarsMap)
1612 getInsts bndrs inst_decl_map
1613 = partitionWith pick_me inst_decl_map
1614 where
1615 pick_me :: (LInstDecl Name, FreeVars)
1616 -> Either (LInstDecl Name) (LInstDecl Name, FreeVars)
1617 pick_me (decl, fvs)
1618 | isEmptyNameSet depleted_fvs = Left decl
1619 | otherwise = Right (decl, depleted_fvs)
1620 where
1621 depleted_fvs = delFVs bndrs fvs
1622
1623 {- ******************************************************
1624 * *
1625 Renaming a type or class declaration
1626 * *
1627 ****************************************************** -}
1628
1629 rnTyClDecl :: TyClDecl RdrName
1630 -> RnM (TyClDecl Name, FreeVars)
1631
1632 -- All flavours of type family declarations ("type family", "newtype family",
1633 -- and "data family"), both top level and (for an associated type)
1634 -- in a class decl
1635 rnTyClDecl (FamDecl { tcdFam = decl })
1636 = do { (decl', fvs) <- rnFamDecl Nothing decl
1637 ; return (FamDecl decl', fvs) }
1638
1639 rnTyClDecl (SynDecl { tcdLName = tycon, tcdTyVars = tyvars,
1640 tcdFixity = fixity, tcdRhs = rhs })
1641 = do { tycon' <- lookupLocatedTopBndrRn tycon
1642 ; kvs <- freeKiTyVarsKindVars <$> extractHsTyRdrTyVars rhs
1643 ; let doc = TySynCtx tycon
1644 ; traceRn "rntycl-ty" (ppr tycon <+> ppr kvs)
1645 ; ((tyvars', rhs'), fvs) <- bindHsQTyVars doc Nothing Nothing kvs tyvars $
1646 \ tyvars' _ ->
1647 do { (rhs', fvs) <- rnTySyn doc rhs
1648 ; return ((tyvars', rhs'), fvs) }
1649 ; return (SynDecl { tcdLName = tycon', tcdTyVars = tyvars'
1650 , tcdFixity = fixity
1651 , tcdRhs = rhs', tcdFVs = fvs }, fvs) }
1652
1653 -- "data", "newtype" declarations
1654 -- both top level and (for an associated type) in an instance decl
1655 rnTyClDecl (DataDecl { tcdLName = tycon, tcdTyVars = tyvars,
1656 tcdFixity = fixity, tcdDataDefn = defn })
1657 = do { tycon' <- lookupLocatedTopBndrRn tycon
1658 ; kvs <- extractDataDefnKindVars defn
1659 ; let doc = TyDataCtx tycon
1660 ; traceRn "rntycl-data" (ppr tycon <+> ppr kvs)
1661 ; ((tyvars', defn', no_kvs), fvs)
1662 <- bindHsQTyVars doc Nothing Nothing kvs tyvars $ \ tyvars' dep_vars ->
1663 do { ((defn', kind_sig_fvs), fvs) <- rnDataDefn doc defn
1664 ; let sig_tvs = filterNameSet isTyVarName kind_sig_fvs
1665 unbound_sig_tvs = sig_tvs `minusNameSet` dep_vars
1666 ; return ((tyvars', defn', isEmptyNameSet unbound_sig_tvs), fvs) }
1667 -- See Note [Complete user-supplied kind signatures] in HsDecls
1668 ; typeintype <- xoptM LangExt.TypeInType
1669 ; let cusk = hsTvbAllKinded tyvars' &&
1670 (not typeintype || no_kvs)
1671 ; return (DataDecl { tcdLName = tycon', tcdTyVars = tyvars'
1672 , tcdFixity = fixity
1673 , tcdDataDefn = defn', tcdDataCusk = cusk
1674 , tcdFVs = fvs }, fvs) }
1675
1676 rnTyClDecl (ClassDecl { tcdCtxt = context, tcdLName = lcls,
1677 tcdTyVars = tyvars, tcdFixity = fixity,
1678 tcdFDs = fds, tcdSigs = sigs,
1679 tcdMeths = mbinds, tcdATs = ats, tcdATDefs = at_defs,
1680 tcdDocs = docs})
1681 = do { lcls' <- lookupLocatedTopBndrRn lcls
1682 ; let cls' = unLoc lcls'
1683 kvs = [] -- No scoped kind vars except those in
1684 -- kind signatures on the tyvars
1685
1686 -- Tyvars scope over superclass context and method signatures
1687 ; ((tyvars', context', fds', ats'), stuff_fvs)
1688 <- bindHsQTyVars cls_doc Nothing Nothing kvs tyvars $ \ tyvars' _ -> do
1689 -- Checks for distinct tyvars
1690 { (context', cxt_fvs) <- rnContext cls_doc context
1691 ; fds' <- rnFds fds
1692 -- The fundeps have no free variables
1693 ; (ats', fv_ats) <- rnATDecls cls' ats
1694 ; let fvs = cxt_fvs `plusFV`
1695 fv_ats
1696 ; return ((tyvars', context', fds', ats'), fvs) }
1697
1698 ; (at_defs', fv_at_defs) <- rnList (rnTyFamDefltEqn cls') at_defs
1699
1700 -- No need to check for duplicate associated type decls
1701 -- since that is done by RnNames.extendGlobalRdrEnvRn
1702
1703 -- Check the signatures
1704 -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).
1705 ; let sig_rdr_names_w_locs = [op | L _ (ClassOpSig False ops _) <- sigs
1706 , op <- ops]
1707 ; checkDupRdrNames sig_rdr_names_w_locs
1708 -- Typechecker is responsible for checking that we only
1709 -- give default-method bindings for things in this class.
1710 -- The renamer *could* check this for class decls, but can't
1711 -- for instance decls.
1712
1713 -- The newLocals call is tiresome: given a generic class decl
1714 -- class C a where
1715 -- op :: a -> a
1716 -- op {| x+y |} (Inl a) = ...
1717 -- op {| x+y |} (Inr b) = ...
1718 -- op {| a*b |} (a*b) = ...
1719 -- we want to name both "x" tyvars with the same unique, so that they are
1720 -- easy to group together in the typechecker.
1721 ; (mbinds', sigs', meth_fvs)
1722 <- rnMethodBinds True cls' (hsAllLTyVarNames tyvars') mbinds sigs
1723 -- No need to check for duplicate method signatures
1724 -- since that is done by RnNames.extendGlobalRdrEnvRn
1725 -- and the methods are already in scope
1726
1727 -- Haddock docs
1728 ; docs' <- mapM (wrapLocM rnDocDecl) docs
1729
1730 ; let all_fvs = meth_fvs `plusFV` stuff_fvs `plusFV` fv_at_defs
1731 ; return (ClassDecl { tcdCtxt = context', tcdLName = lcls',
1732 tcdTyVars = tyvars', tcdFixity = fixity,
1733 tcdFDs = fds', tcdSigs = sigs',
1734 tcdMeths = mbinds', tcdATs = ats', tcdATDefs = at_defs',
1735 tcdDocs = docs', tcdFVs = all_fvs },
1736 all_fvs ) }
1737 where
1738 cls_doc = ClassDeclCtx lcls
1739
1740 -- "type" and "type instance" declarations
1741 rnTySyn :: HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
1742 rnTySyn doc rhs = rnLHsType doc rhs
1743
1744 rnDataDefn :: HsDocContext -> HsDataDefn RdrName
1745 -> RnM ((HsDataDefn Name, NameSet), FreeVars)
1746 -- the NameSet includes all Names free in the kind signature
1747 -- See Note [Complete user-supplied kind signatures]
1748 rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType
1749 , dd_ctxt = context, dd_cons = condecls
1750 , dd_kindSig = m_sig, dd_derivs = derivs })
1751 = do { checkTc (h98_style || null (unLoc context))
1752 (badGadtStupidTheta doc)
1753
1754 ; (m_sig', sig_fvs) <- case m_sig of
1755 Just sig -> first Just <$> rnLHsKind doc sig
1756 Nothing -> return (Nothing, emptyFVs)
1757 ; (context', fvs1) <- rnContext doc context
1758 ; (derivs', fvs3) <- rn_derivs derivs
1759
1760 -- For the constructor declarations, drop the LocalRdrEnv
1761 -- in the GADT case, where the type variables in the declaration
1762 -- do not scope over the constructor signatures
1763 -- data T a where { T1 :: forall b. b-> b }
1764 ; let { zap_lcl_env | h98_style = \ thing -> thing
1765 | otherwise = setLocalRdrEnv emptyLocalRdrEnv }
1766 ; (condecls', con_fvs) <- zap_lcl_env $ rnConDecls condecls
1767 -- No need to check for duplicate constructor decls
1768 -- since that is done by RnNames.extendGlobalRdrEnvRn
1769
1770 ; let all_fvs = fvs1 `plusFV` fvs3 `plusFV`
1771 con_fvs `plusFV` sig_fvs
1772 ; return (( HsDataDefn { dd_ND = new_or_data, dd_cType = cType
1773 , dd_ctxt = context', dd_kindSig = m_sig'
1774 , dd_cons = condecls'
1775 , dd_derivs = derivs' }
1776 , sig_fvs )
1777 , all_fvs )
1778 }
1779 where
1780 h98_style = case condecls of -- Note [Stupid theta]
1781 L _ (ConDeclGADT {}) : _ -> False
1782 _ -> True
1783
1784 rn_derivs (L loc ds)
1785 = do { deriv_strats_ok <- xoptM LangExt.DerivingStrategies
1786 ; failIfTc (lengthExceeds ds 1 && not deriv_strats_ok)
1787 multipleDerivClausesErr
1788 ; (ds', fvs) <- mapFvRn (rnLHsDerivingClause deriv_strats_ok doc) ds
1789 ; return (L loc ds', fvs) }
1790
1791 rnLHsDerivingClause :: Bool -> HsDocContext -> LHsDerivingClause RdrName
1792 -> RnM (LHsDerivingClause Name, FreeVars)
1793 rnLHsDerivingClause deriv_strats_ok doc
1794 (L loc (HsDerivingClause { deriv_clause_strategy = dcs
1795 , deriv_clause_tys = L loc' dct }))
1796 = do { failIfTc (isJust dcs && not deriv_strats_ok) $
1797 illegalDerivStrategyErr $ fmap unLoc dcs
1798 ; (dct', fvs) <- mapFvRn (rnHsSigType doc) dct
1799 ; return ( L loc (HsDerivingClause { deriv_clause_strategy = dcs
1800 , deriv_clause_tys = L loc' dct' })
1801 , fvs ) }
1802
1803 badGadtStupidTheta :: HsDocContext -> SDoc
1804 badGadtStupidTheta _
1805 = vcat [text "No context is allowed on a GADT-style data declaration",
1806 text "(You can put a context on each constructor, though.)"]
1807
1808 illegalDerivStrategyErr :: Maybe DerivStrategy -> SDoc
1809 illegalDerivStrategyErr ds
1810 = vcat [ text "Illegal deriving strategy" <> colon <+> maybe empty ppr ds
1811 , text "Use DerivingStrategies to enable this extension" ]
1812
1813 multipleDerivClausesErr :: SDoc
1814 multipleDerivClausesErr
1815 = vcat [ text "Illegal use of multiple, consecutive deriving clauses"
1816 , text "Use DerivingStrategies to allow this" ]
1817
1818 rnFamDecl :: Maybe Name -- Just cls => this FamilyDecl is nested
1819 -- inside an *class decl* for cls
1820 -- used for associated types
1821 -> FamilyDecl RdrName
1822 -> RnM (FamilyDecl Name, FreeVars)
1823 rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars
1824 , fdFixity = fixity
1825 , fdInfo = info, fdResultSig = res_sig
1826 , fdInjectivityAnn = injectivity })
1827 = do { tycon' <- lookupLocatedTopBndrRn tycon
1828 ; kvs <- extractRdrKindSigVars res_sig
1829 ; ((tyvars', res_sig', injectivity'), fv1) <-
1830 bindHsQTyVars doc Nothing mb_cls kvs tyvars $
1831 \ tyvars'@(HsQTvs { hsq_implicit = rn_kvs }) _ ->
1832 do { let rn_sig = rnFamResultSig doc rn_kvs
1833 ; (res_sig', fv_kind) <- wrapLocFstM rn_sig res_sig
1834 ; injectivity' <- traverse (rnInjectivityAnn tyvars' res_sig')
1835 injectivity
1836 ; return ( (tyvars', res_sig', injectivity') , fv_kind ) }
1837 ; (info', fv2) <- rn_info info
1838 ; return (FamilyDecl { fdLName = tycon', fdTyVars = tyvars'
1839 , fdFixity = fixity
1840 , fdInfo = info', fdResultSig = res_sig'
1841 , fdInjectivityAnn = injectivity' }
1842 , fv1 `plusFV` fv2) }
1843 where
1844 doc = TyFamilyCtx tycon
1845
1846 ----------------------
1847 rn_info (ClosedTypeFamily (Just eqns))
1848 = do { (eqns', fvs) <- rnList (rnTyFamInstEqn Nothing) eqns
1849 -- no class context,
1850 ; return (ClosedTypeFamily (Just eqns'), fvs) }
1851 rn_info (ClosedTypeFamily Nothing)
1852 = return (ClosedTypeFamily Nothing, emptyFVs)
1853 rn_info OpenTypeFamily = return (OpenTypeFamily, emptyFVs)
1854 rn_info DataFamily = return (DataFamily, emptyFVs)
1855
1856 rnFamResultSig :: HsDocContext
1857 -> [Name] -- kind variables already in scope
1858 -> FamilyResultSig RdrName
1859 -> RnM (FamilyResultSig Name, FreeVars)
1860 rnFamResultSig _ _ NoSig
1861 = return (NoSig, emptyFVs)
1862 rnFamResultSig doc _ (KindSig kind)
1863 = do { (rndKind, ftvs) <- rnLHsKind doc kind
1864 ; return (KindSig rndKind, ftvs) }
1865 rnFamResultSig doc kv_names (TyVarSig tvbndr)
1866 = do { -- `TyVarSig` tells us that user named the result of a type family by
1867 -- writing `= tyvar` or `= (tyvar :: kind)`. In such case we want to
1868 -- be sure that the supplied result name is not identical to an
1869 -- already in-scope type variable from an enclosing class.
1870 --
1871 -- Example of disallowed declaration:
1872 -- class C a b where
1873 -- type F b = a | a -> b
1874 rdr_env <- getLocalRdrEnv
1875 ; let resName = hsLTyVarName tvbndr
1876 ; when (resName `elemLocalRdrEnv` rdr_env) $
1877 addErrAt (getLoc tvbndr) $
1878 (hsep [ text "Type variable", quotes (ppr resName) <> comma
1879 , text "naming a type family result,"
1880 ] $$
1881 text "shadows an already bound type variable")
1882
1883 ; bindLHsTyVarBndr doc Nothing -- this might be a lie, but it's used for
1884 -- scoping checks that are irrelevant here
1885 (mkNameSet kv_names) emptyNameSet
1886 -- use of emptyNameSet here avoids
1887 -- redundant duplicate errors
1888 tvbndr $ \ _ _ tvbndr' ->
1889 return (TyVarSig tvbndr', unitFV (hsLTyVarName tvbndr')) }
1890
1891 -- Note [Renaming injectivity annotation]
1892 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1893 --
1894 -- During renaming of injectivity annotation we have to make several checks to
1895 -- make sure that it is well-formed. At the moment injectivity annotation
1896 -- consists of a single injectivity condition, so the terms "injectivity
1897 -- annotation" and "injectivity condition" might be used interchangeably. See
1898 -- Note [Injectivity annotation] for a detailed discussion of currently allowed
1899 -- injectivity annotations.
1900 --
1901 -- Checking LHS is simple because the only type variable allowed on the LHS of
1902 -- injectivity condition is the variable naming the result in type family head.
1903 -- Example of disallowed annotation:
1904 --
1905 -- type family Foo a b = r | b -> a
1906 --
1907 -- Verifying RHS of injectivity consists of checking that:
1908 --
1909 -- 1. only variables defined in type family head appear on the RHS (kind
1910 -- variables are also allowed). Example of disallowed annotation:
1911 --
1912 -- type family Foo a = r | r -> b
1913 --
1914 -- 2. for associated types the result variable does not shadow any of type
1915 -- class variables. Example of disallowed annotation:
1916 --
1917 -- class Foo a b where
1918 -- type F a = b | b -> a
1919 --
1920 -- Breaking any of these assumptions results in an error.
1921
1922 -- | Rename injectivity annotation. Note that injectivity annotation is just the
1923 -- part after the "|". Everything that appears before it is renamed in
1924 -- rnFamDecl.
1925 rnInjectivityAnn :: LHsQTyVars Name -- ^ Type variables declared in
1926 -- type family head
1927 -> LFamilyResultSig Name -- ^ Result signature
1928 -> LInjectivityAnn RdrName -- ^ Injectivity annotation
1929 -> RnM (LInjectivityAnn Name)
1930 rnInjectivityAnn tvBndrs (L _ (TyVarSig resTv))
1931 (L srcSpan (InjectivityAnn injFrom injTo))
1932 = do
1933 { (injDecl'@(L _ (InjectivityAnn injFrom' injTo')), noRnErrors)
1934 <- askNoErrs $
1935 bindLocalNames [hsLTyVarName resTv] $
1936 -- The return type variable scopes over the injectivity annotation
1937 -- e.g. type family F a = (r::*) | r -> a
1938 do { injFrom' <- rnLTyVar injFrom
1939 ; injTo' <- mapM rnLTyVar injTo
1940 ; return $ L srcSpan (InjectivityAnn injFrom' injTo') }
1941
1942 ; let tvNames = Set.fromList $ hsAllLTyVarNames tvBndrs
1943 resName = hsLTyVarName resTv
1944 -- See Note [Renaming injectivity annotation]
1945 lhsValid = EQ == (stableNameCmp resName (unLoc injFrom'))
1946 rhsValid = Set.fromList (map unLoc injTo') `Set.difference` tvNames
1947
1948 -- if renaming of type variables ended with errors (eg. there were
1949 -- not-in-scope variables) don't check the validity of injectivity
1950 -- annotation. This gives better error messages.
1951 ; when (noRnErrors && not lhsValid) $
1952 addErrAt (getLoc injFrom)
1953 ( vcat [ text $ "Incorrect type variable on the LHS of "
1954 ++ "injectivity condition"
1955 , nest 5
1956 ( vcat [ text "Expected :" <+> ppr resName
1957 , text "Actual :" <+> ppr injFrom ])])
1958
1959 ; when (noRnErrors && not (Set.null rhsValid)) $
1960 do { let errorVars = Set.toList rhsValid
1961 ; addErrAt srcSpan $ ( hsep
1962 [ text "Unknown type variable" <> plural errorVars
1963 , text "on the RHS of injectivity condition:"
1964 , interpp'SP errorVars ] ) }
1965
1966 ; return injDecl' }
1967
1968 -- We can only hit this case when the user writes injectivity annotation without
1969 -- naming the result:
1970 --
1971 -- type family F a | result -> a
1972 -- type family F a :: * | result -> a
1973 --
1974 -- So we rename injectivity annotation like we normally would except that
1975 -- this time we expect "result" to be reported not in scope by rnLTyVar.
1976 rnInjectivityAnn _ _ (L srcSpan (InjectivityAnn injFrom injTo)) =
1977 setSrcSpan srcSpan $ do
1978 (injDecl', _) <- askNoErrs $ do
1979 injFrom' <- rnLTyVar injFrom
1980 injTo' <- mapM rnLTyVar injTo
1981 return $ L srcSpan (InjectivityAnn injFrom' injTo')
1982 return $ injDecl'
1983
1984 {-
1985 Note [Stupid theta]
1986 ~~~~~~~~~~~~~~~~~~~
1987 Trac #3850 complains about a regression wrt 6.10 for
1988 data Show a => T a
1989 There is no reason not to allow the stupid theta if there are no data
1990 constructors. It's still stupid, but does no harm, and I don't want
1991 to cause programs to break unnecessarily (notably HList). So if there
1992 are no data constructors we allow h98_style = True
1993 -}
1994
1995
1996 {- *****************************************************
1997 * *
1998 Support code for type/data declarations
1999 * *
2000 ***************************************************** -}
2001
2002 ---------------
2003 badAssocRhs :: [Name] -> RnM ()
2004 badAssocRhs ns
2005 = addErr (hang (text "The RHS of an associated type declaration mentions"
2006 <+> pprWithCommas (quotes . ppr) ns)
2007 2 (text "All such variables must be bound on the LHS"))
2008
2009 -----------------
2010 rnConDecls :: [LConDecl RdrName] -> RnM ([LConDecl Name], FreeVars)
2011 rnConDecls = mapFvRn (wrapLocFstM rnConDecl)
2012
2013 rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name, FreeVars)
2014 rnConDecl decl@(ConDeclH98 { con_name = name, con_qvars = qtvs
2015 , con_cxt = mcxt, con_details = details
2016 , con_doc = mb_doc })
2017 = do { _ <- addLocM checkConName name
2018 ; new_name <- lookupLocatedTopBndrRn name
2019 ; let doc = ConDeclCtx [new_name]
2020 ; mb_doc' <- rnMbLHsDoc mb_doc
2021 ; (kvs, qtvs') <- get_con_qtvs (hsConDeclArgTys details)
2022
2023 ; bindHsQTyVars doc (Just $ inHsDocContext doc) Nothing kvs qtvs' $
2024 \new_tyvars _ -> do
2025 { (new_context, fvs1) <- case mcxt of
2026 Nothing -> return (Nothing,emptyFVs)
2027 Just lcxt -> do { (lctx',fvs) <- rnContext doc lcxt
2028 ; return (Just lctx',fvs) }
2029 ; (new_details, fvs2) <- rnConDeclDetails (unLoc new_name) doc details
2030 ; let (new_details',fvs3) = (new_details,emptyFVs)
2031 ; traceRn "rnConDecl" (ppr name <+> vcat
2032 [ text "free_kvs:" <+> ppr kvs
2033 , text "qtvs:" <+> ppr qtvs
2034 , text "qtvs':" <+> ppr qtvs' ])
2035 ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3
2036 new_tyvars' = case qtvs of
2037 Nothing -> Nothing
2038 Just _ -> Just new_tyvars
2039 ; return (decl { con_name = new_name, con_qvars = new_tyvars'
2040 , con_cxt = new_context, con_details = new_details'
2041 , con_doc = mb_doc' },
2042 all_fvs) }}
2043 where
2044 cxt = maybe [] unLoc mcxt
2045 get_rdr_tvs tys = extractHsTysRdrTyVars (cxt ++ tys)
2046
2047 get_con_qtvs :: [LHsType RdrName]
2048 -> RnM ([Located RdrName], LHsQTyVars RdrName)
2049 get_con_qtvs arg_tys
2050 | Just tvs <- qtvs -- data T = forall a. MkT (a -> a)
2051 = do { free_vars <- get_rdr_tvs arg_tys
2052 ; return (freeKiTyVarsKindVars free_vars, tvs) }
2053 | otherwise -- data T = MkT (a -> a)
2054 = return ([], mkHsQTvs [])
2055
2056 rnConDecl decl@(ConDeclGADT { con_names = names, con_type = ty
2057 , con_doc = mb_doc })
2058 = do { mapM_ (addLocM checkConName) names
2059 ; new_names <- mapM lookupLocatedTopBndrRn names
2060 ; let doc = ConDeclCtx new_names
2061 ; mb_doc' <- rnMbLHsDoc mb_doc
2062
2063 ; (ty', fvs) <- rnHsSigType doc ty
2064 ; traceRn "rnConDecl" (ppr names <+> vcat
2065 [ text "fvs:" <+> ppr fvs ])
2066 ; return (decl { con_names = new_names, con_type = ty'
2067 , con_doc = mb_doc' },
2068 fvs) }
2069
2070 rnConDeclDetails
2071 :: Name
2072 -> HsDocContext
2073 -> HsConDetails (LHsType RdrName) (Located [LConDeclField RdrName])
2074 -> RnM (HsConDetails (LHsType Name) (Located [LConDeclField Name]), FreeVars)
2075 rnConDeclDetails _ doc (PrefixCon tys)
2076 = do { (new_tys, fvs) <- rnLHsTypes doc tys
2077 ; return (PrefixCon new_tys, fvs) }
2078
2079 rnConDeclDetails _ doc (InfixCon ty1 ty2)
2080 = do { (new_ty1, fvs1) <- rnLHsType doc ty1
2081 ; (new_ty2, fvs2) <- rnLHsType doc ty2
2082 ; return (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2) }
2083
2084 rnConDeclDetails con doc (RecCon (L l fields))
2085 = do { fls <- lookupConstructorFields con
2086 ; (new_fields, fvs) <- rnConDeclFields doc fls fields
2087 -- No need to check for duplicate fields
2088 -- since that is done by RnNames.extendGlobalRdrEnvRn
2089 ; return (RecCon (L l new_fields), fvs) }
2090
2091 -------------------------------------------------
2092
2093 -- | Brings pattern synonym names and also pattern synonym selectors
2094 -- from record pattern synonyms into scope.
2095 extendPatSynEnv :: HsValBinds RdrName -> MiniFixityEnv
2096 -> ([Name] -> TcRnIf TcGblEnv TcLclEnv a) -> TcM a
2097 extendPatSynEnv val_decls local_fix_env thing = do {
2098 names_with_fls <- new_ps val_decls
2099 ; let pat_syn_bndrs = concat [ name: map flSelector fields
2100 | (name, fields) <- names_with_fls ]
2101 ; let avails = map avail pat_syn_bndrs
2102 ; (gbl_env, lcl_env) <- extendGlobalRdrEnvRn avails local_fix_env
2103
2104 ; let field_env' = extendNameEnvList (tcg_field_env gbl_env) names_with_fls
2105 final_gbl_env = gbl_env { tcg_field_env = field_env' }
2106 ; setEnvs (final_gbl_env, lcl_env) (thing pat_syn_bndrs) }
2107 where
2108 new_ps :: HsValBinds RdrName -> TcM [(Name, [FieldLabel])]
2109 new_ps (ValBindsIn binds _) = foldrBagM new_ps' [] binds
2110 new_ps _ = panic "new_ps"
2111
2112 new_ps' :: LHsBindLR RdrName RdrName
2113 -> [(Name, [FieldLabel])]
2114 -> TcM [(Name, [FieldLabel])]
2115 new_ps' bind names
2116 | L bind_loc (PatSynBind (PSB { psb_id = L _ n
2117 , psb_args = RecordPatSyn as })) <- bind
2118 = do
2119 bnd_name <- newTopSrcBinder (L bind_loc n)
2120 let rnames = map recordPatSynSelectorId as
2121 mkFieldOcc :: Located RdrName -> LFieldOcc RdrName
2122 mkFieldOcc (L l name) = L l (FieldOcc (L l name) PlaceHolder)
2123 field_occs = map mkFieldOcc rnames
2124 flds <- mapM (newRecordSelector False [bnd_name]) field_occs
2125 return ((bnd_name, flds): names)
2126 | L bind_loc (PatSynBind (PSB { psb_id = L _ n})) <- bind
2127 = do
2128 bnd_name <- newTopSrcBinder (L bind_loc n)
2129 return ((bnd_name, []): names)
2130 | otherwise
2131 = return names
2132
2133 {-
2134 *********************************************************
2135 * *
2136 \subsection{Support code to rename types}
2137 * *
2138 *********************************************************
2139 -}
2140
2141 rnFds :: [Located (FunDep (Located RdrName))]
2142 -> RnM [Located (FunDep (Located Name))]
2143 rnFds fds
2144 = mapM (wrapLocM rn_fds) fds
2145 where
2146 rn_fds (tys1, tys2)
2147 = do { tys1' <- rnHsTyVars tys1
2148 ; tys2' <- rnHsTyVars tys2
2149 ; return (tys1', tys2') }
2150
2151 rnHsTyVars :: [Located RdrName] -> RnM [Located Name]
2152 rnHsTyVars tvs = mapM rnHsTyVar tvs
2153
2154 rnHsTyVar :: Located RdrName -> RnM (Located Name)
2155 rnHsTyVar (L l tyvar) = do
2156 tyvar' <- lookupOccRn tyvar
2157 return (L l tyvar')
2158
2159 {-
2160 *********************************************************
2161 * *
2162 findSplice
2163 * *
2164 *********************************************************
2165
2166 This code marches down the declarations, looking for the first
2167 Template Haskell splice. As it does so it
2168 a) groups the declarations into a HsGroup
2169 b) runs any top-level quasi-quotes
2170 -}
2171
2172 findSplice :: [LHsDecl RdrName] -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName]))
2173 findSplice ds = addl emptyRdrGroup ds
2174
2175 addl :: HsGroup RdrName -> [LHsDecl RdrName]
2176 -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName]))
2177 -- This stuff reverses the declarations (again) but it doesn't matter
2178 addl gp [] = return (gp, Nothing)
2179 addl gp (L l d : ds) = add gp l d ds
2180
2181
2182 add :: HsGroup RdrName -> SrcSpan -> HsDecl RdrName -> [LHsDecl RdrName]
2183 -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName]))
2184
2185 -- #10047: Declaration QuasiQuoters are expanded immediately, without
2186 -- causing a group split
2187 add gp _ (SpliceD (SpliceDecl (L _ qq@HsQuasiQuote{}) _)) ds
2188 = do { (ds', _) <- rnTopSpliceDecls qq
2189 ; addl gp (ds' ++ ds)
2190 }
2191
2192 add gp loc (SpliceD splice@(SpliceDecl _ flag)) ds
2193 = do { -- We've found a top-level splice. If it is an *implicit* one
2194 -- (i.e. a naked top level expression)
2195 case flag of
2196 ExplicitSplice -> return ()
2197 ImplicitSplice -> do { th_on <- xoptM LangExt.TemplateHaskell
2198 ; unless th_on $ setSrcSpan loc $
2199 failWith badImplicitSplice }
2200
2201 ; return (gp, Just (splice, ds)) }
2202 where
2203 badImplicitSplice = text "Parse error: module header, import declaration"
2204 $$ text "or top-level declaration expected."
2205
2206 -- Class declarations: pull out the fixity signatures to the top
2207 add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD d) ds
2208 | isClassDecl d
2209 = let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in
2210 addl (gp { hs_tyclds = add_tycld (L l d) ts, hs_fixds = fsigs ++ fs}) ds
2211 | otherwise
2212 = addl (gp { hs_tyclds = add_tycld (L l d) ts }) ds
2213
2214 -- Signatures: fixity sigs go a different place than all others
2215 add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds
2216 = addl (gp {hs_fixds = L l f : ts}) ds
2217 add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds
2218 = addl (gp {hs_valds = add_sig (L l d) ts}) ds
2219
2220 -- Value declarations: use add_bind
2221 add gp@(HsGroup {hs_valds = ts}) l (ValD d) ds
2222 = addl (gp { hs_valds = add_bind (L l d) ts }) ds
2223
2224 -- Role annotations: added to the TyClGroup
2225 add gp@(HsGroup {hs_tyclds = ts}) l (RoleAnnotD d) ds
2226 = addl (gp { hs_tyclds = add_role_annot (L l d) ts }) ds
2227
2228 -- NB instance declarations go into TyClGroups. We throw them into the first
2229 -- group, just as we do for the TyClD case. The renamer will go on to group
2230 -- and order them later.
2231 add gp@(HsGroup {hs_tyclds = ts}) l (InstD d) ds
2232 = addl (gp { hs_tyclds = add_instd (L l d) ts }) ds
2233
2234 -- The rest are routine
2235 add gp@(HsGroup {hs_derivds = ts}) l (DerivD d) ds
2236 = addl (gp { hs_derivds = L l d : ts }) ds
2237 add gp@(HsGroup {hs_defds = ts}) l (DefD d) ds
2238 = addl (gp { hs_defds = L l d : ts }) ds
2239 add gp@(HsGroup {hs_fords = ts}) l (ForD d) ds
2240 = addl (gp { hs_fords = L l d : ts }) ds
2241 add gp@(HsGroup {hs_warnds = ts}) l (WarningD d) ds
2242 = addl (gp { hs_warnds = L l d : ts }) ds
2243 add gp@(HsGroup {hs_annds = ts}) l (AnnD d) ds
2244 = addl (gp { hs_annds = L l d : ts }) ds
2245 add gp@(HsGroup {hs_ruleds = ts}) l (RuleD d) ds
2246 = addl (gp { hs_ruleds = L l d : ts }) ds
2247 add gp@(HsGroup {hs_vects = ts}) l (VectD d) ds
2248 = addl (gp { hs_vects = L l d : ts }) ds
2249 add gp l (DocD d) ds
2250 = addl (gp { hs_docs = (L l d) : (hs_docs gp) }) ds
2251
2252 add_tycld :: LTyClDecl a -> [TyClGroup a] -> [TyClGroup a]
2253 add_tycld d [] = [TyClGroup { group_tyclds = [d]
2254 , group_roles = []
2255 , group_instds = []
2256 }
2257 ]
2258 add_tycld d (ds@(TyClGroup { group_tyclds = tyclds }):dss)
2259 = ds { group_tyclds = d : tyclds } : dss
2260
2261 add_instd :: LInstDecl a -> [TyClGroup a] -> [TyClGroup a]
2262 add_instd d [] = [TyClGroup { group_tyclds = []
2263 , group_roles = []
2264 , group_instds = [d]
2265 }
2266 ]
2267 add_instd d (ds@(TyClGroup { group_instds = instds }):dss)
2268 = ds { group_instds = d : instds } : dss
2269
2270 add_role_annot :: LRoleAnnotDecl a -> [TyClGroup a] -> [TyClGroup a]
2271 add_role_annot d [] = [TyClGroup { group_tyclds = []
2272 , group_roles = [d]
2273 , group_instds = []
2274 }
2275 ]
2276 add_role_annot d (tycls@(TyClGroup { group_roles = roles }) : rest)
2277 = tycls { group_roles = d : roles } : rest
2278
2279 add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a
2280 add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs
2281 add_bind _ (ValBindsOut {}) = panic "RdrHsSyn:add_bind"
2282
2283 add_sig :: LSig a -> HsValBinds a -> HsValBinds a
2284 add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs)
2285 add_sig _ (ValBindsOut {}) = panic "RdrHsSyn:add_sig"