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