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