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