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 Name ( RdrName )
25 import Maybes ( maybeToBool, catMaybes )
26 import Outputable ( isLocallyDefined, isAvarid, getLocalName, ExportFlag(..) )
28 import SrcLoc ( SrcLoc )
29 import Unique ( Unique )
30 import UniqFM ( addListToUFM, listToUFM )
31 import UniqSet ( UniqSet(..) )
32 import Util ( isn'tIn, panic, assertPanic )
34 rnExports mods Nothing = returnRn (\n -> ExportAll)
35 rnExports mods (Just exps) = returnRn (\n -> ExportAll)
38 rnSource `renames' the source module and export list.
39 It simultaneously performs dependency analysis and precedence parsing.
40 It also does the following error checks:
43 Checks that tyvars are used properly. This includes checking
44 for undefined tyvars, and tyvars in contexts that are ambiguous.
46 Checks that all variable occurences are defined.
48 Checks the (..) etc constraints in the export list.
53 rnSource :: [Module] -- imported modules
54 -> Bag RenamedFixityDecl -- fixity info for imported names
56 -> RnM s (RenamedHsModule,
57 Name -> ExportFlag, -- export info
58 Bag (RnName, RdrName)) -- occurrence info
60 rnSource imp_mods imp_fixes (HsModule mod version exports _ fixes
61 ty_decls specdata_sigs class_decls
62 inst_decls specinst_sigs defaults
65 = pushSrcLocRn src_loc $
67 rnExports (mod:imp_mods) exports `thenRn` \ exported_fn ->
68 rnFixes fixes `thenRn` \ src_fixes ->
70 pair_name (InfixL n i) = (n, i)
71 pair_name (InfixR n i) = (n, i)
72 pair_name (InfixN n i) = (n, i)
74 imp_fixes_fm = listToUFM (map pair_name (bagToList imp_fixes))
75 all_fixes_fm = addListToUFM imp_fixes_fm (map pair_name src_fixes)
77 setExtraRn {-all_fixes_fm-}(panic "rnSource:all_fixes_fm") $
79 mapRn rnTyDecl ty_decls `thenRn` \ new_ty_decls ->
80 mapRn rnSpecDataSig specdata_sigs `thenRn` \ new_specdata_sigs ->
81 mapRn rnClassDecl class_decls `thenRn` \ new_class_decls ->
82 mapRn rnInstDecl inst_decls `thenRn` \ new_inst_decls ->
83 mapRn rnSpecInstSig specinst_sigs `thenRn` \ new_specinst_sigs ->
84 rnDefaultDecl defaults `thenRn` \ new_defaults ->
85 rnTopBinds binds `thenRn` \ new_binds ->
87 getOccurrenceUpRn `thenRn` \ occ_info ->
91 trashed_exports trashed_imports
92 {-new_fixes-}(panic "rnSource:new_fixes (Hi, Patrick!)")
93 new_ty_decls new_specdata_sigs new_class_decls
94 new_inst_decls new_specinst_sigs new_defaults
100 trashed_exports = panic "rnSource:trashed_exports"
101 trashed_imports = panic "rnSource:trashed_imports"
104 %*********************************************************
106 \subsection{Type declarations}
108 %*********************************************************
110 @rnTyDecl@ uses the `global name function' to create a new type
111 declaration in which local names have been replaced by their original
112 names, reporting any unknown names.
114 Renaming type variables is a pain. Because they now contain uniques,
115 it is necessary to pass in an association list which maps a parsed
116 tyvar to its Name representation. In some cases (type signatures of
117 values), it is even necessary to go over the type first in order to
118 get the set of tyvars used by it, make an assoc list, and then go over
119 it again to rename the tyvars! However, we can also do some scoping
120 checks at the same time.
123 rnTyDecl :: RdrNameTyDecl -> RnM_Fixes s RenamedTyDecl
125 rnTyDecl (TyData context tycon tyvars condecls derivings pragmas src_loc)
126 = pushSrcLocRn src_loc $
127 lookupTyCon tycon `thenRn` \ tycon' ->
128 mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env, tyvars') ->
129 rnContext tv_env context `thenRn` \ context' ->
130 rnConDecls tv_env condecls `thenRn` \ condecls' ->
131 rn_derivs tycon' src_loc derivings `thenRn` \ derivings' ->
132 ASSERT(isNoDataPragmas pragmas)
133 returnRn (TyData context' tycon' tyvars' condecls' derivings' noDataPragmas src_loc)
135 rnTyDecl (TyNew context tycon tyvars condecl derivings pragmas src_loc)
136 = pushSrcLocRn src_loc $
137 lookupTyCon tycon `thenRn` \ tycon' ->
138 mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env, tyvars') ->
139 rnContext tv_env context `thenRn` \ context' ->
140 rnConDecls tv_env condecl `thenRn` \ condecl' ->
141 rn_derivs tycon' src_loc derivings `thenRn` \ derivings' ->
142 ASSERT(isNoDataPragmas pragmas)
143 returnRn (TyNew context' tycon' tyvars' condecl' derivings' noDataPragmas src_loc)
145 rnTyDecl (TySynonym name tyvars ty src_loc)
146 = pushSrcLocRn src_loc $
147 lookupTyCon name `thenRn` \ name' ->
148 mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env, tyvars') ->
149 rnMonoType tv_env ty `thenRn` \ ty' ->
150 returnRn (TySynonym name' tyvars' ty' src_loc)
152 rn_derivs tycon2 locn Nothing -- derivs not specified
155 rn_derivs tycon2 locn (Just ds)
156 = mapRn (rn_deriv tycon2 locn) ds `thenRn` \ derivs ->
157 returnRn (Just derivs)
159 rn_deriv tycon2 locn clas
160 = lookupClass clas `thenRn` \ clas_name ->
161 addErrIfRn (uniqueOf clas_name `not_elem` derivableClassKeys)
162 (derivingNonStdClassErr clas locn)
166 not_elem = isn'tIn "rn_deriv"
169 @rnConDecls@ uses the `global name function' to create a new
170 constructor in which local names have been replaced by their original
171 names, reporting any unknown names.
174 rnConDecls :: TyVarNamesEnv
176 -> RnM_Fixes s [RenamedConDecl]
178 rnConDecls tv_env con_decls
179 = mapRn rn_decl con_decls
181 rn_decl (ConDecl name tys src_loc)
182 = pushSrcLocRn src_loc $
183 lookupValue name `thenRn` \ new_name ->
184 mapRn rn_bang_ty tys `thenRn` \ new_tys ->
185 returnRn (ConDecl new_name new_tys src_loc)
187 rn_decl (ConOpDecl ty1 op ty2 src_loc)
188 = pushSrcLocRn src_loc $
189 lookupValue op `thenRn` \ new_op ->
190 rn_bang_ty ty1 `thenRn` \ new_ty1 ->
191 rn_bang_ty ty2 `thenRn` \ new_ty2 ->
192 returnRn (ConOpDecl new_ty1 new_op new_ty2 src_loc)
194 rn_decl (NewConDecl name ty src_loc)
195 = pushSrcLocRn src_loc $
196 lookupValue name `thenRn` \ new_name ->
197 rn_mono_ty ty `thenRn` \ new_ty ->
198 returnRn (NewConDecl new_name new_ty src_loc)
200 rn_decl (RecConDecl con fields src_loc)
201 = panic "rnConDecls:RecConDecl"
204 rn_mono_ty = rnMonoType tv_env
206 rn_bang_ty (Banged ty)
207 = rn_mono_ty ty `thenRn` \ new_ty ->
208 returnRn (Banged new_ty)
209 rn_bang_ty (Unbanged ty)
210 = rn_mono_ty ty `thenRn` \ new_ty ->
211 returnRn (Unbanged new_ty)
214 %*********************************************************
216 \subsection{SPECIALIZE data pragmas}
218 %*********************************************************
221 rnSpecDataSig :: RdrNameSpecDataSig
222 -> RnM_Fixes s RenamedSpecDataSig
224 rnSpecDataSig (SpecDataSig tycon ty src_loc)
225 = pushSrcLocRn src_loc $
227 tyvars = extractMonoTyNames ty
229 mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env,_) ->
230 lookupTyCon tycon `thenRn` \ tycon' ->
231 rnMonoType tv_env ty `thenRn` \ ty' ->
232 returnRn (SpecDataSig tycon' ty' src_loc)
235 %*********************************************************
237 \subsection{Class declarations}
239 %*********************************************************
241 @rnClassDecl@ uses the `global name function' to create a new
242 class declaration in which local names have been replaced by their
243 original names, reporting any unknown names.
246 rnClassDecl :: RdrNameClassDecl -> RnM_Fixes s RenamedClassDecl
248 rnClassDecl (ClassDecl context cname tyvar sigs mbinds pragmas src_loc)
249 = pushSrcLocRn src_loc $
250 mkTyVarNamesEnv src_loc [tyvar] `thenRn` \ (tv_env, [tyvar']) ->
251 rnContext tv_env context `thenRn` \ context' ->
252 lookupClass cname `thenRn` \ cname' ->
253 mapRn (rn_op cname' tv_env) sigs `thenRn` \ sigs' ->
254 rnMethodBinds cname' mbinds `thenRn` \ mbinds' ->
255 ASSERT(isNoClassPragmas pragmas)
256 returnRn (ClassDecl context' cname' tyvar' sigs' mbinds' NoClassPragmas src_loc)
258 rn_op clas tv_env (ClassOpSig op ty pragmas locn)
259 = pushSrcLocRn locn $
260 lookupClassOp clas op `thenRn` \ op_name ->
261 rnPolyType tv_env ty `thenRn` \ new_ty ->
264 *** Please check here that tyvar' appears in new_ty ***
265 *** (used to be in tcClassSig, but it's better here)
266 *** not_elem = isn'tIn "tcClassSigs"
267 *** -- Check that the class type variable is mentioned
268 *** checkTc (clas_tyvar `not_elem` extractTyVarTemplatesFromTy local_ty)
269 *** (methodTypeLacksTyVarErr clas_tyvar (_UNPK_ op_name) src_loc) `thenTc_`
272 ASSERT(isNoClassOpPragmas pragmas)
273 returnRn (ClassOpSig op_name new_ty noClassOpPragmas locn)
277 %*********************************************************
279 \subsection{Instance declarations}
281 %*********************************************************
284 @rnInstDecl@ uses the `global name function' to create a new of
285 instance declaration in which local names have been replaced by their
286 original names, reporting any unknown names.
289 rnInstDecl :: RdrNameInstDecl -> RnM_Fixes s RenamedInstDecl
291 rnInstDecl (InstDecl cname ty mbinds from_here modname uprags pragmas src_loc)
292 = pushSrcLocRn src_loc $
293 lookupClass cname `thenRn` \ cname' ->
295 rnPolyType [] ty `thenRn` \ ty' ->
296 -- [] tv_env ensures that tyvars will be foralled
298 rnMethodBinds cname' mbinds `thenRn` \ mbinds' ->
299 mapRn (rn_uprag cname') uprags `thenRn` \ new_uprags ->
301 ASSERT(isNoInstancePragmas pragmas)
302 returnRn (InstDecl cname' ty' mbinds'
303 from_here modname new_uprags noInstancePragmas src_loc)
305 rn_uprag class_name (SpecSig op ty using locn)
306 = pushSrcLocRn src_loc $
307 lookupClassOp class_name op `thenRn` \ op_name ->
308 rnPolyType nullTyVarNamesEnv ty `thenRn` \ new_ty ->
309 rn_using using `thenRn` \ new_using ->
310 returnRn (SpecSig op_name new_ty new_using locn)
312 rn_uprag class_name (InlineSig op locn)
313 = pushSrcLocRn locn $
314 lookupClassOp class_name op `thenRn` \ op_name ->
315 returnRn (InlineSig op_name locn)
317 rn_uprag class_name (DeforestSig op locn)
318 = pushSrcLocRn locn $
319 lookupClassOp class_name op `thenRn` \ op_name ->
320 returnRn (DeforestSig op_name locn)
322 rn_uprag class_name (MagicUnfoldingSig op str locn)
323 = pushSrcLocRn locn $
324 lookupClassOp class_name op `thenRn` \ op_name ->
325 returnRn (MagicUnfoldingSig op_name str locn)
330 = lookupValue v `thenRn` \ new_v ->
331 returnRn (Just new_v)
334 %*********************************************************
336 \subsection{@SPECIALIZE instance@ user-pragmas}
338 %*********************************************************
341 rnSpecInstSig :: RdrNameSpecInstSig
342 -> RnM_Fixes s RenamedSpecInstSig
344 rnSpecInstSig (SpecInstSig clas ty src_loc)
345 = pushSrcLocRn src_loc $
347 tyvars = extractMonoTyNames ty
349 mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env,_) ->
350 lookupClass clas `thenRn` \ new_clas ->
351 rnMonoType tv_env ty `thenRn` \ new_ty ->
352 returnRn (SpecInstSig new_clas new_ty src_loc)
355 %*********************************************************
357 \subsection{Default declarations}
359 %*********************************************************
361 @rnDefaultDecl@ uses the `global name function' to create a new set
362 of default declarations in which local names have been replaced by
363 their original names, reporting any unknown names.
366 rnDefaultDecl :: [RdrNameDefaultDecl] -> RnM_Fixes s [RenamedDefaultDecl]
368 rnDefaultDecl [] = returnRn []
369 rnDefaultDecl [DefaultDecl tys src_loc]
370 = pushSrcLocRn src_loc $
371 mapRn (rnMonoType nullTyVarNamesEnv) tys `thenRn` \ tys' ->
372 returnRn [DefaultDecl tys' src_loc]
373 rnDefaultDecl defs@(d:ds)
374 = addErrRn (dupDefaultDeclErr defs) `thenRn_`
378 %*************************************************************************
380 \subsection{Fixity declarations}
382 %*************************************************************************
385 rnFixes :: [RdrNameFixityDecl] -> RnM s [RenamedFixityDecl]
388 = mapRn rn_fixity fixities `thenRn` \ fixes_maybe ->
389 returnRn (catMaybes fixes_maybe)
391 rn_fixity fix@(InfixL name i)
392 = rn_fixity_pieces InfixL name i fix
393 rn_fixity fix@(InfixR name i)
394 = rn_fixity_pieces InfixR name i fix
395 rn_fixity fix@(InfixN name i)
396 = rn_fixity_pieces InfixN name i fix
398 rn_fixity_pieces mk_fixity name i fix
399 = lookupValueMaybe name `thenRn` \ maybe_res ->
401 Just res | isLocallyDefined res
402 -> returnRn (Just (mk_fixity res i))
403 _ -> failButContinueRn Nothing (undefinedFixityDeclErr fix)
407 %*********************************************************
409 \subsection{Support code to rename types}
411 %*********************************************************
414 rnPolyType :: TyVarNamesEnv
416 -> RnM_Fixes s RenamedPolyType
418 rnPolyType tv_env (HsForAllTy tvs ctxt ty)
419 = rn_poly_help tv_env tvs ctxt ty
421 rnPolyType tv_env poly_ty@(HsPreForAllTy ctxt ty)
422 = rn_poly_help tv_env forall_tyvars ctxt ty
424 mentioned_tyvars = extract_poly_ty_names poly_ty
425 forall_tyvars = mentioned_tyvars `minusList` domTyVarNamesEnv tv_env
428 extract_poly_ty_names (HsPreForAllTy ctxt ty)
429 = extractCtxtTyNames ctxt
431 extractMonoTyNames ty
434 rn_poly_help :: TyVarNamesEnv
438 -> RnM_Fixes s RenamedPolyType
440 rn_poly_help tv_env tyvars ctxt ty
441 = getSrcLocRn `thenRn` \ src_loc ->
442 mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env1, new_tyvars) ->
444 tv_env2 = catTyVarNamesEnvs tv_env1 tv_env
446 rnContext tv_env2 ctxt `thenRn` \ new_ctxt ->
447 rnMonoType tv_env2 ty `thenRn` \ new_ty ->
448 returnRn (HsForAllTy new_tyvars new_ctxt new_ty)
452 rnMonoType :: TyVarNamesEnv
454 -> RnM_Fixes s RenamedMonoType
456 rnMonoType tv_env (MonoTyVar tyvar)
457 = lookupTyVarName tv_env tyvar `thenRn` \ tyvar' ->
458 returnRn (MonoTyVar tyvar')
460 rnMonoType tv_env (MonoListTy ty)
461 = rnMonoType tv_env ty `thenRn` \ ty' ->
462 returnRn (MonoListTy ty')
464 rnMonoType tv_env (MonoFunTy ty1 ty2)
465 = andRn MonoFunTy (rnMonoType tv_env ty1)
466 (rnMonoType tv_env ty2)
468 rnMonoType tv_env (MonoTupleTy tys)
469 = mapRn (rnMonoType tv_env) tys `thenRn` \ tys' ->
470 returnRn (MonoTupleTy tys')
472 rnMonoType tv_env (MonoTyApp name tys)
474 lookup_fn = if isAvarid (getLocalName name)
475 then lookupTyVarName tv_env
478 lookup_fn name `thenRn` \ name' ->
479 mapRn (rnMonoType tv_env) tys `thenRn` \ tys' ->
480 returnRn (MonoTyApp name' tys')
484 rnContext :: TyVarNamesEnv -> RdrNameContext -> RnM_Fixes s RenamedContext
486 rnContext tv_env ctxt
489 rn_ctxt (clas, tyvar)
490 = lookupClass clas `thenRn` \ clas_name ->
491 lookupTyVarName tv_env tyvar `thenRn` \ tyvar_name ->
492 returnRn (clas_name, tyvar_name)
497 derivingNonStdClassErr clas locn sty
498 = ppHang (ppStr "Non-standard class in deriving")
499 4 (ppCat [ppr sty clas, ppr sty locn])
501 dupDefaultDeclErr defs sty
502 = ppHang (ppStr "Duplicate default declarations")
503 4 (ppAboves (map pp_def_loc defs))
505 pp_def_loc (DefaultDecl _ src_loc) = ppr sty src_loc
507 undefinedFixityDeclErr decl sty
508 = ppHang (ppStr "Fixity declaration for unknown operator")