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