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 )
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, lookupUFM, eltsUFM )
36 import UniqSet ( UniqSet(..) )
37 import Util ( isIn, isn'tIn, sortLt, removeDups, cmpPString, assertPanic, pprTrace{-ToDo:rm-} )
40 rnSource `renames' the source module and export list.
41 It simultaneously performs dependency analysis and precedence parsing.
42 It also does the following error checks:
45 Checks that tyvars are used properly. This includes checking
46 for undefined tyvars, and tyvars in contexts that are ambiguous.
48 Checks that all variable occurences are defined.
50 Checks the (..) etc constraints in the export list.
56 -> Bag (Module,RnName) -- unqualified imports from module
57 -> Bag RenamedFixityDecl -- fixity info for imported names
59 -> RnM s (RenamedHsModule,
60 Name -> ExportFlag, -- export info
61 Bag (RnName, RdrName)) -- occurrence info
63 rnSource imp_mods unqual_imps imp_fixes
64 (HsModule mod version exports _ fixes
65 ty_decls specdata_sigs class_decls
66 inst_decls specinst_sigs defaults
69 = pushSrcLocRn src_loc $
71 rnExports (mod:imp_mods) unqual_imps exports `thenRn` \ exported_fn ->
72 rnFixes fixes `thenRn` \ src_fixes ->
74 pair_name inf = (nameFixDecl inf, inf)
76 all_fixes = src_fixes ++ bagToList imp_fixes
77 all_fixes_fm = listToUFM (map pair_name all_fixes)
79 setExtraRn all_fixes_fm $
81 mapRn rnTyDecl ty_decls `thenRn` \ new_ty_decls ->
82 mapRn rnSpecDataSig specdata_sigs `thenRn` \ new_specdata_sigs ->
83 mapRn rnClassDecl class_decls `thenRn` \ new_class_decls ->
84 mapRn rnInstDecl inst_decls `thenRn` \ new_inst_decls ->
85 mapRn rnSpecInstSig specinst_sigs `thenRn` \ new_specinst_sigs ->
86 rnDefaultDecl defaults `thenRn` \ new_defaults ->
87 rnTopBinds binds `thenRn` \ new_binds ->
89 getOccurrenceUpRn `thenRn` \ occ_info ->
93 trashed_exports trashed_imports all_fixes
94 new_ty_decls new_specdata_sigs new_class_decls
95 new_inst_decls new_specinst_sigs new_defaults
101 trashed_exports = {-trace "rnSource:trashed_exports"-} Nothing
102 trashed_imports = {-trace "rnSource:trashed_imports"-} []
106 %*********************************************************
108 \subsection{Export list}
110 %*********************************************************
113 rnExports :: [Module]
114 -> Bag (Module,RnName)
116 -> RnM s (Name -> ExportFlag)
118 rnExports mods unqual_imps Nothing
119 = returnRn (\n -> if isLocallyDefined n then ExportAll else NotExported)
121 rnExports mods unqual_imps (Just exps)
122 = mapAndUnzipRn (rnIE mods) exps `thenRn` \ (mod_maybes, exp_bags) ->
124 exp_names = bagToList (unionManyBags exp_bags)
125 exp_mods = catMaybes mod_maybes
127 -- Warn for duplicate names and modules
128 (uniq_exp_names, dup_names) = removeDups cmp_fst exp_names
129 (uniq_exp_mods, dup_mods) = removeDups cmpPString exp_mods
130 cmp_fst (x,_) (y,_) = x `cmp` y
132 -- Build finite map of exported names to export flag
133 exp_map0 = addListToUFM_C lub_expflag emptyUFM (map pair_fst uniq_exp_names)
134 (exp_map1, empty_mods) = foldl add_mod_names (exp_map0, []) uniq_exp_mods
136 mod_fm = addListToFM_C unionBags emptyFM
137 [(mod, unitBag (getName rn, nameImportFlag (getName rn)))
138 | (mod,rn) <- bagToList unqual_imps]
140 add_mod_names (exp_map, empty) mod
141 = case lookupFM mod_fm mod of
142 Nothing -> (exp_map, mod:empty)
143 Just mod_names -> (addListToUFM_C lub_expflag exp_map (map pair_fst (bagToList mod_names)), empty)
145 pair_fst p@(f,_) = (f,p)
146 lub_expflag (n, flag1) (_, flag2) = (n, lubExportFlag flag1 flag2)
148 -- Check for exporting of duplicate local names
149 exp_locals = [(getLocalName n, n) | (n,_) <- eltsUFM exp_map1]
150 (_, dup_locals) = removeDups cmp_local exp_locals
151 cmp_local (x,_) (y,_) = x `cmpPString` y
153 -- Build export flag function
154 exp_fn n = case lookupUFM exp_map1 n of
155 Nothing -> NotExported
156 Just (_,flag) -> flag
158 getSrcLocRn `thenRn` \ src_loc ->
159 mapRn (addWarnRn . dupNameExportWarn src_loc) dup_names `thenRn_`
160 mapRn (addWarnRn . dupModExportWarn src_loc) dup_mods `thenRn_`
161 mapRn (addWarnRn . emptyModExportWarn src_loc) empty_mods `thenRn_`
162 mapRn (addErrRn . dupLocalsExportErr src_loc) dup_locals `thenRn_`
166 rnIE mods (IEVar name)
167 = lookupValue name `thenRn` \ rn ->
168 checkIEVar rn `thenRn` \ exps ->
169 returnRn (Nothing, exps)
171 checkIEVar (RnName n) = returnRn (unitBag (n,ExportAll))
172 checkIEVar rn@(RnClassOp _ _) = getSrcLocRn `thenRn` \ src_loc ->
173 failButContinueRn emptyBag (classOpExportErr rn src_loc)
174 checkIEVar rn = returnRn emptyBag
176 rnIE mods (IEThingAbs name)
177 = lookupTyConOrClass name `thenRn` \ rn ->
178 checkIEAbs rn `thenRn` \ exps ->
179 returnRn (Nothing, exps)
181 checkIEAbs (RnSyn n) = returnRn (unitBag (n,ExportAbs))
182 checkIEAbs (RnData n _ _) = returnRn (unitBag (n,ExportAbs))
183 checkIEAbs (RnClass n _) = returnRn (unitBag (n,ExportAbs))
184 checkIEAbs rn = returnRn emptyBag
186 rnIE mods (IEThingAll name)
187 = lookupTyConOrClass name `thenRn` \ rn ->
188 checkIEAll rn `thenRn` \ exps ->
189 checkImportAll rn `thenRn_`
190 returnRn (Nothing, exps)
192 checkIEAll (RnData n cons fields) = returnRn (exp_all n `consBag` listToBag (map exp_all cons)
193 `unionBags` listToBag (map exp_all fields))
194 checkIEAll (RnClass n ops) = returnRn (exp_all n `consBag` listToBag (map exp_all ops))
195 checkIEAll rn@(RnSyn _) = getSrcLocRn `thenRn` \ src_loc ->
196 warnAndContinueRn emptyBag (synAllExportErr rn src_loc)
197 checkIEAll rn = returnRn emptyBag
199 exp_all n = (n, ExportAll)
201 rnIE mods (IEThingWith name names)
202 = lookupTyConOrClass name `thenRn` \ rn ->
203 mapRn lookupValue names `thenRn` \ rns ->
204 checkIEWith rn rns `thenRn` \ exps ->
205 checkImportAll rn `thenRn_`
206 returnRn (Nothing, exps)
208 checkIEWith rn@(RnData n cons fields) rns
209 | same_names (cons++fields) rns
210 = returnRn (consBag (exp_all n) (listToBag (map exp_all cons)))
212 = rnWithErr "constructrs (and fields)" rn (cons++fields) rns
213 checkIEWith rn@(RnClass n ops) rns
215 = returnRn (consBag (exp_all n) (listToBag (map exp_all ops)))
217 = rnWithErr "class ops" rn ops rns
218 checkIEWith rn@(RnSyn _) rns
219 = getSrcLocRn `thenRn` \ src_loc ->
220 failButContinueRn emptyBag (synAllExportErr rn src_loc)
224 exp_all n = (n, ExportAll)
227 = all (not.isRnUnbound) rns &&
228 sortLt (<) (map uniqueOf has) == sortLt (<) (map uniqueOf rns)
230 rnWithErr str rn has rns
231 = getSrcLocRn `thenRn` \ src_loc ->
232 failButContinueRn emptyBag (withExportErr str rn has rns src_loc)
234 rnIE mods (IEModuleContents mod)
235 | isIn "rnIE:IEModule" mod mods
236 = returnRn (Just mod, emptyBag)
238 = getSrcLocRn `thenRn` \ src_loc ->
239 failButContinueRn (Nothing,emptyBag) (badModExportErr mod src_loc)
243 = case nameImportFlag (getName rn) of
244 ExportAll -> returnRn ()
245 exp -> getSrcLocRn `thenRn` \ src_loc ->
246 addErrRn (importAllErr rn src_loc)
249 %*********************************************************
251 \subsection{Type declarations}
253 %*********************************************************
255 @rnTyDecl@ uses the `global name function' to create a new type
256 declaration in which local names have been replaced by their original
257 names, reporting any unknown names.
259 Renaming type variables is a pain. Because they now contain uniques,
260 it is necessary to pass in an association list which maps a parsed
261 tyvar to its Name representation. In some cases (type signatures of
262 values), it is even necessary to go over the type first in order to
263 get the set of tyvars used by it, make an assoc list, and then go over
264 it again to rename the tyvars! However, we can also do some scoping
265 checks at the same time.
268 rnTyDecl :: RdrNameTyDecl -> RnM_Fixes s RenamedTyDecl
270 rnTyDecl (TyData context tycon tyvars condecls derivings pragmas src_loc)
271 = pushSrcLocRn src_loc $
272 lookupTyCon tycon `thenRn` \ tycon' ->
273 mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env, tyvars') ->
274 rnContext tv_env context `thenRn` \ context' ->
275 rnConDecls tv_env condecls `thenRn` \ condecls' ->
276 rn_derivs tycon' src_loc derivings `thenRn` \ derivings' ->
277 ASSERT(isNoDataPragmas pragmas)
278 returnRn (TyData context' tycon' tyvars' condecls' derivings' noDataPragmas src_loc)
280 rnTyDecl (TyNew context tycon tyvars condecl derivings pragmas src_loc)
281 = pushSrcLocRn src_loc $
282 lookupTyCon tycon `thenRn` \ tycon' ->
283 mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env, tyvars') ->
284 rnContext tv_env context `thenRn` \ context' ->
285 rnConDecls tv_env condecl `thenRn` \ condecl' ->
286 rn_derivs tycon' src_loc derivings `thenRn` \ derivings' ->
287 ASSERT(isNoDataPragmas pragmas)
288 returnRn (TyNew context' tycon' tyvars' condecl' derivings' noDataPragmas src_loc)
290 rnTyDecl (TySynonym name tyvars ty src_loc)
291 = pushSrcLocRn src_loc $
292 lookupTyCon name `thenRn` \ name' ->
293 mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env, tyvars') ->
294 rnMonoType tv_env ty `thenRn` \ ty' ->
295 returnRn (TySynonym name' tyvars' ty' src_loc)
297 rn_derivs tycon2 locn Nothing -- derivs not specified
300 rn_derivs tycon2 locn (Just ds)
301 = mapRn (rn_deriv tycon2 locn) ds `thenRn` \ derivs ->
302 returnRn (Just derivs)
304 rn_deriv tycon2 locn clas
305 = lookupClass clas `thenRn` \ clas_name ->
306 addErrIfRn (uniqueOf clas_name `not_elem` derivableClassKeys)
307 (derivingNonStdClassErr clas locn)
311 not_elem = isn'tIn "rn_deriv"
314 @rnConDecls@ uses the `global name function' to create a new
315 constructor in which local names have been replaced by their original
316 names, reporting any unknown names.
319 rnConDecls :: TyVarNamesEnv
321 -> RnM_Fixes s [RenamedConDecl]
323 rnConDecls tv_env con_decls
324 = mapRn rn_decl con_decls
326 rn_decl (ConDecl name tys src_loc)
327 = pushSrcLocRn src_loc $
328 lookupConstr name `thenRn` \ new_name ->
329 mapRn rn_bang_ty tys `thenRn` \ new_tys ->
330 returnRn (ConDecl new_name new_tys src_loc)
332 rn_decl (ConOpDecl ty1 op ty2 src_loc)
333 = pushSrcLocRn src_loc $
334 lookupConstr op `thenRn` \ new_op ->
335 rn_bang_ty ty1 `thenRn` \ new_ty1 ->
336 rn_bang_ty ty2 `thenRn` \ new_ty2 ->
337 returnRn (ConOpDecl new_ty1 new_op new_ty2 src_loc)
339 rn_decl (NewConDecl name ty src_loc)
340 = pushSrcLocRn src_loc $
341 lookupConstr name `thenRn` \ new_name ->
342 rn_mono_ty ty `thenRn` \ new_ty ->
343 returnRn (NewConDecl new_name new_ty src_loc)
345 rn_decl (RecConDecl name fields src_loc)
346 = pushSrcLocRn src_loc $
347 lookupConstr name `thenRn` \ new_name ->
348 mapRn rn_field fields `thenRn` \ new_fields ->
349 returnRn (RecConDecl new_name new_fields src_loc)
352 = mapRn lookupField names `thenRn` \ new_names ->
353 rn_bang_ty ty `thenRn` \ new_ty ->
354 returnRn (new_names, new_ty)
356 rn_mono_ty = rnMonoType tv_env
357 rn_poly_ty = rnPolyType tv_env
359 rn_bang_ty (Banged ty)
360 = rn_poly_ty ty `thenRn` \ new_ty ->
361 returnRn (Banged new_ty)
362 rn_bang_ty (Unbanged ty)
363 = rn_poly_ty ty `thenRn` \ new_ty ->
364 returnRn (Unbanged new_ty)
367 %*********************************************************
369 \subsection{SPECIALIZE data pragmas}
371 %*********************************************************
374 rnSpecDataSig :: RdrNameSpecDataSig
375 -> RnM_Fixes s RenamedSpecDataSig
377 rnSpecDataSig (SpecDataSig tycon ty src_loc)
378 = pushSrcLocRn src_loc $
380 tyvars = extractMonoTyNames is_tyvar_name ty
382 mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env,_) ->
383 lookupTyCon tycon `thenRn` \ tycon' ->
384 rnMonoType tv_env ty `thenRn` \ ty' ->
385 returnRn (SpecDataSig tycon' ty' src_loc)
387 is_tyvar_name n = isLexVarId (getLocalName n)
390 %*********************************************************
392 \subsection{Class declarations}
394 %*********************************************************
396 @rnClassDecl@ uses the `global name function' to create a new
397 class declaration in which local names have been replaced by their
398 original names, reporting any unknown names.
401 rnClassDecl :: RdrNameClassDecl -> RnM_Fixes s RenamedClassDecl
403 rnClassDecl (ClassDecl context cname tyvar sigs mbinds pragmas src_loc)
404 = pushSrcLocRn src_loc $
405 mkTyVarNamesEnv src_loc [tyvar] `thenRn` \ (tv_env, [tyvar']) ->
406 rnContext tv_env context `thenRn` \ context' ->
407 lookupClass cname `thenRn` \ cname' ->
408 mapRn (rn_op cname' tv_env) sigs `thenRn` \ sigs' ->
409 rnMethodBinds cname' mbinds `thenRn` \ mbinds' ->
410 ASSERT(isNoClassPragmas pragmas)
411 returnRn (ClassDecl context' cname' tyvar' sigs' mbinds' NoClassPragmas src_loc)
413 rn_op clas tv_env (ClassOpSig op ty pragmas locn)
414 = pushSrcLocRn locn $
415 lookupClassOp clas op `thenRn` \ op_name ->
416 rnPolyType tv_env ty `thenRn` \ new_ty ->
419 *** Please check here that tyvar' appears in new_ty ***
420 *** (used to be in tcClassSig, but it's better here)
421 *** not_elem = isn'tIn "tcClassSigs"
422 *** -- Check that the class type variable is mentioned
423 *** checkTc (clas_tyvar `not_elem` extractTyVarTemplatesFromTy local_ty)
424 *** (methodTypeLacksTyVarErr clas_tyvar (_UNPK_ op_name) src_loc) `thenTc_`
427 ASSERT(isNoClassOpPragmas pragmas)
428 returnRn (ClassOpSig op_name new_ty noClassOpPragmas locn)
432 %*********************************************************
434 \subsection{Instance declarations}
436 %*********************************************************
439 @rnInstDecl@ uses the `global name function' to create a new of
440 instance declaration in which local names have been replaced by their
441 original names, reporting any unknown names.
444 rnInstDecl :: RdrNameInstDecl -> RnM_Fixes s RenamedInstDecl
446 rnInstDecl (InstDecl cname ty mbinds from_here modname uprags pragmas src_loc)
447 = pushSrcLocRn src_loc $
448 lookupClass cname `thenRn` \ cname' ->
450 rnPolyType [] ty `thenRn` \ ty' ->
451 -- [] tv_env ensures that tyvars will be foralled
453 rnMethodBinds cname' mbinds `thenRn` \ mbinds' ->
454 mapRn (rn_uprag cname') uprags `thenRn` \ new_uprags ->
456 ASSERT(isNoInstancePragmas pragmas)
457 returnRn (InstDecl cname' ty' mbinds'
458 from_here modname new_uprags noInstancePragmas src_loc)
460 rn_uprag class_name (SpecSig op ty using locn)
461 = pushSrcLocRn src_loc $
462 lookupClassOp class_name op `thenRn` \ op_name ->
463 rnPolyType nullTyVarNamesEnv ty `thenRn` \ new_ty ->
464 rn_using using `thenRn` \ new_using ->
465 returnRn (SpecSig op_name new_ty new_using locn)
467 rn_uprag class_name (InlineSig op locn)
468 = pushSrcLocRn locn $
469 lookupClassOp class_name op `thenRn` \ op_name ->
470 returnRn (InlineSig op_name locn)
472 rn_uprag class_name (DeforestSig op locn)
473 = pushSrcLocRn locn $
474 lookupClassOp class_name op `thenRn` \ op_name ->
475 returnRn (DeforestSig op_name locn)
477 rn_uprag class_name (MagicUnfoldingSig op str locn)
478 = pushSrcLocRn locn $
479 lookupClassOp class_name op `thenRn` \ op_name ->
480 returnRn (MagicUnfoldingSig op_name str locn)
485 = lookupValue v `thenRn` \ new_v ->
486 returnRn (Just new_v)
489 %*********************************************************
491 \subsection{@SPECIALIZE instance@ user-pragmas}
493 %*********************************************************
496 rnSpecInstSig :: RdrNameSpecInstSig
497 -> RnM_Fixes s RenamedSpecInstSig
499 rnSpecInstSig (SpecInstSig clas ty src_loc)
500 = pushSrcLocRn src_loc $
502 tyvars = extractMonoTyNames is_tyvar_name ty
504 mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env,_) ->
505 lookupClass clas `thenRn` \ new_clas ->
506 rnMonoType tv_env ty `thenRn` \ new_ty ->
507 returnRn (SpecInstSig new_clas new_ty src_loc)
510 %*********************************************************
512 \subsection{Default declarations}
514 %*********************************************************
516 @rnDefaultDecl@ uses the `global name function' to create a new set
517 of default declarations in which local names have been replaced by
518 their original names, reporting any unknown names.
521 rnDefaultDecl :: [RdrNameDefaultDecl] -> RnM_Fixes s [RenamedDefaultDecl]
523 rnDefaultDecl [] = returnRn []
524 rnDefaultDecl [DefaultDecl tys src_loc]
525 = pushSrcLocRn src_loc $
526 mapRn (rnMonoType nullTyVarNamesEnv) tys `thenRn` \ tys' ->
527 returnRn [DefaultDecl tys' src_loc]
528 rnDefaultDecl defs@(d:ds)
529 = addErrRn (dupDefaultDeclErr defs) `thenRn_`
533 %*************************************************************************
535 \subsection{Fixity declarations}
537 %*************************************************************************
540 rnFixes :: [RdrNameFixityDecl] -> RnM s [RenamedFixityDecl]
543 = getSrcLocRn `thenRn` \ src_loc ->
545 (_, dup_fixes) = removeDups cmp_fix fixities
546 cmp_fix fix1 fix2 = nameFixDecl fix1 `cmp` nameFixDecl fix2
548 rn_fixity fix@(InfixL name i)
549 = rn_fixity_pieces InfixL name i fix
550 rn_fixity fix@(InfixR name i)
551 = rn_fixity_pieces InfixR name i fix
552 rn_fixity fix@(InfixN name i)
553 = rn_fixity_pieces InfixN name i fix
555 rn_fixity_pieces mk_fixity name i fix
556 = getRnEnv `thenRn` \ env ->
557 case lookupGlobalRnEnv env name of
558 Just res | isLocallyDefined res
559 -> returnRn (Just (mk_fixity res i))
560 _ -> failButContinueRn Nothing (undefinedFixityDeclErr src_loc fix)
562 mapRn (addErrRn . dupFixityDeclErr src_loc) dup_fixes `thenRn_`
563 mapRn rn_fixity fixities `thenRn` \ fixes_maybe ->
564 returnRn (catMaybes fixes_maybe)
566 nameFixDecl (InfixL name i) = name
567 nameFixDecl (InfixR name i) = name
568 nameFixDecl (InfixN name i) = name
571 %*********************************************************
573 \subsection{Support code to rename types}
575 %*********************************************************
578 rnPolyType :: TyVarNamesEnv
580 -> RnM_Fixes s RenamedPolyType
582 rnPolyType tv_env (HsForAllTy tvs ctxt ty)
583 = rn_poly_help tv_env tvs ctxt ty
585 rnPolyType tv_env (HsPreForAllTy ctxt ty)
586 = rn_poly_help tv_env forall_tyvars ctxt ty
588 mentioned_tyvars = extractCtxtTyNames ctxt `unionLists` extractMonoTyNames is_tyvar_name ty
589 forall_tyvars = --pprTrace "mentioned:" (ppCat (map (ppr PprShowAll) mentioned_tyvars)) $
590 --pprTrace "from_ty:" (ppCat (map (ppr PprShowAll) (extractMonoTyNames is_tyvar_name ty))) $
591 mentioned_tyvars `minusList` domTyVarNamesEnv tv_env
594 rn_poly_help :: TyVarNamesEnv
598 -> RnM_Fixes s RenamedPolyType
600 rn_poly_help tv_env tyvars ctxt ty
601 = --pprTrace "rnPolyType:" (ppCat [ppCat (map (ppr PprShowAll . snd) tv_env),
602 -- ppStr ";tvs=", ppCat (map (ppr PprShowAll) tyvars),
603 -- ppStr ";ctxt=", ppCat (map (ppr PprShowAll) ctxt),
604 -- ppStr ";ty=", ppr PprShowAll ty]
606 getSrcLocRn `thenRn` \ src_loc ->
607 mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env1, new_tyvars) ->
609 tv_env2 = catTyVarNamesEnvs tv_env1 tv_env
611 rnContext tv_env2 ctxt `thenRn` \ new_ctxt ->
612 rnMonoType tv_env2 ty `thenRn` \ new_ty ->
613 returnRn (HsForAllTy new_tyvars new_ctxt new_ty)
617 rnMonoType :: TyVarNamesEnv
619 -> RnM_Fixes s RenamedMonoType
621 rnMonoType tv_env (MonoTyVar tyvar)
622 = lookupTyVarName tv_env tyvar `thenRn` \ tyvar' ->
623 returnRn (MonoTyVar tyvar')
625 rnMonoType tv_env (MonoListTy ty)
626 = rnMonoType tv_env ty `thenRn` \ ty' ->
627 returnRn (MonoListTy ty')
629 rnMonoType tv_env (MonoFunTy ty1 ty2)
630 = andRn MonoFunTy (rnMonoType tv_env ty1)
631 (rnMonoType tv_env ty2)
633 rnMonoType tv_env (MonoTupleTy tys)
634 = mapRn (rnMonoType tv_env) tys `thenRn` \ tys' ->
635 returnRn (MonoTupleTy tys')
637 rnMonoType tv_env (MonoTyApp name tys)
639 lookup_fn = if isLexVarId (getLocalName name)
640 then lookupTyVarName tv_env
643 lookup_fn name `thenRn` \ name' ->
644 mapRn (rnMonoType tv_env) tys `thenRn` \ tys' ->
645 returnRn (MonoTyApp name' tys')
649 rnContext :: TyVarNamesEnv -> RdrNameContext -> RnM_Fixes s RenamedContext
651 rnContext tv_env ctxt
654 rn_ctxt (clas, tyvar)
655 = lookupClass clas `thenRn` \ clas_name ->
656 lookupTyVarName tv_env tyvar `thenRn` \ tyvar_name ->
657 returnRn (clas_name, tyvar_name)
662 dupNameExportWarn locn names@((n,_):_)
663 = addShortErrLocLine locn (\ sty ->
664 ppCat [pprNonSym sty n, ppStr "exported", ppInt (length names), ppStr "times"])
666 dupLocalsExportErr locn locals@((str,_):_)
667 = addErrLoc locn "exported names have same local name" (\ sty ->
668 ppInterleave ppSP (map (pprNonSym sty . snd) locals))
670 classOpExportErr op locn
671 = addShortErrLocLine locn (\ sty ->
672 ppBesides [ppStr "class operation `", ppr sty op, ppStr "' can only be exported with class"])
674 synAllExportErr syn locn
675 = addShortErrLocLine locn (\ sty ->
676 ppBesides [ppStr "type synonym `", ppr sty syn, ppStr "' should be exported abstractly"])
678 withExportErr str rn has rns locn
679 = addErrLoc locn "" (\ sty ->
680 ppAboves [ ppBesides [ppStr "inconsistent list of", ppStr str, ppStr "in export list for `", ppr sty rn, ppStr "'"],
681 ppCat [ppStr " expected:", ppInterleave ppComma (map (ppr sty) has)],
682 ppCat [ppStr " found: ", ppInterleave ppComma (map (ppr sty) rns)] ])
685 = addShortErrLocLine locn (\ sty ->
686 ppBesides [ ppStr "`", pprNonSym sty rn, ppStr "' has been exported with (..), but is only imported abstractly"])
688 badModExportErr mod locn
689 = addShortErrLocLine locn (\ sty ->
690 ppCat [ ppStr "unknown module in export list:", ppPStr mod])
692 dupModExportWarn locn mods@(mod:_)
693 = addShortErrLocLine locn (\ sty ->
694 ppCat [ppStr "module", ppPStr mod, ppStr "appears", ppInt (length mods), ppStr "times in export list"])
696 emptyModExportWarn locn mod
697 = addShortErrLocLine locn (\ sty ->
698 ppCat [ppStr "module", ppPStr mod, ppStr "has no unqualified imports to export"])
700 derivingNonStdClassErr clas locn
701 = addShortErrLocLine locn (\ sty ->
702 ppCat [ppStr "non-standard class in deriving:", ppr sty clas])
704 dupDefaultDeclErr (DefaultDecl _ locn1 : dup_things) sty
705 = ppAboves (item1 : map dup_item dup_things)
708 = addShortErrLocLine locn1 (\ sty -> ppStr "multiple default declarations") sty
710 dup_item (DefaultDecl _ locn)
711 = addShortErrLocLine locn (\ sty -> ppStr "here was another default declaration") sty
713 undefinedFixityDeclErr locn decl
714 = addErrLoc locn "fixity declaration for unknown operator" (\ sty ->
717 dupFixityDeclErr locn dups
718 = addErrLoc locn "multiple fixity declarations for same operator" (\ sty ->
719 ppAboves (map (ppr sty) dups))