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