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