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