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_DELOOPER(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, thenCmp, 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 "constructors (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 src_loc 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 src_loc 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 src_loc context `thenRn` \ context' ->
434 lookupClass cname `thenRn` \ cname' ->
435 mapRn (rn_op cname' tyvar' 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 clas_tyvar tv_env sig@(ClassOpSig op ty pragmas locn)
441 = pushSrcLocRn locn $
442 lookupClassOp clas op `thenRn` \ op_name ->
443 rnPolyType tv_env ty `thenRn` \ new_ty ->
445 (HsForAllTy tvs ctxt op_ty) = new_ty
446 ctxt_tvs = extractCtxtTyNames ctxt
447 op_tvs = extractMonoTyNames is_tyvar_name op_ty
449 -- check that class tyvar appears in op_ty
450 ( if isIn "rn_op" clas_tyvar op_tvs
452 else addErrRn (classTyVarNotInOpTyErr clas_tyvar sig locn)
455 -- check that class tyvar *doesn't* appear in the sig's context
456 ( if isIn "rn_op(2)" clas_tyvar ctxt_tvs
457 then addErrRn (classTyVarInOpCtxtErr clas_tyvar sig locn)
461 ASSERT(isNoClassOpPragmas pragmas)
462 returnRn (ClassOpSig op_name new_ty noClassOpPragmas locn)
466 %*********************************************************
468 \subsection{Instance declarations}
470 %*********************************************************
473 @rnInstDecl@ uses the `global name function' to create a new of
474 instance declaration in which local names have been replaced by their
475 original names, reporting any unknown names.
478 rnInstDecl :: RdrNameInstDecl -> RnM_Fixes s RenamedInstDecl
480 rnInstDecl (InstDecl cname ty mbinds from_here modname uprags pragmas src_loc)
481 = pushSrcLocRn src_loc $
482 lookupClass cname `thenRn` \ cname' ->
484 rnPolyType [] ty `thenRn` \ ty' ->
485 -- [] tv_env ensures that tyvars will be foralled
487 rnMethodBinds cname' mbinds `thenRn` \ mbinds' ->
488 mapRn (rn_uprag cname') uprags `thenRn` \ new_uprags ->
490 ASSERT(isNoInstancePragmas pragmas)
491 returnRn (InstDecl cname' ty' mbinds'
492 from_here modname new_uprags noInstancePragmas src_loc)
494 rn_uprag class_name (SpecSig op ty using locn)
495 = pushSrcLocRn src_loc $
496 lookupClassOp class_name op `thenRn` \ op_name ->
497 rnPolyType nullTyVarNamesEnv ty `thenRn` \ new_ty ->
498 rn_using using `thenRn` \ new_using ->
499 returnRn (SpecSig op_name new_ty new_using locn)
501 rn_uprag class_name (InlineSig op locn)
502 = pushSrcLocRn locn $
503 lookupClassOp class_name op `thenRn` \ op_name ->
504 returnRn (InlineSig op_name locn)
506 rn_uprag class_name (DeforestSig op locn)
507 = pushSrcLocRn locn $
508 lookupClassOp class_name op `thenRn` \ op_name ->
509 returnRn (DeforestSig op_name locn)
511 rn_uprag class_name (MagicUnfoldingSig op str locn)
512 = pushSrcLocRn locn $
513 lookupClassOp class_name op `thenRn` \ op_name ->
514 returnRn (MagicUnfoldingSig op_name str locn)
519 = lookupValue v `thenRn` \ new_v ->
520 returnRn (Just new_v)
523 %*********************************************************
525 \subsection{@SPECIALIZE instance@ user-pragmas}
527 %*********************************************************
530 rnSpecInstSig :: RdrNameSpecInstSig
531 -> RnM_Fixes s RenamedSpecInstSig
533 rnSpecInstSig (SpecInstSig clas ty src_loc)
534 = pushSrcLocRn src_loc $
536 tyvars = extractMonoTyNames is_tyvar_name ty
538 mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env,_) ->
539 lookupClass clas `thenRn` \ new_clas ->
540 rnMonoType tv_env ty `thenRn` \ new_ty ->
541 returnRn (SpecInstSig new_clas new_ty src_loc)
544 %*********************************************************
546 \subsection{Default declarations}
548 %*********************************************************
550 @rnDefaultDecl@ uses the `global name function' to create a new set
551 of default declarations in which local names have been replaced by
552 their original names, reporting any unknown names.
555 rnDefaultDecl :: [RdrNameDefaultDecl] -> RnM_Fixes s [RenamedDefaultDecl]
557 rnDefaultDecl [] = returnRn []
558 rnDefaultDecl [DefaultDecl tys src_loc]
559 = pushSrcLocRn src_loc $
560 mapRn (rnMonoType nullTyVarNamesEnv) tys `thenRn` \ tys' ->
561 returnRn [DefaultDecl tys' src_loc]
562 rnDefaultDecl defs@(d:ds)
563 = addErrRn (dupDefaultDeclErr defs) `thenRn_`
567 %*************************************************************************
569 \subsection{Fixity declarations}
571 %*************************************************************************
574 rnFixes :: [RdrNameFixityDecl] -> RnM s [RenamedFixityDecl]
577 = getSrcLocRn `thenRn` \ src_loc ->
579 (_, dup_fixes) = removeDups cmp_fix fixities
580 cmp_fix fix1 fix2 = fixDeclName fix1 `cmp` fixDeclName fix2
582 rn_fixity fix@(InfixL name i)
583 = rn_fixity_pieces InfixL name i fix
584 rn_fixity fix@(InfixR name i)
585 = rn_fixity_pieces InfixR name i fix
586 rn_fixity fix@(InfixN name i)
587 = rn_fixity_pieces InfixN name i fix
589 rn_fixity_pieces mk_fixity name i fix
590 = getRnEnv `thenRn` \ env ->
591 case lookupGlobalRnEnv env name of
592 Just res | isLocallyDefined res
593 -> returnRn (Just (mk_fixity res i))
594 _ -> failButContinueRn Nothing (undefinedFixityDeclErr src_loc fix)
596 mapRn (addErrRn . dupFixityDeclErr src_loc) dup_fixes `thenRn_`
597 mapRn rn_fixity fixities `thenRn` \ fixes_maybe ->
598 returnRn (catMaybes fixes_maybe)
601 %*********************************************************
603 \subsection{Support code to rename types}
605 %*********************************************************
608 rnPolyType :: TyVarNamesEnv
610 -> RnM_Fixes s RenamedPolyType
612 rnPolyType tv_env (HsForAllTy tvs ctxt ty)
613 = rn_poly_help tv_env tvs ctxt ty
615 rnPolyType tv_env (HsPreForAllTy ctxt ty)
616 = rn_poly_help tv_env forall_tyvars ctxt ty
618 mentioned_tyvars = extractCtxtTyNames ctxt `unionLists` extractMonoTyNames is_tyvar_name ty
620 pprTrace "mentioned:" (ppCat (map (ppr PprShowAll) mentioned_tyvars)) $
621 pprTrace "from_ty:" (ppCat (map (ppr PprShowAll) (extractMonoTyNames is_tyvar_name ty))) $
623 mentioned_tyvars `minusList` domTyVarNamesEnv tv_env
626 rn_poly_help :: TyVarNamesEnv
630 -> RnM_Fixes s RenamedPolyType
632 rn_poly_help tv_env tyvars ctxt ty
634 pprTrace "rnPolyType:"
635 (ppCat [ppCat (map (ppr PprShowAll . snd) tv_env),
636 ppStr ";tvs=", ppCat (map (ppr PprShowAll) tyvars),
637 ppStr ";ctxt=", ppCat (map (ppr PprShowAll) ctxt),
638 ppStr ";ty=", ppr PprShowAll ty]) $
640 getSrcLocRn `thenRn` \ src_loc ->
641 mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env1, new_tyvars) ->
643 tv_env2 = catTyVarNamesEnvs tv_env1 tv_env
645 rnContext tv_env2 src_loc ctxt `thenRn` \ new_ctxt ->
646 rnMonoType tv_env2 ty `thenRn` \ new_ty ->
647 returnRn (HsForAllTy new_tyvars new_ctxt new_ty)
651 rnMonoType :: TyVarNamesEnv
653 -> RnM_Fixes s RenamedMonoType
655 rnMonoType tv_env (MonoTyVar tyvar)
656 = lookupTyVarName tv_env tyvar `thenRn` \ tyvar' ->
657 returnRn (MonoTyVar tyvar')
659 rnMonoType tv_env (MonoListTy ty)
660 = rnMonoType tv_env ty `thenRn` \ ty' ->
661 returnRn (MonoListTy ty')
663 rnMonoType tv_env (MonoFunTy ty1 ty2)
664 = andRn MonoFunTy (rnMonoType tv_env ty1)
665 (rnMonoType tv_env ty2)
667 rnMonoType tv_env (MonoTupleTy tys)
668 = mapRn (rnMonoType tv_env) tys `thenRn` \ tys' ->
669 returnRn (MonoTupleTy tys')
671 rnMonoType tv_env (MonoTyApp name tys)
673 lookup_fn = if isLexVarId (getLocalName name)
674 then lookupTyVarName tv_env
677 lookup_fn name `thenRn` \ name' ->
678 mapRn (rnMonoType tv_env) tys `thenRn` \ tys' ->
679 returnRn (MonoTyApp name' tys')
683 rnContext :: TyVarNamesEnv -> SrcLoc -> RdrNameContext -> RnM_Fixes s RenamedContext
685 rnContext tv_env locn ctxt
686 = mapRn rn_ctxt ctxt `thenRn` \ result ->
688 (_, dup_asserts) = removeDups cmp_assert result
690 -- If this isn't an error, then it ought to be:
691 mapRn (addWarnRn . dupClassAssertWarn result locn) dup_asserts `thenRn_`
694 rn_ctxt (clas, tyvar)
695 = lookupClass clas `thenRn` \ clas_name ->
696 lookupTyVarName tv_env tyvar `thenRn` \ tyvar_name ->
697 returnRn (clas_name, tyvar_name)
699 cmp_assert (c1,tv1) (c2,tv2)
700 = (c1 `cmp` c2) `thenCmp` (tv1 `cmp` tv2)
705 dupNameExportWarn locn names@((n,_):_)
706 = addShortWarnLocLine locn $ \ sty ->
707 ppCat [pprNonSym sty n, ppStr "exported", ppInt (length names), ppStr "times"]
709 dupLocalsExportErr locn locals@((str,_):_)
710 = addErrLoc locn "exported names have same local name" $ \ sty ->
711 ppInterleave ppSP (map (pprNonSym sty . snd) locals)
713 classOpExportErr op locn
714 = addShortErrLocLine locn $ \ sty ->
715 ppBesides [ppStr "class operation `", ppr sty op, ppStr "' can only be exported with class"]
717 synAllExportErr is_error syn locn
718 = (if is_error then addShortErrLocLine else addShortWarnLocLine) locn $ \ sty ->
719 ppBesides [ppStr "type synonym `", ppr sty syn, ppStr "' should be exported abstractly"]
721 withExportErr str rn has rns locn
722 = addErrLoc locn "" $ \ sty ->
723 ppAboves [ ppBesides [ppStr "inconsistent list of ", ppStr str, ppStr " in export list for `", ppr sty rn, ppStr "'"],
724 ppCat [ppStr " expected:", ppInterleave ppComma (map (ppr sty) has)],
725 ppCat [ppStr " found: ", ppInterleave ppComma (map (ppr sty) rns)] ]
728 = addShortErrLocLine locn $ \ sty ->
729 ppBesides [ ppStr "`", pprNonSym sty rn, ppStr "' has been exported with (..), but is only imported abstractly"]
731 badModExportErr mod locn
732 = addShortErrLocLine locn $ \ sty ->
733 ppCat [ ppStr "unknown module in export list: module", ppPStr mod]
735 emptyModExportWarn locn mod
736 = addShortWarnLocLine locn $ \ sty ->
737 ppCat [ppStr "module", ppPStr mod, ppStr "has no unqualified imports to export"]
739 dupModExportWarn locn mods@(mod:_)
740 = addShortWarnLocLine locn $ \ sty ->
741 ppCat [ppStr "module", ppPStr mod, ppStr "appears", ppInt (length mods), ppStr "times in export list"]
743 derivingNonStdClassErr clas locn
744 = addShortErrLocLine locn $ \ sty ->
745 ppCat [ppStr "non-standard class in deriving:", ppr sty clas]
747 dupDefaultDeclErr (DefaultDecl _ locn1 : dup_things) sty
748 = ppAboves (item1 : map dup_item dup_things)
751 = addShortErrLocLine locn1 (\ sty ->
752 ppStr "multiple default declarations") sty
754 dup_item (DefaultDecl _ locn)
755 = addShortErrLocLine locn (\ sty ->
756 ppStr "here was another default declaration") sty
758 undefinedFixityDeclErr locn decl
759 = addErrLoc locn "fixity declaration for unknown operator" $ \ sty ->
762 dupFixityDeclErr locn dups
763 = addErrLoc locn "multiple fixity declarations for same operator" $ \ sty ->
764 ppAboves (map (ppr sty) dups)
766 classTyVarNotInOpTyErr clas_tyvar sig locn
767 = addShortErrLocLine locn $ \ sty ->
768 ppHang (ppBesides [ppStr "Class type variable `", ppr sty clas_tyvar, ppStr "' does not appear in method signature:"])
771 classTyVarInOpCtxtErr clas_tyvar sig locn
772 = addShortErrLocLine locn $ \ sty ->
773 ppHang (ppBesides [ppStr "Class type variable `", ppr sty clas_tyvar, ppStr "' present in method's local overloading context:"])
776 dupClassAssertWarn ctxt locn dups
777 = addShortWarnLocLine locn $ \ sty ->
778 ppHang (ppBesides [ppStr "Duplicate class assertion `", ppr sty dups, ppStr "' in context:"])