a53adf2cba7fc38ca6851fc9bd45f7cdfd0992e7
[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 ; typeintype <- xoptM LangExt.TypeInType
1513 ; let cusk = hsTvbAllKinded tyvars' &&
1514 (not typeintype || no_rhs_kvs)
1515 rn_info = DataDeclRn { tcdDataCusk = cusk
1516 , tcdFVs = fvs }
1517 ; traceRn "rndata" (ppr tycon <+> ppr cusk <+> ppr no_rhs_kvs)
1518 ; return (DataDecl { tcdLName = tycon'
1519 , tcdTyVars = tyvars'
1520 , tcdFixity = fixity
1521 , tcdDataDefn = defn'
1522 , tcdDExt = rn_info }, fvs) } }
1523
1524 rnTyClDecl (ClassDecl { tcdCtxt = context, tcdLName = lcls,
1525 tcdTyVars = tyvars, tcdFixity = fixity,
1526 tcdFDs = fds, tcdSigs = sigs,
1527 tcdMeths = mbinds, tcdATs = ats, tcdATDefs = at_defs,
1528 tcdDocs = docs})
1529 = do { lcls' <- lookupLocatedTopBndrRn lcls
1530 ; let cls' = unLoc lcls'
1531 kvs = [] -- No scoped kind vars except those in
1532 -- kind signatures on the tyvars
1533
1534 -- Tyvars scope over superclass context and method signatures
1535 ; ((tyvars', context', fds', ats'), stuff_fvs)
1536 <- bindHsQTyVars cls_doc Nothing Nothing kvs tyvars $ \ tyvars' _ -> do
1537 -- Checks for distinct tyvars
1538 { (context', cxt_fvs) <- rnContext cls_doc context
1539 ; fds' <- rnFds fds
1540 -- The fundeps have no free variables
1541 ; (ats', fv_ats) <- rnATDecls cls' ats
1542 ; let fvs = cxt_fvs `plusFV`
1543 fv_ats
1544 ; return ((tyvars', context', fds', ats'), fvs) }
1545
1546 ; (at_defs', fv_at_defs) <- rnList (rnTyFamDefltEqn cls') at_defs
1547
1548 -- No need to check for duplicate associated type decls
1549 -- since that is done by RnNames.extendGlobalRdrEnvRn
1550
1551 -- Check the signatures
1552 -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).
1553 ; let sig_rdr_names_w_locs = [op |L _ (ClassOpSig _ False ops _) <- sigs
1554 , op <- ops]
1555 ; checkDupRdrNames sig_rdr_names_w_locs
1556 -- Typechecker is responsible for checking that we only
1557 -- give default-method bindings for things in this class.
1558 -- The renamer *could* check this for class decls, but can't
1559 -- for instance decls.
1560
1561 -- The newLocals call is tiresome: given a generic class decl
1562 -- class C a where
1563 -- op :: a -> a
1564 -- op {| x+y |} (Inl a) = ...
1565 -- op {| x+y |} (Inr b) = ...
1566 -- op {| a*b |} (a*b) = ...
1567 -- we want to name both "x" tyvars with the same unique, so that they are
1568 -- easy to group together in the typechecker.
1569 ; (mbinds', sigs', meth_fvs)
1570 <- rnMethodBinds True cls' (hsAllLTyVarNames tyvars') mbinds sigs
1571 -- No need to check for duplicate method signatures
1572 -- since that is done by RnNames.extendGlobalRdrEnvRn
1573 -- and the methods are already in scope
1574
1575 -- Haddock docs
1576 ; docs' <- mapM (wrapLocM rnDocDecl) docs
1577
1578 ; let all_fvs = meth_fvs `plusFV` stuff_fvs `plusFV` fv_at_defs
1579 ; return (ClassDecl { tcdCtxt = context', tcdLName = lcls',
1580 tcdTyVars = tyvars', tcdFixity = fixity,
1581 tcdFDs = fds', tcdSigs = sigs',
1582 tcdMeths = mbinds', tcdATs = ats', tcdATDefs = at_defs',
1583 tcdDocs = docs', tcdCExt = all_fvs },
1584 all_fvs ) }
1585 where
1586 cls_doc = ClassDeclCtx lcls
1587
1588 rnTyClDecl (XTyClDecl _) = panic "rnTyClDecl"
1589
1590 -- "type" and "type instance" declarations
1591 rnTySyn :: HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
1592 rnTySyn doc rhs = rnLHsType doc rhs
1593
1594 rnDataDefn :: HsDocContext -> HsDataDefn GhcPs
1595 -> RnM (HsDataDefn GhcRn, FreeVars)
1596 rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType
1597 , dd_ctxt = context, dd_cons = condecls
1598 , dd_kindSig = m_sig, dd_derivs = derivs })
1599 = do { checkTc (h98_style || null (unLoc context))
1600 (badGadtStupidTheta doc)
1601
1602 ; (m_sig', sig_fvs) <- case m_sig of
1603 Just sig -> first Just <$> rnLHsKind doc sig
1604 Nothing -> return (Nothing, emptyFVs)
1605 ; (context', fvs1) <- rnContext doc context
1606 ; (derivs', fvs3) <- rn_derivs derivs
1607
1608 -- For the constructor declarations, drop the LocalRdrEnv
1609 -- in the GADT case, where the type variables in the declaration
1610 -- do not scope over the constructor signatures
1611 -- data T a where { T1 :: forall b. b-> b }
1612 ; let { zap_lcl_env | h98_style = \ thing -> thing
1613 | otherwise = setLocalRdrEnv emptyLocalRdrEnv }
1614 ; (condecls', con_fvs) <- zap_lcl_env $ rnConDecls condecls
1615 -- No need to check for duplicate constructor decls
1616 -- since that is done by RnNames.extendGlobalRdrEnvRn
1617
1618 ; let all_fvs = fvs1 `plusFV` fvs3 `plusFV`
1619 con_fvs `plusFV` sig_fvs
1620 ; return ( HsDataDefn { dd_ext = noExt
1621 , dd_ND = new_or_data, dd_cType = cType
1622 , dd_ctxt = context', dd_kindSig = m_sig'
1623 , dd_cons = condecls'
1624 , dd_derivs = derivs' }
1625 , all_fvs )
1626 }
1627 where
1628 h98_style = case condecls of -- Note [Stupid theta]
1629 L _ (ConDeclGADT {}) : _ -> False
1630 _ -> True
1631
1632 rn_derivs (L loc ds)
1633 = do { deriv_strats_ok <- xoptM LangExt.DerivingStrategies
1634 ; failIfTc (lengthExceeds ds 1 && not deriv_strats_ok)
1635 multipleDerivClausesErr
1636 ; (ds', fvs) <- mapFvRn (rnLHsDerivingClause doc) ds
1637 ; return (L loc ds', fvs) }
1638 rnDataDefn _ (XHsDataDefn _) = panic "rnDataDefn"
1639
1640 rnLHsDerivingClause :: HsDocContext -> LHsDerivingClause GhcPs
1641 -> RnM (LHsDerivingClause GhcRn, FreeVars)
1642 rnLHsDerivingClause doc
1643 (L loc (HsDerivingClause { deriv_clause_ext = noExt
1644 , deriv_clause_strategy = dcs
1645 , deriv_clause_tys = L loc' dct }))
1646 = do { (dcs', dct', fvs)
1647 <- rnLDerivStrategy doc dcs $ \strat_tvs ppr_via_ty ->
1648 mapFvRn (rn_deriv_ty strat_tvs ppr_via_ty) dct
1649 ; pure ( L loc (HsDerivingClause { deriv_clause_ext = noExt
1650 , deriv_clause_strategy = dcs'
1651 , deriv_clause_tys = L loc' dct' })
1652 , fvs ) }
1653 where
1654 rn_deriv_ty :: [Name] -> SDoc -> LHsSigType GhcPs
1655 -> RnM (LHsSigType GhcRn, FreeVars)
1656 rn_deriv_ty strat_tvs ppr_via_ty deriv_ty@(HsIB {hsib_body = L loc _}) =
1657 rnAndReportFloatingViaTvs strat_tvs loc ppr_via_ty "class" $
1658 rnHsSigType doc deriv_ty
1659 rn_deriv_ty _ _ (XHsImplicitBndrs _) = panic "rn_deriv_ty"
1660 rnLHsDerivingClause _ (L _ (XHsDerivingClause _))
1661 = panic "rnLHsDerivingClause"
1662
1663 rnLDerivStrategy :: forall a.
1664 HsDocContext
1665 -> Maybe (LDerivStrategy GhcPs)
1666 -> ([Name] -- The tyvars bound by the via type
1667 -> SDoc -- The pretty-printed via type (used for
1668 -- error message reporting)
1669 -> RnM (a, FreeVars))
1670 -> RnM (Maybe (LDerivStrategy GhcRn), a, FreeVars)
1671 rnLDerivStrategy doc mds thing_inside
1672 = case mds of
1673 Nothing -> boring_case Nothing
1674 Just ds -> do (ds', thing, fvs) <- rn_deriv_strat ds
1675 pure (Just ds', thing, fvs)
1676 where
1677 rn_deriv_strat :: LDerivStrategy GhcPs
1678 -> RnM (LDerivStrategy GhcRn, a, FreeVars)
1679 rn_deriv_strat (L loc ds) = do
1680 let extNeeded :: LangExt.Extension
1681 extNeeded
1682 | ViaStrategy{} <- ds
1683 = LangExt.DerivingVia
1684 | otherwise
1685 = LangExt.DerivingStrategies
1686
1687 unlessXOptM extNeeded $
1688 failWith $ illegalDerivStrategyErr ds
1689
1690 case ds of
1691 StockStrategy -> boring_case (L loc StockStrategy)
1692 AnyclassStrategy -> boring_case (L loc AnyclassStrategy)
1693 NewtypeStrategy -> boring_case (L loc NewtypeStrategy)
1694 ViaStrategy via_ty ->
1695 do (via_ty', fvs1) <- rnHsSigType doc via_ty
1696 let HsIB { hsib_ext = HsIBRn { hsib_vars = via_imp_tvs }
1697 , hsib_body = via_body } = via_ty'
1698 (via_exp_tv_bndrs, _, _) = splitLHsSigmaTy via_body
1699 via_exp_tvs = map hsLTyVarName via_exp_tv_bndrs
1700 via_tvs = via_imp_tvs ++ via_exp_tvs
1701 (thing, fvs2) <- extendTyVarEnvFVRn via_tvs $
1702 thing_inside via_tvs (ppr via_ty')
1703 pure (L loc (ViaStrategy via_ty'), thing, fvs1 `plusFV` fvs2)
1704
1705 boring_case :: mds
1706 -> RnM (mds, a, FreeVars)
1707 boring_case mds = do
1708 (thing, fvs) <- thing_inside [] empty
1709 pure (mds, thing, fvs)
1710
1711 -- | Errors if a @via@ type binds any floating type variables.
1712 -- See @Note [Floating `via` type variables]@
1713 rnAndReportFloatingViaTvs
1714 :: forall a. Outputable a
1715 => [Name] -- ^ The bound type variables from a @via@ type.
1716 -> SrcSpan -- ^ The source span (for error reporting only).
1717 -> SDoc -- ^ The pretty-printed @via@ type (for error reporting only).
1718 -> String -- ^ A description of what the @via@ type scopes over
1719 -- (for error reporting only).
1720 -> RnM (a, FreeVars) -- ^ The thing the @via@ type scopes over.
1721 -> RnM (a, FreeVars)
1722 rnAndReportFloatingViaTvs tv_names loc ppr_via_ty via_scope_desc thing_inside
1723 = do (thing, thing_fvs) <- thing_inside
1724 setSrcSpan loc $ mapM_ (report_floating_via_tv thing thing_fvs) tv_names
1725 pure (thing, thing_fvs)
1726 where
1727 report_floating_via_tv :: a -> FreeVars -> Name -> RnM ()
1728 report_floating_via_tv thing used_names tv_name
1729 = unless (tv_name `elemNameSet` used_names) $ addErr $ vcat
1730 [ text "Type variable" <+> quotes (ppr tv_name) <+>
1731 text "is bound in the" <+> quotes (text "via") <+>
1732 text "type" <+> quotes ppr_via_ty
1733 , text "but is not mentioned in the derived" <+>
1734 text via_scope_desc <+> quotes (ppr thing) <>
1735 text ", which is illegal" ]
1736
1737 {-
1738 Note [Floating `via` type variables]
1739 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1740 Imagine the following `deriving via` clause:
1741
1742 data Quux
1743 deriving Eq via (Const a Quux)
1744
1745 This should be rejected. Why? Because it would generate the following instance:
1746
1747 instance Eq Quux where
1748 (==) = coerce @(Quux -> Quux -> Bool)
1749 @(Const a Quux -> Const a Quux -> Bool)
1750 (==)
1751
1752 This instance is ill-formed, as the `a` in `Const a Quux` is unbound. The
1753 problem is that `a` is never used anywhere in the derived class `Eq`. Since
1754 `a` is bound but has no use sites, we refer to it as "floating".
1755
1756 We use the rnAndReportFloatingViaTvs function to check that any type renamed
1757 within the context of the `via` deriving strategy actually uses all bound
1758 `via` type variables, and if it doesn't, it throws an error.
1759 -}
1760
1761 badGadtStupidTheta :: HsDocContext -> SDoc
1762 badGadtStupidTheta _
1763 = vcat [text "No context is allowed on a GADT-style data declaration",
1764 text "(You can put a context on each constructor, though.)"]
1765
1766 illegalDerivStrategyErr :: DerivStrategy GhcPs -> SDoc
1767 illegalDerivStrategyErr ds
1768 = vcat [ text "Illegal deriving strategy" <> colon <+> derivStrategyName ds
1769 , text enableStrategy ]
1770
1771 where
1772 enableStrategy :: String
1773 enableStrategy
1774 | ViaStrategy{} <- ds
1775 = "Use DerivingVia to enable this extension"
1776 | otherwise
1777 = "Use DerivingStrategies to enable this extension"
1778
1779 multipleDerivClausesErr :: SDoc
1780 multipleDerivClausesErr
1781 = vcat [ text "Illegal use of multiple, consecutive deriving clauses"
1782 , text "Use DerivingStrategies to allow this" ]
1783
1784 rnFamDecl :: Maybe Name -- Just cls => this FamilyDecl is nested
1785 -- inside an *class decl* for cls
1786 -- used for associated types
1787 -> FamilyDecl GhcPs
1788 -> RnM (FamilyDecl GhcRn, FreeVars)
1789 rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars
1790 , fdFixity = fixity
1791 , fdInfo = info, fdResultSig = res_sig
1792 , fdInjectivityAnn = injectivity })
1793 = do { tycon' <- lookupLocatedTopBndrRn tycon
1794 ; kvs <- extractRdrKindSigVars res_sig
1795 ; ((tyvars', res_sig', injectivity'), fv1) <-
1796 bindHsQTyVars doc Nothing mb_cls kvs tyvars $ \ tyvars' _ ->
1797 do { let rn_sig = rnFamResultSig doc
1798 ; (res_sig', fv_kind) <- wrapLocFstM rn_sig res_sig
1799 ; injectivity' <- traverse (rnInjectivityAnn tyvars' res_sig')
1800 injectivity
1801 ; return ( (tyvars', res_sig', injectivity') , fv_kind ) }
1802 ; (info', fv2) <- rn_info info
1803 ; return (FamilyDecl { fdExt = noExt
1804 , fdLName = tycon', fdTyVars = tyvars'
1805 , fdFixity = fixity
1806 , fdInfo = info', fdResultSig = res_sig'
1807 , fdInjectivityAnn = injectivity' }
1808 , fv1 `plusFV` fv2) }
1809 where
1810 doc = TyFamilyCtx tycon
1811
1812 ----------------------
1813 rn_info (ClosedTypeFamily (Just eqns))
1814 = do { (eqns', fvs) <- rnList (rnTyFamInstEqn Nothing) eqns
1815 -- no class context,
1816 ; return (ClosedTypeFamily (Just eqns'), fvs) }
1817 rn_info (ClosedTypeFamily Nothing)
1818 = return (ClosedTypeFamily Nothing, emptyFVs)
1819 rn_info OpenTypeFamily = return (OpenTypeFamily, emptyFVs)
1820 rn_info DataFamily = return (DataFamily, emptyFVs)
1821 rnFamDecl _ (XFamilyDecl _) = panic "rnFamDecl"
1822
1823 rnFamResultSig :: HsDocContext
1824 -> FamilyResultSig GhcPs
1825 -> RnM (FamilyResultSig GhcRn, FreeVars)
1826 rnFamResultSig _ (NoSig _)
1827 = return (NoSig noExt, emptyFVs)
1828 rnFamResultSig doc (KindSig _ kind)
1829 = do { (rndKind, ftvs) <- rnLHsKind doc kind
1830 ; return (KindSig noExt rndKind, ftvs) }
1831 rnFamResultSig doc (TyVarSig _ tvbndr)
1832 = do { -- `TyVarSig` tells us that user named the result of a type family by
1833 -- writing `= tyvar` or `= (tyvar :: kind)`. In such case we want to
1834 -- be sure that the supplied result name is not identical to an
1835 -- already in-scope type variable from an enclosing class.
1836 --
1837 -- Example of disallowed declaration:
1838 -- class C a b where
1839 -- type F b = a | a -> b
1840 rdr_env <- getLocalRdrEnv
1841 ; let resName = hsLTyVarName tvbndr
1842 ; when (resName `elemLocalRdrEnv` rdr_env) $
1843 addErrAt (getLoc tvbndr) $
1844 (hsep [ text "Type variable", quotes (ppr resName) <> comma
1845 , text "naming a type family result,"
1846 ] $$
1847 text "shadows an already bound type variable")
1848
1849 ; bindLHsTyVarBndr doc Nothing -- This might be a lie, but it's used for
1850 -- scoping checks that are irrelevant here
1851 tvbndr $ \ tvbndr' ->
1852 return (TyVarSig noExt tvbndr', unitFV (hsLTyVarName tvbndr')) }
1853 rnFamResultSig _ (XFamilyResultSig _) = panic "rnFamResultSig"
1854
1855 -- Note [Renaming injectivity annotation]
1856 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1857 --
1858 -- During renaming of injectivity annotation we have to make several checks to
1859 -- make sure that it is well-formed. At the moment injectivity annotation
1860 -- consists of a single injectivity condition, so the terms "injectivity
1861 -- annotation" and "injectivity condition" might be used interchangeably. See
1862 -- Note [Injectivity annotation] for a detailed discussion of currently allowed
1863 -- injectivity annotations.
1864 --
1865 -- Checking LHS is simple because the only type variable allowed on the LHS of
1866 -- injectivity condition is the variable naming the result in type family head.
1867 -- Example of disallowed annotation:
1868 --
1869 -- type family Foo a b = r | b -> a
1870 --
1871 -- Verifying RHS of injectivity consists of checking that:
1872 --
1873 -- 1. only variables defined in type family head appear on the RHS (kind
1874 -- variables are also allowed). Example of disallowed annotation:
1875 --
1876 -- type family Foo a = r | r -> b
1877 --
1878 -- 2. for associated types the result variable does not shadow any of type
1879 -- class variables. Example of disallowed annotation:
1880 --
1881 -- class Foo a b where
1882 -- type F a = b | b -> a
1883 --
1884 -- Breaking any of these assumptions results in an error.
1885
1886 -- | Rename injectivity annotation. Note that injectivity annotation is just the
1887 -- part after the "|". Everything that appears before it is renamed in
1888 -- rnFamDecl.
1889 rnInjectivityAnn :: LHsQTyVars GhcRn -- ^ Type variables declared in
1890 -- type family head
1891 -> LFamilyResultSig GhcRn -- ^ Result signature
1892 -> LInjectivityAnn GhcPs -- ^ Injectivity annotation
1893 -> RnM (LInjectivityAnn GhcRn)
1894 rnInjectivityAnn tvBndrs (L _ (TyVarSig _ resTv))
1895 (L srcSpan (InjectivityAnn injFrom injTo))
1896 = do
1897 { (injDecl'@(L _ (InjectivityAnn injFrom' injTo')), noRnErrors)
1898 <- askNoErrs $
1899 bindLocalNames [hsLTyVarName resTv] $
1900 -- The return type variable scopes over the injectivity annotation
1901 -- e.g. type family F a = (r::*) | r -> a
1902 do { injFrom' <- rnLTyVar injFrom
1903 ; injTo' <- mapM rnLTyVar injTo
1904 ; return $ L srcSpan (InjectivityAnn injFrom' injTo') }
1905
1906 ; let tvNames = Set.fromList $ hsAllLTyVarNames tvBndrs
1907 resName = hsLTyVarName resTv
1908 -- See Note [Renaming injectivity annotation]
1909 lhsValid = EQ == (stableNameCmp resName (unLoc injFrom'))
1910 rhsValid = Set.fromList (map unLoc injTo') `Set.difference` tvNames
1911
1912 -- if renaming of type variables ended with errors (eg. there were
1913 -- not-in-scope variables) don't check the validity of injectivity
1914 -- annotation. This gives better error messages.
1915 ; when (noRnErrors && not lhsValid) $
1916 addErrAt (getLoc injFrom)
1917 ( vcat [ text $ "Incorrect type variable on the LHS of "
1918 ++ "injectivity condition"
1919 , nest 5
1920 ( vcat [ text "Expected :" <+> ppr resName
1921 , text "Actual :" <+> ppr injFrom ])])
1922
1923 ; when (noRnErrors && not (Set.null rhsValid)) $
1924 do { let errorVars = Set.toList rhsValid
1925 ; addErrAt srcSpan $ ( hsep
1926 [ text "Unknown type variable" <> plural errorVars
1927 , text "on the RHS of injectivity condition:"
1928 , interpp'SP errorVars ] ) }
1929
1930 ; return injDecl' }
1931
1932 -- We can only hit this case when the user writes injectivity annotation without
1933 -- naming the result:
1934 --
1935 -- type family F a | result -> a
1936 -- type family F a :: * | result -> a
1937 --
1938 -- So we rename injectivity annotation like we normally would except that
1939 -- this time we expect "result" to be reported not in scope by rnLTyVar.
1940 rnInjectivityAnn _ _ (L srcSpan (InjectivityAnn injFrom injTo)) =
1941 setSrcSpan srcSpan $ do
1942 (injDecl', _) <- askNoErrs $ do
1943 injFrom' <- rnLTyVar injFrom
1944 injTo' <- mapM rnLTyVar injTo
1945 return $ L srcSpan (InjectivityAnn injFrom' injTo')
1946 return $ injDecl'
1947
1948 {-
1949 Note [Stupid theta]
1950 ~~~~~~~~~~~~~~~~~~~
1951 Trac #3850 complains about a regression wrt 6.10 for
1952 data Show a => T a
1953 There is no reason not to allow the stupid theta if there are no data
1954 constructors. It's still stupid, but does no harm, and I don't want
1955 to cause programs to break unnecessarily (notably HList). So if there
1956 are no data constructors we allow h98_style = True
1957 -}
1958
1959
1960 {- *****************************************************
1961 * *
1962 Support code for type/data declarations
1963 * *
1964 ***************************************************** -}
1965
1966 ---------------
1967 badAssocRhs :: [Name] -> RnM ()
1968 badAssocRhs ns
1969 = addErr (hang (text "The RHS of an associated type declaration mentions"
1970 <+> text "out-of-scope variable" <> plural ns
1971 <+> pprWithCommas (quotes . ppr) ns)
1972 2 (text "All such variables must be bound on the LHS"))
1973
1974 -----------------
1975 rnConDecls :: [LConDecl GhcPs] -> RnM ([LConDecl GhcRn], FreeVars)
1976 rnConDecls = mapFvRn (wrapLocFstM rnConDecl)
1977
1978 rnConDecl :: ConDecl GhcPs -> RnM (ConDecl GhcRn, FreeVars)
1979 rnConDecl decl@(ConDeclH98 { con_name = name, con_ex_tvs = ex_tvs
1980 , con_mb_cxt = mcxt, con_args = args
1981 , con_doc = mb_doc })
1982 = do { _ <- addLocM checkConName name
1983 ; new_name <- lookupLocatedTopBndrRn name
1984 ; mb_doc' <- rnMbLHsDoc mb_doc
1985
1986 -- We bind no implicit binders here; this is just like
1987 -- a nested HsForAllTy. E.g. consider
1988 -- data T a = forall (b::k). MkT (...)
1989 -- The 'k' will already be in scope from the bindHsQTyVars
1990 -- for the data decl itself. So we'll get
1991 -- data T {k} a = ...
1992 -- And indeed we may later discover (a::k). But that's the
1993 -- scoping we get. So no implicit binders at the existential forall
1994
1995 ; let ctxt = ConDeclCtx [new_name]
1996 ; bindLHsTyVarBndrs ctxt (Just (inHsDocContext ctxt))
1997 Nothing ex_tvs $ \ new_ex_tvs ->
1998 do { (new_context, fvs1) <- rnMbContext ctxt mcxt
1999 ; (new_args, fvs2) <- rnConDeclDetails (unLoc new_name) ctxt args
2000 ; let all_fvs = fvs1 `plusFV` fvs2
2001 ; traceRn "rnConDecl" (ppr name <+> vcat
2002 [ text "ex_tvs:" <+> ppr ex_tvs
2003 , text "new_ex_dqtvs':" <+> ppr new_ex_tvs ])
2004
2005 ; return (decl { con_ext = noExt
2006 , con_name = new_name, con_ex_tvs = new_ex_tvs
2007 , con_mb_cxt = new_context, con_args = new_args
2008 , con_doc = mb_doc' },
2009 all_fvs) }}
2010
2011 rnConDecl decl@(ConDeclGADT { con_names = names
2012 , con_forall = explicit_forall
2013 , con_qvars = qtvs
2014 , con_mb_cxt = mcxt
2015 , con_args = args
2016 , con_res_ty = res_ty
2017 , con_doc = mb_doc })
2018 = do { mapM_ (addLocM checkConName) names
2019 ; new_names <- mapM lookupLocatedTopBndrRn names
2020 ; mb_doc' <- rnMbLHsDoc mb_doc
2021
2022 ; let explicit_tkvs = hsQTvExplicit qtvs
2023 theta = hsConDeclTheta mcxt
2024 arg_tys = hsConDeclArgTys args
2025
2026 -- We must ensure that we extract the free tkvs in left-to-right
2027 -- order of their appearance in the constructor type.
2028 -- That order governs the order the implicitly-quantified type
2029 -- variable, and hence the order needed for visible type application
2030 -- See Trac #14808.
2031 ; free_tkvs <- extractHsTysRdrTyVarsDups (theta ++ arg_tys ++ [res_ty])
2032 ; free_tkvs <- extractHsTvBndrs explicit_tkvs free_tkvs
2033
2034 ; let ctxt = ConDeclCtx new_names
2035 mb_ctxt = Just (inHsDocContext ctxt)
2036
2037 ; traceRn "rnConDecl" (ppr names $$ ppr free_tkvs $$ ppr explicit_forall )
2038 ; rnImplicitBndrs (not explicit_forall) free_tkvs $ \ implicit_tkvs ->
2039 bindLHsTyVarBndrs ctxt mb_ctxt Nothing explicit_tkvs $ \ explicit_tkvs ->
2040 do { (new_cxt, fvs1) <- rnMbContext ctxt mcxt
2041 ; (new_args, fvs2) <- rnConDeclDetails (unLoc (head new_names)) ctxt args
2042 ; (new_res_ty, fvs3) <- rnLHsType ctxt res_ty
2043
2044 ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3
2045 (args', res_ty')
2046 = case args of
2047 InfixCon {} -> pprPanic "rnConDecl" (ppr names)
2048 RecCon {} -> (new_args, new_res_ty)
2049 PrefixCon as | (arg_tys, final_res_ty) <- splitHsFunType new_res_ty
2050 -> ASSERT( null as )
2051 -- See Note [GADT abstract syntax] in HsDecls
2052 (PrefixCon arg_tys, final_res_ty)
2053
2054 new_qtvs = HsQTvs { hsq_ext = HsQTvsRn
2055 { hsq_implicit = implicit_tkvs
2056 , hsq_dependent = emptyNameSet }
2057 , hsq_explicit = explicit_tkvs }
2058
2059 ; traceRn "rnConDecl2" (ppr names $$ ppr implicit_tkvs $$ ppr explicit_tkvs)
2060 ; return (decl { con_g_ext = noExt, con_names = new_names
2061 , con_qvars = new_qtvs, con_mb_cxt = new_cxt
2062 , con_args = args', con_res_ty = res_ty'
2063 , con_doc = mb_doc' },
2064 all_fvs) } }
2065
2066 rnConDecl (XConDecl _) = panic "rnConDecl"
2067
2068
2069 rnMbContext :: HsDocContext -> Maybe (LHsContext GhcPs)
2070 -> RnM (Maybe (LHsContext GhcRn), FreeVars)
2071 rnMbContext _ Nothing = return (Nothing, emptyFVs)
2072 rnMbContext doc (Just cxt) = do { (ctx',fvs) <- rnContext doc cxt
2073 ; return (Just ctx',fvs) }
2074
2075 rnConDeclDetails
2076 :: Name
2077 -> HsDocContext
2078 -> HsConDetails (LHsType GhcPs) (Located [LConDeclField GhcPs])
2079 -> RnM (HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn]),
2080 FreeVars)
2081 rnConDeclDetails _ doc (PrefixCon tys)
2082 = do { (new_tys, fvs) <- rnLHsTypes doc tys
2083 ; return (PrefixCon new_tys, fvs) }
2084
2085 rnConDeclDetails _ doc (InfixCon ty1 ty2)
2086 = do { (new_ty1, fvs1) <- rnLHsType doc ty1
2087 ; (new_ty2, fvs2) <- rnLHsType doc ty2
2088 ; return (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2) }
2089
2090 rnConDeclDetails con doc (RecCon (L l fields))
2091 = do { fls <- lookupConstructorFields con
2092 ; (new_fields, fvs) <- rnConDeclFields doc fls fields
2093 -- No need to check for duplicate fields
2094 -- since that is done by RnNames.extendGlobalRdrEnvRn
2095 ; return (RecCon (L l new_fields), fvs) }
2096
2097 -------------------------------------------------
2098
2099 -- | Brings pattern synonym names and also pattern synonym selectors
2100 -- from record pattern synonyms into scope.
2101 extendPatSynEnv :: HsValBinds GhcPs -> MiniFixityEnv
2102 -> ([Name] -> TcRnIf TcGblEnv TcLclEnv a) -> TcM a
2103 extendPatSynEnv val_decls local_fix_env thing = do {
2104 names_with_fls <- new_ps val_decls
2105 ; let pat_syn_bndrs = concat [ name: map flSelector fields
2106 | (name, fields) <- names_with_fls ]
2107 ; let avails = map avail pat_syn_bndrs
2108 ; (gbl_env, lcl_env) <- extendGlobalRdrEnvRn avails local_fix_env
2109
2110 ; let field_env' = extendNameEnvList (tcg_field_env gbl_env) names_with_fls
2111 final_gbl_env = gbl_env { tcg_field_env = field_env' }
2112 ; setEnvs (final_gbl_env, lcl_env) (thing pat_syn_bndrs) }
2113 where
2114 new_ps :: HsValBinds GhcPs -> TcM [(Name, [FieldLabel])]
2115 new_ps (ValBinds _ binds _) = foldrBagM new_ps' [] binds
2116 new_ps _ = panic "new_ps"
2117
2118 new_ps' :: LHsBindLR GhcPs GhcPs
2119 -> [(Name, [FieldLabel])]
2120 -> TcM [(Name, [FieldLabel])]
2121 new_ps' bind names
2122 | L bind_loc (PatSynBind _ (PSB { psb_id = L _ n
2123 , psb_args = RecCon as })) <- bind
2124 = do
2125 bnd_name <- newTopSrcBinder (L bind_loc n)
2126 let rnames = map recordPatSynSelectorId as
2127 mkFieldOcc :: Located RdrName -> LFieldOcc GhcPs
2128 mkFieldOcc (L l name) = L l (FieldOcc noExt (L l name))
2129 field_occs = map mkFieldOcc rnames
2130 flds <- mapM (newRecordSelector False [bnd_name]) field_occs
2131 return ((bnd_name, flds): names)
2132 | L bind_loc (PatSynBind _ (PSB { psb_id = L _ n})) <- bind
2133 = do
2134 bnd_name <- newTopSrcBinder (L bind_loc n)
2135 return ((bnd_name, []): names)
2136 | otherwise
2137 = return names
2138
2139 {-
2140 *********************************************************
2141 * *
2142 \subsection{Support code to rename types}
2143 * *
2144 *********************************************************
2145 -}
2146
2147 rnFds :: [Located (FunDep (Located RdrName))]
2148 -> RnM [Located (FunDep (Located Name))]
2149 rnFds fds
2150 = mapM (wrapLocM rn_fds) fds
2151 where
2152 rn_fds (tys1, tys2)
2153 = do { tys1' <- rnHsTyVars tys1
2154 ; tys2' <- rnHsTyVars tys2
2155 ; return (tys1', tys2') }
2156
2157 rnHsTyVars :: [Located RdrName] -> RnM [Located Name]
2158 rnHsTyVars tvs = mapM rnHsTyVar tvs
2159
2160 rnHsTyVar :: Located RdrName -> RnM (Located Name)
2161 rnHsTyVar (L l tyvar) = do
2162 tyvar' <- lookupOccRn tyvar
2163 return (L l tyvar')
2164
2165 {-
2166 *********************************************************
2167 * *
2168 findSplice
2169 * *
2170 *********************************************************
2171
2172 This code marches down the declarations, looking for the first
2173 Template Haskell splice. As it does so it
2174 a) groups the declarations into a HsGroup
2175 b) runs any top-level quasi-quotes
2176 -}
2177
2178 findSplice :: [LHsDecl GhcPs]
2179 -> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
2180 findSplice ds = addl emptyRdrGroup ds
2181
2182 addl :: HsGroup GhcPs -> [LHsDecl GhcPs]
2183 -> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
2184 -- This stuff reverses the declarations (again) but it doesn't matter
2185 addl gp [] = return (gp, Nothing)
2186 addl gp (L l d : ds) = add gp l d ds
2187
2188
2189 add :: HsGroup GhcPs -> SrcSpan -> HsDecl GhcPs -> [LHsDecl GhcPs]
2190 -> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
2191
2192 -- #10047: Declaration QuasiQuoters are expanded immediately, without
2193 -- causing a group split
2194 add gp _ (SpliceD _ (SpliceDecl _ (L _ qq@HsQuasiQuote{}) _)) ds
2195 = do { (ds', _) <- rnTopSpliceDecls qq
2196 ; addl gp (ds' ++ ds)
2197 }
2198
2199 add gp loc (SpliceD _ splice@(SpliceDecl _ _ flag)) ds
2200 = do { -- We've found a top-level splice. If it is an *implicit* one
2201 -- (i.e. a naked top level expression)
2202 case flag of
2203 ExplicitSplice -> return ()
2204 ImplicitSplice -> do { th_on <- xoptM LangExt.TemplateHaskell
2205 ; unless th_on $ setSrcSpan loc $
2206 failWith badImplicitSplice }
2207
2208 ; return (gp, Just (splice, ds)) }
2209 where
2210 badImplicitSplice = text "Parse error: module header, import declaration"
2211 $$ text "or top-level declaration expected."
2212
2213 -- Class declarations: pull out the fixity signatures to the top
2214 add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD _ d) ds
2215 | isClassDecl d
2216 = let fsigs = [ L l f | L l (FixSig _ f) <- tcdSigs d ] in
2217 addl (gp { hs_tyclds = add_tycld (L l d) ts, hs_fixds = fsigs ++ fs}) ds
2218 | otherwise
2219 = addl (gp { hs_tyclds = add_tycld (L l d) ts }) ds
2220
2221 -- Signatures: fixity sigs go a different place than all others
2222 add gp@(HsGroup {hs_fixds = ts}) l (SigD _ (FixSig _ f)) ds
2223 = addl (gp {hs_fixds = L l f : ts}) ds
2224 add gp@(HsGroup {hs_valds = ts}) l (SigD _ d) ds
2225 = addl (gp {hs_valds = add_sig (L l d) ts}) ds
2226
2227 -- Value declarations: use add_bind
2228 add gp@(HsGroup {hs_valds = ts}) l (ValD _ d) ds
2229 = addl (gp { hs_valds = add_bind (L l d) ts }) ds
2230
2231 -- Role annotations: added to the TyClGroup
2232 add gp@(HsGroup {hs_tyclds = ts}) l (RoleAnnotD _ d) ds
2233 = addl (gp { hs_tyclds = add_role_annot (L l d) ts }) ds
2234
2235 -- NB instance declarations go into TyClGroups. We throw them into the first
2236 -- group, just as we do for the TyClD case. The renamer will go on to group
2237 -- and order them later.
2238 add gp@(HsGroup {hs_tyclds = ts}) l (InstD _ d) ds
2239 = addl (gp { hs_tyclds = add_instd (L l d) ts }) ds
2240
2241 -- The rest are routine
2242 add gp@(HsGroup {hs_derivds = ts}) l (DerivD _ d) ds
2243 = addl (gp { hs_derivds = L l d : ts }) ds
2244 add gp@(HsGroup {hs_defds = ts}) l (DefD _ d) ds
2245 = addl (gp { hs_defds = L l d : ts }) ds
2246 add gp@(HsGroup {hs_fords = ts}) l (ForD _ d) ds
2247 = addl (gp { hs_fords = L l d : ts }) ds
2248 add gp@(HsGroup {hs_warnds = ts}) l (WarningD _ d) ds
2249 = addl (gp { hs_warnds = L l d : ts }) ds
2250 add gp@(HsGroup {hs_annds = ts}) l (AnnD _ d) ds
2251 = addl (gp { hs_annds = L l d : ts }) ds
2252 add gp@(HsGroup {hs_ruleds = ts}) l (RuleD _ d) ds
2253 = addl (gp { hs_ruleds = L l d : ts }) ds
2254 add gp l (DocD _ d) ds
2255 = addl (gp { hs_docs = (L l d) : (hs_docs gp) }) ds
2256 add (HsGroup {}) _ (SpliceD _ (XSpliceDecl _)) _ = panic "RnSource.add"
2257 add (HsGroup {}) _ (XHsDecl _) _ = panic "RnSource.add"
2258 add (XHsGroup _) _ _ _ = panic "RnSource.add"
2259
2260 add_tycld :: LTyClDecl (GhcPass p) -> [TyClGroup (GhcPass p)]
2261 -> [TyClGroup (GhcPass p)]
2262 add_tycld d [] = [TyClGroup { group_ext = noExt
2263 , group_tyclds = [d]
2264 , group_roles = []
2265 , group_instds = []
2266 }
2267 ]
2268 add_tycld d (ds@(TyClGroup { group_tyclds = tyclds }):dss)
2269 = ds { group_tyclds = d : tyclds } : dss
2270 add_tycld _ (XTyClGroup _: _) = panic "add_tycld"
2271
2272 add_instd :: LInstDecl (GhcPass p) -> [TyClGroup (GhcPass p)]
2273 -> [TyClGroup (GhcPass p)]
2274 add_instd d [] = [TyClGroup { group_ext = noExt
2275 , group_tyclds = []
2276 , group_roles = []
2277 , group_instds = [d]
2278 }
2279 ]
2280 add_instd d (ds@(TyClGroup { group_instds = instds }):dss)
2281 = ds { group_instds = d : instds } : dss
2282 add_instd _ (XTyClGroup _: _) = panic "add_instd"
2283
2284 add_role_annot :: LRoleAnnotDecl (GhcPass p) -> [TyClGroup (GhcPass p)]
2285 -> [TyClGroup (GhcPass p)]
2286 add_role_annot d [] = [TyClGroup { group_ext = noExt
2287 , group_tyclds = []
2288 , group_roles = [d]
2289 , group_instds = []
2290 }
2291 ]
2292 add_role_annot d (tycls@(TyClGroup { group_roles = roles }) : rest)
2293 = tycls { group_roles = d : roles } : rest
2294 add_role_annot _ (XTyClGroup _: _) = panic "add_role_annot"
2295
2296 add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a
2297 add_bind b (ValBinds x bs sigs) = ValBinds x (bs `snocBag` b) sigs
2298 add_bind _ (XValBindsLR {}) = panic "RdrHsSyn:add_bind"
2299
2300 add_sig :: LSig (GhcPass a) -> HsValBinds (GhcPass a) -> HsValBinds (GhcPass a)
2301 add_sig s (ValBinds x bs sigs) = ValBinds x bs (s:sigs)
2302 add_sig _ (XValBindsLR {}) = panic "RdrHsSyn:add_sig"