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, rnPolyType ) where
12 import RnLoop -- *check* the RnPass/RnExpr/RnBinds loop-breaking
19 import RnBinds ( rnTopBinds, rnMethodBinds )
21 import Bag ( emptyBag, unitBag, consBag, unionManyBags, listToBag, bagToList )
22 import Class ( derivableClassKeys )
23 import ListSetOps ( unionLists, minusList )
24 import Maybes ( maybeToBool, catMaybes )
25 import Name ( Name, isLocallyDefined, isAvarid, getLocalName, ExportFlag(..), RdrName )
27 import SrcLoc ( SrcLoc )
28 import Unique ( Unique )
29 import UniqFM ( addListToUFM, listToUFM )
30 import UniqSet ( UniqSet(..) )
31 import Util ( isIn, isn'tIn, sortLt, panic, assertPanic )
35 rnSource `renames' the source module and export list.
36 It simultaneously performs dependency analysis and precedence parsing.
37 It also does the following error checks:
40 Checks that tyvars are used properly. This includes checking
41 for undefined tyvars, and tyvars in contexts that are ambiguous.
43 Checks that all variable occurences are defined.
45 Checks the (..) etc constraints in the export list.
51 -> Bag (Module,(RnName,ExportFlag)) -- unqualified imports from module
52 -> Bag RenamedFixityDecl -- fixity info for imported names
54 -> RnM s (RenamedHsModule,
55 Name -> ExportFlag, -- export info
56 Bag (RnName, RdrName)) -- occurrence info
58 rnSource imp_mods unqual_imps imp_fixes
59 (HsModule mod version exports _ fixes
60 ty_decls specdata_sigs class_decls
61 inst_decls specinst_sigs defaults
64 = pushSrcLocRn src_loc $
66 rnExports (mod:imp_mods) unqual_imps exports `thenRn` \ exported_fn ->
67 rnFixes fixes `thenRn` \ src_fixes ->
69 pair_name inf@(InfixL n _) = (n, inf)
70 pair_name inf@(InfixR n _) = (n, inf)
71 pair_name inf@(InfixN n _) = (n, inf)
73 imp_fixes_fm = listToUFM (map pair_name (bagToList imp_fixes))
74 all_fixes_fm = addListToUFM imp_fixes_fm (map pair_name src_fixes)
76 setExtraRn all_fixes_fm $
78 mapRn rnTyDecl ty_decls `thenRn` \ new_ty_decls ->
79 mapRn rnSpecDataSig specdata_sigs `thenRn` \ new_specdata_sigs ->
80 mapRn rnClassDecl class_decls `thenRn` \ new_class_decls ->
81 mapRn rnInstDecl inst_decls `thenRn` \ new_inst_decls ->
82 mapRn rnSpecInstSig specinst_sigs `thenRn` \ new_specinst_sigs ->
83 rnDefaultDecl defaults `thenRn` \ new_defaults ->
84 rnTopBinds binds `thenRn` \ new_binds ->
86 getOccurrenceUpRn `thenRn` \ occ_info ->
90 trashed_exports trashed_imports src_fixes
91 new_ty_decls new_specdata_sigs new_class_decls
92 new_inst_decls new_specinst_sigs new_defaults
98 trashed_exports = trace "rnSource:trashed_exports" Nothing
99 trashed_imports = trace "rnSource:trashed_imports" []
103 %*********************************************************
105 \subsection{Export list}
107 %*********************************************************
110 rnExports :: [Module]
111 -> Bag (Module,(RnName,ExportFlag))
113 -> RnM s (Name -> ExportFlag)
115 rnExports mods unqual_imps Nothing
116 = returnRn (\n -> if isLocallyDefined n then ExportAll else NotExported)
118 rnExports mods unqual_imps (Just exps)
119 = mapAndUnzipRn (rnIE mods) exps `thenRn` \ (mod_maybes, exp_bags) ->
121 exp_mods = catMaybes mod_maybes
122 exp_names = unionManyBags exp_bags
124 -- check for duplicate names
125 -- check for duplicate modules
127 -- check for duplicate local names
128 -- add in module contents checking for duplicate local names
130 -- build export flag lookup function
131 exp_fn n = if isLocallyDefined n then ExportAll else NotExported
135 rnIE mods (IEVar name)
136 = lookupValue name `thenRn` \ rn ->
137 checkIEVar rn `thenRn` \ exps ->
138 returnRn (Nothing, exps)
140 checkIEVar (RnName n) = returnRn (unitBag (n,ExportAbs))
141 checkIEVar (RnUnbound _) = returnRn emptyBag
142 checkIEVar rn@(RnClassOp _ _) = getSrcLocRn `thenRn` \ src_loc ->
143 failButContinueRn emptyBag (classOpExportErr rn src_loc)
144 checkIEVar rn = panic "checkIEVar"
146 rnIE mods (IEThingAbs name)
147 = lookupTyConOrClass name `thenRn` \ rn ->
148 checkIEAbs rn `thenRn` \ exps ->
149 returnRn (Nothing, exps)
151 checkIEAbs (RnSyn n) = returnRn (unitBag (n,ExportAbs))
152 checkIEAbs (RnData n _) = returnRn (unitBag (n,ExportAbs))
153 checkIEAbs (RnClass n _) = returnRn (unitBag (n,ExportAbs))
154 checkIEAbs (RnUnbound _) = returnRn emptyBag
155 checkIEAbs rn = panic "checkIEAbs"
157 rnIE mods (IEThingAll name)
158 = lookupTyConOrClass name `thenRn` \ rn ->
159 checkIEAll rn `thenRn` \ exps ->
160 returnRn (Nothing, exps)
162 checkIEAll (RnData n cons) = returnRn (consBag (exp_all n) (listToBag (map exp_all cons)))
163 checkIEAll (RnClass n ops) = returnRn (consBag (exp_all n) (listToBag (map exp_all ops)))
164 checkIEAll (RnUnbound _) = returnRn emptyBag
165 checkIEAll rn@(RnSyn _) = getSrcLocRn `thenRn` \ src_loc ->
166 warnAndContinueRn emptyBag (synAllExportErr rn src_loc)
167 checkIEAll rn = panic "checkIEAll"
169 exp_all n = (n, ExportAll)
171 rnIE mods (IEThingWith name names)
172 = lookupTyConOrClass name `thenRn` \ rn ->
173 mapRn lookupValue names `thenRn` \ rns ->
174 checkIEWith rn rns `thenRn` \ exps ->
175 returnRn (Nothing, exps)
177 checkIEWith rn@(RnData n cons) rns
178 | same_names cons rns = returnRn (consBag (exp_all n) (listToBag (map exp_all cons)))
179 | otherwise = rnWithErr "constructrs" rn cons rns
180 checkIEWith rn@(RnClass n ops) rns
181 | same_names ops rns = returnRn (consBag (exp_all n) (listToBag (map exp_all ops)))
182 | otherwise = rnWithErr "class ops" rn ops rns
183 checkIEWith (RnUnbound _) rns = returnRn emptyBag
184 checkIEWith rn@(RnSyn _) rns = getSrcLocRn `thenRn` \ src_loc ->
185 failButContinueRn emptyBag (synAllExportErr rn src_loc)
186 checkIEWith rn rns = panic "checkIEWith"
188 exp_all n = (n, ExportAll)
191 = all (not.isRnUnbound) rns &&
192 sortLt (<) (map uniqueOf has) == sortLt (<) (map uniqueOf rns)
194 rnWithErr str rn has rns
195 = getSrcLocRn `thenRn` \ src_loc ->
196 failButContinueRn emptyBag (withExportErr str rn has rns src_loc)
198 rnIE mods (IEModuleContents mod)
199 | isIn "IEModule" mod mods = returnRn (Just mod, emptyBag)
200 | otherwise = getSrcLocRn `thenRn` \ src_loc ->
201 failButContinueRn (Nothing,emptyBag) (badModExportErr mod src_loc)
204 %*********************************************************
206 \subsection{Type declarations}
208 %*********************************************************
210 @rnTyDecl@ uses the `global name function' to create a new type
211 declaration in which local names have been replaced by their original
212 names, reporting any unknown names.
214 Renaming type variables is a pain. Because they now contain uniques,
215 it is necessary to pass in an association list which maps a parsed
216 tyvar to its Name representation. In some cases (type signatures of
217 values), it is even necessary to go over the type first in order to
218 get the set of tyvars used by it, make an assoc list, and then go over
219 it again to rename the tyvars! However, we can also do some scoping
220 checks at the same time.
223 rnTyDecl :: RdrNameTyDecl -> RnM_Fixes s RenamedTyDecl
225 rnTyDecl (TyData context tycon tyvars condecls derivings pragmas src_loc)
226 = pushSrcLocRn src_loc $
227 lookupTyCon tycon `thenRn` \ tycon' ->
228 mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env, tyvars') ->
229 rnContext tv_env context `thenRn` \ context' ->
230 rnConDecls tv_env condecls `thenRn` \ condecls' ->
231 rn_derivs tycon' src_loc derivings `thenRn` \ derivings' ->
232 ASSERT(isNoDataPragmas pragmas)
233 returnRn (TyData context' tycon' tyvars' condecls' derivings' noDataPragmas src_loc)
235 rnTyDecl (TyNew context tycon tyvars condecl derivings pragmas src_loc)
236 = pushSrcLocRn src_loc $
237 lookupTyCon tycon `thenRn` \ tycon' ->
238 mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env, tyvars') ->
239 rnContext tv_env context `thenRn` \ context' ->
240 rnConDecls tv_env condecl `thenRn` \ condecl' ->
241 rn_derivs tycon' src_loc derivings `thenRn` \ derivings' ->
242 ASSERT(isNoDataPragmas pragmas)
243 returnRn (TyNew context' tycon' tyvars' condecl' derivings' noDataPragmas src_loc)
245 rnTyDecl (TySynonym name tyvars ty src_loc)
246 = pushSrcLocRn src_loc $
247 lookupTyCon name `thenRn` \ name' ->
248 mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env, tyvars') ->
249 rnMonoType tv_env ty `thenRn` \ ty' ->
250 returnRn (TySynonym name' tyvars' ty' src_loc)
252 rn_derivs tycon2 locn Nothing -- derivs not specified
255 rn_derivs tycon2 locn (Just ds)
256 = mapRn (rn_deriv tycon2 locn) ds `thenRn` \ derivs ->
257 returnRn (Just derivs)
259 rn_deriv tycon2 locn clas
260 = lookupClass clas `thenRn` \ clas_name ->
261 addErrIfRn (uniqueOf clas_name `not_elem` derivableClassKeys)
262 (derivingNonStdClassErr clas locn)
266 not_elem = isn'tIn "rn_deriv"
269 @rnConDecls@ uses the `global name function' to create a new
270 constructor in which local names have been replaced by their original
271 names, reporting any unknown names.
274 rnConDecls :: TyVarNamesEnv
276 -> RnM_Fixes s [RenamedConDecl]
278 rnConDecls tv_env con_decls
279 = mapRn rn_decl con_decls
281 rn_decl (ConDecl name tys src_loc)
282 = pushSrcLocRn src_loc $
283 lookupValue name `thenRn` \ new_name ->
284 mapRn rn_bang_ty tys `thenRn` \ new_tys ->
285 returnRn (ConDecl new_name new_tys src_loc)
287 rn_decl (ConOpDecl ty1 op ty2 src_loc)
288 = pushSrcLocRn src_loc $
289 lookupValue op `thenRn` \ new_op ->
290 rn_bang_ty ty1 `thenRn` \ new_ty1 ->
291 rn_bang_ty ty2 `thenRn` \ new_ty2 ->
292 returnRn (ConOpDecl new_ty1 new_op new_ty2 src_loc)
294 rn_decl (NewConDecl name ty src_loc)
295 = pushSrcLocRn src_loc $
296 lookupValue name `thenRn` \ new_name ->
297 rn_mono_ty ty `thenRn` \ new_ty ->
298 returnRn (NewConDecl new_name new_ty src_loc)
300 rn_decl (RecConDecl con fields src_loc)
301 = panic "rnConDecls:RecConDecl"
304 rn_mono_ty = rnMonoType tv_env
306 rn_bang_ty (Banged ty)
307 = rn_mono_ty ty `thenRn` \ new_ty ->
308 returnRn (Banged new_ty)
309 rn_bang_ty (Unbanged ty)
310 = rn_mono_ty ty `thenRn` \ new_ty ->
311 returnRn (Unbanged new_ty)
314 %*********************************************************
316 \subsection{SPECIALIZE data pragmas}
318 %*********************************************************
321 rnSpecDataSig :: RdrNameSpecDataSig
322 -> RnM_Fixes s RenamedSpecDataSig
324 rnSpecDataSig (SpecDataSig tycon ty src_loc)
325 = pushSrcLocRn src_loc $
327 tyvars = extractMonoTyNames ty
329 mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env,_) ->
330 lookupTyCon tycon `thenRn` \ tycon' ->
331 rnMonoType tv_env ty `thenRn` \ ty' ->
332 returnRn (SpecDataSig tycon' ty' src_loc)
335 %*********************************************************
337 \subsection{Class declarations}
339 %*********************************************************
341 @rnClassDecl@ uses the `global name function' to create a new
342 class declaration in which local names have been replaced by their
343 original names, reporting any unknown names.
346 rnClassDecl :: RdrNameClassDecl -> RnM_Fixes s RenamedClassDecl
348 rnClassDecl (ClassDecl context cname tyvar sigs mbinds pragmas src_loc)
349 = pushSrcLocRn src_loc $
350 mkTyVarNamesEnv src_loc [tyvar] `thenRn` \ (tv_env, [tyvar']) ->
351 rnContext tv_env context `thenRn` \ context' ->
352 lookupClass cname `thenRn` \ cname' ->
353 mapRn (rn_op cname' tv_env) sigs `thenRn` \ sigs' ->
354 rnMethodBinds cname' mbinds `thenRn` \ mbinds' ->
355 ASSERT(isNoClassPragmas pragmas)
356 returnRn (ClassDecl context' cname' tyvar' sigs' mbinds' NoClassPragmas src_loc)
358 rn_op clas tv_env (ClassOpSig op ty pragmas locn)
359 = pushSrcLocRn locn $
360 lookupClassOp clas op `thenRn` \ op_name ->
361 rnPolyType tv_env ty `thenRn` \ new_ty ->
364 *** Please check here that tyvar' appears in new_ty ***
365 *** (used to be in tcClassSig, but it's better here)
366 *** not_elem = isn'tIn "tcClassSigs"
367 *** -- Check that the class type variable is mentioned
368 *** checkTc (clas_tyvar `not_elem` extractTyVarTemplatesFromTy local_ty)
369 *** (methodTypeLacksTyVarErr clas_tyvar (_UNPK_ op_name) src_loc) `thenTc_`
372 ASSERT(isNoClassOpPragmas pragmas)
373 returnRn (ClassOpSig op_name new_ty noClassOpPragmas locn)
377 %*********************************************************
379 \subsection{Instance declarations}
381 %*********************************************************
384 @rnInstDecl@ uses the `global name function' to create a new of
385 instance declaration in which local names have been replaced by their
386 original names, reporting any unknown names.
389 rnInstDecl :: RdrNameInstDecl -> RnM_Fixes s RenamedInstDecl
391 rnInstDecl (InstDecl cname ty mbinds from_here modname uprags pragmas src_loc)
392 = pushSrcLocRn src_loc $
393 lookupClass cname `thenRn` \ cname' ->
395 rnPolyType [] ty `thenRn` \ ty' ->
396 -- [] tv_env ensures that tyvars will be foralled
398 rnMethodBinds cname' mbinds `thenRn` \ mbinds' ->
399 mapRn (rn_uprag cname') uprags `thenRn` \ new_uprags ->
401 ASSERT(isNoInstancePragmas pragmas)
402 returnRn (InstDecl cname' ty' mbinds'
403 from_here modname new_uprags noInstancePragmas src_loc)
405 rn_uprag class_name (SpecSig op ty using locn)
406 = pushSrcLocRn src_loc $
407 lookupClassOp class_name op `thenRn` \ op_name ->
408 rnPolyType nullTyVarNamesEnv ty `thenRn` \ new_ty ->
409 rn_using using `thenRn` \ new_using ->
410 returnRn (SpecSig op_name new_ty new_using locn)
412 rn_uprag class_name (InlineSig op locn)
413 = pushSrcLocRn locn $
414 lookupClassOp class_name op `thenRn` \ op_name ->
415 returnRn (InlineSig op_name locn)
417 rn_uprag class_name (DeforestSig op locn)
418 = pushSrcLocRn locn $
419 lookupClassOp class_name op `thenRn` \ op_name ->
420 returnRn (DeforestSig op_name locn)
422 rn_uprag class_name (MagicUnfoldingSig op str locn)
423 = pushSrcLocRn locn $
424 lookupClassOp class_name op `thenRn` \ op_name ->
425 returnRn (MagicUnfoldingSig op_name str locn)
430 = lookupValue v `thenRn` \ new_v ->
431 returnRn (Just new_v)
434 %*********************************************************
436 \subsection{@SPECIALIZE instance@ user-pragmas}
438 %*********************************************************
441 rnSpecInstSig :: RdrNameSpecInstSig
442 -> RnM_Fixes s RenamedSpecInstSig
444 rnSpecInstSig (SpecInstSig clas ty src_loc)
445 = pushSrcLocRn src_loc $
447 tyvars = extractMonoTyNames ty
449 mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env,_) ->
450 lookupClass clas `thenRn` \ new_clas ->
451 rnMonoType tv_env ty `thenRn` \ new_ty ->
452 returnRn (SpecInstSig new_clas new_ty src_loc)
455 %*********************************************************
457 \subsection{Default declarations}
459 %*********************************************************
461 @rnDefaultDecl@ uses the `global name function' to create a new set
462 of default declarations in which local names have been replaced by
463 their original names, reporting any unknown names.
466 rnDefaultDecl :: [RdrNameDefaultDecl] -> RnM_Fixes s [RenamedDefaultDecl]
468 rnDefaultDecl [] = returnRn []
469 rnDefaultDecl [DefaultDecl tys src_loc]
470 = pushSrcLocRn src_loc $
471 mapRn (rnMonoType nullTyVarNamesEnv) tys `thenRn` \ tys' ->
472 returnRn [DefaultDecl tys' src_loc]
473 rnDefaultDecl defs@(d:ds)
474 = addErrRn (dupDefaultDeclErr defs) `thenRn_`
478 %*************************************************************************
480 \subsection{Fixity declarations}
482 %*************************************************************************
485 rnFixes :: [RdrNameFixityDecl] -> RnM s [RenamedFixityDecl]
488 = mapRn rn_fixity fixities `thenRn` \ fixes_maybe ->
489 returnRn (catMaybes fixes_maybe)
491 rn_fixity fix@(InfixL name i)
492 = rn_fixity_pieces InfixL name i fix
493 rn_fixity fix@(InfixR name i)
494 = rn_fixity_pieces InfixR name i fix
495 rn_fixity fix@(InfixN name i)
496 = rn_fixity_pieces InfixN name i fix
498 rn_fixity_pieces mk_fixity name i fix
499 = lookupValueMaybe name `thenRn` \ maybe_res ->
501 Just res | isLocallyDefined res
502 -> returnRn (Just (mk_fixity res i))
503 _ -> failButContinueRn Nothing (undefinedFixityDeclErr fix)
507 %*********************************************************
509 \subsection{Support code to rename types}
511 %*********************************************************
514 rnPolyType :: TyVarNamesEnv
516 -> RnM_Fixes s RenamedPolyType
518 rnPolyType tv_env (HsForAllTy tvs ctxt ty)
519 = rn_poly_help tv_env tvs ctxt ty
521 rnPolyType tv_env poly_ty@(HsPreForAllTy ctxt ty)
522 = rn_poly_help tv_env forall_tyvars ctxt ty
524 mentioned_tyvars = extract_poly_ty_names poly_ty
525 forall_tyvars = mentioned_tyvars `minusList` domTyVarNamesEnv tv_env
528 extract_poly_ty_names (HsPreForAllTy ctxt ty)
529 = extractCtxtTyNames ctxt
531 extractMonoTyNames ty
534 rn_poly_help :: TyVarNamesEnv
538 -> RnM_Fixes s RenamedPolyType
540 rn_poly_help tv_env tyvars ctxt ty
541 = getSrcLocRn `thenRn` \ src_loc ->
542 mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env1, new_tyvars) ->
544 tv_env2 = catTyVarNamesEnvs tv_env1 tv_env
546 rnContext tv_env2 ctxt `thenRn` \ new_ctxt ->
547 rnMonoType tv_env2 ty `thenRn` \ new_ty ->
548 returnRn (HsForAllTy new_tyvars new_ctxt new_ty)
552 rnMonoType :: TyVarNamesEnv
554 -> RnM_Fixes s RenamedMonoType
556 rnMonoType tv_env (MonoTyVar tyvar)
557 = lookupTyVarName tv_env tyvar `thenRn` \ tyvar' ->
558 returnRn (MonoTyVar tyvar')
560 rnMonoType tv_env (MonoListTy ty)
561 = rnMonoType tv_env ty `thenRn` \ ty' ->
562 returnRn (MonoListTy ty')
564 rnMonoType tv_env (MonoFunTy ty1 ty2)
565 = andRn MonoFunTy (rnMonoType tv_env ty1)
566 (rnMonoType tv_env ty2)
568 rnMonoType tv_env (MonoTupleTy tys)
569 = mapRn (rnMonoType tv_env) tys `thenRn` \ tys' ->
570 returnRn (MonoTupleTy tys')
572 rnMonoType tv_env (MonoTyApp name tys)
574 lookup_fn = if isAvarid (getLocalName name)
575 then lookupTyVarName tv_env
578 lookup_fn name `thenRn` \ name' ->
579 mapRn (rnMonoType tv_env) tys `thenRn` \ tys' ->
580 returnRn (MonoTyApp name' tys')
584 rnContext :: TyVarNamesEnv -> RdrNameContext -> RnM_Fixes s RenamedContext
586 rnContext tv_env ctxt
589 rn_ctxt (clas, tyvar)
590 = lookupClass clas `thenRn` \ clas_name ->
591 lookupTyVarName tv_env tyvar `thenRn` \ tyvar_name ->
592 returnRn (clas_name, tyvar_name)
597 classOpExportErr op locn sty
598 = ppHang (ppStr "Class operation can only be exported with class:")
599 4 (ppCat [ppr sty op, ppr sty locn])
601 synAllExportErr syn locn sty
602 = ppHang (ppStr "Type synonym should be exported abstractly:")
603 4 (ppCat [ppr sty syn, ppr sty locn])
605 withExportErr str rn has rns locn sty
606 = ppHang (ppBesides [ppStr "Inconsistent list of ", ppStr str, ppStr ": ", ppr sty locn])
607 4 (ppAbove (ppCat [ppStr "expected:", ppInterleave ppComma (map (ppr sty) has)])
608 (ppCat [ppStr "found: ", ppInterleave ppComma (map (ppr sty) rns)]))
610 badModExportErr mod locn sty
611 = ppHang (ppStr "Unknown module in export list:")
612 4 (ppCat [ppStr "module", ppPStr mod, ppr sty locn])
614 derivingNonStdClassErr clas locn sty
615 = ppHang (ppStr "Non-standard class in deriving:")
616 4 (ppCat [ppr sty clas, ppr sty locn])
618 dupDefaultDeclErr defs sty
619 = ppHang (ppStr "Duplicate default declarations:")
620 4 (ppAboves (map pp_def_loc defs))
622 pp_def_loc (DefaultDecl _ src_loc) = ppr sty src_loc
624 undefinedFixityDeclErr decl sty
625 = ppHang (ppStr "Fixity declaration for unknown operator:")