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
13 IMPORT_1_3(List(partition))
20 import RnBinds ( rnTopBinds, rnMethodBinds )
21 import RnUtils ( getLocalsFromRnEnv, lookupGlobalRnEnv, lubExportFlag )
23 import Bag ( emptyBag, unitBag, consBag, unionManyBags, unionBags, listToBag, bagToList )
24 import Class ( derivableClassKeys )
25 import CmdLineOpts ( opt_CompilingGhcInternals )
26 import ErrUtils ( addErrLoc, addShortErrLocLine, addShortWarnLocLine )
27 import FiniteMap ( emptyFM, lookupFM, addListToFM_C )
28 import Id ( isDataCon, GenId{-instance NamedThing-} )
29 import ListSetOps ( unionLists, minusList )
30 import Maybes ( maybeToBool, catMaybes )
31 import Name ( isLocallyDefined, isLexVarId, getLocalName, ExportFlag(..),
32 nameImportFlag, RdrName, pprNonSym, Name )
33 import Outputable ( Outputable(..){-instances-} )
34 --import PprStyle -- ToDo:rm
36 import SrcLoc ( SrcLoc )
37 import TyCon ( tyConDataCons, TyCon{-instance NamedThing-} )
38 import Unique ( Unique )
39 import UniqFM ( emptyUFM, addListToUFM_C, listToUFM, plusUFM, lookupUFM, eltsUFM )
40 import UniqSet ( SYN_IE(UniqSet) )
41 import Util ( isIn, isn'tIn, thenCmp, sortLt, removeDups, mapAndUnzip3, cmpPString,
42 panic, assertPanic{- , pprTrace ToDo:rm-} )
45 rnSource `renames' the source module and export list.
46 It simultaneously performs dependency analysis and precedence parsing.
47 It also does the following error checks:
50 Checks that tyvars are used properly. This includes checking
51 for undefined tyvars, and tyvars in contexts that are ambiguous.
53 Checks that all variable occurences are defined.
55 Checks the (..) etc constraints in the export list.
60 rnSource :: [Module] -- imported modules
61 -> Bag (Module,RnName) -- unqualified imports from module
62 -> Bag RenamedFixityDecl -- fixity info for imported names
64 -> RnM s (RenamedHsModule,
65 Name -> ExportFlag, -- export info
66 ([(Name, ExportFlag)], -- export module X stuff
67 [(Name, ExportFlag)]),
68 Bag (RnName, RdrName)) -- occurrence info
70 rnSource imp_mods unqual_imps imp_fixes
71 (HsModule mod version exports _ fixes
72 ty_decls specdata_sigs class_decls
73 inst_decls specinst_sigs defaults
76 = pushSrcLocRn src_loc $
78 rnExports (mod:imp_mods) unqual_imps exports `thenRn` \ (exported_fn, module_dotdots) ->
79 rnFixes fixes `thenRn` \ src_fixes ->
81 all_fixes = src_fixes ++ bagToList imp_fixes
82 all_fixes_fm = listToUFM (map pair_name all_fixes)
84 pair_name inf = (fixDeclName inf, inf)
86 setExtraRn all_fixes_fm $
88 mapRn rnTyDecl ty_decls `thenRn` \ new_ty_decls ->
89 mapRn rnSpecDataSig specdata_sigs `thenRn` \ new_specdata_sigs ->
90 mapRn rnClassDecl class_decls `thenRn` \ new_class_decls ->
91 mapRn rnInstDecl inst_decls `thenRn` \ new_inst_decls ->
92 mapRn rnSpecInstSig specinst_sigs `thenRn` \ new_specinst_sigs ->
93 rnDefaultDecl defaults `thenRn` \ new_defaults ->
94 rnTopBinds binds `thenRn` \ new_binds ->
96 getOccurrenceUpRn `thenRn` \ occ_info ->
100 trashed_exports trashed_imports all_fixes
101 new_ty_decls new_specdata_sigs new_class_decls
102 new_inst_decls new_specinst_sigs new_defaults
103 new_binds [] src_loc,
104 exported_fn, module_dotdots,
108 trashed_exports = {-trace "rnSource:trashed_exports"-} Nothing
109 trashed_imports = {-trace "rnSource:trashed_imports"-} []
113 %*********************************************************
115 \subsection{Export list}
117 %*********************************************************
120 rnExports :: [Module]
121 -> Bag (Module,RnName)
123 -> RnM s (Name -> ExportFlag, -- main export-flag fun
124 ([(Name,ExportFlag)], -- info about "module X" exports
128 rnExports mods unqual_imps Nothing
129 = returnRn (\n -> if isLocallyDefined n then ExportAll else NotExported
133 rnExports mods unqual_imps (Just exps)
134 = getModuleRn `thenRn` \ this_mod ->
135 getRnEnv `thenRn` \ rn_env ->
136 mapAndUnzipRn (rnIE mods) exps `thenRn` \ (mod_maybes, exp_bags) ->
138 (tc_bags, val_bags) = unzip exp_bags
139 tc_names = bagToList (unionManyBags tc_bags)
140 val_names = bagToList (unionManyBags val_bags)
141 exp_mods = catMaybes mod_maybes
143 -- Warn for duplicate names and modules
144 (_, dup_tc_names) = removeDups cmp_fst tc_names
145 (_, dup_val_names) = removeDups cmp_fst val_names
146 cmp_fst (x,_) (y,_) = x `cmp` y
148 (uniq_mods, dup_mods) = removeDups cmpPString exp_mods
149 (expmods_this, expmods_imps) = partition (== this_mod) uniq_mods
151 -- Get names for "module This_Mod" export
152 (this_tcs, this_vals)
153 = if null expmods_this
155 else getLocalsFromRnEnv rn_env
157 -- Get names for exported imported modules
158 (mod_tcs, mod_vals, empty_mods)
159 = case mapAndUnzip3 get_mod_names expmods_imps of
160 (tcs, vals, emptys) -> (concat tcs, concat vals, catMaybes emptys)
162 (unqual_tcs, unqual_vals) = partition (isRnTyConOrClass.snd) (bagToList unqual_imps)
165 = --pprTrace "get_mod_names" (ppAboves [ppPStr mod, interpp'SP PprDebug (map fst tcs), interpp'SP PprDebug (map fst vals)]) $
166 (tcs, vals, empty_mod)
168 tcs = [(getName rn, nameImportFlag (getName rn))
169 | (mod',rn) <- unqual_tcs, mod == mod']
170 vals = [(getName rn, nameImportFlag (getName rn))
171 | (mod',rn) <- unqual_vals, mod == mod', fun_looking rn]
172 empty_mod = if null tcs && null vals
176 -- fun_looking: must avoid class ops and data constructors
177 -- and record fieldnames
178 fun_looking (RnName _) = True
179 fun_looking (WiredInId i) = not (isDataCon i)
180 fun_looking _ = False
182 -- Build finite map of exported names to export flag
183 tc_map0 = addListToUFM_C lub_expflag emptyUFM (map pair_fst tc_names)
184 tc_map1 = addListToUFM_C lub_expflag tc_map0 (map pair_fst mod_tcs)
185 tc_map = addListToUFM_C lub_expflag tc_map1 (map (pair_fst.exp_all) this_tcs)
187 val_map0 = addListToUFM_C lub_expflag emptyUFM (map pair_fst val_names)
188 val_map1 = addListToUFM_C lub_expflag val_map0 (map pair_fst mod_vals)
189 val_map = addListToUFM_C lub_expflag val_map1 (map (pair_fst.exp_all) this_vals)
191 pair_fst pr@(n,_) = (n,pr)
192 exp_all rn = (getName rn, ExportAll)
193 lub_expflag (n, flag1) (_, flag2) = (n, lubExportFlag flag1 flag2)
195 -- Check for exporting of duplicate local names
196 tc_locals = [(getLocalName n, n) | (n,_) <- eltsUFM tc_map]
197 val_locals = [(getLocalName n, n) | (n,_) <- eltsUFM val_map]
198 (_, dup_tc_locals) = removeDups cmp_local tc_locals
199 (_, dup_val_locals) = removeDups cmp_local val_locals
200 cmp_local (x,_) (y,_) = x `cmpPString` y
202 -- Build export flag function
203 final_exp_map = plusUFM tc_map val_map
204 exp_fn n = case lookupUFM final_exp_map n of
205 Nothing -> NotExported
206 Just (_,flag) -> flag
208 getSrcLocRn `thenRn` \ src_loc ->
209 mapRn (addWarnRn . dupNameExportWarn src_loc) dup_tc_names `thenRn_`
210 mapRn (addWarnRn . dupNameExportWarn src_loc) dup_val_names `thenRn_`
211 mapRn (addWarnRn . dupModExportWarn src_loc) dup_mods `thenRn_`
212 mapRn (addWarnRn . emptyModExportWarn src_loc) empty_mods `thenRn_`
213 mapRn (addErrRn . dupLocalsExportErr src_loc) dup_tc_locals `thenRn_`
214 mapRn (addErrRn . dupLocalsExportErr src_loc) dup_val_locals `thenRn_`
215 returnRn (exp_fn, (mod_vals, mod_tcs))
217 ------------------------------------
218 -- rename an "IE" in the export list
220 rnIE :: [Module] -- this module and all the (directly?) imported modules
223 Maybe Module, -- Just m => a "module X" export item
224 (Bag (Name, ExportFlag), -- Exported tycons/classes
225 Bag (Name, ExportFlag))) -- Exported values
227 rnIE mods (IEVar name)
228 = lookupValue name `thenRn` \ rn ->
229 checkIEVar rn `thenRn` \ exps ->
230 returnRn (Nothing, exps)
232 checkIEVar (RnName n) = returnRn (emptyBag, unitBag (n,ExportAll))
233 checkIEVar (WiredInId i) = returnRn (emptyBag, unitBag (getName i, ExportAll))
234 checkIEVar rn@(RnClassOp _ _) = getSrcLocRn `thenRn` \ src_loc ->
235 failButContinueRn (emptyBag, emptyBag) (classOpExportErr rn src_loc)
236 checkIEVar rn@(RnField _ _) = getSrcLocRn `thenRn` \ src_loc ->
237 failButContinueRn (emptyBag, emptyBag) (fieldExportErr rn src_loc)
238 checkIEVar rn = --pprTrace "rnIE:IEVar:panic? ToDo?:" (ppr PprDebug rn) $
239 returnRn (emptyBag, emptyBag)
241 rnIE mods (IEThingAbs name)
242 = lookupTyConOrClass name `thenRn` \ rn ->
243 checkIEAbs rn `thenRn` \ exps ->
244 returnRn (Nothing, exps)
246 checkIEAbs (RnSyn n) = returnRn (unitBag (n,ExportAbs), emptyBag)
247 checkIEAbs (RnData n _ _) = returnRn (unitBag (n,ExportAbs), emptyBag)
248 checkIEAbs (RnClass n _) = returnRn (unitBag (n,ExportAbs), emptyBag)
249 checkIEAbs (WiredInTyCon t) = returnRn (unitBag (getName t,ExportAbs), emptyBag)
250 checkIEAbs rn = --pprTrace "rnIE:IEAbs:panic? ToDo?:" (ppr PprDebug rn) $
251 returnRn (emptyBag, emptyBag)
253 rnIE mods (IEThingAll name)
254 = lookupTyConOrClass name `thenRn` \ rn ->
255 checkIEAll rn `thenRn` \ exps ->
256 checkImportAll rn `thenRn_`
257 returnRn (Nothing, exps)
259 checkIEAll (RnData n cons fields)
260 = returnRn (unitBag (exp_all n),
261 listToBag (map exp_all cons) `unionBags` listToBag (map exp_all fields))
263 checkIEAll (WiredInTyCon t)
264 = returnRn (unitBag (exp_all (getName t)), listToBag (map exp_all cons))
266 cons = map getName (tyConDataCons t)
268 checkIEAll (RnClass n ops)
269 = returnRn (unitBag (exp_all n), listToBag (map exp_all ops))
270 checkIEAll rn@(RnSyn n)
271 = getSrcLocRn `thenRn` \ src_loc ->
272 warnAndContinueRn (unitBag (n, ExportAbs), emptyBag)
273 (synAllExportErr False{-warning-} rn src_loc)
275 checkIEAll rn = --pprTrace "rnIE:IEAll:panic? ToDo?:" (ppr PprDebug rn) $
276 returnRn (emptyBag, emptyBag)
278 exp_all n = (n, ExportAll)
280 rnIE mods (IEThingWith name names)
281 = lookupTyConOrClass name `thenRn` \ rn ->
282 mapRn lookupValue names `thenRn` \ rns ->
283 checkIEWith rn rns `thenRn` \ exps ->
284 checkImportAll rn `thenRn_`
285 returnRn (Nothing, exps)
287 checkIEWith rn@(RnData n cons fields) rns
288 | same_names (cons++fields) rns
289 = returnRn (unitBag (exp_all n), listToBag (map exp_all cons)
291 listToBag (map exp_all fields))
293 = rnWithErr "constructors (and fields)" rn (cons++fields) rns
294 checkIEWith rn@(RnClass n ops) rns
296 = returnRn (unitBag (exp_all n), listToBag (map exp_all ops))
298 = rnWithErr "class ops" rn ops rns
299 checkIEWith rn@(RnSyn _) rns
300 = getSrcLocRn `thenRn` \ src_loc ->
301 failButContinueRn (emptyBag, emptyBag) (synAllExportErr True{-error-} rn src_loc)
302 checkIEWith (WiredInTyCon _) rns = panic "RnSource.rnIE:checkIEWith:WiredInTyCon:ToDo (boring)"
304 = --pprTrace "rnIE:IEWith:panic? ToDo?:" (ppr PprDebug rn) $
305 returnRn (emptyBag, emptyBag)
307 exp_all n = (n, ExportAll)
310 = all (not.isRnUnbound) rns &&
311 sortLt (<) (map uniqueOf has) == sortLt (<) (map uniqueOf rns)
313 rnWithErr str rn has rns
314 = getSrcLocRn `thenRn` \ src_loc ->
315 failButContinueRn (emptyBag, emptyBag) (withExportErr str rn has rns src_loc)
317 rnIE mods (IEModuleContents mod)
318 | isIn "rnIE:IEModule" mod mods
319 = returnRn (Just mod, (emptyBag, emptyBag))
321 = getSrcLocRn `thenRn` \ src_loc ->
322 failButContinueRn (Nothing, (emptyBag, emptyBag)) (badModExportErr mod src_loc)
326 = case nameImportFlag (getName rn) of
327 ExportAll -> returnRn ()
328 exp -> getSrcLocRn `thenRn` \ src_loc ->
329 addErrRn (importAllErr rn src_loc)
332 %*********************************************************
334 \subsection{Type declarations}
336 %*********************************************************
338 @rnTyDecl@ uses the `global name function' to create a new type
339 declaration in which local names have been replaced by their original
340 names, reporting any unknown names.
342 Renaming type variables is a pain. Because they now contain uniques,
343 it is necessary to pass in an association list which maps a parsed
344 tyvar to its Name representation. In some cases (type signatures of
345 values), it is even necessary to go over the type first in order to
346 get the set of tyvars used by it, make an assoc list, and then go over
347 it again to rename the tyvars! However, we can also do some scoping
348 checks at the same time.
351 rnTyDecl :: RdrNameTyDecl -> RnM_Fixes s RenamedTyDecl
353 rnTyDecl (TyData context tycon tyvars condecls derivings pragmas src_loc)
354 = pushSrcLocRn src_loc $
355 lookupTyCon tycon `thenRn` \ tycon' ->
356 mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env, tyvars') ->
357 rnContext tv_env src_loc context `thenRn` \ context' ->
358 rnConDecls tv_env condecls `thenRn` \ condecls' ->
359 rn_derivs tycon' src_loc derivings `thenRn` \ derivings' ->
360 ASSERT(isNoDataPragmas pragmas)
361 returnRn (TyData context' tycon' tyvars' condecls' derivings' noDataPragmas src_loc)
363 rnTyDecl (TyNew context tycon tyvars condecl derivings pragmas src_loc)
364 = pushSrcLocRn src_loc $
365 lookupTyCon tycon `thenRn` \ tycon' ->
366 mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env, tyvars') ->
367 rnContext tv_env src_loc context `thenRn` \ context' ->
368 rnConDecls tv_env condecl `thenRn` \ condecl' ->
369 rn_derivs tycon' src_loc derivings `thenRn` \ derivings' ->
370 ASSERT(isNoDataPragmas pragmas)
371 returnRn (TyNew context' tycon' tyvars' condecl' derivings' noDataPragmas src_loc)
373 rnTyDecl (TySynonym name tyvars ty src_loc)
374 = pushSrcLocRn src_loc $
375 lookupTyCon name `thenRn` \ name' ->
376 mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env, tyvars') ->
377 rnMonoType tv_env ty `thenRn` \ ty' ->
378 returnRn (TySynonym name' tyvars' ty' src_loc)
380 rn_derivs tycon2 locn Nothing -- derivs not specified
383 rn_derivs tycon2 locn (Just ds)
384 = mapRn (rn_deriv tycon2 locn) ds `thenRn` \ derivs ->
385 returnRn (Just derivs)
387 rn_deriv tycon2 locn clas
388 = lookupClass clas `thenRn` \ clas_name ->
389 addErrIfRn (uniqueOf clas_name `not_elem` derivableClassKeys)
390 (derivingNonStdClassErr clas_name locn)
394 not_elem = isn'tIn "rn_deriv"
397 @rnConDecls@ uses the `global name function' to create a new
398 constructor in which local names have been replaced by their original
399 names, reporting any unknown names.
402 rnConDecls :: TyVarNamesEnv
404 -> RnM_Fixes s [RenamedConDecl]
406 rnConDecls tv_env con_decls
407 = mapRn rn_decl con_decls
409 rn_decl (ConDecl name tys src_loc)
410 = pushSrcLocRn src_loc $
411 lookupConstr name `thenRn` \ new_name ->
412 mapRn rn_bang_ty tys `thenRn` \ new_tys ->
413 returnRn (ConDecl new_name new_tys src_loc)
415 rn_decl (ConOpDecl ty1 op ty2 src_loc)
416 = pushSrcLocRn src_loc $
417 lookupConstr op `thenRn` \ new_op ->
418 rn_bang_ty ty1 `thenRn` \ new_ty1 ->
419 rn_bang_ty ty2 `thenRn` \ new_ty2 ->
420 returnRn (ConOpDecl new_ty1 new_op new_ty2 src_loc)
422 rn_decl (NewConDecl name ty src_loc)
423 = pushSrcLocRn src_loc $
424 lookupConstr name `thenRn` \ new_name ->
425 rn_mono_ty ty `thenRn` \ new_ty ->
426 returnRn (NewConDecl new_name new_ty src_loc)
428 rn_decl (RecConDecl name fields src_loc)
429 = pushSrcLocRn src_loc $
430 lookupConstr name `thenRn` \ new_name ->
431 mapRn rn_field fields `thenRn` \ new_fields ->
432 returnRn (RecConDecl new_name new_fields src_loc)
435 = mapRn lookupField names `thenRn` \ new_names ->
436 rn_bang_ty ty `thenRn` \ new_ty ->
437 returnRn (new_names, new_ty)
439 rn_mono_ty = rnMonoType tv_env
440 rn_poly_ty = rnPolyType tv_env
442 rn_bang_ty (Banged ty)
443 = rn_poly_ty ty `thenRn` \ new_ty ->
444 returnRn (Banged new_ty)
445 rn_bang_ty (Unbanged ty)
446 = rn_poly_ty ty `thenRn` \ new_ty ->
447 returnRn (Unbanged new_ty)
450 %*********************************************************
452 \subsection{SPECIALIZE data pragmas}
454 %*********************************************************
457 rnSpecDataSig :: RdrNameSpecDataSig
458 -> RnM_Fixes s RenamedSpecDataSig
460 rnSpecDataSig (SpecDataSig tycon ty src_loc)
461 = pushSrcLocRn src_loc $
463 tyvars = extractMonoTyNames is_tyvar_name ty
465 mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env,_) ->
466 lookupTyCon tycon `thenRn` \ tycon' ->
467 rnMonoType tv_env ty `thenRn` \ ty' ->
468 returnRn (SpecDataSig tycon' ty' src_loc)
470 is_tyvar_name n = isLexVarId (getLocalName n)
473 %*********************************************************
475 \subsection{Class declarations}
477 %*********************************************************
479 @rnClassDecl@ uses the `global name function' to create a new
480 class declaration in which local names have been replaced by their
481 original names, reporting any unknown names.
484 rnClassDecl :: RdrNameClassDecl -> RnM_Fixes s RenamedClassDecl
486 rnClassDecl (ClassDecl context cname tyvar sigs mbinds pragmas src_loc)
487 = pushSrcLocRn src_loc $
488 mkTyVarNamesEnv src_loc [tyvar] `thenRn` \ (tv_env, [tyvar']) ->
489 rnContext tv_env src_loc context `thenRn` \ context' ->
490 lookupClass cname `thenRn` \ cname' ->
491 mapRn (rn_op cname' tyvar' tv_env) sigs `thenRn` \ sigs' ->
492 rnMethodBinds cname' mbinds `thenRn` \ mbinds' ->
493 ASSERT(isNoClassPragmas pragmas)
494 returnRn (ClassDecl context' cname' tyvar' sigs' mbinds' NoClassPragmas src_loc)
496 rn_op clas clas_tyvar tv_env sig@(ClassOpSig op ty pragmas locn)
497 = pushSrcLocRn locn $
498 lookupClassOp clas op `thenRn` \ op_name ->
499 rnPolyType tv_env ty `thenRn` \ new_ty ->
501 (HsForAllTy tvs ctxt op_ty) = new_ty
502 ctxt_tvs = extractCtxtTyNames ctxt
503 op_tvs = extractMonoTyNames is_tyvar_name op_ty
505 -- check that class tyvar appears in op_ty
506 ( if isIn "rn_op" clas_tyvar op_tvs
508 else addErrRn (classTyVarNotInOpTyErr clas_tyvar sig locn)
511 -- check that class tyvar *doesn't* appear in the sig's context
512 ( if isIn "rn_op(2)" clas_tyvar ctxt_tvs
513 then addErrRn (classTyVarInOpCtxtErr clas_tyvar sig locn)
517 ASSERT(isNoClassOpPragmas pragmas)
518 returnRn (ClassOpSig op_name new_ty noClassOpPragmas locn)
522 %*********************************************************
524 \subsection{Instance declarations}
526 %*********************************************************
529 @rnInstDecl@ uses the `global name function' to create a new of
530 instance declaration in which local names have been replaced by their
531 original names, reporting any unknown names.
534 rnInstDecl :: RdrNameInstDecl -> RnM_Fixes s RenamedInstDecl
536 rnInstDecl (InstDecl cname ty mbinds from_here modname uprags pragmas src_loc)
537 = pushSrcLocRn src_loc $
538 lookupClass cname `thenRn` \ cname' ->
540 rnPolyType [] ty `thenRn` \ ty' ->
541 -- [] tv_env ensures that tyvars will be foralled
543 rnMethodBinds cname' mbinds `thenRn` \ mbinds' ->
544 mapRn (rn_uprag cname') uprags `thenRn` \ new_uprags ->
546 ASSERT(isNoInstancePragmas pragmas)
547 returnRn (InstDecl cname' ty' mbinds'
548 from_here modname new_uprags noInstancePragmas src_loc)
550 rn_uprag class_name (SpecSig op ty using locn)
551 = pushSrcLocRn src_loc $
552 lookupClassOp class_name op `thenRn` \ op_name ->
553 rnPolyType nullTyVarNamesEnv ty `thenRn` \ new_ty ->
554 rn_using using `thenRn` \ new_using ->
555 returnRn (SpecSig op_name new_ty new_using locn)
557 rn_uprag class_name (InlineSig op locn)
558 = pushSrcLocRn locn $
559 lookupClassOp class_name op `thenRn` \ op_name ->
560 returnRn (InlineSig op_name locn)
562 rn_uprag class_name (DeforestSig op locn)
563 = pushSrcLocRn locn $
564 lookupClassOp class_name op `thenRn` \ op_name ->
565 returnRn (DeforestSig op_name locn)
567 rn_uprag class_name (MagicUnfoldingSig op str locn)
568 = pushSrcLocRn locn $
569 lookupClassOp class_name op `thenRn` \ op_name ->
570 returnRn (MagicUnfoldingSig op_name str locn)
575 = lookupValue v `thenRn` \ new_v ->
576 returnRn (Just new_v)
579 %*********************************************************
581 \subsection{@SPECIALIZE instance@ user-pragmas}
583 %*********************************************************
586 rnSpecInstSig :: RdrNameSpecInstSig
587 -> RnM_Fixes s RenamedSpecInstSig
589 rnSpecInstSig (SpecInstSig clas ty src_loc)
590 = pushSrcLocRn src_loc $
592 tyvars = extractMonoTyNames is_tyvar_name ty
594 mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env,_) ->
595 lookupClass clas `thenRn` \ new_clas ->
596 rnMonoType tv_env ty `thenRn` \ new_ty ->
597 returnRn (SpecInstSig new_clas new_ty src_loc)
600 %*********************************************************
602 \subsection{Default declarations}
604 %*********************************************************
606 @rnDefaultDecl@ uses the `global name function' to create a new set
607 of default declarations in which local names have been replaced by
608 their original names, reporting any unknown names.
611 rnDefaultDecl :: [RdrNameDefaultDecl] -> RnM_Fixes s [RenamedDefaultDecl]
613 rnDefaultDecl [] = returnRn []
614 rnDefaultDecl [DefaultDecl tys src_loc]
615 = pushSrcLocRn src_loc $
616 mapRn (rnMonoType nullTyVarNamesEnv) tys `thenRn` \ tys' ->
617 returnRn [DefaultDecl tys' src_loc]
618 rnDefaultDecl defs@(d:ds)
619 = addErrRn (dupDefaultDeclErr defs) `thenRn_`
623 %*************************************************************************
625 \subsection{Fixity declarations}
627 %*************************************************************************
630 rnFixes :: [RdrNameFixityDecl] -> RnM s [RenamedFixityDecl]
633 = getSrcLocRn `thenRn` \ src_loc ->
635 (_, dup_fixes) = removeDups cmp_fix fixities
636 cmp_fix fix1 fix2 = fixDeclName fix1 `cmp` fixDeclName fix2
638 rn_fixity fix@(InfixL name i)
639 = rn_fixity_pieces InfixL name i fix
640 rn_fixity fix@(InfixR name i)
641 = rn_fixity_pieces InfixR name i fix
642 rn_fixity fix@(InfixN name i)
643 = rn_fixity_pieces InfixN name i fix
645 rn_fixity_pieces mk_fixity name i fix
646 = getRnEnv `thenRn` \ env ->
647 case lookupGlobalRnEnv env name of
648 Just res | isLocallyDefined res -- || opt_CompilingGhcInternals
649 -- the opt_CompilingGhcInternals thing is a *HACK* to get (:)'s
650 -- fixity decl to go through. It has a builtin name, which
651 -- doesn't respond to isLocallyDefined... sigh.
652 -> returnRn (Just (mk_fixity res i))
653 _ -> failButContinueRn Nothing (undefinedFixityDeclErr src_loc fix)
655 mapRn (addErrRn . dupFixityDeclErr src_loc) dup_fixes `thenRn_`
656 mapRn rn_fixity fixities `thenRn` \ fixes_maybe ->
657 returnRn (catMaybes fixes_maybe)
660 %*********************************************************
662 \subsection{Support code to rename types}
664 %*********************************************************
667 rnPolyType :: TyVarNamesEnv
669 -> RnM_Fixes s RenamedPolyType
671 rnPolyType tv_env (HsForAllTy tvs ctxt ty)
672 = rn_poly_help tv_env tvs ctxt ty
674 rnPolyType tv_env (HsPreForAllTy ctxt ty)
675 = rn_poly_help tv_env forall_tyvars ctxt ty
677 mentioned_tyvars = extractCtxtTyNames ctxt `unionLists` extractMonoTyNames is_tyvar_name ty
679 pprTrace "mentioned:" (ppCat (map (ppr PprShowAll) mentioned_tyvars)) $
680 pprTrace "from_ty:" (ppCat (map (ppr PprShowAll) (extractMonoTyNames is_tyvar_name ty))) $
682 mentioned_tyvars `minusList` domTyVarNamesEnv tv_env
685 rn_poly_help :: TyVarNamesEnv
689 -> RnM_Fixes s RenamedPolyType
691 rn_poly_help tv_env tyvars ctxt ty
693 pprTrace "rnPolyType:"
694 (ppCat [ppCat (map (ppr PprShowAll . snd) tv_env),
695 ppStr ";tvs=", ppCat (map (ppr PprShowAll) tyvars),
696 ppStr ";ctxt=", ppCat (map (ppr PprShowAll) ctxt),
697 ppStr ";ty=", ppr PprShowAll ty]) $
699 getSrcLocRn `thenRn` \ src_loc ->
700 mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env1, new_tyvars) ->
702 tv_env2 = catTyVarNamesEnvs tv_env1 tv_env
704 rnContext tv_env2 src_loc ctxt `thenRn` \ new_ctxt ->
705 rnMonoType tv_env2 ty `thenRn` \ new_ty ->
706 returnRn (HsForAllTy new_tyvars new_ctxt new_ty)
710 rnMonoType :: TyVarNamesEnv
712 -> RnM_Fixes s RenamedMonoType
714 rnMonoType tv_env (MonoTyVar tyvar)
715 = lookupTyVarName tv_env tyvar `thenRn` \ tyvar' ->
716 returnRn (MonoTyVar tyvar')
718 rnMonoType tv_env (MonoListTy ty)
719 = rnMonoType tv_env ty `thenRn` \ ty' ->
720 returnRn (MonoListTy ty')
722 rnMonoType tv_env (MonoFunTy ty1 ty2)
723 = andRn MonoFunTy (rnMonoType tv_env ty1)
724 (rnMonoType tv_env ty2)
726 rnMonoType tv_env (MonoTupleTy tys)
727 = mapRn (rnMonoType tv_env) tys `thenRn` \ tys' ->
728 returnRn (MonoTupleTy tys')
730 rnMonoType tv_env (MonoTyApp name tys)
732 lookup_fn = if isLexVarId (getLocalName name)
733 then lookupTyVarName tv_env
736 lookup_fn name `thenRn` \ name' ->
737 mapRn (rnMonoType tv_env) tys `thenRn` \ tys' ->
738 returnRn (MonoTyApp name' tys')
742 rnContext :: TyVarNamesEnv -> SrcLoc -> RdrNameContext -> RnM_Fixes s RenamedContext
744 rnContext tv_env locn ctxt
745 = mapRn rn_ctxt ctxt `thenRn` \ result ->
747 (_, dup_asserts) = removeDups cmp_assert result
749 -- If this isn't an error, then it ought to be:
750 mapRn (addWarnRn . dupClassAssertWarn result locn) dup_asserts `thenRn_`
753 rn_ctxt (clas, tyvar)
754 = lookupClass clas `thenRn` \ clas_name ->
755 lookupTyVarName tv_env tyvar `thenRn` \ tyvar_name ->
756 returnRn (clas_name, tyvar_name)
758 cmp_assert (c1,tv1) (c2,tv2)
759 = (c1 `cmp` c2) `thenCmp` (tv1 `cmp` tv2)
764 dupNameExportWarn locn names@((n,_):_)
765 = addShortWarnLocLine locn $ \ sty ->
766 ppCat [pprNonSym sty n, ppStr "exported", ppInt (length names), ppStr "times"]
768 dupLocalsExportErr locn locals@((str,_):_)
769 = addErrLoc locn "exported names have same local name" $ \ sty ->
770 ppInterleave ppSP (map (pprNonSym sty . snd) locals)
772 classOpExportErr op locn
773 = addShortErrLocLine locn $ \ sty ->
774 ppBesides [ppStr "class operation `", ppr sty op, ppStr "' can only be exported with its class"]
776 fieldExportErr op locn
777 = addShortErrLocLine locn $ \ sty ->
778 ppBesides [ppStr "field name `", ppr sty op, ppStr "' can only be exported with its data type"]
780 synAllExportErr is_error syn locn
781 = (if is_error then addShortErrLocLine else addShortWarnLocLine) locn $ \ sty ->
782 ppBesides [ppStr "type synonym `", ppr sty syn, ppStr "' should be exported abstractly"]
784 withExportErr str rn has rns locn
785 = addErrLoc locn "" $ \ sty ->
786 ppAboves [ ppBesides [ppStr "inconsistent list of ", ppStr str, ppStr " in export list for `", ppr sty rn, ppStr "'"],
787 ppCat [ppStr " expected:", ppInterleave ppComma (map (ppr sty) has)],
788 ppCat [ppStr " found: ", ppInterleave ppComma (map (ppr sty) rns)] ]
791 = addShortErrLocLine locn $ \ sty ->
792 ppBesides [ ppStr "`", pprNonSym sty rn, ppStr "' has been exported with (..), but is only imported abstractly"]
794 badModExportErr mod locn
795 = addShortErrLocLine locn $ \ sty ->
796 ppCat [ ppStr "unknown module in export list: module", ppPStr mod]
798 emptyModExportWarn locn mod
799 = addShortWarnLocLine locn $ \ sty ->
800 ppCat [ppStr "module", ppPStr mod, ppStr "has no unqualified imports to export"]
802 dupModExportWarn locn mods@(mod:_)
803 = addShortWarnLocLine locn $ \ sty ->
804 ppCat [ppStr "module", ppPStr mod, ppStr "appears", ppInt (length mods), ppStr "times in export list"]
806 derivingNonStdClassErr clas locn
807 = addShortErrLocLine locn $ \ sty ->
808 ppCat [ppStr "non-standard class in deriving:", ppr sty clas]
810 dupDefaultDeclErr (DefaultDecl _ locn1 : dup_things) sty
811 = ppAboves (item1 : map dup_item dup_things)
814 = addShortErrLocLine locn1 (\ sty ->
815 ppStr "multiple default declarations") sty
817 dup_item (DefaultDecl _ locn)
818 = addShortErrLocLine locn (\ sty ->
819 ppStr "here was another default declaration") sty
821 undefinedFixityDeclErr locn decl
822 = addErrLoc locn "fixity declaration for unknown operator" $ \ sty ->
825 dupFixityDeclErr locn dups
826 = addErrLoc locn "multiple fixity declarations for same operator" $ \ sty ->
827 ppAboves (map (ppr sty) dups)
829 classTyVarNotInOpTyErr clas_tyvar sig locn
830 = addShortErrLocLine locn $ \ sty ->
831 ppHang (ppBesides [ppStr "Class type variable `", ppr sty clas_tyvar, ppStr "' does not appear in method signature:"])
834 classTyVarInOpCtxtErr clas_tyvar sig locn
835 = addShortErrLocLine locn $ \ sty ->
836 ppHang (ppBesides [ppStr "Class type variable `", ppr sty clas_tyvar, ppStr "' present in method's local overloading context:"])
839 dupClassAssertWarn ctxt locn dups
840 = addShortWarnLocLine locn $ \ sty ->
841 ppHang (ppBesides [ppStr "Duplicate class assertion `", ppr sty dups, ppStr "' in context:"])