ea7d03660104258a28f9c9b7085752a31377a48a
[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])
713 -> Located RdrName
714 -> HsTyPats RdrName
715 -> rhs
716 -> (HsDocContext -> rhs -> RnM (rhs', FreeVars))
717 -> RnM (Located Name, HsTyPats Name, rhs', FreeVars)
718 rnFamInstDecl doc mb_cls tycon (HsIB { hsib_body = pats }) payload rnPayload
719 = do { tycon' <- lookupFamInstName (fmap fst mb_cls) tycon
720 ; let loc = case pats of
721 [] -> pprPanic "rnFamInstDecl" (ppr tycon)
722 (L loc _ : []) -> loc
723 (L loc _ : ps) -> combineSrcSpans loc (getLoc (last ps))
724
725 ; pat_kity_vars_with_dups <- extractHsTysRdrTyVarsDups pats
726 -- Use the "...Dups" form because it's needed
727 -- below to report unsed binder on the LHS
728 ; var_names <- mapM (newTyVarNameRn mb_cls . L loc . unLoc) $
729 freeKiTyVarsAllVars $
730 rmDupsInRdrTyVars pat_kity_vars_with_dups
731
732 -- All the free vars of the family patterns
733 -- with a sensible binding location
734 ; ((pats', payload'), fvs)
735 <- bindLocalNamesFV var_names $
736 do { (pats', pat_fvs) <- rnLHsTypes (FamPatCtx tycon) pats
737 ; (payload', rhs_fvs) <- rnPayload doc payload
738
739 -- Report unused binders on the LHS
740 -- See Note [Unused type variables in family instances]
741 ; let groups :: [[Located RdrName]]
742 groups = equivClasses cmpLocated $
743 freeKiTyVarsAllVars pat_kity_vars_with_dups
744 ; tv_nms_dups <- mapM (lookupOccRn . unLoc) $
745 [ tv | (tv:_:_) <- groups ]
746 -- Add to the used variables any variables that
747 -- appear *more than once* on the LHS
748 -- e.g. F a Int a = Bool
749 ; let tv_nms_used = extendNameSetList rhs_fvs tv_nms_dups
750 ; warnUnusedTypePatterns var_names tv_nms_used
751
752 -- See Note [Renaming associated types]
753 ; let bad_tvs = case mb_cls of
754 Nothing -> []
755 Just (_,cls_tkvs) -> filter is_bad cls_tkvs
756 var_name_set = mkNameSet var_names
757
758 is_bad cls_tkv = cls_tkv `elemNameSet` rhs_fvs
759 && not (cls_tkv `elemNameSet` var_name_set)
760
761 ; unless (null bad_tvs) (badAssocRhs bad_tvs)
762 ; return ((pats', payload'), rhs_fvs `plusFV` pat_fvs) }
763
764 ; let anon_wcs = concatMap collectAnonWildCards pats'
765 all_ibs = anon_wcs ++ var_names
766 -- all_ibs: include anonymous wildcards in the implicit
767 -- binders In a type pattern they behave just like any
768 -- other type variable except for being anoymous. See
769 -- Note [Wildcards in family instances]
770 all_fvs = fvs `addOneFV` unLoc tycon'
771
772 ; return (tycon',
773 HsIB { hsib_body = pats'
774 , hsib_vars = all_ibs },
775 payload',
776 all_fvs) }
777 -- type instance => use, hence addOneFV
778
779 rnTyFamInstDecl :: Maybe (Name, [Name])
780 -> TyFamInstDecl RdrName
781 -> RnM (TyFamInstDecl Name, FreeVars)
782 rnTyFamInstDecl mb_cls (TyFamInstDecl { tfid_eqn = L loc eqn })
783 = do { (eqn', fvs) <- rnTyFamInstEqn mb_cls eqn
784 ; return (TyFamInstDecl { tfid_eqn = L loc eqn'
785 , tfid_fvs = fvs }, fvs) }
786
787 rnTyFamInstEqn :: Maybe (Name, [Name])
788 -> TyFamInstEqn RdrName
789 -> RnM (TyFamInstEqn Name, FreeVars)
790 rnTyFamInstEqn mb_cls (TyFamEqn { tfe_tycon = tycon
791 , tfe_pats = pats
792 , tfe_rhs = rhs })
793 = do { (tycon', pats', rhs', fvs) <-
794 rnFamInstDecl (TySynCtx tycon) mb_cls tycon pats rhs rnTySyn
795 ; return (TyFamEqn { tfe_tycon = tycon'
796 , tfe_pats = pats'
797 , tfe_rhs = rhs' }, fvs) }
798
799 rnTyFamDefltEqn :: Name
800 -> TyFamDefltEqn RdrName
801 -> RnM (TyFamDefltEqn Name, FreeVars)
802 rnTyFamDefltEqn cls (TyFamEqn { tfe_tycon = tycon
803 , tfe_pats = tyvars
804 , tfe_rhs = rhs })
805 = bindHsQTyVars ctx Nothing (Just cls) [] tyvars $ \ tyvars' _ ->
806 do { tycon' <- lookupFamInstName (Just cls) tycon
807 ; (rhs', fvs) <- rnLHsType ctx rhs
808 ; return (TyFamEqn { tfe_tycon = tycon'
809 , tfe_pats = tyvars'
810 , tfe_rhs = rhs' }, fvs) }
811 where
812 ctx = TyFamilyCtx tycon
813
814 rnDataFamInstDecl :: Maybe (Name, [Name])
815 -> DataFamInstDecl RdrName
816 -> RnM (DataFamInstDecl Name, FreeVars)
817 rnDataFamInstDecl mb_cls (DataFamInstDecl { dfid_tycon = tycon
818 , dfid_pats = pats
819 , dfid_defn = defn })
820 = do { (tycon', pats', (defn', _), fvs) <-
821 rnFamInstDecl (TyDataCtx tycon) mb_cls tycon pats defn rnDataDefn
822 ; return (DataFamInstDecl { dfid_tycon = tycon'
823 , dfid_pats = pats'
824 , dfid_defn = defn'
825 , dfid_fvs = fvs }, fvs) }
826
827 -- Renaming of the associated types in instances.
828
829 -- Rename associated type family decl in class
830 rnATDecls :: Name -- Class
831 -> [LFamilyDecl RdrName]
832 -> RnM ([LFamilyDecl Name], FreeVars)
833 rnATDecls cls at_decls
834 = rnList (rnFamDecl (Just cls)) at_decls
835
836 rnATInstDecls :: (Maybe (Name, [Name]) -> -- The function that renames
837 decl RdrName -> -- an instance. rnTyFamInstDecl
838 RnM (decl Name, FreeVars)) -- or rnDataFamInstDecl
839 -> Name -- Class
840 -> [Name]
841 -> [Located (decl RdrName)]
842 -> RnM ([Located (decl Name)], FreeVars)
843 -- Used for data and type family defaults in a class decl
844 -- and the family instance declarations in an instance
845 --
846 -- NB: We allow duplicate associated-type decls;
847 -- See Note [Associated type instances] in TcInstDcls
848 rnATInstDecls rnFun cls tv_ns at_insts
849 = rnList (rnFun (Just (cls, tv_ns))) at_insts
850 -- See Note [Renaming associated types]
851
852 {- Note [Wildcards in family instances]
853 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
854 Wild cards can be used in type/data family instance declarations to indicate
855 that the name of a type variable doesn't matter. Each wild card will be
856 replaced with a new unique type variable. For instance:
857
858 type family F a b :: *
859 type instance F Int _ = Int
860
861 is the same as
862
863 type family F a b :: *
864 type instance F Int b = Int
865
866 This is implemented as follows: during renaming anonymous wild cards
867 '_' are given freshly generated names. These names are collected after
868 renaming (rnFamInstDecl) and used to make new type variables during
869 type checking (tc_fam_ty_pats). One should not confuse these wild
870 cards with the ones from partial type signatures. The latter generate
871 fresh meta-variables whereas the former generate fresh skolems.
872
873 Note [Unused type variables in family instances]
874 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
875 When the flag -fwarn-unused-type-patterns is on, the compiler reports warnings
876 about unused type variables. (rnFamInstDecl) A type variable is considered
877 used
878 * when it is either occurs on the RHS of the family instance, or
879 e.g. type instance F a b = a -- a is used on the RHS
880
881 * it occurs multiple times in the patterns on the LHS
882 e.g. type instance F a a = Int -- a appears more than once on LHS
883
884 As usual, the warnings are not reported for for type variables with names
885 beginning with an underscore.
886
887 Extra-constraints wild cards are not supported in type/data family
888 instance declarations.
889
890 Relevant tickets: #3699, #10586, #10982 and #11451.
891
892 Note [Renaming associated types]
893 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
894 Check that the RHS of the decl mentions only type variables
895 bound on the LHS. For example, this is not ok
896 class C a b where
897 type F a x :: *
898 instance C (p,q) r where
899 type F (p,q) x = (x, r) -- BAD: mentions 'r'
900 c.f. Trac #5515
901
902 The same thing applies to kind variables, of course (Trac #7938, #9574):
903 class Funct f where
904 type Codomain f :: *
905 instance Funct ('KProxy :: KProxy o) where
906 type Codomain 'KProxy = NatTr (Proxy :: o -> *)
907 Here 'o' is mentioned on the RHS of the Codomain function, but
908 not on the LHS.
909
910 All this applies only for *instance* declarations. In *class*
911 declarations there is no RHS to worry about, and the class variables
912 can all be in scope (Trac #5862):
913 class Category (x :: k -> k -> *) where
914 type Ob x :: k -> Constraint
915 id :: Ob x a => x a a
916 (.) :: (Ob x a, Ob x b, Ob x c) => x b c -> x a b -> x a c
917 Here 'k' is in scope in the kind signature, just like 'x'.
918 -}
919
920
921 {-
922 *********************************************************
923 * *
924 \subsection{Stand-alone deriving declarations}
925 * *
926 *********************************************************
927 -}
928
929 rnSrcDerivDecl :: DerivDecl RdrName -> RnM (DerivDecl Name, FreeVars)
930 rnSrcDerivDecl (DerivDecl ty overlap)
931 = do { standalone_deriv_ok <- xoptM LangExt.StandaloneDeriving
932 ; unless standalone_deriv_ok (addErr standaloneDerivErr)
933 ; (ty', fvs) <- rnLHsInstType (text "In a deriving declaration") ty
934 ; return (DerivDecl ty' overlap, fvs) }
935
936 standaloneDerivErr :: SDoc
937 standaloneDerivErr
938 = hang (text "Illegal standalone deriving declaration")
939 2 (text "Use StandaloneDeriving to enable this extension")
940
941 {-
942 *********************************************************
943 * *
944 \subsection{Rules}
945 * *
946 *********************************************************
947 -}
948
949 rnHsRuleDecls :: RuleDecls RdrName -> RnM (RuleDecls Name, FreeVars)
950 rnHsRuleDecls (HsRules src rules)
951 = do { (rn_rules,fvs) <- rnList rnHsRuleDecl rules
952 ; return (HsRules src rn_rules,fvs) }
953
954 rnHsRuleDecl :: RuleDecl RdrName -> RnM (RuleDecl Name, FreeVars)
955 rnHsRuleDecl (HsRule rule_name act vars lhs _fv_lhs rhs _fv_rhs)
956 = do { let rdr_names_w_loc = map get_var vars
957 ; checkDupRdrNames rdr_names_w_loc
958 ; checkShadowedRdrNames rdr_names_w_loc
959 ; names <- newLocalBndrsRn rdr_names_w_loc
960 ; bindHsRuleVars (snd $ unLoc rule_name) vars names $ \ vars' ->
961 do { (lhs', fv_lhs') <- rnLExpr lhs
962 ; (rhs', fv_rhs') <- rnLExpr rhs
963 ; checkValidRule (snd $ unLoc rule_name) names lhs' fv_lhs'
964 ; return (HsRule rule_name act vars' lhs' fv_lhs' rhs' fv_rhs',
965 fv_lhs' `plusFV` fv_rhs') } }
966 where
967 get_var (L _ (RuleBndrSig v _)) = v
968 get_var (L _ (RuleBndr v)) = v
969
970 bindHsRuleVars :: RuleName -> [LRuleBndr RdrName] -> [Name]
971 -> ([LRuleBndr Name] -> RnM (a, FreeVars))
972 -> RnM (a, FreeVars)
973 bindHsRuleVars rule_name vars names thing_inside
974 = go vars names $ \ vars' ->
975 bindLocalNamesFV names (thing_inside vars')
976 where
977 doc = RuleCtx rule_name
978
979 go (L l (RuleBndr (L loc _)) : vars) (n : ns) thing_inside
980 = go vars ns $ \ vars' ->
981 thing_inside (L l (RuleBndr (L loc n)) : vars')
982
983 go (L l (RuleBndrSig (L loc _) bsig) : vars) (n : ns) thing_inside
984 = rnHsSigWcTypeScoped doc bsig $ \ bsig' ->
985 go vars ns $ \ vars' ->
986 thing_inside (L l (RuleBndrSig (L loc n) bsig') : vars')
987
988 go [] [] thing_inside = thing_inside []
989 go vars names _ = pprPanic "bindRuleVars" (ppr vars $$ ppr names)
990
991 {-
992 Note [Rule LHS validity checking]
993 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
994 Check the shape of a transformation rule LHS. Currently we only allow
995 LHSs of the form @(f e1 .. en)@, where @f@ is not one of the
996 @forall@'d variables.
997
998 We used restrict the form of the 'ei' to prevent you writing rules
999 with LHSs with a complicated desugaring (and hence unlikely to match);
1000 (e.g. a case expression is not allowed: too elaborate.)
1001
1002 But there are legitimate non-trivial args ei, like sections and
1003 lambdas. So it seems simmpler not to check at all, and that is why
1004 check_e is commented out.
1005 -}
1006
1007 checkValidRule :: FastString -> [Name] -> LHsExpr Name -> NameSet -> RnM ()
1008 checkValidRule rule_name ids lhs' fv_lhs'
1009 = do { -- Check for the form of the LHS
1010 case (validRuleLhs ids lhs') of
1011 Nothing -> return ()
1012 Just bad -> failWithTc (badRuleLhsErr rule_name lhs' bad)
1013
1014 -- Check that LHS vars are all bound
1015 ; let bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs')]
1016 ; mapM_ (addErr . badRuleVar rule_name) bad_vars }
1017
1018 validRuleLhs :: [Name] -> LHsExpr Name -> Maybe (HsExpr Name)
1019 -- Nothing => OK
1020 -- Just e => Not ok, and e is the offending sub-expression
1021 validRuleLhs foralls lhs
1022 = checkl lhs
1023 where
1024 checkl (L _ e) = check e
1025
1026 check (OpApp e1 op _ e2) = checkl op `mplus` checkl_e e1 `mplus` checkl_e e2
1027 check (HsApp e1 e2) = checkl e1 `mplus` checkl_e e2
1028 check (HsAppType e _) = checkl e
1029 check (HsVar (L _ v)) | v `notElem` foralls = Nothing
1030 check other = Just other -- Failure
1031
1032 -- Check an argument
1033 checkl_e (L _ _e) = Nothing -- Was (check_e e); see Note [Rule LHS validity checking]
1034
1035 {- Commented out; see Note [Rule LHS validity checking] above
1036 check_e (HsVar v) = Nothing
1037 check_e (HsPar e) = checkl_e e
1038 check_e (HsLit e) = Nothing
1039 check_e (HsOverLit e) = Nothing
1040
1041 check_e (OpApp e1 op _ e2) = checkl_e e1 `mplus` checkl_e op `mplus` checkl_e e2
1042 check_e (HsApp e1 e2) = checkl_e e1 `mplus` checkl_e e2
1043 check_e (NegApp e _) = checkl_e e
1044 check_e (ExplicitList _ es) = checkl_es es
1045 check_e other = Just other -- Fails
1046
1047 checkl_es es = foldr (mplus . checkl_e) Nothing es
1048 -}
1049
1050 badRuleVar :: FastString -> Name -> SDoc
1051 badRuleVar name var
1052 = sep [text "Rule" <+> doubleQuotes (ftext name) <> colon,
1053 text "Forall'd variable" <+> quotes (ppr var) <+>
1054 text "does not appear on left hand side"]
1055
1056 badRuleLhsErr :: FastString -> LHsExpr Name -> HsExpr Name -> SDoc
1057 badRuleLhsErr name lhs bad_e
1058 = sep [text "Rule" <+> pprRuleName name <> colon,
1059 nest 4 (vcat [err,
1060 text "in left-hand side:" <+> ppr lhs])]
1061 $$
1062 text "LHS must be of form (f e1 .. en) where f is not forall'd"
1063 where
1064 err = case bad_e of
1065 HsUnboundVar uv -> text "Not in scope:" <+> ppr uv
1066 _ -> text "Illegal expression:" <+> ppr bad_e
1067
1068 {-
1069 *********************************************************
1070 * *
1071 \subsection{Vectorisation declarations}
1072 * *
1073 *********************************************************
1074 -}
1075
1076 rnHsVectDecl :: VectDecl RdrName -> RnM (VectDecl Name, FreeVars)
1077 -- FIXME: For the moment, the right-hand side is restricted to be a variable as we cannot properly
1078 -- typecheck a complex right-hand side without invoking 'vectType' from the vectoriser.
1079 rnHsVectDecl (HsVect s var rhs@(L _ (HsVar _)))
1080 = do { var' <- lookupLocatedOccRn var
1081 ; (rhs', fv_rhs) <- rnLExpr rhs
1082 ; return (HsVect s var' rhs', fv_rhs `addOneFV` unLoc var')
1083 }
1084 rnHsVectDecl (HsVect _ _var _rhs)
1085 = failWith $ vcat
1086 [ text "IMPLEMENTATION RESTRICTION: right-hand side of a VECTORISE pragma"
1087 , text "must be an identifier"
1088 ]
1089 rnHsVectDecl (HsNoVect s var)
1090 = do { var' <- lookupLocatedTopBndrRn var -- only applies to local (not imported) names
1091 ; return (HsNoVect s var', unitFV (unLoc var'))
1092 }
1093 rnHsVectDecl (HsVectTypeIn s isScalar tycon Nothing)
1094 = do { tycon' <- lookupLocatedOccRn tycon
1095 ; return (HsVectTypeIn s isScalar tycon' Nothing, unitFV (unLoc tycon'))
1096 }
1097 rnHsVectDecl (HsVectTypeIn s isScalar tycon (Just rhs_tycon))
1098 = do { tycon' <- lookupLocatedOccRn tycon
1099 ; rhs_tycon' <- lookupLocatedOccRn rhs_tycon
1100 ; return ( HsVectTypeIn s isScalar tycon' (Just rhs_tycon')
1101 , mkFVs [unLoc tycon', unLoc rhs_tycon'])
1102 }
1103 rnHsVectDecl (HsVectTypeOut _ _ _)
1104 = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectTypeOut'"
1105 rnHsVectDecl (HsVectClassIn s cls)
1106 = do { cls' <- lookupLocatedOccRn cls
1107 ; return (HsVectClassIn s cls', unitFV (unLoc cls'))
1108 }
1109 rnHsVectDecl (HsVectClassOut _)
1110 = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectClassOut'"
1111 rnHsVectDecl (HsVectInstIn instTy)
1112 = do { (instTy', fvs) <- rnLHsInstType (text "a VECTORISE pragma") instTy
1113 ; return (HsVectInstIn instTy', fvs)
1114 }
1115 rnHsVectDecl (HsVectInstOut _)
1116 = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectInstOut'"
1117
1118 {-
1119 *********************************************************
1120 * *
1121 \subsection{Type, class and iface sig declarations}
1122 * *
1123 *********************************************************
1124
1125 @rnTyDecl@ uses the `global name function' to create a new type
1126 declaration in which local names have been replaced by their original
1127 names, reporting any unknown names.
1128
1129 Renaming type variables is a pain. Because they now contain uniques,
1130 it is necessary to pass in an association list which maps a parsed
1131 tyvar to its @Name@ representation.
1132 In some cases (type signatures of values),
1133 it is even necessary to go over the type first
1134 in order to get the set of tyvars used by it, make an assoc list,
1135 and then go over it again to rename the tyvars!
1136 However, we can also do some scoping checks at the same time.
1137
1138
1139 Note [Extra dependencies from .hs-boot files]
1140 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1141 Consider the following case:
1142
1143 A.hs-boot
1144 module A where
1145 data A1
1146
1147 B.hs
1148 module B where
1149 import {-# SOURCE #-} A
1150 type DisguisedA1 = A1
1151 data B1 = B1 DisguisedA1
1152
1153 A.hs
1154 module A where
1155 import B
1156 data A2 = A2 A1
1157 data A1 = A1 B1
1158
1159 Here A1 is really recursive (via B1), but we won't see that easily when
1160 doing dependency analysis when compiling A.hs
1161
1162 To handle this problem, we add a dependency
1163 - from every local declaration
1164 - to everything that comes from this module's .hs-boot file.
1165 In this case, we'll ad and edges
1166 - from A2 to A1 (but that edge is there already)
1167 - from A1 to A1 (which is new)
1168
1169 Well, not quite *every* declaration. Imagine module A
1170 above had another datatype declaration:
1171
1172 data A3 = A3 Int
1173
1174 Even though A3 has a dependency (on Int), all its dependencies are from things
1175 that live on other packages. Since we don't have mutual dependencies across
1176 packages, it is safe not to add the dependencies on the .hs-boot stuff to A2.
1177
1178 Hence function Name.thisPackageImport.
1179
1180 See also Note [Grouping of type and class declarations] in TcTyClsDecls.
1181 -}
1182
1183
1184 rnTyClDecls :: [TyClGroup RdrName]
1185 -> RnM ([TyClGroup Name], FreeVars)
1186 -- Rename the declarations and do dependency analysis on them
1187 rnTyClDecls tycl_ds
1188 = do { ds_w_fvs <- mapM (wrapLocFstM rnTyClDecl) (tyClGroupConcat tycl_ds)
1189 ; let decl_names = mkNameSet (map (tcdName . unLoc . fst) ds_w_fvs)
1190 ; role_annot_env <- rnRoleAnnots decl_names (concatMap group_roles tycl_ds)
1191 ; tcg_env <- getGblEnv
1192 ; let this_mod = tcg_mod tcg_env
1193 boot_info = tcg_self_boot tcg_env
1194
1195 add_boot_deps :: [(LTyClDecl Name, FreeVars)] -> [(LTyClDecl Name, FreeVars)]
1196 -- See Note [Extra dependencies from .hs-boot files]
1197 add_boot_deps ds_w_fvs
1198 = case boot_info of
1199 SelfBoot { sb_tcs = tcs } | not (isEmptyNameSet tcs)
1200 -> map (add_one tcs) ds_w_fvs
1201 _ -> ds_w_fvs
1202
1203 add_one :: NameSet -> (LTyClDecl Name, FreeVars) -> (LTyClDecl Name, FreeVars)
1204 add_one tcs pr@(decl,fvs)
1205 | has_local_imports fvs = (decl, fvs `plusFV` tcs)
1206 | otherwise = pr
1207
1208 has_local_imports fvs
1209 = foldNameSet ((||) . nameIsHomePackageImport this_mod)
1210 False fvs
1211
1212 ds_w_fvs' = add_boot_deps ds_w_fvs
1213
1214 sccs :: [SCC (LTyClDecl Name)]
1215 sccs = depAnalTyClDecls ds_w_fvs'
1216
1217 all_fvs = foldr (plusFV . snd) emptyFVs ds_w_fvs'
1218
1219 raw_groups = map flattenSCC sccs
1220 -- See Note [Role annotations in the renamer]
1221 (groups, orphan_roles)
1222 = foldr (\group (groups_acc, orphans_acc) ->
1223 let names = map (tcdName . unLoc) group
1224 roles = mapMaybe (lookupNameEnv orphans_acc) names
1225 orphans' = delListFromNameEnv orphans_acc names
1226 -- there doesn't seem to be an interface to
1227 -- do the above more efficiently
1228 in ( TyClGroup { group_tyclds = group
1229 , group_roles = roles } : groups_acc
1230 , orphans' )
1231 )
1232 ([], role_annot_env)
1233 raw_groups
1234
1235 ; mapM_ orphanRoleAnnotErr (nameEnvElts orphan_roles)
1236 ; traceRn (text "rnTycl" <+> (ppr ds_w_fvs $$ ppr sccs))
1237 ; return (groups, all_fvs) }
1238
1239 rnTyClDecl :: TyClDecl RdrName
1240 -> RnM (TyClDecl Name, FreeVars)
1241
1242 -- All flavours of type family declarations ("type family", "newtype family",
1243 -- and "data family"), both top level and (for an associated type)
1244 -- in a class decl
1245 rnTyClDecl (FamDecl { tcdFam = decl })
1246 = do { (decl', fvs) <- rnFamDecl Nothing decl
1247 ; return (FamDecl decl', fvs) }
1248
1249 rnTyClDecl (SynDecl { tcdLName = tycon, tcdTyVars = tyvars, tcdRhs = rhs })
1250 = do { tycon' <- lookupLocatedTopBndrRn tycon
1251 ; kvs <- freeKiTyVarsKindVars <$> extractHsTyRdrTyVars rhs
1252 ; let doc = TySynCtx tycon
1253 ; traceRn (text "rntycl-ty" <+> ppr tycon <+> ppr kvs)
1254 ; ((tyvars', rhs'), fvs) <- bindHsQTyVars doc Nothing Nothing kvs tyvars $
1255 \ tyvars' _ ->
1256 do { (rhs', fvs) <- rnTySyn doc rhs
1257 ; return ((tyvars', rhs'), fvs) }
1258 ; return (SynDecl { tcdLName = tycon', tcdTyVars = tyvars'
1259 , tcdRhs = rhs', tcdFVs = fvs }, fvs) }
1260
1261 -- "data", "newtype" declarations
1262 -- both top level and (for an associated type) in an instance decl
1263 rnTyClDecl (DataDecl { tcdLName = tycon, tcdTyVars = tyvars, tcdDataDefn = defn })
1264 = do { tycon' <- lookupLocatedTopBndrRn tycon
1265 ; kvs <- extractDataDefnKindVars defn
1266 ; let doc = TyDataCtx tycon
1267 ; traceRn (text "rntycl-data" <+> ppr tycon <+> ppr kvs)
1268 ; ((tyvars', defn', no_kvs), fvs)
1269 <- bindHsQTyVars doc Nothing Nothing kvs tyvars $ \ tyvars' dep_vars ->
1270 do { ((defn', kind_sig_fvs), fvs) <- rnDataDefn doc defn
1271 ; let sig_tvs = filterNameSet isTyVarName kind_sig_fvs
1272 unbound_sig_tvs = sig_tvs `minusNameSet` dep_vars
1273 ; return ((tyvars', defn', isEmptyNameSet unbound_sig_tvs), fvs) }
1274 -- See Note [Complete user-supplied kind signatures] in HsDecls
1275 ; typeintype <- xoptM LangExt.TypeInType
1276 ; let cusk = hsTvbAllKinded tyvars' &&
1277 (not typeintype || no_kvs)
1278 ; return (DataDecl { tcdLName = tycon', tcdTyVars = tyvars'
1279 , tcdDataDefn = defn', tcdDataCusk = cusk
1280 , tcdFVs = fvs }, fvs) }
1281
1282 rnTyClDecl (ClassDecl { tcdCtxt = context, tcdLName = lcls,
1283 tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs,
1284 tcdMeths = mbinds, tcdATs = ats, tcdATDefs = at_defs,
1285 tcdDocs = docs})
1286 = do { lcls' <- lookupLocatedTopBndrRn lcls
1287 ; let cls' = unLoc lcls'
1288 kvs = [] -- No scoped kind vars except those in
1289 -- kind signatures on the tyvars
1290
1291 -- Tyvars scope over superclass context and method signatures
1292 ; ((tyvars', context', fds', ats'), stuff_fvs)
1293 <- bindHsQTyVars cls_doc Nothing Nothing kvs tyvars $ \ tyvars' _ -> do
1294 -- Checks for distinct tyvars
1295 { (context', cxt_fvs) <- rnContext cls_doc context
1296 ; fds' <- rnFds fds
1297 -- The fundeps have no free variables
1298 ; (ats', fv_ats) <- rnATDecls cls' ats
1299 ; let fvs = cxt_fvs `plusFV`
1300 fv_ats
1301 ; return ((tyvars', context', fds', ats'), fvs) }
1302
1303 ; (at_defs', fv_at_defs) <- rnList (rnTyFamDefltEqn cls') at_defs
1304
1305 -- No need to check for duplicate associated type decls
1306 -- since that is done by RnNames.extendGlobalRdrEnvRn
1307
1308 -- Check the signatures
1309 -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).
1310 ; let sig_rdr_names_w_locs = [op | L _ (ClassOpSig False ops _) <- sigs
1311 , op <- ops]
1312 ; checkDupRdrNames sig_rdr_names_w_locs
1313 -- Typechecker is responsible for checking that we only
1314 -- give default-method bindings for things in this class.
1315 -- The renamer *could* check this for class decls, but can't
1316 -- for instance decls.
1317
1318 -- The newLocals call is tiresome: given a generic class decl
1319 -- class C a where
1320 -- op :: a -> a
1321 -- op {| x+y |} (Inl a) = ...
1322 -- op {| x+y |} (Inr b) = ...
1323 -- op {| a*b |} (a*b) = ...
1324 -- we want to name both "x" tyvars with the same unique, so that they are
1325 -- easy to group together in the typechecker.
1326 ; (mbinds', sigs', meth_fvs)
1327 <- rnMethodBinds True cls' (hsAllLTyVarNames tyvars') mbinds sigs
1328 -- No need to check for duplicate method signatures
1329 -- since that is done by RnNames.extendGlobalRdrEnvRn
1330 -- and the methods are already in scope
1331
1332 -- Haddock docs
1333 ; docs' <- mapM (wrapLocM rnDocDecl) docs
1334
1335 ; let all_fvs = meth_fvs `plusFV` stuff_fvs `plusFV` fv_at_defs
1336 ; return (ClassDecl { tcdCtxt = context', tcdLName = lcls',
1337 tcdTyVars = tyvars', tcdFDs = fds', tcdSigs = sigs',
1338 tcdMeths = mbinds', tcdATs = ats', tcdATDefs = at_defs',
1339 tcdDocs = docs', tcdFVs = all_fvs },
1340 all_fvs ) }
1341 where
1342 cls_doc = ClassDeclCtx lcls
1343
1344 -- "type" and "type instance" declarations
1345 rnTySyn :: HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
1346 rnTySyn doc rhs = rnLHsType doc rhs
1347
1348 -- | Renames role annotations, returning them as the values in a NameEnv
1349 -- and checks for duplicate role annotations.
1350 -- It is quite convenient to do both of these in the same place.
1351 -- See also Note [Role annotations in the renamer]
1352 rnRoleAnnots :: NameSet -- ^ of the decls in this group
1353 -> [LRoleAnnotDecl RdrName]
1354 -> RnM (NameEnv (LRoleAnnotDecl Name))
1355 rnRoleAnnots decl_names role_annots
1356 = do { -- check for duplicates *before* renaming, to avoid lumping
1357 -- together all the unboundNames
1358 let (no_dups, dup_annots) = removeDups role_annots_cmp role_annots
1359 role_annots_cmp (L _ annot1) (L _ annot2)
1360 = roleAnnotDeclName annot1 `compare` roleAnnotDeclName annot2
1361 ; mapM_ dupRoleAnnotErr dup_annots
1362 ; role_annots' <- mapM (wrapLocM rn_role_annot1) no_dups
1363 -- some of the role annots will be unbound; we don't wish
1364 -- to include these
1365 ; return $ mkNameEnv [ (name, ra)
1366 | ra <- role_annots'
1367 , let name = roleAnnotDeclName (unLoc ra)
1368 , not (isUnboundName name) ] }
1369 where
1370 rn_role_annot1 (RoleAnnotDecl tycon roles)
1371 = do { -- the name is an *occurrence*, but look it up only in the
1372 -- decls defined in this group (see #10263)
1373 tycon' <- lookupSigCtxtOccRn (RoleAnnotCtxt decl_names)
1374 (text "role annotation")
1375 tycon
1376 ; return $ RoleAnnotDecl tycon' roles }
1377
1378 dupRoleAnnotErr :: [LRoleAnnotDecl RdrName] -> RnM ()
1379 dupRoleAnnotErr [] = panic "dupRoleAnnotErr"
1380 dupRoleAnnotErr list
1381 = addErrAt loc $
1382 hang (text "Duplicate role annotations for" <+>
1383 quotes (ppr $ roleAnnotDeclName first_decl) <> colon)
1384 2 (vcat $ map pp_role_annot sorted_list)
1385 where
1386 sorted_list = sortBy cmp_annot list
1387 (L loc first_decl : _) = sorted_list
1388
1389 pp_role_annot (L loc decl) = hang (ppr decl)
1390 4 (text "-- written at" <+> ppr loc)
1391
1392 cmp_annot (L loc1 _) (L loc2 _) = loc1 `compare` loc2
1393
1394 orphanRoleAnnotErr :: LRoleAnnotDecl Name -> RnM ()
1395 orphanRoleAnnotErr (L loc decl)
1396 = addErrAt loc $
1397 hang (text "Role annotation for a type previously declared:")
1398 2 (ppr decl) $$
1399 parens (text "The role annotation must be given where" <+>
1400 quotes (ppr $ roleAnnotDeclName decl) <+>
1401 text "is declared.")
1402
1403 rnDataDefn :: HsDocContext -> HsDataDefn RdrName
1404 -> RnM ((HsDataDefn Name, NameSet), FreeVars)
1405 -- the NameSet includes all Names free in the kind signature
1406 -- See Note [Complete user-supplied kind signatures]
1407 rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType
1408 , dd_ctxt = context, dd_cons = condecls
1409 , dd_kindSig = m_sig, dd_derivs = derivs })
1410 = do { checkTc (h98_style || null (unLoc context))
1411 (badGadtStupidTheta doc)
1412
1413 ; (m_sig', sig_fvs) <- case m_sig of
1414 Just sig -> first Just <$> rnLHsKind doc sig
1415 Nothing -> return (Nothing, emptyFVs)
1416 ; (context', fvs1) <- rnContext doc context
1417 ; (derivs', fvs3) <- rn_derivs derivs
1418
1419 -- For the constructor declarations, drop the LocalRdrEnv
1420 -- in the GADT case, where the type variables in the declaration
1421 -- do not scope over the constructor signatures
1422 -- data T a where { T1 :: forall b. b-> b }
1423 ; let { zap_lcl_env | h98_style = \ thing -> thing
1424 | otherwise = setLocalRdrEnv emptyLocalRdrEnv }
1425 ; (condecls', con_fvs) <- zap_lcl_env $ rnConDecls condecls
1426 -- No need to check for duplicate constructor decls
1427 -- since that is done by RnNames.extendGlobalRdrEnvRn
1428
1429 ; let all_fvs = fvs1 `plusFV` fvs3 `plusFV`
1430 con_fvs `plusFV` sig_fvs
1431 ; return (( HsDataDefn { dd_ND = new_or_data, dd_cType = cType
1432 , dd_ctxt = context', dd_kindSig = m_sig'
1433 , dd_cons = condecls'
1434 , dd_derivs = derivs' }
1435 , sig_fvs )
1436 , all_fvs )
1437 }
1438 where
1439 h98_style = case condecls of -- Note [Stupid theta]
1440 L _ (ConDeclGADT {}) : _ -> False
1441 _ -> True
1442
1443 rn_derivs Nothing
1444 = return (Nothing, emptyFVs)
1445 rn_derivs (Just (L loc ds))
1446 = do { (ds', fvs) <- mapFvRn (rnHsSigType doc) ds
1447 ; return (Just (L loc ds'), fvs) }
1448
1449 badGadtStupidTheta :: HsDocContext -> SDoc
1450 badGadtStupidTheta _
1451 = vcat [text "No context is allowed on a GADT-style data declaration",
1452 text "(You can put a context on each contructor, though.)"]
1453
1454 rnFamDecl :: Maybe Name -- Just cls => this FamilyDecl is nested
1455 -- inside an *class decl* for cls
1456 -- used for associated types
1457 -> FamilyDecl RdrName
1458 -> RnM (FamilyDecl Name, FreeVars)
1459 rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars
1460 , fdInfo = info, fdResultSig = res_sig
1461 , fdInjectivityAnn = injectivity })
1462 = do { tycon' <- lookupLocatedTopBndrRn tycon
1463 ; kvs <- extractRdrKindSigVars res_sig
1464 ; ((tyvars', res_sig', injectivity'), fv1) <-
1465 bindHsQTyVars doc Nothing mb_cls kvs tyvars $
1466 \ tyvars'@(HsQTvs { hsq_implicit = rn_kvs }) _ ->
1467 do { let rn_sig = rnFamResultSig doc rn_kvs
1468 ; (res_sig', fv_kind) <- wrapLocFstM rn_sig res_sig
1469 ; injectivity' <- traverse (rnInjectivityAnn tyvars' res_sig')
1470 injectivity
1471 ; return ( (tyvars', res_sig', injectivity') , fv_kind ) }
1472 ; (info', fv2) <- rn_info info
1473 ; return (FamilyDecl { fdLName = tycon', fdTyVars = tyvars'
1474 , fdInfo = info', fdResultSig = res_sig'
1475 , fdInjectivityAnn = injectivity' }
1476 , fv1 `plusFV` fv2) }
1477 where
1478 doc = TyFamilyCtx tycon
1479
1480 ----------------------
1481 rn_info (ClosedTypeFamily (Just eqns))
1482 = do { (eqns', fvs) <- rnList (rnTyFamInstEqn Nothing) eqns
1483 -- no class context,
1484 ; return (ClosedTypeFamily (Just eqns'), fvs) }
1485 rn_info (ClosedTypeFamily Nothing)
1486 = return (ClosedTypeFamily Nothing, emptyFVs)
1487 rn_info OpenTypeFamily = return (OpenTypeFamily, emptyFVs)
1488 rn_info DataFamily = return (DataFamily, emptyFVs)
1489
1490 rnFamResultSig :: HsDocContext
1491 -> [Name] -- kind variables already in scope
1492 -> FamilyResultSig RdrName
1493 -> RnM (FamilyResultSig Name, FreeVars)
1494 rnFamResultSig _ _ NoSig
1495 = return (NoSig, emptyFVs)
1496 rnFamResultSig doc _ (KindSig kind)
1497 = do { (rndKind, ftvs) <- rnLHsKind doc kind
1498 ; return (KindSig rndKind, ftvs) }
1499 rnFamResultSig doc kv_names (TyVarSig tvbndr)
1500 = do { -- `TyVarSig` tells us that user named the result of a type family by
1501 -- writing `= tyvar` or `= (tyvar :: kind)`. In such case we want to
1502 -- be sure that the supplied result name is not identical to an
1503 -- already in-scope type variable from an enclosing class.
1504 --
1505 -- Example of disallowed declaration:
1506 -- class C a b where
1507 -- type F b = a | a -> b
1508 rdr_env <- getLocalRdrEnv
1509 ; let resName = hsLTyVarName tvbndr
1510 ; when (resName `elemLocalRdrEnv` rdr_env) $
1511 addErrAt (getLoc tvbndr) $
1512 (hsep [ text "Type variable", quotes (ppr resName) <> comma
1513 , text "naming a type family result,"
1514 ] $$
1515 text "shadows an already bound type variable")
1516
1517 ; bindLHsTyVarBndr doc Nothing -- this might be a lie, but it's used for
1518 -- scoping checks that are irrelevant here
1519 (mkNameSet kv_names) emptyNameSet
1520 -- use of emptyNameSet here avoids
1521 -- redundant duplicate errors
1522 tvbndr $ \ _ _ tvbndr' ->
1523 return (TyVarSig tvbndr', unitFV (hsLTyVarName tvbndr')) }
1524
1525 -- Note [Renaming injectivity annotation]
1526 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1527 --
1528 -- During renaming of injectivity annotation we have to make several checks to
1529 -- make sure that it is well-formed. At the moment injectivity annotation
1530 -- consists of a single injectivity condition, so the terms "injectivity
1531 -- annotation" and "injectivity condition" might be used interchangeably. See
1532 -- Note [Injectivity annotation] for a detailed discussion of currently allowed
1533 -- injectivity annotations.
1534 --
1535 -- Checking LHS is simple because the only type variable allowed on the LHS of
1536 -- injectivity condition is the variable naming the result in type family head.
1537 -- Example of disallowed annotation:
1538 --
1539 -- type family Foo a b = r | b -> a
1540 --
1541 -- Verifying RHS of injectivity consists of checking that:
1542 --
1543 -- 1. only variables defined in type family head appear on the RHS (kind
1544 -- variables are also allowed). Example of disallowed annotation:
1545 --
1546 -- type family Foo a = r | r -> b
1547 --
1548 -- 2. for associated types the result variable does not shadow any of type
1549 -- class variables. Example of disallowed annotation:
1550 --
1551 -- class Foo a b where
1552 -- type F a = b | b -> a
1553 --
1554 -- Breaking any of these assumptions results in an error.
1555
1556 -- | Rename injectivity annotation. Note that injectivity annotation is just the
1557 -- part after the "|". Everything that appears before it is renamed in
1558 -- rnFamDecl.
1559 rnInjectivityAnn :: LHsQTyVars Name -- ^ Type variables declared in
1560 -- type family head
1561 -> LFamilyResultSig Name -- ^ Result signature
1562 -> LInjectivityAnn RdrName -- ^ Injectivity annotation
1563 -> RnM (LInjectivityAnn Name)
1564 rnInjectivityAnn tvBndrs (L _ (TyVarSig resTv))
1565 (L srcSpan (InjectivityAnn injFrom injTo))
1566 = do
1567 { (injDecl'@(L _ (InjectivityAnn injFrom' injTo')), noRnErrors)
1568 <- askNoErrs $
1569 bindLocalNames [hsLTyVarName resTv] $
1570 -- The return type variable scopes over the injectivity annotation
1571 -- e.g. type family F a = (r::*) | r -> a
1572 do { injFrom' <- rnLTyVar injFrom
1573 ; injTo' <- mapM rnLTyVar injTo
1574 ; return $ L srcSpan (InjectivityAnn injFrom' injTo') }
1575
1576 ; let tvNames = Set.fromList $ hsAllLTyVarNames tvBndrs
1577 resName = hsLTyVarName resTv
1578 -- See Note [Renaming injectivity annotation]
1579 lhsValid = EQ == (stableNameCmp resName (unLoc injFrom'))
1580 rhsValid = Set.fromList (map unLoc injTo') `Set.difference` tvNames
1581
1582 -- if renaming of type variables ended with errors (eg. there were
1583 -- not-in-scope variables) don't check the validity of injectivity
1584 -- annotation. This gives better error messages.
1585 ; when (noRnErrors && not lhsValid) $
1586 addErrAt (getLoc injFrom)
1587 ( vcat [ text $ "Incorrect type variable on the LHS of "
1588 ++ "injectivity condition"
1589 , nest 5
1590 ( vcat [ text "Expected :" <+> ppr resName
1591 , text "Actual :" <+> ppr injFrom ])])
1592
1593 ; when (noRnErrors && not (Set.null rhsValid)) $
1594 do { let errorVars = Set.toList rhsValid
1595 ; addErrAt srcSpan $ ( hsep
1596 [ text "Unknown type variable" <> plural errorVars
1597 , text "on the RHS of injectivity condition:"
1598 , interpp'SP errorVars ] ) }
1599
1600 ; return injDecl' }
1601
1602 -- We can only hit this case when the user writes injectivity annotation without
1603 -- naming the result:
1604 --
1605 -- type family F a | result -> a
1606 -- type family F a :: * | result -> a
1607 --
1608 -- So we rename injectivity annotation like we normally would except that
1609 -- this time we expect "result" to be reported not in scope by rnLTyVar.
1610 rnInjectivityAnn _ _ (L srcSpan (InjectivityAnn injFrom injTo)) =
1611 setSrcSpan srcSpan $ do
1612 (injDecl', _) <- askNoErrs $ do
1613 injFrom' <- rnLTyVar injFrom
1614 injTo' <- mapM rnLTyVar injTo
1615 return $ L srcSpan (InjectivityAnn injFrom' injTo')
1616 return $ injDecl'
1617
1618 {-
1619 Note [Stupid theta]
1620 ~~~~~~~~~~~~~~~~~~~
1621 Trac #3850 complains about a regression wrt 6.10 for
1622 data Show a => T a
1623 There is no reason not to allow the stupid theta if there are no data
1624 constructors. It's still stupid, but does no harm, and I don't want
1625 to cause programs to break unnecessarily (notably HList). So if there
1626 are no data constructors we allow h98_style = True
1627 -}
1628
1629 depAnalTyClDecls :: [(LTyClDecl Name, FreeVars)] -> [SCC (LTyClDecl Name)]
1630 -- See Note [Dependency analysis of type and class decls]
1631 depAnalTyClDecls ds_w_fvs
1632 = stronglyConnCompFromEdgedVertices edges
1633 where
1634 edges = [ (d, tcdName (unLoc d), map get_parent (nameSetElems fvs))
1635 | (d, fvs) <- ds_w_fvs ]
1636
1637 -- We also need to consider data constructor names since
1638 -- they may appear in types because of promotion.
1639 get_parent n = lookupNameEnv assoc_env n `orElse` n
1640
1641 assoc_env :: NameEnv Name -- Maps a data constructor back
1642 -- to its parent type constructor
1643 assoc_env = mkNameEnv $ concat assoc_env_list
1644 assoc_env_list = do
1645 (L _ d, _) <- ds_w_fvs
1646 case d of
1647 ClassDecl { tcdLName = L _ cls_name
1648 , tcdATs = ats }
1649 -> do L _ (FamilyDecl { fdLName = L _ fam_name }) <- ats
1650 return [(fam_name, cls_name)]
1651 DataDecl { tcdLName = L _ data_name
1652 , tcdDataDefn = HsDataDefn { dd_cons = cons } }
1653 -> do L _ dc <- cons
1654 return $ zip (map unLoc $ getConNames dc) (repeat data_name)
1655 _ -> []
1656
1657 {-
1658 Note [Dependency analysis of type and class decls]
1659 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1660 We need to do dependency analysis on type and class declarations
1661 else we get bad error messages. Consider
1662
1663 data T f a = MkT f a
1664 data S f a = MkS f (T f a)
1665
1666 This has a kind error, but the error message is better if you
1667 check T first, (fixing its kind) and *then* S. If you do kind
1668 inference together, you might get an error reported in S, which
1669 is jolly confusing. See Trac #4875
1670
1671 Note [Role annotations in the renamer]
1672 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1673 We must ensure that a type's role annotation is put in the same group as the
1674 proper type declaration. This is because role annotations are needed during
1675 type-checking when creating the type's TyCon. So, rnRoleAnnots builds a
1676 NameEnv (LRoleAnnotDecl Name) that maps a name to a role annotation for that
1677 type, if any. Then, this map can be used to add the role annotations to the
1678 groups after dependency analysis.
1679
1680 This process checks for duplicate role annotations, where we must be careful
1681 to do the check *before* renaming to avoid calling all unbound names duplicates
1682 of one another.
1683
1684 The renaming process, as usual, might identify and report errors for unbound
1685 names. We exclude the annotations for unbound names in the annotation
1686 environment to avoid spurious errors for orphaned annotations.
1687
1688 We then (in rnTyClDecls) do a check for orphan role annotations (role
1689 annotations without an accompanying type decl). The check works by folding
1690 over raw_groups (of type [[TyClDecl Name]]), selecting out the relevant
1691 role declarations for each group, as well as diminishing the annotation
1692 environment. After the fold is complete, anything left over in the name
1693 environment must be an orphan, and errors are generated.
1694
1695 An earlier version of this algorithm short-cut the orphan check by renaming
1696 only with names declared in this module. But, this check is insufficient in
1697 the case of staged module compilation (Template Haskell, GHCi).
1698 See #8485. With the new lookup process (which includes types declared in other
1699 modules), we get better error messages, too.
1700
1701 *********************************************************
1702 * *
1703 \subsection{Support code for type/data declarations}
1704 * *
1705 *********************************************************
1706 -}
1707
1708 ---------------
1709 badAssocRhs :: [Name] -> RnM ()
1710 badAssocRhs ns
1711 = addErr (hang (text "The RHS of an associated type declaration mentions"
1712 <+> pprWithCommas (quotes . ppr) ns)
1713 2 (text "All such variables must be bound on the LHS"))
1714
1715 -----------------
1716 rnConDecls :: [LConDecl RdrName] -> RnM ([LConDecl Name], FreeVars)
1717 rnConDecls = mapFvRn (wrapLocFstM rnConDecl)
1718
1719 rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name, FreeVars)
1720 rnConDecl decl@(ConDeclH98 { con_name = name, con_qvars = qtvs
1721 , con_cxt = mcxt, con_details = details
1722 , con_doc = mb_doc })
1723 = do { _ <- addLocM checkConName name
1724 ; new_name <- lookupLocatedTopBndrRn name
1725 ; let doc = ConDeclCtx [new_name]
1726 ; mb_doc' <- rnMbLHsDoc mb_doc
1727 ; (kvs, qtvs') <- get_con_qtvs (hsConDeclArgTys details)
1728
1729 ; bindHsQTyVars doc (Just $ inHsDocContext doc) Nothing kvs qtvs' $
1730 \new_tyvars _ -> do
1731 { (new_context, fvs1) <- case mcxt of
1732 Nothing -> return (Nothing,emptyFVs)
1733 Just lcxt -> do { (lctx',fvs) <- rnContext doc lcxt
1734 ; return (Just lctx',fvs) }
1735 ; (new_details, fvs2) <- rnConDeclDetails (unLoc new_name) doc details
1736 ; let (new_details',fvs3) = (new_details,emptyFVs)
1737 ; traceRn (text "rnConDecl" <+> ppr name <+> vcat
1738 [ text "free_kvs:" <+> ppr kvs
1739 , text "qtvs:" <+> ppr qtvs
1740 , text "qtvs':" <+> ppr qtvs' ])
1741 ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3
1742 new_tyvars' = case qtvs of
1743 Nothing -> Nothing
1744 Just _ -> Just new_tyvars
1745 ; return (decl { con_name = new_name, con_qvars = new_tyvars'
1746 , con_cxt = new_context, con_details = new_details'
1747 , con_doc = mb_doc' },
1748 all_fvs) }}
1749 where
1750 cxt = maybe [] unLoc mcxt
1751 get_rdr_tvs tys = extractHsTysRdrTyVars (cxt ++ tys)
1752
1753 get_con_qtvs :: [LHsType RdrName]
1754 -> RnM ([Located RdrName], LHsQTyVars RdrName)
1755 get_con_qtvs arg_tys
1756 | Just tvs <- qtvs -- data T = forall a. MkT (a -> a)
1757 = do { free_vars <- get_rdr_tvs arg_tys
1758 ; return (freeKiTyVarsKindVars free_vars, tvs) }
1759 | otherwise -- data T = MkT (a -> a)
1760 = return ([], mkHsQTvs [])
1761
1762 rnConDecl decl@(ConDeclGADT { con_names = names, con_type = ty
1763 , con_doc = mb_doc })
1764 = do { mapM_ (addLocM checkConName) names
1765 ; new_names <- mapM lookupLocatedTopBndrRn names
1766 ; let doc = ConDeclCtx new_names
1767 ; mb_doc' <- rnMbLHsDoc mb_doc
1768
1769 ; (ty', fvs) <- rnHsSigType doc ty
1770 ; traceRn (text "rnConDecl" <+> ppr names <+> vcat
1771 [ text "fvs:" <+> ppr fvs ])
1772 ; return (decl { con_names = new_names, con_type = ty'
1773 , con_doc = mb_doc' },
1774 fvs) }
1775
1776 rnConDeclDetails
1777 :: Name
1778 -> HsDocContext
1779 -> HsConDetails (LHsType RdrName) (Located [LConDeclField RdrName])
1780 -> RnM (HsConDetails (LHsType Name) (Located [LConDeclField Name]), FreeVars)
1781 rnConDeclDetails _ doc (PrefixCon tys)
1782 = do { (new_tys, fvs) <- rnLHsTypes doc tys
1783 ; return (PrefixCon new_tys, fvs) }
1784
1785 rnConDeclDetails _ doc (InfixCon ty1 ty2)
1786 = do { (new_ty1, fvs1) <- rnLHsType doc ty1
1787 ; (new_ty2, fvs2) <- rnLHsType doc ty2
1788 ; return (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2) }
1789
1790 rnConDeclDetails con doc (RecCon (L l fields))
1791 = do { fls <- lookupConstructorFields con
1792 ; (new_fields, fvs) <- rnConDeclFields doc fls fields
1793 -- No need to check for duplicate fields
1794 -- since that is done by RnNames.extendGlobalRdrEnvRn
1795 ; return (RecCon (L l new_fields), fvs) }
1796
1797 -------------------------------------------------
1798
1799 -- | Brings pattern synonym names and also pattern synonym selectors
1800 -- from record pattern synonyms into scope.
1801 extendPatSynEnv :: HsValBinds RdrName -> MiniFixityEnv
1802 -> ([Name] -> TcRnIf TcGblEnv TcLclEnv a) -> TcM a
1803 extendPatSynEnv val_decls local_fix_env thing = do {
1804 names_with_fls <- new_ps val_decls
1805 ; let pat_syn_bndrs =
1806 concat [name: map flSelector fields | (name, fields) <- names_with_fls]
1807 ; let avails = map patSynAvail pat_syn_bndrs
1808 ; (gbl_env, lcl_env) <-
1809 extendGlobalRdrEnvRn avails local_fix_env
1810
1811
1812 ; let field_env' = extendNameEnvList (tcg_field_env gbl_env) names_with_fls
1813 final_gbl_env = gbl_env { tcg_field_env = field_env' }
1814 ; setEnvs (final_gbl_env, lcl_env) (thing pat_syn_bndrs) }
1815 where
1816 new_ps :: HsValBinds RdrName -> TcM [(Name, [FieldLabel])]
1817 new_ps (ValBindsIn binds _) = foldrBagM new_ps' [] binds
1818 new_ps _ = panic "new_ps"
1819
1820 new_ps' :: LHsBindLR RdrName RdrName
1821 -> [(Name, [FieldLabel])]
1822 -> TcM [(Name, [FieldLabel])]
1823 new_ps' bind names
1824 | L bind_loc (PatSynBind (PSB { psb_id = L _ n
1825 , psb_args = RecordPatSyn as })) <- bind
1826 = do
1827 bnd_name <- newTopSrcBinder (L bind_loc n)
1828 let rnames = map recordPatSynSelectorId as
1829 mkFieldOcc :: Located RdrName -> LFieldOcc RdrName
1830 mkFieldOcc (L l name) = L l (FieldOcc (L l name) PlaceHolder)
1831 field_occs = map mkFieldOcc rnames
1832 flds <- mapM (newRecordSelector False [bnd_name]) field_occs
1833 return ((bnd_name, flds): names)
1834 | L bind_loc (PatSynBind (PSB { psb_id = L _ n})) <- bind
1835 = do
1836 bnd_name <- newTopSrcBinder (L bind_loc n)
1837 return ((bnd_name, []): names)
1838 | otherwise
1839 = return names
1840
1841 {-
1842 *********************************************************
1843 * *
1844 \subsection{Support code to rename types}
1845 * *
1846 *********************************************************
1847 -}
1848
1849 rnFds :: [Located (FunDep (Located RdrName))]
1850 -> RnM [Located (FunDep (Located Name))]
1851 rnFds fds
1852 = mapM (wrapLocM rn_fds) fds
1853 where
1854 rn_fds (tys1, tys2)
1855 = do { tys1' <- rnHsTyVars tys1
1856 ; tys2' <- rnHsTyVars tys2
1857 ; return (tys1', tys2') }
1858
1859 rnHsTyVars :: [Located RdrName] -> RnM [Located Name]
1860 rnHsTyVars tvs = mapM rnHsTyVar tvs
1861
1862 rnHsTyVar :: Located RdrName -> RnM (Located Name)
1863 rnHsTyVar (L l tyvar) = do
1864 tyvar' <- lookupOccRn tyvar
1865 return (L l tyvar')
1866
1867 {-
1868 *********************************************************
1869 * *
1870 findSplice
1871 * *
1872 *********************************************************
1873
1874 This code marches down the declarations, looking for the first
1875 Template Haskell splice. As it does so it
1876 a) groups the declarations into a HsGroup
1877 b) runs any top-level quasi-quotes
1878 -}
1879
1880 findSplice :: [LHsDecl RdrName] -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName]))
1881 findSplice ds = addl emptyRdrGroup ds
1882
1883 addl :: HsGroup RdrName -> [LHsDecl RdrName]
1884 -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName]))
1885 -- This stuff reverses the declarations (again) but it doesn't matter
1886 addl gp [] = return (gp, Nothing)
1887 addl gp (L l d : ds) = add gp l d ds
1888
1889
1890 add :: HsGroup RdrName -> SrcSpan -> HsDecl RdrName -> [LHsDecl RdrName]
1891 -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName]))
1892
1893 -- #10047: Declaration QuasiQuoters are expanded immediately, without
1894 -- causing a group split
1895 add gp _ (SpliceD (SpliceDecl (L _ qq@HsQuasiQuote{}) _)) ds
1896 = do { (ds', _) <- rnTopSpliceDecls qq
1897 ; addl gp (ds' ++ ds)
1898 }
1899
1900 add gp loc (SpliceD splice@(SpliceDecl _ flag)) ds
1901 = do { -- We've found a top-level splice. If it is an *implicit* one
1902 -- (i.e. a naked top level expression)
1903 case flag of
1904 ExplicitSplice -> return ()
1905 ImplicitSplice -> do { th_on <- xoptM LangExt.TemplateHaskell
1906 ; unless th_on $ setSrcSpan loc $
1907 failWith badImplicitSplice }
1908
1909 ; return (gp, Just (splice, ds)) }
1910 where
1911 badImplicitSplice = text "Parse error: naked expression at top level"
1912 $$ text "Perhaps you intended to use TemplateHaskell"
1913
1914 -- Class declarations: pull out the fixity signatures to the top
1915 add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD d) ds
1916 | isClassDecl d
1917 = let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in
1918 addl (gp { hs_tyclds = add_tycld (L l d) ts, hs_fixds = fsigs ++ fs}) ds
1919 | otherwise
1920 = addl (gp { hs_tyclds = add_tycld (L l d) ts }) ds
1921
1922 -- Signatures: fixity sigs go a different place than all others
1923 add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds
1924 = addl (gp {hs_fixds = L l f : ts}) ds
1925 add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds
1926 = addl (gp {hs_valds = add_sig (L l d) ts}) ds
1927
1928 -- Value declarations: use add_bind
1929 add gp@(HsGroup {hs_valds = ts}) l (ValD d) ds
1930 = addl (gp { hs_valds = add_bind (L l d) ts }) ds
1931
1932 -- Role annotations: added to the TyClGroup
1933 add gp@(HsGroup {hs_tyclds = ts}) l (RoleAnnotD d) ds
1934 = addl (gp { hs_tyclds = add_role_annot (L l d) ts }) ds
1935
1936 -- The rest are routine
1937 add gp@(HsGroup {hs_instds = ts}) l (InstD d) ds
1938 = addl (gp { hs_instds = L l d : ts }) ds
1939 add gp@(HsGroup {hs_derivds = ts}) l (DerivD d) ds
1940 = addl (gp { hs_derivds = L l d : ts }) ds
1941 add gp@(HsGroup {hs_defds = ts}) l (DefD d) ds
1942 = addl (gp { hs_defds = L l d : ts }) ds
1943 add gp@(HsGroup {hs_fords = ts}) l (ForD d) ds
1944 = addl (gp { hs_fords = L l d : ts }) ds
1945 add gp@(HsGroup {hs_warnds = ts}) l (WarningD d) ds
1946 = addl (gp { hs_warnds = L l d : ts }) ds
1947 add gp@(HsGroup {hs_annds = ts}) l (AnnD d) ds
1948 = addl (gp { hs_annds = L l d : ts }) ds
1949 add gp@(HsGroup {hs_ruleds = ts}) l (RuleD d) ds
1950 = addl (gp { hs_ruleds = L l d : ts }) ds
1951 add gp@(HsGroup {hs_vects = ts}) l (VectD d) ds
1952 = addl (gp { hs_vects = L l d : ts }) ds
1953 add gp l (DocD d) ds
1954 = addl (gp { hs_docs = (L l d) : (hs_docs gp) }) ds
1955
1956 add_tycld :: LTyClDecl a -> [TyClGroup a] -> [TyClGroup a]
1957 add_tycld d [] = [TyClGroup { group_tyclds = [d], group_roles = [] }]
1958 add_tycld d (ds@(TyClGroup { group_tyclds = tyclds }):dss)
1959 = ds { group_tyclds = d : tyclds } : dss
1960
1961 add_role_annot :: LRoleAnnotDecl a -> [TyClGroup a] -> [TyClGroup a]
1962 add_role_annot d [] = [TyClGroup { group_tyclds = [], group_roles = [d] }]
1963 add_role_annot d (tycls@(TyClGroup { group_roles = roles }) : rest)
1964 = tycls { group_roles = d : roles } : rest
1965
1966 add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a
1967 add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs
1968 add_bind _ (ValBindsOut {}) = panic "RdrHsSyn:add_bind"
1969
1970 add_sig :: LSig a -> HsValBinds a -> HsValBinds a
1971 add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs)
1972 add_sig _ (ValBindsOut {}) = panic "RdrHsSyn:add_sig"