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