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 RnPass4/RnExpr4/RnBinds4 loop-breaking
19 import RnBinds ( rnTopBinds, rnMethodBinds )
21 import Bag ( bagToList )
22 import Class ( derivableClassKeys )
23 import ListSetOps ( unionLists, minusList )
24 import Maybes ( maybeToBool, catMaybes )
25 import 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 ( isn'tIn, panic, assertPanic )
33 rnExports mods Nothing = returnRn (\n -> ExportAll)
34 rnExports mods (Just exps) = returnRn (\n -> ExportAll)
37 rnSource `renames' the source module and export list.
38 It simultaneously performs dependency analysis and precedence parsing.
39 It also does the following error checks:
42 Checks that tyvars are used properly. This includes checking
43 for undefined tyvars, and tyvars in contexts that are ambiguous.
45 Checks that all variable occurences are defined.
47 Checks the (..) etc constraints in the export list.
52 rnSource :: [Module] -- imported modules
53 -> Bag RenamedFixityDecl -- fixity info for imported names
55 -> RnM s (RenamedHsModule,
56 Name -> ExportFlag, -- export info
57 Bag (RnName, RdrName)) -- occurrence info
59 rnSource imp_mods imp_fixes (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) 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" []
102 %*********************************************************
104 \subsection{Type declarations}
106 %*********************************************************
108 @rnTyDecl@ uses the `global name function' to create a new type
109 declaration in which local names have been replaced by their original
110 names, reporting any unknown names.
112 Renaming type variables is a pain. Because they now contain uniques,
113 it is necessary to pass in an association list which maps a parsed
114 tyvar to its Name representation. In some cases (type signatures of
115 values), it is even necessary to go over the type first in order to
116 get the set of tyvars used by it, make an assoc list, and then go over
117 it again to rename the tyvars! However, we can also do some scoping
118 checks at the same time.
121 rnTyDecl :: RdrNameTyDecl -> RnM_Fixes s RenamedTyDecl
123 rnTyDecl (TyData context tycon tyvars condecls derivings pragmas src_loc)
124 = pushSrcLocRn src_loc $
125 lookupTyCon tycon `thenRn` \ tycon' ->
126 mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env, tyvars') ->
127 rnContext tv_env context `thenRn` \ context' ->
128 rnConDecls tv_env condecls `thenRn` \ condecls' ->
129 rn_derivs tycon' src_loc derivings `thenRn` \ derivings' ->
130 ASSERT(isNoDataPragmas pragmas)
131 returnRn (TyData context' tycon' tyvars' condecls' derivings' noDataPragmas src_loc)
133 rnTyDecl (TyNew context tycon tyvars condecl derivings pragmas src_loc)
134 = pushSrcLocRn src_loc $
135 lookupTyCon tycon `thenRn` \ tycon' ->
136 mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env, tyvars') ->
137 rnContext tv_env context `thenRn` \ context' ->
138 rnConDecls tv_env condecl `thenRn` \ condecl' ->
139 rn_derivs tycon' src_loc derivings `thenRn` \ derivings' ->
140 ASSERT(isNoDataPragmas pragmas)
141 returnRn (TyNew context' tycon' tyvars' condecl' derivings' noDataPragmas src_loc)
143 rnTyDecl (TySynonym name tyvars ty src_loc)
144 = pushSrcLocRn src_loc $
145 lookupTyCon name `thenRn` \ name' ->
146 mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env, tyvars') ->
147 rnMonoType tv_env ty `thenRn` \ ty' ->
148 returnRn (TySynonym name' tyvars' ty' src_loc)
150 rn_derivs tycon2 locn Nothing -- derivs not specified
153 rn_derivs tycon2 locn (Just ds)
154 = mapRn (rn_deriv tycon2 locn) ds `thenRn` \ derivs ->
155 returnRn (Just derivs)
157 rn_deriv tycon2 locn clas
158 = lookupClass clas `thenRn` \ clas_name ->
159 addErrIfRn (uniqueOf clas_name `not_elem` derivableClassKeys)
160 (derivingNonStdClassErr clas locn)
164 not_elem = isn'tIn "rn_deriv"
167 @rnConDecls@ uses the `global name function' to create a new
168 constructor in which local names have been replaced by their original
169 names, reporting any unknown names.
172 rnConDecls :: TyVarNamesEnv
174 -> RnM_Fixes s [RenamedConDecl]
176 rnConDecls tv_env con_decls
177 = mapRn rn_decl con_decls
179 rn_decl (ConDecl name tys src_loc)
180 = pushSrcLocRn src_loc $
181 lookupValue name `thenRn` \ new_name ->
182 mapRn rn_bang_ty tys `thenRn` \ new_tys ->
183 returnRn (ConDecl new_name new_tys src_loc)
185 rn_decl (ConOpDecl ty1 op ty2 src_loc)
186 = pushSrcLocRn src_loc $
187 lookupValue op `thenRn` \ new_op ->
188 rn_bang_ty ty1 `thenRn` \ new_ty1 ->
189 rn_bang_ty ty2 `thenRn` \ new_ty2 ->
190 returnRn (ConOpDecl new_ty1 new_op new_ty2 src_loc)
192 rn_decl (NewConDecl name ty src_loc)
193 = pushSrcLocRn src_loc $
194 lookupValue name `thenRn` \ new_name ->
195 rn_mono_ty ty `thenRn` \ new_ty ->
196 returnRn (NewConDecl new_name new_ty src_loc)
198 rn_decl (RecConDecl con fields src_loc)
199 = panic "rnConDecls:RecConDecl"
202 rn_mono_ty = rnMonoType tv_env
204 rn_bang_ty (Banged ty)
205 = rn_mono_ty ty `thenRn` \ new_ty ->
206 returnRn (Banged new_ty)
207 rn_bang_ty (Unbanged ty)
208 = rn_mono_ty ty `thenRn` \ new_ty ->
209 returnRn (Unbanged new_ty)
212 %*********************************************************
214 \subsection{SPECIALIZE data pragmas}
216 %*********************************************************
219 rnSpecDataSig :: RdrNameSpecDataSig
220 -> RnM_Fixes s RenamedSpecDataSig
222 rnSpecDataSig (SpecDataSig tycon ty src_loc)
223 = pushSrcLocRn src_loc $
225 tyvars = extractMonoTyNames ty
227 mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env,_) ->
228 lookupTyCon tycon `thenRn` \ tycon' ->
229 rnMonoType tv_env ty `thenRn` \ ty' ->
230 returnRn (SpecDataSig tycon' ty' src_loc)
233 %*********************************************************
235 \subsection{Class declarations}
237 %*********************************************************
239 @rnClassDecl@ uses the `global name function' to create a new
240 class declaration in which local names have been replaced by their
241 original names, reporting any unknown names.
244 rnClassDecl :: RdrNameClassDecl -> RnM_Fixes s RenamedClassDecl
246 rnClassDecl (ClassDecl context cname tyvar sigs mbinds pragmas src_loc)
247 = pushSrcLocRn src_loc $
248 mkTyVarNamesEnv src_loc [tyvar] `thenRn` \ (tv_env, [tyvar']) ->
249 rnContext tv_env context `thenRn` \ context' ->
250 lookupClass cname `thenRn` \ cname' ->
251 mapRn (rn_op cname' tv_env) sigs `thenRn` \ sigs' ->
252 rnMethodBinds cname' mbinds `thenRn` \ mbinds' ->
253 ASSERT(isNoClassPragmas pragmas)
254 returnRn (ClassDecl context' cname' tyvar' sigs' mbinds' NoClassPragmas src_loc)
256 rn_op clas tv_env (ClassOpSig op ty pragmas locn)
257 = pushSrcLocRn locn $
258 lookupClassOp clas op `thenRn` \ op_name ->
259 rnPolyType tv_env ty `thenRn` \ new_ty ->
262 *** Please check here that tyvar' appears in new_ty ***
263 *** (used to be in tcClassSig, but it's better here)
264 *** not_elem = isn'tIn "tcClassSigs"
265 *** -- Check that the class type variable is mentioned
266 *** checkTc (clas_tyvar `not_elem` extractTyVarTemplatesFromTy local_ty)
267 *** (methodTypeLacksTyVarErr clas_tyvar (_UNPK_ op_name) src_loc) `thenTc_`
270 ASSERT(isNoClassOpPragmas pragmas)
271 returnRn (ClassOpSig op_name new_ty noClassOpPragmas locn)
275 %*********************************************************
277 \subsection{Instance declarations}
279 %*********************************************************
282 @rnInstDecl@ uses the `global name function' to create a new of
283 instance declaration in which local names have been replaced by their
284 original names, reporting any unknown names.
287 rnInstDecl :: RdrNameInstDecl -> RnM_Fixes s RenamedInstDecl
289 rnInstDecl (InstDecl cname ty mbinds from_here modname uprags pragmas src_loc)
290 = pushSrcLocRn src_loc $
291 lookupClass cname `thenRn` \ cname' ->
293 rnPolyType [] ty `thenRn` \ ty' ->
294 -- [] tv_env ensures that tyvars will be foralled
296 rnMethodBinds cname' mbinds `thenRn` \ mbinds' ->
297 mapRn (rn_uprag cname') uprags `thenRn` \ new_uprags ->
299 ASSERT(isNoInstancePragmas pragmas)
300 returnRn (InstDecl cname' ty' mbinds'
301 from_here modname new_uprags noInstancePragmas src_loc)
303 rn_uprag class_name (SpecSig op ty using locn)
304 = pushSrcLocRn src_loc $
305 lookupClassOp class_name op `thenRn` \ op_name ->
306 rnPolyType nullTyVarNamesEnv ty `thenRn` \ new_ty ->
307 rn_using using `thenRn` \ new_using ->
308 returnRn (SpecSig op_name new_ty new_using locn)
310 rn_uprag class_name (InlineSig op locn)
311 = pushSrcLocRn locn $
312 lookupClassOp class_name op `thenRn` \ op_name ->
313 returnRn (InlineSig op_name locn)
315 rn_uprag class_name (DeforestSig op locn)
316 = pushSrcLocRn locn $
317 lookupClassOp class_name op `thenRn` \ op_name ->
318 returnRn (DeforestSig op_name locn)
320 rn_uprag class_name (MagicUnfoldingSig op str locn)
321 = pushSrcLocRn locn $
322 lookupClassOp class_name op `thenRn` \ op_name ->
323 returnRn (MagicUnfoldingSig op_name str locn)
328 = lookupValue v `thenRn` \ new_v ->
329 returnRn (Just new_v)
332 %*********************************************************
334 \subsection{@SPECIALIZE instance@ user-pragmas}
336 %*********************************************************
339 rnSpecInstSig :: RdrNameSpecInstSig
340 -> RnM_Fixes s RenamedSpecInstSig
342 rnSpecInstSig (SpecInstSig clas ty src_loc)
343 = pushSrcLocRn src_loc $
345 tyvars = extractMonoTyNames ty
347 mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env,_) ->
348 lookupClass clas `thenRn` \ new_clas ->
349 rnMonoType tv_env ty `thenRn` \ new_ty ->
350 returnRn (SpecInstSig new_clas new_ty src_loc)
353 %*********************************************************
355 \subsection{Default declarations}
357 %*********************************************************
359 @rnDefaultDecl@ uses the `global name function' to create a new set
360 of default declarations in which local names have been replaced by
361 their original names, reporting any unknown names.
364 rnDefaultDecl :: [RdrNameDefaultDecl] -> RnM_Fixes s [RenamedDefaultDecl]
366 rnDefaultDecl [] = returnRn []
367 rnDefaultDecl [DefaultDecl tys src_loc]
368 = pushSrcLocRn src_loc $
369 mapRn (rnMonoType nullTyVarNamesEnv) tys `thenRn` \ tys' ->
370 returnRn [DefaultDecl tys' src_loc]
371 rnDefaultDecl defs@(d:ds)
372 = addErrRn (dupDefaultDeclErr defs) `thenRn_`
376 %*************************************************************************
378 \subsection{Fixity declarations}
380 %*************************************************************************
383 rnFixes :: [RdrNameFixityDecl] -> RnM s [RenamedFixityDecl]
386 = mapRn rn_fixity fixities `thenRn` \ fixes_maybe ->
387 returnRn (catMaybes fixes_maybe)
389 rn_fixity fix@(InfixL name i)
390 = rn_fixity_pieces InfixL name i fix
391 rn_fixity fix@(InfixR name i)
392 = rn_fixity_pieces InfixR name i fix
393 rn_fixity fix@(InfixN name i)
394 = rn_fixity_pieces InfixN name i fix
396 rn_fixity_pieces mk_fixity name i fix
397 = lookupValueMaybe name `thenRn` \ maybe_res ->
399 Just res | isLocallyDefined res
400 -> returnRn (Just (mk_fixity res i))
401 _ -> failButContinueRn Nothing (undefinedFixityDeclErr fix)
405 %*********************************************************
407 \subsection{Support code to rename types}
409 %*********************************************************
412 rnPolyType :: TyVarNamesEnv
414 -> RnM_Fixes s RenamedPolyType
416 rnPolyType tv_env (HsForAllTy tvs ctxt ty)
417 = rn_poly_help tv_env tvs ctxt ty
419 rnPolyType tv_env poly_ty@(HsPreForAllTy ctxt ty)
420 = rn_poly_help tv_env forall_tyvars ctxt ty
422 mentioned_tyvars = extract_poly_ty_names poly_ty
423 forall_tyvars = mentioned_tyvars `minusList` domTyVarNamesEnv tv_env
426 extract_poly_ty_names (HsPreForAllTy ctxt ty)
427 = extractCtxtTyNames ctxt
429 extractMonoTyNames ty
432 rn_poly_help :: TyVarNamesEnv
436 -> RnM_Fixes s RenamedPolyType
438 rn_poly_help tv_env tyvars ctxt ty
439 = getSrcLocRn `thenRn` \ src_loc ->
440 mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env1, new_tyvars) ->
442 tv_env2 = catTyVarNamesEnvs tv_env1 tv_env
444 rnContext tv_env2 ctxt `thenRn` \ new_ctxt ->
445 rnMonoType tv_env2 ty `thenRn` \ new_ty ->
446 returnRn (HsForAllTy new_tyvars new_ctxt new_ty)
450 rnMonoType :: TyVarNamesEnv
452 -> RnM_Fixes s RenamedMonoType
454 rnMonoType tv_env (MonoTyVar tyvar)
455 = lookupTyVarName tv_env tyvar `thenRn` \ tyvar' ->
456 returnRn (MonoTyVar tyvar')
458 rnMonoType tv_env (MonoListTy ty)
459 = rnMonoType tv_env ty `thenRn` \ ty' ->
460 returnRn (MonoListTy ty')
462 rnMonoType tv_env (MonoFunTy ty1 ty2)
463 = andRn MonoFunTy (rnMonoType tv_env ty1)
464 (rnMonoType tv_env ty2)
466 rnMonoType tv_env (MonoTupleTy tys)
467 = mapRn (rnMonoType tv_env) tys `thenRn` \ tys' ->
468 returnRn (MonoTupleTy tys')
470 rnMonoType tv_env (MonoTyApp name tys)
472 lookup_fn = if isAvarid (getLocalName name)
473 then lookupTyVarName tv_env
476 lookup_fn name `thenRn` \ name' ->
477 mapRn (rnMonoType tv_env) tys `thenRn` \ tys' ->
478 returnRn (MonoTyApp name' tys')
482 rnContext :: TyVarNamesEnv -> RdrNameContext -> RnM_Fixes s RenamedContext
484 rnContext tv_env ctxt
487 rn_ctxt (clas, tyvar)
488 = lookupClass clas `thenRn` \ clas_name ->
489 lookupTyVarName tv_env tyvar `thenRn` \ tyvar_name ->
490 returnRn (clas_name, tyvar_name)
495 derivingNonStdClassErr clas locn sty
496 = ppHang (ppStr "Non-standard class in deriving")
497 4 (ppCat [ppr sty clas, ppr sty locn])
499 dupDefaultDeclErr defs sty
500 = ppHang (ppStr "Duplicate default declarations")
501 4 (ppAboves (map pp_def_loc defs))
503 pp_def_loc (DefaultDecl _ src_loc) = ppr sty src_loc
505 undefinedFixityDeclErr decl sty
506 = ppHang (ppStr "Fixity declaration for unknown operator")