SCC analysis for instances as well as types/classes
[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 = foldNameSet ((||) . nameIsHomePackageImport this_mod)
1424 False fvs
1425 ; return (add_boot_deps ds_w_fvs) }
1426
1427
1428
1429 {- ******************************************************
1430 * *
1431 Role annotations
1432 * *
1433 ****************************************************** -}
1434
1435 -- | Renames role annotations, returning them as the values in a NameEnv
1436 -- and checks for duplicate role annotations.
1437 -- It is quite convenient to do both of these in the same place.
1438 -- See also Note [Role annotations in the renamer]
1439 rnRoleAnnots :: NameSet
1440 -> [LRoleAnnotDecl RdrName]
1441 -> RnM [LRoleAnnotDecl Name]
1442 rnRoleAnnots tc_names role_annots
1443 = do { -- Check for duplicates *before* renaming, to avoid
1444 -- lumping together all the unboundNames
1445 let (no_dups, dup_annots) = removeDups role_annots_cmp role_annots
1446 role_annots_cmp (L _ annot1) (L _ annot2)
1447 = roleAnnotDeclName annot1 `compare` roleAnnotDeclName annot2
1448 ; mapM_ dupRoleAnnotErr dup_annots
1449 ; mapM (wrapLocM rn_role_annot1) no_dups }
1450 where
1451 rn_role_annot1 (RoleAnnotDecl tycon roles)
1452 = do { -- the name is an *occurrence*, but look it up only in the
1453 -- decls defined in this group (see #10263)
1454 tycon' <- lookupSigCtxtOccRn (RoleAnnotCtxt tc_names)
1455 (text "role annotation")
1456 tycon
1457 ; return $ RoleAnnotDecl tycon' roles }
1458
1459 dupRoleAnnotErr :: [LRoleAnnotDecl RdrName] -> RnM ()
1460 dupRoleAnnotErr [] = panic "dupRoleAnnotErr"
1461 dupRoleAnnotErr list
1462 = addErrAt loc $
1463 hang (text "Duplicate role annotations for" <+>
1464 quotes (ppr $ roleAnnotDeclName first_decl) <> colon)
1465 2 (vcat $ map pp_role_annot sorted_list)
1466 where
1467 sorted_list = sortBy cmp_annot list
1468 (L loc first_decl : _) = sorted_list
1469
1470 pp_role_annot (L loc decl) = hang (ppr decl)
1471 4 (text "-- written at" <+> ppr loc)
1472
1473 cmp_annot (L loc1 _) (L loc2 _) = loc1 `compare` loc2
1474
1475 orphanRoleAnnotErr :: LRoleAnnotDecl Name -> RnM ()
1476 orphanRoleAnnotErr (L loc decl)
1477 = addErrAt loc $
1478 hang (text "Role annotation for a type previously declared:")
1479 2 (ppr decl) $$
1480 parens (text "The role annotation must be given where" <+>
1481 quotes (ppr $ roleAnnotDeclName decl) <+>
1482 text "is declared.")
1483
1484
1485 {- Note [Role annotations in the renamer]
1486 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1487 We must ensure that a type's role annotation is put in the same group as the
1488 proper type declaration. This is because role annotations are needed during
1489 type-checking when creating the type's TyCon. So, rnRoleAnnots builds a
1490 NameEnv (LRoleAnnotDecl Name) that maps a name to a role annotation for that
1491 type, if any. Then, this map can be used to add the role annotations to the
1492 groups after dependency analysis.
1493
1494 This process checks for duplicate role annotations, where we must be careful
1495 to do the check *before* renaming to avoid calling all unbound names duplicates
1496 of one another.
1497
1498 The renaming process, as usual, might identify and report errors for unbound
1499 names. We exclude the annotations for unbound names in the annotation
1500 environment to avoid spurious errors for orphaned annotations.
1501
1502 We then (in rnTyClDecls) do a check for orphan role annotations (role
1503 annotations without an accompanying type decl). The check works by folding
1504 over components (of type [[Either (TyClDecl Name) (InstDecl Name)]]), selecting
1505 out the relevant role declarations for each group, as well as diminishing the
1506 annotation environment. After the fold is complete, anything left over in the
1507 name environment must be an orphan, and errors are generated.
1508
1509 An earlier version of this algorithm short-cut the orphan check by renaming
1510 only with names declared in this module. But, this check is insufficient in
1511 the case of staged module compilation (Template Haskell, GHCi).
1512 See #8485. With the new lookup process (which includes types declared in other
1513 modules), we get better error messages, too.
1514 -}
1515
1516
1517 {- ******************************************************
1518 * *
1519 Dependency info for instances
1520 * *
1521 ****************************************************** -}
1522
1523 ----------------------------------------------------------
1524 -- | 'InstDeclFreeVarsMap is an association of an
1525 -- @InstDecl@ with @FreeVars@. The @FreeVars@ are
1526 -- the names that are
1527 -- a) free in the instance declaration
1528 -- b) bound by this group of type/class/instance decls
1529 type InstDeclFreeVarsMap = [(LInstDecl Name, FreeVars)]
1530
1531 -- | Construct an @InstDeclFreeVarsMap@ by eliminating any @Name@s from the
1532 -- @FreeVars@ which are *not* the binders of a @TyClDecl@.
1533 mkInstDeclFreeVarsMap :: GlobalRdrEnv
1534 -> NameSet
1535 -> [(LInstDecl Name, FreeVars)]
1536 -> InstDeclFreeVarsMap
1537 mkInstDeclFreeVarsMap rdr_env tycl_bndrs inst_ds_fvs
1538 = [ (inst_decl, toParents rdr_env fvs `intersectFVs` tycl_bndrs)
1539 | (inst_decl, fvs) <- inst_ds_fvs ]
1540
1541 -- | Get the @LInstDecl@s which have empty @FreeVars@ sets, and the
1542 -- @InstDeclFreeVarsMap@ with these entries removed.
1543 getInsts :: [Name] -> InstDeclFreeVarsMap -> ([LInstDecl Name], InstDeclFreeVarsMap)
1544 getInsts bndrs inst_decl_map
1545 = partitionWith pick_me inst_decl_map
1546 where
1547 pick_me :: (LInstDecl Name, FreeVars)
1548 -> Either (LInstDecl Name) (LInstDecl Name, FreeVars)
1549 pick_me (decl, fvs)
1550 | isEmptyNameSet depleted_fvs = Left decl
1551 | otherwise = Right (decl, depleted_fvs)
1552 where
1553 depleted_fvs = delFVs bndrs fvs
1554
1555 {- ******************************************************
1556 * *
1557 Renaming a type or class declaration
1558 * *
1559 ****************************************************** -}
1560
1561 rnTyClDecl :: TyClDecl RdrName
1562 -> RnM (TyClDecl Name, FreeVars)
1563
1564 -- All flavours of type family declarations ("type family", "newtype family",
1565 -- and "data family"), both top level and (for an associated type)
1566 -- in a class decl
1567 rnTyClDecl (FamDecl { tcdFam = decl })
1568 = do { (decl', fvs) <- rnFamDecl Nothing decl
1569 ; return (FamDecl decl', fvs) }
1570
1571 rnTyClDecl (SynDecl { tcdLName = tycon, tcdTyVars = tyvars, tcdRhs = rhs })
1572 = do { tycon' <- lookupLocatedTopBndrRn tycon
1573 ; kvs <- freeKiTyVarsKindVars <$> extractHsTyRdrTyVars rhs
1574 ; let doc = TySynCtx tycon
1575 ; traceRn (text "rntycl-ty" <+> ppr tycon <+> ppr kvs)
1576 ; ((tyvars', rhs'), fvs) <- bindHsQTyVars doc Nothing Nothing kvs tyvars $
1577 \ tyvars' _ ->
1578 do { (rhs', fvs) <- rnTySyn doc rhs
1579 ; return ((tyvars', rhs'), fvs) }
1580 ; return (SynDecl { tcdLName = tycon', tcdTyVars = tyvars'
1581 , tcdRhs = rhs', tcdFVs = fvs }, fvs) }
1582
1583 -- "data", "newtype" declarations
1584 -- both top level and (for an associated type) in an instance decl
1585 rnTyClDecl (DataDecl { tcdLName = tycon, tcdTyVars = tyvars, tcdDataDefn = defn })
1586 = do { tycon' <- lookupLocatedTopBndrRn tycon
1587 ; kvs <- extractDataDefnKindVars defn
1588 ; let doc = TyDataCtx tycon
1589 ; traceRn (text "rntycl-data" <+> ppr tycon <+> ppr kvs)
1590 ; ((tyvars', defn', no_kvs), fvs)
1591 <- bindHsQTyVars doc Nothing Nothing kvs tyvars $ \ tyvars' dep_vars ->
1592 do { ((defn', kind_sig_fvs), fvs) <- rnDataDefn doc defn
1593 ; let sig_tvs = filterNameSet isTyVarName kind_sig_fvs
1594 unbound_sig_tvs = sig_tvs `minusNameSet` dep_vars
1595 ; return ((tyvars', defn', isEmptyNameSet unbound_sig_tvs), fvs) }
1596 -- See Note [Complete user-supplied kind signatures] in HsDecls
1597 ; typeintype <- xoptM LangExt.TypeInType
1598 ; let cusk = hsTvbAllKinded tyvars' &&
1599 (not typeintype || no_kvs)
1600 ; return (DataDecl { tcdLName = tycon', tcdTyVars = tyvars'
1601 , tcdDataDefn = defn', tcdDataCusk = cusk
1602 , tcdFVs = fvs }, fvs) }
1603
1604 rnTyClDecl (ClassDecl { tcdCtxt = context, tcdLName = lcls,
1605 tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs,
1606 tcdMeths = mbinds, tcdATs = ats, tcdATDefs = at_defs,
1607 tcdDocs = docs})
1608 = do { lcls' <- lookupLocatedTopBndrRn lcls
1609 ; let cls' = unLoc lcls'
1610 kvs = [] -- No scoped kind vars except those in
1611 -- kind signatures on the tyvars
1612
1613 -- Tyvars scope over superclass context and method signatures
1614 ; ((tyvars', context', fds', ats'), stuff_fvs)
1615 <- bindHsQTyVars cls_doc Nothing Nothing kvs tyvars $ \ tyvars' _ -> do
1616 -- Checks for distinct tyvars
1617 { (context', cxt_fvs) <- rnContext cls_doc context
1618 ; fds' <- rnFds fds
1619 -- The fundeps have no free variables
1620 ; (ats', fv_ats) <- rnATDecls cls' ats
1621 ; let fvs = cxt_fvs `plusFV`
1622 fv_ats
1623 ; return ((tyvars', context', fds', ats'), fvs) }
1624
1625 ; (at_defs', fv_at_defs) <- rnList (rnTyFamDefltEqn cls') at_defs
1626
1627 -- No need to check for duplicate associated type decls
1628 -- since that is done by RnNames.extendGlobalRdrEnvRn
1629
1630 -- Check the signatures
1631 -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).
1632 ; let sig_rdr_names_w_locs = [op | L _ (ClassOpSig False ops _) <- sigs
1633 , op <- ops]
1634 ; checkDupRdrNames sig_rdr_names_w_locs
1635 -- Typechecker is responsible for checking that we only
1636 -- give default-method bindings for things in this class.
1637 -- The renamer *could* check this for class decls, but can't
1638 -- for instance decls.
1639
1640 -- The newLocals call is tiresome: given a generic class decl
1641 -- class C a where
1642 -- op :: a -> a
1643 -- op {| x+y |} (Inl a) = ...
1644 -- op {| x+y |} (Inr b) = ...
1645 -- op {| a*b |} (a*b) = ...
1646 -- we want to name both "x" tyvars with the same unique, so that they are
1647 -- easy to group together in the typechecker.
1648 ; (mbinds', sigs', meth_fvs)
1649 <- rnMethodBinds True cls' (hsAllLTyVarNames tyvars') mbinds sigs
1650 -- No need to check for duplicate method signatures
1651 -- since that is done by RnNames.extendGlobalRdrEnvRn
1652 -- and the methods are already in scope
1653
1654 -- Haddock docs
1655 ; docs' <- mapM (wrapLocM rnDocDecl) docs
1656
1657 ; let all_fvs = meth_fvs `plusFV` stuff_fvs `plusFV` fv_at_defs
1658 ; return (ClassDecl { tcdCtxt = context', tcdLName = lcls',
1659 tcdTyVars = tyvars', tcdFDs = fds', tcdSigs = sigs',
1660 tcdMeths = mbinds', tcdATs = ats', tcdATDefs = at_defs',
1661 tcdDocs = docs', tcdFVs = all_fvs },
1662 all_fvs ) }
1663 where
1664 cls_doc = ClassDeclCtx lcls
1665
1666 -- "type" and "type instance" declarations
1667 rnTySyn :: HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
1668 rnTySyn doc rhs = rnLHsType doc rhs
1669
1670 rnDataDefn :: HsDocContext -> HsDataDefn RdrName
1671 -> RnM ((HsDataDefn Name, NameSet), FreeVars)
1672 -- the NameSet includes all Names free in the kind signature
1673 -- See Note [Complete user-supplied kind signatures]
1674 rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType
1675 , dd_ctxt = context, dd_cons = condecls
1676 , dd_kindSig = m_sig, dd_derivs = derivs })
1677 = do { checkTc (h98_style || null (unLoc context))
1678 (badGadtStupidTheta doc)
1679
1680 ; (m_sig', sig_fvs) <- case m_sig of
1681 Just sig -> first Just <$> rnLHsKind doc sig
1682 Nothing -> return (Nothing, emptyFVs)
1683 ; (context', fvs1) <- rnContext doc context
1684 ; (derivs', fvs3) <- rn_derivs derivs
1685
1686 -- For the constructor declarations, drop the LocalRdrEnv
1687 -- in the GADT case, where the type variables in the declaration
1688 -- do not scope over the constructor signatures
1689 -- data T a where { T1 :: forall b. b-> b }
1690 ; let { zap_lcl_env | h98_style = \ thing -> thing
1691 | otherwise = setLocalRdrEnv emptyLocalRdrEnv }
1692 ; (condecls', con_fvs) <- zap_lcl_env $ rnConDecls condecls
1693 -- No need to check for duplicate constructor decls
1694 -- since that is done by RnNames.extendGlobalRdrEnvRn
1695
1696 ; let all_fvs = fvs1 `plusFV` fvs3 `plusFV`
1697 con_fvs `plusFV` sig_fvs
1698 ; return (( HsDataDefn { dd_ND = new_or_data, dd_cType = cType
1699 , dd_ctxt = context', dd_kindSig = m_sig'
1700 , dd_cons = condecls'
1701 , dd_derivs = derivs' }
1702 , sig_fvs )
1703 , all_fvs )
1704 }
1705 where
1706 h98_style = case condecls of -- Note [Stupid theta]
1707 L _ (ConDeclGADT {}) : _ -> False
1708 _ -> True
1709
1710 rn_derivs Nothing
1711 = return (Nothing, emptyFVs)
1712 rn_derivs (Just (L loc ds))
1713 = do { (ds', fvs) <- mapFvRn (rnHsSigType doc) ds
1714 ; return (Just (L loc ds'), fvs) }
1715
1716 badGadtStupidTheta :: HsDocContext -> SDoc
1717 badGadtStupidTheta _
1718 = vcat [text "No context is allowed on a GADT-style data declaration",
1719 text "(You can put a context on each contructor, though.)"]
1720
1721 rnFamDecl :: Maybe Name -- Just cls => this FamilyDecl is nested
1722 -- inside an *class decl* for cls
1723 -- used for associated types
1724 -> FamilyDecl RdrName
1725 -> RnM (FamilyDecl Name, FreeVars)
1726 rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars
1727 , fdInfo = info, fdResultSig = res_sig
1728 , fdInjectivityAnn = injectivity })
1729 = do { tycon' <- lookupLocatedTopBndrRn tycon
1730 ; kvs <- extractRdrKindSigVars res_sig
1731 ; ((tyvars', res_sig', injectivity'), fv1) <-
1732 bindHsQTyVars doc Nothing mb_cls kvs tyvars $
1733 \ tyvars'@(HsQTvs { hsq_implicit = rn_kvs }) _ ->
1734 do { let rn_sig = rnFamResultSig doc rn_kvs
1735 ; (res_sig', fv_kind) <- wrapLocFstM rn_sig res_sig
1736 ; injectivity' <- traverse (rnInjectivityAnn tyvars' res_sig')
1737 injectivity
1738 ; return ( (tyvars', res_sig', injectivity') , fv_kind ) }
1739 ; (info', fv2) <- rn_info info
1740 ; return (FamilyDecl { fdLName = tycon', fdTyVars = tyvars'
1741 , fdInfo = info', fdResultSig = res_sig'
1742 , fdInjectivityAnn = injectivity' }
1743 , fv1 `plusFV` fv2) }
1744 where
1745 doc = TyFamilyCtx tycon
1746
1747 ----------------------
1748 rn_info (ClosedTypeFamily (Just eqns))
1749 = do { (eqns', fvs) <- rnList (rnTyFamInstEqn Nothing) eqns
1750 -- no class context,
1751 ; return (ClosedTypeFamily (Just eqns'), fvs) }
1752 rn_info (ClosedTypeFamily Nothing)
1753 = return (ClosedTypeFamily Nothing, emptyFVs)
1754 rn_info OpenTypeFamily = return (OpenTypeFamily, emptyFVs)
1755 rn_info DataFamily = return (DataFamily, emptyFVs)
1756
1757 rnFamResultSig :: HsDocContext
1758 -> [Name] -- kind variables already in scope
1759 -> FamilyResultSig RdrName
1760 -> RnM (FamilyResultSig Name, FreeVars)
1761 rnFamResultSig _ _ NoSig
1762 = return (NoSig, emptyFVs)
1763 rnFamResultSig doc _ (KindSig kind)
1764 = do { (rndKind, ftvs) <- rnLHsKind doc kind
1765 ; return (KindSig rndKind, ftvs) }
1766 rnFamResultSig doc kv_names (TyVarSig tvbndr)
1767 = do { -- `TyVarSig` tells us that user named the result of a type family by
1768 -- writing `= tyvar` or `= (tyvar :: kind)`. In such case we want to
1769 -- be sure that the supplied result name is not identical to an
1770 -- already in-scope type variable from an enclosing class.
1771 --
1772 -- Example of disallowed declaration:
1773 -- class C a b where
1774 -- type F b = a | a -> b
1775 rdr_env <- getLocalRdrEnv
1776 ; let resName = hsLTyVarName tvbndr
1777 ; when (resName `elemLocalRdrEnv` rdr_env) $
1778 addErrAt (getLoc tvbndr) $
1779 (hsep [ text "Type variable", quotes (ppr resName) <> comma
1780 , text "naming a type family result,"
1781 ] $$
1782 text "shadows an already bound type variable")
1783
1784 ; bindLHsTyVarBndr doc Nothing -- this might be a lie, but it's used for
1785 -- scoping checks that are irrelevant here
1786 (mkNameSet kv_names) emptyNameSet
1787 -- use of emptyNameSet here avoids
1788 -- redundant duplicate errors
1789 tvbndr $ \ _ _ tvbndr' ->
1790 return (TyVarSig tvbndr', unitFV (hsLTyVarName tvbndr')) }
1791
1792 -- Note [Renaming injectivity annotation]
1793 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1794 --
1795 -- During renaming of injectivity annotation we have to make several checks to
1796 -- make sure that it is well-formed. At the moment injectivity annotation
1797 -- consists of a single injectivity condition, so the terms "injectivity
1798 -- annotation" and "injectivity condition" might be used interchangeably. See
1799 -- Note [Injectivity annotation] for a detailed discussion of currently allowed
1800 -- injectivity annotations.
1801 --
1802 -- Checking LHS is simple because the only type variable allowed on the LHS of
1803 -- injectivity condition is the variable naming the result in type family head.
1804 -- Example of disallowed annotation:
1805 --
1806 -- type family Foo a b = r | b -> a
1807 --
1808 -- Verifying RHS of injectivity consists of checking that:
1809 --
1810 -- 1. only variables defined in type family head appear on the RHS (kind
1811 -- variables are also allowed). Example of disallowed annotation:
1812 --
1813 -- type family Foo a = r | r -> b
1814 --
1815 -- 2. for associated types the result variable does not shadow any of type
1816 -- class variables. Example of disallowed annotation:
1817 --
1818 -- class Foo a b where
1819 -- type F a = b | b -> a
1820 --
1821 -- Breaking any of these assumptions results in an error.
1822
1823 -- | Rename injectivity annotation. Note that injectivity annotation is just the
1824 -- part after the "|". Everything that appears before it is renamed in
1825 -- rnFamDecl.
1826 rnInjectivityAnn :: LHsQTyVars Name -- ^ Type variables declared in
1827 -- type family head
1828 -> LFamilyResultSig Name -- ^ Result signature
1829 -> LInjectivityAnn RdrName -- ^ Injectivity annotation
1830 -> RnM (LInjectivityAnn Name)
1831 rnInjectivityAnn tvBndrs (L _ (TyVarSig resTv))
1832 (L srcSpan (InjectivityAnn injFrom injTo))
1833 = do
1834 { (injDecl'@(L _ (InjectivityAnn injFrom' injTo')), noRnErrors)
1835 <- askNoErrs $
1836 bindLocalNames [hsLTyVarName resTv] $
1837 -- The return type variable scopes over the injectivity annotation
1838 -- e.g. type family F a = (r::*) | r -> a
1839 do { injFrom' <- rnLTyVar injFrom
1840 ; injTo' <- mapM rnLTyVar injTo
1841 ; return $ L srcSpan (InjectivityAnn injFrom' injTo') }
1842
1843 ; let tvNames = Set.fromList $ hsAllLTyVarNames tvBndrs
1844 resName = hsLTyVarName resTv
1845 -- See Note [Renaming injectivity annotation]
1846 lhsValid = EQ == (stableNameCmp resName (unLoc injFrom'))
1847 rhsValid = Set.fromList (map unLoc injTo') `Set.difference` tvNames
1848
1849 -- if renaming of type variables ended with errors (eg. there were
1850 -- not-in-scope variables) don't check the validity of injectivity
1851 -- annotation. This gives better error messages.
1852 ; when (noRnErrors && not lhsValid) $
1853 addErrAt (getLoc injFrom)
1854 ( vcat [ text $ "Incorrect type variable on the LHS of "
1855 ++ "injectivity condition"
1856 , nest 5
1857 ( vcat [ text "Expected :" <+> ppr resName
1858 , text "Actual :" <+> ppr injFrom ])])
1859
1860 ; when (noRnErrors && not (Set.null rhsValid)) $
1861 do { let errorVars = Set.toList rhsValid
1862 ; addErrAt srcSpan $ ( hsep
1863 [ text "Unknown type variable" <> plural errorVars
1864 , text "on the RHS of injectivity condition:"
1865 , interpp'SP errorVars ] ) }
1866
1867 ; return injDecl' }
1868
1869 -- We can only hit this case when the user writes injectivity annotation without
1870 -- naming the result:
1871 --
1872 -- type family F a | result -> a
1873 -- type family F a :: * | result -> a
1874 --
1875 -- So we rename injectivity annotation like we normally would except that
1876 -- this time we expect "result" to be reported not in scope by rnLTyVar.
1877 rnInjectivityAnn _ _ (L srcSpan (InjectivityAnn injFrom injTo)) =
1878 setSrcSpan srcSpan $ do
1879 (injDecl', _) <- askNoErrs $ do
1880 injFrom' <- rnLTyVar injFrom
1881 injTo' <- mapM rnLTyVar injTo
1882 return $ L srcSpan (InjectivityAnn injFrom' injTo')
1883 return $ injDecl'
1884
1885 {-
1886 Note [Stupid theta]
1887 ~~~~~~~~~~~~~~~~~~~
1888 Trac #3850 complains about a regression wrt 6.10 for
1889 data Show a => T a
1890 There is no reason not to allow the stupid theta if there are no data
1891 constructors. It's still stupid, but does no harm, and I don't want
1892 to cause programs to break unnecessarily (notably HList). So if there
1893 are no data constructors we allow h98_style = True
1894 -}
1895
1896
1897 {- *****************************************************
1898 * *
1899 Support code for type/data declarations
1900 * *
1901 ***************************************************** -}
1902
1903 ---------------
1904 badAssocRhs :: [Name] -> RnM ()
1905 badAssocRhs ns
1906 = addErr (hang (text "The RHS of an associated type declaration mentions"
1907 <+> pprWithCommas (quotes . ppr) ns)
1908 2 (text "All such variables must be bound on the LHS"))
1909
1910 -----------------
1911 rnConDecls :: [LConDecl RdrName] -> RnM ([LConDecl Name], FreeVars)
1912 rnConDecls = mapFvRn (wrapLocFstM rnConDecl)
1913
1914 rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name, FreeVars)
1915 rnConDecl decl@(ConDeclH98 { con_name = name, con_qvars = qtvs
1916 , con_cxt = mcxt, con_details = details
1917 , con_doc = mb_doc })
1918 = do { _ <- addLocM checkConName name
1919 ; new_name <- lookupLocatedTopBndrRn name
1920 ; let doc = ConDeclCtx [new_name]
1921 ; mb_doc' <- rnMbLHsDoc mb_doc
1922 ; (kvs, qtvs') <- get_con_qtvs (hsConDeclArgTys details)
1923
1924 ; bindHsQTyVars doc (Just $ inHsDocContext doc) Nothing kvs qtvs' $
1925 \new_tyvars _ -> do
1926 { (new_context, fvs1) <- case mcxt of
1927 Nothing -> return (Nothing,emptyFVs)
1928 Just lcxt -> do { (lctx',fvs) <- rnContext doc lcxt
1929 ; return (Just lctx',fvs) }
1930 ; (new_details, fvs2) <- rnConDeclDetails (unLoc new_name) doc details
1931 ; let (new_details',fvs3) = (new_details,emptyFVs)
1932 ; traceRn (text "rnConDecl" <+> ppr name <+> vcat
1933 [ text "free_kvs:" <+> ppr kvs
1934 , text "qtvs:" <+> ppr qtvs
1935 , text "qtvs':" <+> ppr qtvs' ])
1936 ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3
1937 new_tyvars' = case qtvs of
1938 Nothing -> Nothing
1939 Just _ -> Just new_tyvars
1940 ; return (decl { con_name = new_name, con_qvars = new_tyvars'
1941 , con_cxt = new_context, con_details = new_details'
1942 , con_doc = mb_doc' },
1943 all_fvs) }}
1944 where
1945 cxt = maybe [] unLoc mcxt
1946 get_rdr_tvs tys = extractHsTysRdrTyVars (cxt ++ tys)
1947
1948 get_con_qtvs :: [LHsType RdrName]
1949 -> RnM ([Located RdrName], LHsQTyVars RdrName)
1950 get_con_qtvs arg_tys
1951 | Just tvs <- qtvs -- data T = forall a. MkT (a -> a)
1952 = do { free_vars <- get_rdr_tvs arg_tys
1953 ; return (freeKiTyVarsKindVars free_vars, tvs) }
1954 | otherwise -- data T = MkT (a -> a)
1955 = return ([], mkHsQTvs [])
1956
1957 rnConDecl decl@(ConDeclGADT { con_names = names, con_type = ty
1958 , con_doc = mb_doc })
1959 = do { mapM_ (addLocM checkConName) names
1960 ; new_names <- mapM lookupLocatedTopBndrRn names
1961 ; let doc = ConDeclCtx new_names
1962 ; mb_doc' <- rnMbLHsDoc mb_doc
1963
1964 ; (ty', fvs) <- rnHsSigType doc ty
1965 ; traceRn (text "rnConDecl" <+> ppr names <+> vcat
1966 [ text "fvs:" <+> ppr fvs ])
1967 ; return (decl { con_names = new_names, con_type = ty'
1968 , con_doc = mb_doc' },
1969 fvs) }
1970
1971 rnConDeclDetails
1972 :: Name
1973 -> HsDocContext
1974 -> HsConDetails (LHsType RdrName) (Located [LConDeclField RdrName])
1975 -> RnM (HsConDetails (LHsType Name) (Located [LConDeclField Name]), FreeVars)
1976 rnConDeclDetails _ doc (PrefixCon tys)
1977 = do { (new_tys, fvs) <- rnLHsTypes doc tys
1978 ; return (PrefixCon new_tys, fvs) }
1979
1980 rnConDeclDetails _ doc (InfixCon ty1 ty2)
1981 = do { (new_ty1, fvs1) <- rnLHsType doc ty1
1982 ; (new_ty2, fvs2) <- rnLHsType doc ty2
1983 ; return (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2) }
1984
1985 rnConDeclDetails con doc (RecCon (L l fields))
1986 = do { fls <- lookupConstructorFields con
1987 ; (new_fields, fvs) <- rnConDeclFields doc fls fields
1988 -- No need to check for duplicate fields
1989 -- since that is done by RnNames.extendGlobalRdrEnvRn
1990 ; return (RecCon (L l new_fields), fvs) }
1991
1992 -------------------------------------------------
1993
1994 -- | Brings pattern synonym names and also pattern synonym selectors
1995 -- from record pattern synonyms into scope.
1996 extendPatSynEnv :: HsValBinds RdrName -> MiniFixityEnv
1997 -> ([Name] -> TcRnIf TcGblEnv TcLclEnv a) -> TcM a
1998 extendPatSynEnv val_decls local_fix_env thing = do {
1999 names_with_fls <- new_ps val_decls
2000 ; let pat_syn_bndrs =
2001 concat [name: map flSelector fields | (name, fields) <- names_with_fls]
2002 ; let avails = map patSynAvail pat_syn_bndrs
2003 ; (gbl_env, lcl_env) <-
2004 extendGlobalRdrEnvRn avails local_fix_env
2005
2006
2007 ; let field_env' = extendNameEnvList (tcg_field_env gbl_env) names_with_fls
2008 final_gbl_env = gbl_env { tcg_field_env = field_env' }
2009 ; setEnvs (final_gbl_env, lcl_env) (thing pat_syn_bndrs) }
2010 where
2011 new_ps :: HsValBinds RdrName -> TcM [(Name, [FieldLabel])]
2012 new_ps (ValBindsIn binds _) = foldrBagM new_ps' [] binds
2013 new_ps _ = panic "new_ps"
2014
2015 new_ps' :: LHsBindLR RdrName RdrName
2016 -> [(Name, [FieldLabel])]
2017 -> TcM [(Name, [FieldLabel])]
2018 new_ps' bind names
2019 | L bind_loc (PatSynBind (PSB { psb_id = L _ n
2020 , psb_args = RecordPatSyn as })) <- bind
2021 = do
2022 bnd_name <- newTopSrcBinder (L bind_loc n)
2023 let rnames = map recordPatSynSelectorId as
2024 mkFieldOcc :: Located RdrName -> LFieldOcc RdrName
2025 mkFieldOcc (L l name) = L l (FieldOcc (L l name) PlaceHolder)
2026 field_occs = map mkFieldOcc rnames
2027 flds <- mapM (newRecordSelector False [bnd_name]) field_occs
2028 return ((bnd_name, flds): names)
2029 | L bind_loc (PatSynBind (PSB { psb_id = L _ n})) <- bind
2030 = do
2031 bnd_name <- newTopSrcBinder (L bind_loc n)
2032 return ((bnd_name, []): names)
2033 | otherwise
2034 = return names
2035
2036 {-
2037 *********************************************************
2038 * *
2039 \subsection{Support code to rename types}
2040 * *
2041 *********************************************************
2042 -}
2043
2044 rnFds :: [Located (FunDep (Located RdrName))]
2045 -> RnM [Located (FunDep (Located Name))]
2046 rnFds fds
2047 = mapM (wrapLocM rn_fds) fds
2048 where
2049 rn_fds (tys1, tys2)
2050 = do { tys1' <- rnHsTyVars tys1
2051 ; tys2' <- rnHsTyVars tys2
2052 ; return (tys1', tys2') }
2053
2054 rnHsTyVars :: [Located RdrName] -> RnM [Located Name]
2055 rnHsTyVars tvs = mapM rnHsTyVar tvs
2056
2057 rnHsTyVar :: Located RdrName -> RnM (Located Name)
2058 rnHsTyVar (L l tyvar) = do
2059 tyvar' <- lookupOccRn tyvar
2060 return (L l tyvar')
2061
2062 {-
2063 *********************************************************
2064 * *
2065 findSplice
2066 * *
2067 *********************************************************
2068
2069 This code marches down the declarations, looking for the first
2070 Template Haskell splice. As it does so it
2071 a) groups the declarations into a HsGroup
2072 b) runs any top-level quasi-quotes
2073 -}
2074
2075 findSplice :: [LHsDecl RdrName] -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName]))
2076 findSplice ds = addl emptyRdrGroup ds
2077
2078 addl :: HsGroup RdrName -> [LHsDecl RdrName]
2079 -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName]))
2080 -- This stuff reverses the declarations (again) but it doesn't matter
2081 addl gp [] = return (gp, Nothing)
2082 addl gp (L l d : ds) = add gp l d ds
2083
2084
2085 add :: HsGroup RdrName -> SrcSpan -> HsDecl RdrName -> [LHsDecl RdrName]
2086 -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName]))
2087
2088 -- #10047: Declaration QuasiQuoters are expanded immediately, without
2089 -- causing a group split
2090 add gp _ (SpliceD (SpliceDecl (L _ qq@HsQuasiQuote{}) _)) ds
2091 = do { (ds', _) <- rnTopSpliceDecls qq
2092 ; addl gp (ds' ++ ds)
2093 }
2094
2095 add gp loc (SpliceD splice@(SpliceDecl _ flag)) ds
2096 = do { -- We've found a top-level splice. If it is an *implicit* one
2097 -- (i.e. a naked top level expression)
2098 case flag of
2099 ExplicitSplice -> return ()
2100 ImplicitSplice -> do { th_on <- xoptM LangExt.TemplateHaskell
2101 ; unless th_on $ setSrcSpan loc $
2102 failWith badImplicitSplice }
2103
2104 ; return (gp, Just (splice, ds)) }
2105 where
2106 badImplicitSplice = text "Parse error: naked expression at top level"
2107 $$ text "Perhaps you intended to use TemplateHaskell"
2108
2109 -- Class declarations: pull out the fixity signatures to the top
2110 add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD d) ds
2111 | isClassDecl d
2112 = let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in
2113 addl (gp { hs_tyclds = add_tycld (L l d) ts, hs_fixds = fsigs ++ fs}) ds
2114 | otherwise
2115 = addl (gp { hs_tyclds = add_tycld (L l d) ts }) ds
2116
2117 -- Signatures: fixity sigs go a different place than all others
2118 add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds
2119 = addl (gp {hs_fixds = L l f : ts}) ds
2120 add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds
2121 = addl (gp {hs_valds = add_sig (L l d) ts}) ds
2122
2123 -- Value declarations: use add_bind
2124 add gp@(HsGroup {hs_valds = ts}) l (ValD d) ds
2125 = addl (gp { hs_valds = add_bind (L l d) ts }) ds
2126
2127 -- Role annotations: added to the TyClGroup
2128 add gp@(HsGroup {hs_tyclds = ts}) l (RoleAnnotD d) ds
2129 = addl (gp { hs_tyclds = add_role_annot (L l d) ts }) ds
2130
2131 -- NB instance declarations go into TyClGroups. We throw them into the first
2132 -- group, just as we do for the TyClD case. The renamer will go on to group
2133 -- and order them later.
2134 add gp@(HsGroup {hs_tyclds = ts}) l (InstD d) ds
2135 = addl (gp { hs_tyclds = add_instd (L l d) ts }) ds
2136
2137 -- The rest are routine
2138 add gp@(HsGroup {hs_derivds = ts}) l (DerivD d) ds
2139 = addl (gp { hs_derivds = L l d : ts }) ds
2140 add gp@(HsGroup {hs_defds = ts}) l (DefD d) ds
2141 = addl (gp { hs_defds = L l d : ts }) ds
2142 add gp@(HsGroup {hs_fords = ts}) l (ForD d) ds
2143 = addl (gp { hs_fords = L l d : ts }) ds
2144 add gp@(HsGroup {hs_warnds = ts}) l (WarningD d) ds
2145 = addl (gp { hs_warnds = L l d : ts }) ds
2146 add gp@(HsGroup {hs_annds = ts}) l (AnnD d) ds
2147 = addl (gp { hs_annds = L l d : ts }) ds
2148 add gp@(HsGroup {hs_ruleds = ts}) l (RuleD d) ds
2149 = addl (gp { hs_ruleds = L l d : ts }) ds
2150 add gp@(HsGroup {hs_vects = ts}) l (VectD d) ds
2151 = addl (gp { hs_vects = L l d : ts }) ds
2152 add gp l (DocD d) ds
2153 = addl (gp { hs_docs = (L l d) : (hs_docs gp) }) ds
2154
2155 add_tycld :: LTyClDecl a -> [TyClGroup a] -> [TyClGroup a]
2156 add_tycld d [] = [TyClGroup { group_tyclds = [d]
2157 , group_roles = []
2158 , group_instds = []
2159 }
2160 ]
2161 add_tycld d (ds@(TyClGroup { group_tyclds = tyclds }):dss)
2162 = ds { group_tyclds = d : tyclds } : dss
2163
2164 add_instd :: LInstDecl a -> [TyClGroup a] -> [TyClGroup a]
2165 add_instd d [] = [TyClGroup { group_tyclds = []
2166 , group_roles = []
2167 , group_instds = [d]
2168 }
2169 ]
2170 add_instd d (ds@(TyClGroup { group_instds = instds }):dss)
2171 = ds { group_instds = d : instds } : dss
2172
2173 add_role_annot :: LRoleAnnotDecl a -> [TyClGroup a] -> [TyClGroup a]
2174 add_role_annot d [] = [TyClGroup { group_tyclds = []
2175 , group_roles = [d]
2176 , group_instds = []
2177 }
2178 ]
2179 add_role_annot d (tycls@(TyClGroup { group_roles = roles }) : rest)
2180 = tycls { group_roles = d : roles } : rest
2181
2182 add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a
2183 add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs
2184 add_bind _ (ValBindsOut {}) = panic "RdrHsSyn:add_bind"
2185
2186 add_sig :: LSig a -> HsValBinds a -> HsValBinds a
2187 add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs)
2188 add_sig _ (ValBindsOut {}) = panic "RdrHsSyn:add_sig"