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