2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[RnSource]{Main pass of renamer}
7 #include "HsVersions.h"
9 module RnSource ( rnSource, rnTyDecl, rnClassDecl, rnInstDecl, rnPolyType ) where
12 import RnLoop -- *check* the RnPass/RnExpr/RnBinds loop-breaking
19 import RnBinds ( rnTopBinds, rnMethodBinds )
20 import RnUtils ( lookupGlobalRnEnv, lubExportFlag )
22 import Bag ( emptyBag, unitBag, consBag, unionManyBags, unionBags, listToBag, bagToList )
23 import Class ( derivableClassKeys )
24 import ErrUtils ( addErrLoc, addShortErrLocLine, addShortWarnLocLine )
25 import FiniteMap ( emptyFM, lookupFM, addListToFM_C )
26 import ListSetOps ( unionLists, minusList )
27 import Maybes ( maybeToBool, catMaybes )
28 import Name ( Name, isLocallyDefined, isLexVarId, getLocalName, ExportFlag(..),
29 nameImportFlag, RdrName, pprNonSym )
30 import Outputable -- ToDo:rm
31 import PprStyle -- ToDo:rm
33 import SrcLoc ( SrcLoc )
34 import Unique ( Unique )
35 import UniqFM ( emptyUFM, addListToUFM_C, listToUFM, plusUFM, lookupUFM, eltsUFM )
36 import UniqSet ( UniqSet(..) )
37 import Util ( isIn, isn'tIn, sortLt, removeDups, mapAndUnzip3, cmpPString,
38 assertPanic, pprTrace{-ToDo:rm-} )
41 rnSource `renames' the source module and export list.
42 It simultaneously performs dependency analysis and precedence parsing.
43 It also does the following error checks:
46 Checks that tyvars are used properly. This includes checking
47 for undefined tyvars, and tyvars in contexts that are ambiguous.
49 Checks that all variable occurences are defined.
51 Checks the (..) etc constraints in the export list.
56 rnSource :: [Module] -- imported modules
57 -> Bag (Module,RnName) -- unqualified imports from module
58 -> Bag RenamedFixityDecl -- fixity info for imported names
60 -> RnM s (RenamedHsModule,
61 Name -> ExportFlag, -- export info
62 Bag (RnName, RdrName)) -- occurrence info
64 rnSource imp_mods unqual_imps imp_fixes
65 (HsModule mod version exports _ fixes
66 ty_decls specdata_sigs class_decls
67 inst_decls specinst_sigs defaults
70 = pushSrcLocRn src_loc $
72 rnExports (mod:imp_mods) unqual_imps exports `thenRn` \ exported_fn ->
73 rnFixes fixes `thenRn` \ src_fixes ->
75 all_fixes = src_fixes ++ bagToList imp_fixes
76 all_fixes_fm = listToUFM (map pair_name all_fixes)
78 pair_name inf = (fixDeclName inf, inf)
80 setExtraRn all_fixes_fm $
82 mapRn rnTyDecl ty_decls `thenRn` \ new_ty_decls ->
83 mapRn rnSpecDataSig specdata_sigs `thenRn` \ new_specdata_sigs ->
84 mapRn rnClassDecl class_decls `thenRn` \ new_class_decls ->
85 mapRn rnInstDecl inst_decls `thenRn` \ new_inst_decls ->
86 mapRn rnSpecInstSig specinst_sigs `thenRn` \ new_specinst_sigs ->
87 rnDefaultDecl defaults `thenRn` \ new_defaults ->
88 rnTopBinds binds `thenRn` \ new_binds ->
90 getOccurrenceUpRn `thenRn` \ occ_info ->
94 trashed_exports trashed_imports all_fixes
95 new_ty_decls new_specdata_sigs new_class_decls
96 new_inst_decls new_specinst_sigs new_defaults
102 trashed_exports = {-trace "rnSource:trashed_exports"-} Nothing
103 trashed_imports = {-trace "rnSource:trashed_imports"-} []
107 %*********************************************************
109 \subsection{Export list}
111 %*********************************************************
114 rnExports :: [Module]
115 -> Bag (Module,RnName)
117 -> RnM s (Name -> ExportFlag)
119 rnExports mods unqual_imps Nothing
120 = returnRn (\n -> if isLocallyDefined n then ExportAll else NotExported)
122 rnExports mods unqual_imps (Just exps)
123 = mapAndUnzipRn (rnIE mods) exps `thenRn` \ (mod_maybes, exp_bags) ->
125 (tc_bags, val_bags) = unzip exp_bags
126 tc_names = bagToList (unionManyBags tc_bags)
127 val_names = bagToList (unionManyBags val_bags)
128 exp_mods = catMaybes mod_maybes
130 -- Warn for duplicate names and modules
131 (_, dup_tc_names) = removeDups cmp_fst tc_names
132 (_, dup_val_names) = removeDups cmp_fst val_names
133 cmp_fst (x,_) (y,_) = x `cmp` y
135 (uniq_mods, dup_mods) = removeDups cmpPString exp_mods
137 -- Get names for exported modules
139 (mod_tcs, mod_vals, empty_mods)
140 = case mapAndUnzip3 get_mod_names uniq_mods of
141 (tcs, vals, emptys) -> (concat tcs, concat vals, catMaybes emptys)
143 (unqual_tcs, unqual_vals) = partition (isRnTyConOrClass.snd) (bagToList unqual_imps)
146 = (tcs, vals, empty_mod)
148 tcs = [(getName rn, nameImportFlag (getName rn))
149 | (mod',rn) <- unqual_tcs, mod == mod']
150 vals = [(getName rn, nameImportFlag (getName rn))
151 | (mod',rn) <- unqual_vals, mod == mod']
152 empty_mod = if null tcs && null vals
156 -- Build finite map of exported names to export flag
157 tc_map0 = addListToUFM_C lub_expflag emptyUFM (map pair_fst tc_names)
158 tc_map = addListToUFM_C lub_expflag tc_map0 (map pair_fst mod_tcs)
160 val_map0 = addListToUFM_C lub_expflag emptyUFM (map pair_fst val_names)
161 val_map = addListToUFM_C lub_expflag val_map0 (map pair_fst mod_vals)
163 pair_fst p@(f,_) = (f,p)
164 lub_expflag (n, flag1) (_, flag2) = (n, lubExportFlag flag1 flag2)
166 -- Check for exporting of duplicate local names
167 tc_locals = [(getLocalName n, n) | (n,_) <- eltsUFM tc_map]
168 val_locals = [(getLocalName n, n) | (n,_) <- eltsUFM val_map]
169 (_, dup_tc_locals) = removeDups cmp_local tc_locals
170 (_, dup_val_locals) = removeDups cmp_local val_locals
171 cmp_local (x,_) (y,_) = x `cmpPString` y
173 -- Build export flag function
174 final_exp_map = plusUFM tc_map val_map
175 exp_fn n = case lookupUFM final_exp_map n of
176 Nothing -> NotExported
177 Just (_,flag) -> flag
179 getSrcLocRn `thenRn` \ src_loc ->
180 mapRn (addWarnRn . dupNameExportWarn src_loc) dup_tc_names `thenRn_`
181 mapRn (addWarnRn . dupNameExportWarn src_loc) dup_val_names `thenRn_`
182 mapRn (addWarnRn . dupModExportWarn src_loc) dup_mods `thenRn_`
183 mapRn (addWarnRn . emptyModExportWarn src_loc) empty_mods `thenRn_`
184 mapRn (addErrRn . dupLocalsExportErr src_loc) dup_tc_locals `thenRn_`
185 mapRn (addErrRn . dupLocalsExportErr src_loc) dup_val_locals `thenRn_`
189 rnIE mods (IEVar name)
190 = lookupValue name `thenRn` \ rn ->
191 checkIEVar rn `thenRn` \ exps ->
192 returnRn (Nothing, exps)
194 checkIEVar (RnName n) = returnRn (emptyBag, unitBag (n,ExportAll))
195 checkIEVar rn@(RnClassOp _ _) = getSrcLocRn `thenRn` \ src_loc ->
196 failButContinueRn (emptyBag, emptyBag) (classOpExportErr rn src_loc)
197 checkIEVar rn = returnRn (emptyBag, emptyBag)
199 rnIE mods (IEThingAbs name)
200 = lookupTyConOrClass name `thenRn` \ rn ->
201 checkIEAbs rn `thenRn` \ exps ->
202 returnRn (Nothing, exps)
204 checkIEAbs (RnSyn n) = returnRn (unitBag (n,ExportAbs), emptyBag)
205 checkIEAbs (RnData n _ _) = returnRn (unitBag (n,ExportAbs), emptyBag)
206 checkIEAbs (RnClass n _) = returnRn (unitBag (n,ExportAbs), emptyBag)
207 checkIEAbs rn = returnRn (emptyBag, emptyBag)
209 rnIE mods (IEThingAll name)
210 = lookupTyConOrClass name `thenRn` \ rn ->
211 checkIEAll rn `thenRn` \ exps ->
212 checkImportAll rn `thenRn_`
213 returnRn (Nothing, exps)
215 checkIEAll (RnData n cons fields) = returnRn (unitBag (exp_all n), listToBag (map exp_all cons)
217 listToBag (map exp_all fields))
218 checkIEAll (RnClass n ops) = returnRn (unitBag (exp_all n), listToBag (map exp_all ops))
219 checkIEAll rn@(RnSyn n) = getSrcLocRn `thenRn` \ src_loc ->
220 warnAndContinueRn (unitBag (n, ExportAbs), emptyBag)
221 (synAllExportErr False{-warning-} rn src_loc)
222 checkIEAll rn = returnRn (emptyBag, emptyBag)
224 exp_all n = (n, ExportAll)
226 rnIE mods (IEThingWith name names)
227 = lookupTyConOrClass name `thenRn` \ rn ->
228 mapRn lookupValue names `thenRn` \ rns ->
229 checkIEWith rn rns `thenRn` \ exps ->
230 checkImportAll rn `thenRn_`
231 returnRn (Nothing, exps)
233 checkIEWith rn@(RnData n cons fields) rns
234 | same_names (cons++fields) rns
235 = returnRn (unitBag (exp_all n), listToBag (map exp_all cons)
237 listToBag (map exp_all fields))
239 = rnWithErr "constructrs (and fields)" rn (cons++fields) rns
240 checkIEWith rn@(RnClass n ops) rns
242 = returnRn (unitBag (exp_all n), listToBag (map exp_all ops))
244 = rnWithErr "class ops" rn ops rns
245 checkIEWith rn@(RnSyn _) rns
246 = getSrcLocRn `thenRn` \ src_loc ->
247 failButContinueRn (emptyBag, emptyBag) (synAllExportErr True{-error-} rn src_loc)
249 = returnRn (emptyBag, emptyBag)
251 exp_all n = (n, ExportAll)
254 = all (not.isRnUnbound) rns &&
255 sortLt (<) (map uniqueOf has) == sortLt (<) (map uniqueOf rns)
257 rnWithErr str rn has rns
258 = getSrcLocRn `thenRn` \ src_loc ->
259 failButContinueRn (emptyBag, emptyBag) (withExportErr str rn has rns src_loc)
261 rnIE mods (IEModuleContents mod)
262 | isIn "rnIE:IEModule" mod mods
263 = returnRn (Just mod, (emptyBag, emptyBag))
265 = getSrcLocRn `thenRn` \ src_loc ->
266 failButContinueRn (Nothing, (emptyBag, emptyBag)) (badModExportErr mod src_loc)
270 = case nameImportFlag (getName rn) of
271 ExportAll -> returnRn ()
272 exp -> getSrcLocRn `thenRn` \ src_loc ->
273 addErrRn (importAllErr rn src_loc)
276 %*********************************************************
278 \subsection{Type declarations}
280 %*********************************************************
282 @rnTyDecl@ uses the `global name function' to create a new type
283 declaration in which local names have been replaced by their original
284 names, reporting any unknown names.
286 Renaming type variables is a pain. Because they now contain uniques,
287 it is necessary to pass in an association list which maps a parsed
288 tyvar to its Name representation. In some cases (type signatures of
289 values), it is even necessary to go over the type first in order to
290 get the set of tyvars used by it, make an assoc list, and then go over
291 it again to rename the tyvars! However, we can also do some scoping
292 checks at the same time.
295 rnTyDecl :: RdrNameTyDecl -> RnM_Fixes s RenamedTyDecl
297 rnTyDecl (TyData context tycon tyvars condecls derivings pragmas src_loc)
298 = pushSrcLocRn src_loc $
299 lookupTyCon tycon `thenRn` \ tycon' ->
300 mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env, tyvars') ->
301 rnContext tv_env context `thenRn` \ context' ->
302 rnConDecls tv_env condecls `thenRn` \ condecls' ->
303 rn_derivs tycon' src_loc derivings `thenRn` \ derivings' ->
304 ASSERT(isNoDataPragmas pragmas)
305 returnRn (TyData context' tycon' tyvars' condecls' derivings' noDataPragmas src_loc)
307 rnTyDecl (TyNew context tycon tyvars condecl derivings pragmas src_loc)
308 = pushSrcLocRn src_loc $
309 lookupTyCon tycon `thenRn` \ tycon' ->
310 mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env, tyvars') ->
311 rnContext tv_env context `thenRn` \ context' ->
312 rnConDecls tv_env condecl `thenRn` \ condecl' ->
313 rn_derivs tycon' src_loc derivings `thenRn` \ derivings' ->
314 ASSERT(isNoDataPragmas pragmas)
315 returnRn (TyNew context' tycon' tyvars' condecl' derivings' noDataPragmas src_loc)
317 rnTyDecl (TySynonym name tyvars ty src_loc)
318 = pushSrcLocRn src_loc $
319 lookupTyCon name `thenRn` \ name' ->
320 mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env, tyvars') ->
321 rnMonoType tv_env ty `thenRn` \ ty' ->
322 returnRn (TySynonym name' tyvars' ty' src_loc)
324 rn_derivs tycon2 locn Nothing -- derivs not specified
327 rn_derivs tycon2 locn (Just ds)
328 = mapRn (rn_deriv tycon2 locn) ds `thenRn` \ derivs ->
329 returnRn (Just derivs)
331 rn_deriv tycon2 locn clas
332 = lookupClass clas `thenRn` \ clas_name ->
333 addErrIfRn (uniqueOf clas_name `not_elem` derivableClassKeys)
334 (derivingNonStdClassErr clas_name locn)
338 not_elem = isn'tIn "rn_deriv"
341 @rnConDecls@ uses the `global name function' to create a new
342 constructor in which local names have been replaced by their original
343 names, reporting any unknown names.
346 rnConDecls :: TyVarNamesEnv
348 -> RnM_Fixes s [RenamedConDecl]
350 rnConDecls tv_env con_decls
351 = mapRn rn_decl con_decls
353 rn_decl (ConDecl name tys src_loc)
354 = pushSrcLocRn src_loc $
355 lookupConstr name `thenRn` \ new_name ->
356 mapRn rn_bang_ty tys `thenRn` \ new_tys ->
357 returnRn (ConDecl new_name new_tys src_loc)
359 rn_decl (ConOpDecl ty1 op ty2 src_loc)
360 = pushSrcLocRn src_loc $
361 lookupConstr op `thenRn` \ new_op ->
362 rn_bang_ty ty1 `thenRn` \ new_ty1 ->
363 rn_bang_ty ty2 `thenRn` \ new_ty2 ->
364 returnRn (ConOpDecl new_ty1 new_op new_ty2 src_loc)
366 rn_decl (NewConDecl name ty src_loc)
367 = pushSrcLocRn src_loc $
368 lookupConstr name `thenRn` \ new_name ->
369 rn_mono_ty ty `thenRn` \ new_ty ->
370 returnRn (NewConDecl new_name new_ty src_loc)
372 rn_decl (RecConDecl name fields src_loc)
373 = pushSrcLocRn src_loc $
374 lookupConstr name `thenRn` \ new_name ->
375 mapRn rn_field fields `thenRn` \ new_fields ->
376 returnRn (RecConDecl new_name new_fields src_loc)
379 = mapRn lookupField names `thenRn` \ new_names ->
380 rn_bang_ty ty `thenRn` \ new_ty ->
381 returnRn (new_names, new_ty)
383 rn_mono_ty = rnMonoType tv_env
384 rn_poly_ty = rnPolyType tv_env
386 rn_bang_ty (Banged ty)
387 = rn_poly_ty ty `thenRn` \ new_ty ->
388 returnRn (Banged new_ty)
389 rn_bang_ty (Unbanged ty)
390 = rn_poly_ty ty `thenRn` \ new_ty ->
391 returnRn (Unbanged new_ty)
394 %*********************************************************
396 \subsection{SPECIALIZE data pragmas}
398 %*********************************************************
401 rnSpecDataSig :: RdrNameSpecDataSig
402 -> RnM_Fixes s RenamedSpecDataSig
404 rnSpecDataSig (SpecDataSig tycon ty src_loc)
405 = pushSrcLocRn src_loc $
407 tyvars = extractMonoTyNames is_tyvar_name ty
409 mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env,_) ->
410 lookupTyCon tycon `thenRn` \ tycon' ->
411 rnMonoType tv_env ty `thenRn` \ ty' ->
412 returnRn (SpecDataSig tycon' ty' src_loc)
414 is_tyvar_name n = isLexVarId (getLocalName n)
417 %*********************************************************
419 \subsection{Class declarations}
421 %*********************************************************
423 @rnClassDecl@ uses the `global name function' to create a new
424 class declaration in which local names have been replaced by their
425 original names, reporting any unknown names.
428 rnClassDecl :: RdrNameClassDecl -> RnM_Fixes s RenamedClassDecl
430 rnClassDecl (ClassDecl context cname tyvar sigs mbinds pragmas src_loc)
431 = pushSrcLocRn src_loc $
432 mkTyVarNamesEnv src_loc [tyvar] `thenRn` \ (tv_env, [tyvar']) ->
433 rnContext tv_env context `thenRn` \ context' ->
434 lookupClass cname `thenRn` \ cname' ->
435 mapRn (rn_op cname' tv_env) sigs `thenRn` \ sigs' ->
436 rnMethodBinds cname' mbinds `thenRn` \ mbinds' ->
437 ASSERT(isNoClassPragmas pragmas)
438 returnRn (ClassDecl context' cname' tyvar' sigs' mbinds' NoClassPragmas src_loc)
440 rn_op clas tv_env (ClassOpSig op ty pragmas locn)
441 = pushSrcLocRn locn $
442 lookupClassOp clas op `thenRn` \ op_name ->
443 rnPolyType tv_env ty `thenRn` \ new_ty ->
446 *** Please check here that tyvar' appears in new_ty ***
447 *** (used to be in tcClassSig, but it's better here)
448 *** not_elem = isn'tIn "tcClassSigs"
449 *** -- Check that the class type variable is mentioned
450 *** checkTc (clas_tyvar `not_elem` extractTyVarTemplatesFromTy local_ty)
451 *** (methodTypeLacksTyVarErr clas_tyvar (_UNPK_ op_name) src_loc) `thenTc_`
454 ASSERT(isNoClassOpPragmas pragmas)
455 returnRn (ClassOpSig op_name new_ty noClassOpPragmas locn)
459 %*********************************************************
461 \subsection{Instance declarations}
463 %*********************************************************
466 @rnInstDecl@ uses the `global name function' to create a new of
467 instance declaration in which local names have been replaced by their
468 original names, reporting any unknown names.
471 rnInstDecl :: RdrNameInstDecl -> RnM_Fixes s RenamedInstDecl
473 rnInstDecl (InstDecl cname ty mbinds from_here modname uprags pragmas src_loc)
474 = pushSrcLocRn src_loc $
475 lookupClass cname `thenRn` \ cname' ->
477 rnPolyType [] ty `thenRn` \ ty' ->
478 -- [] tv_env ensures that tyvars will be foralled
480 rnMethodBinds cname' mbinds `thenRn` \ mbinds' ->
481 mapRn (rn_uprag cname') uprags `thenRn` \ new_uprags ->
483 ASSERT(isNoInstancePragmas pragmas)
484 returnRn (InstDecl cname' ty' mbinds'
485 from_here modname new_uprags noInstancePragmas src_loc)
487 rn_uprag class_name (SpecSig op ty using locn)
488 = pushSrcLocRn src_loc $
489 lookupClassOp class_name op `thenRn` \ op_name ->
490 rnPolyType nullTyVarNamesEnv ty `thenRn` \ new_ty ->
491 rn_using using `thenRn` \ new_using ->
492 returnRn (SpecSig op_name new_ty new_using locn)
494 rn_uprag class_name (InlineSig op locn)
495 = pushSrcLocRn locn $
496 lookupClassOp class_name op `thenRn` \ op_name ->
497 returnRn (InlineSig op_name locn)
499 rn_uprag class_name (DeforestSig op locn)
500 = pushSrcLocRn locn $
501 lookupClassOp class_name op `thenRn` \ op_name ->
502 returnRn (DeforestSig op_name locn)
504 rn_uprag class_name (MagicUnfoldingSig op str locn)
505 = pushSrcLocRn locn $
506 lookupClassOp class_name op `thenRn` \ op_name ->
507 returnRn (MagicUnfoldingSig op_name str locn)
512 = lookupValue v `thenRn` \ new_v ->
513 returnRn (Just new_v)
516 %*********************************************************
518 \subsection{@SPECIALIZE instance@ user-pragmas}
520 %*********************************************************
523 rnSpecInstSig :: RdrNameSpecInstSig
524 -> RnM_Fixes s RenamedSpecInstSig
526 rnSpecInstSig (SpecInstSig clas ty src_loc)
527 = pushSrcLocRn src_loc $
529 tyvars = extractMonoTyNames is_tyvar_name ty
531 mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env,_) ->
532 lookupClass clas `thenRn` \ new_clas ->
533 rnMonoType tv_env ty `thenRn` \ new_ty ->
534 returnRn (SpecInstSig new_clas new_ty src_loc)
537 %*********************************************************
539 \subsection{Default declarations}
541 %*********************************************************
543 @rnDefaultDecl@ uses the `global name function' to create a new set
544 of default declarations in which local names have been replaced by
545 their original names, reporting any unknown names.
548 rnDefaultDecl :: [RdrNameDefaultDecl] -> RnM_Fixes s [RenamedDefaultDecl]
550 rnDefaultDecl [] = returnRn []
551 rnDefaultDecl [DefaultDecl tys src_loc]
552 = pushSrcLocRn src_loc $
553 mapRn (rnMonoType nullTyVarNamesEnv) tys `thenRn` \ tys' ->
554 returnRn [DefaultDecl tys' src_loc]
555 rnDefaultDecl defs@(d:ds)
556 = addErrRn (dupDefaultDeclErr defs) `thenRn_`
560 %*************************************************************************
562 \subsection{Fixity declarations}
564 %*************************************************************************
567 rnFixes :: [RdrNameFixityDecl] -> RnM s [RenamedFixityDecl]
570 = getSrcLocRn `thenRn` \ src_loc ->
572 (_, dup_fixes) = removeDups cmp_fix fixities
573 cmp_fix fix1 fix2 = fixDeclName fix1 `cmp` fixDeclName fix2
575 rn_fixity fix@(InfixL name i)
576 = rn_fixity_pieces InfixL name i fix
577 rn_fixity fix@(InfixR name i)
578 = rn_fixity_pieces InfixR name i fix
579 rn_fixity fix@(InfixN name i)
580 = rn_fixity_pieces InfixN name i fix
582 rn_fixity_pieces mk_fixity name i fix
583 = getRnEnv `thenRn` \ env ->
584 case lookupGlobalRnEnv env name of
585 Just res | isLocallyDefined res
586 -> returnRn (Just (mk_fixity res i))
587 _ -> failButContinueRn Nothing (undefinedFixityDeclErr src_loc fix)
589 mapRn (addErrRn . dupFixityDeclErr src_loc) dup_fixes `thenRn_`
590 mapRn rn_fixity fixities `thenRn` \ fixes_maybe ->
591 returnRn (catMaybes fixes_maybe)
594 %*********************************************************
596 \subsection{Support code to rename types}
598 %*********************************************************
601 rnPolyType :: TyVarNamesEnv
603 -> RnM_Fixes s RenamedPolyType
605 rnPolyType tv_env (HsForAllTy tvs ctxt ty)
606 = rn_poly_help tv_env tvs ctxt ty
608 rnPolyType tv_env (HsPreForAllTy ctxt ty)
609 = rn_poly_help tv_env forall_tyvars ctxt ty
611 mentioned_tyvars = extractCtxtTyNames ctxt `unionLists` extractMonoTyNames is_tyvar_name ty
613 pprTrace "mentioned:" (ppCat (map (ppr PprShowAll) mentioned_tyvars)) $
614 pprTrace "from_ty:" (ppCat (map (ppr PprShowAll) (extractMonoTyNames is_tyvar_name ty))) $
616 mentioned_tyvars `minusList` domTyVarNamesEnv tv_env
619 rn_poly_help :: TyVarNamesEnv
623 -> RnM_Fixes s RenamedPolyType
625 rn_poly_help tv_env tyvars ctxt ty
627 pprTrace "rnPolyType:"
628 (ppCat [ppCat (map (ppr PprShowAll . snd) tv_env),
629 ppStr ";tvs=", ppCat (map (ppr PprShowAll) tyvars),
630 ppStr ";ctxt=", ppCat (map (ppr PprShowAll) ctxt),
631 ppStr ";ty=", ppr PprShowAll ty]) $
633 getSrcLocRn `thenRn` \ src_loc ->
634 mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env1, new_tyvars) ->
636 tv_env2 = catTyVarNamesEnvs tv_env1 tv_env
638 rnContext tv_env2 ctxt `thenRn` \ new_ctxt ->
639 rnMonoType tv_env2 ty `thenRn` \ new_ty ->
640 returnRn (HsForAllTy new_tyvars new_ctxt new_ty)
644 rnMonoType :: TyVarNamesEnv
646 -> RnM_Fixes s RenamedMonoType
648 rnMonoType tv_env (MonoTyVar tyvar)
649 = lookupTyVarName tv_env tyvar `thenRn` \ tyvar' ->
650 returnRn (MonoTyVar tyvar')
652 rnMonoType tv_env (MonoListTy ty)
653 = rnMonoType tv_env ty `thenRn` \ ty' ->
654 returnRn (MonoListTy ty')
656 rnMonoType tv_env (MonoFunTy ty1 ty2)
657 = andRn MonoFunTy (rnMonoType tv_env ty1)
658 (rnMonoType tv_env ty2)
660 rnMonoType tv_env (MonoTupleTy tys)
661 = mapRn (rnMonoType tv_env) tys `thenRn` \ tys' ->
662 returnRn (MonoTupleTy tys')
664 rnMonoType tv_env (MonoTyApp name tys)
666 lookup_fn = if isLexVarId (getLocalName name)
667 then lookupTyVarName tv_env
670 lookup_fn name `thenRn` \ name' ->
671 mapRn (rnMonoType tv_env) tys `thenRn` \ tys' ->
672 returnRn (MonoTyApp name' tys')
676 rnContext :: TyVarNamesEnv -> RdrNameContext -> RnM_Fixes s RenamedContext
678 rnContext tv_env ctxt
681 rn_ctxt (clas, tyvar)
682 = lookupClass clas `thenRn` \ clas_name ->
683 lookupTyVarName tv_env tyvar `thenRn` \ tyvar_name ->
684 returnRn (clas_name, tyvar_name)
689 dupNameExportWarn locn names@((n,_):_)
690 = addShortWarnLocLine locn (\ sty ->
691 ppCat [pprNonSym sty n, ppStr "exported", ppInt (length names), ppStr "times"])
693 dupLocalsExportErr locn locals@((str,_):_)
694 = addErrLoc locn "exported names have same local name" (\ sty ->
695 ppInterleave ppSP (map (pprNonSym sty . snd) locals))
697 classOpExportErr op locn
698 = addShortErrLocLine locn (\ sty ->
699 ppBesides [ppStr "class operation `", ppr sty op, ppStr "' can only be exported with class"])
701 synAllExportErr is_error syn locn
702 = (if is_error then addShortErrLocLine else addShortWarnLocLine) locn (\ sty ->
703 ppBesides [ppStr "type synonym `", ppr sty syn, ppStr "' should be exported abstractly"])
705 withExportErr str rn has rns locn
706 = addErrLoc locn "" (\ sty ->
707 ppAboves [ ppBesides [ppStr "inconsistent list of ", ppStr str, ppStr " in export list for `", ppr sty rn, ppStr "'"],
708 ppCat [ppStr " expected:", ppInterleave ppComma (map (ppr sty) has)],
709 ppCat [ppStr " found: ", ppInterleave ppComma (map (ppr sty) rns)] ])
712 = addShortErrLocLine locn (\ sty ->
713 ppBesides [ ppStr "`", pprNonSym sty rn, ppStr "' has been exported with (..), but is only imported abstractly"])
715 badModExportErr mod locn
716 = addShortErrLocLine locn (\ sty ->
717 ppCat [ ppStr "unknown module in export list: module", ppPStr mod])
719 emptyModExportWarn locn mod
720 = addShortWarnLocLine locn (\ sty ->
721 ppCat [ppStr "module", ppPStr mod, ppStr "has no unqualified imports to export"])
723 dupModExportWarn locn mods@(mod:_)
724 = addShortWarnLocLine locn (\ sty ->
725 ppCat [ppStr "module", ppPStr mod, ppStr "appears", ppInt (length mods), ppStr "times in export list"])
727 derivingNonStdClassErr clas locn
728 = addShortErrLocLine locn (\ sty ->
729 ppCat [ppStr "non-standard class in deriving:", ppr sty clas])
731 dupDefaultDeclErr (DefaultDecl _ locn1 : dup_things) sty
732 = ppAboves (item1 : map dup_item dup_things)
735 = addShortErrLocLine locn1 (\ sty -> ppStr "multiple default declarations") sty
737 dup_item (DefaultDecl _ locn)
738 = addShortErrLocLine locn (\ sty -> ppStr "here was another default declaration") sty
740 undefinedFixityDeclErr locn decl
741 = addErrLoc locn "fixity declaration for unknown operator" (\ sty ->
744 dupFixityDeclErr locn dups
745 = addErrLoc locn "multiple fixity declarations for same operator" (\ sty ->
746 ppAboves (map (ppr sty) dups))