2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[RnPass4]{Fourth of the renaming passes}
7 #include "HsVersions.h"
9 module RnPass4 ( rnModule, rnPolyType, rnGenPragmas ) where
12 import RnLoop -- *check* the RnPass4/RnExpr4/RnBinds4 loop-breaking
17 import HsPragmas -- all of it
18 import HsCore -- all of it
21 import Class ( derivableClassKeys )
22 import Maybes ( maybeToBool, catMaybes )
23 import Name ( Name(..) )
24 import Outputable ( Outputable(..), isAvarid )
25 import Pretty ( ppHang, ppStr, ppCat, ppAboves )
26 import ProtoName ( eqProtoName, elemProtoNames, ProtoName{-instance-} )
27 import RnBinds4 ( rnTopBinds, rnMethodBinds )
28 import SrcLoc ( SrcLoc{-instance-} )
29 import Unique ( Unique{-instances-} )
30 import UniqSet ( UniqSet(..) )
31 import Util ( isIn, panic, assertPanic )
34 This pass `renames' the module+imported info, simultaneously
35 performing dependency analysis. It also does the following error
39 Checks that tyvars are used properly. This includes checking
40 for undefined tyvars, and tyvars in contexts that are ambiguous.
42 Checks that local variables are defined.
46 rnModule :: ProtoNameHsModule -> Rn4M RenamedHsModule
48 rnModule (HsModule mod_name exports _ fixes ty_decls specdata_sigs
49 class_decls inst_decls specinst_sigs defaults
50 binds int_sigs src_loc)
52 = pushSrcLocRn4 src_loc (
54 mapRn4 rnTyDecl ty_decls `thenRn4` \ new_ty_decls ->
55 mapRn4 rnSpecDataSig specdata_sigs `thenRn4` \ new_specdata_sigs ->
56 mapRn4 rnClassDecl class_decls `thenRn4` \ new_class_decls ->
57 mapRn4 rnInstDecl inst_decls `thenRn4` \ new_inst_decls ->
58 mapRn4 rnSpecInstSig specinst_sigs `thenRn4` \ new_specinst_sigs ->
59 rnDefaultDecl defaults `thenRn4` \ new_defaults ->
60 rnTopBinds binds `thenRn4` \ new_binds ->
61 mapRn4 rnIntSig int_sigs `thenRn4` \ new_int_sigs ->
62 rnFixes fixes `thenRn4` \ new_fixes ->
63 rnExports exports `thenRn4` \ new_exports ->
65 returnRn4 (HsModule mod_name
66 new_exports [{-imports finally clobbered-}] new_fixes
67 new_ty_decls new_specdata_sigs new_class_decls
68 new_inst_decls new_specinst_sigs new_defaults
69 new_binds new_int_sigs src_loc)
72 rnExports Nothing = returnRn4 Nothing
73 rnExports (Just exp_list)
74 = returnRn4 (Just (_trace "rnExports:trashing exports" []))
77 %*********************************************************
79 \subsection{Type declarations}
81 %*********************************************************
83 @rnTyDecl@ uses the `global name function' to create a new type
84 declaration in which local names have been replaced by their original
85 names, reporting any unknown names.
87 Renaming type variables is a pain. Because they now contain uniques,
88 it is necessary to pass in an association list which maps a parsed
89 tyvar to its Name representation. In some cases (type signatures of
90 values), it is even necessary to go over the type first in order to
91 get the set of tyvars used by it, make an assoc list, and then go over
92 it again to rename the tyvars! However, we can also do some scoping
93 checks at the same time.
96 rnTyDecl :: ProtoNameTyDecl -> Rn4M RenamedTyDecl
98 rnTyDecl (TyData context tycon tyvars condecls derivings pragmas src_loc)
99 = pushSrcLocRn4 src_loc (
100 lookupTyCon tycon `thenRn4` \ tycon' ->
101 mkTyVarNamesEnv src_loc tyvars `thenRn4` \ (tv_env, tyvars') ->
102 rnContext tv_env context `thenRn4` \ context' ->
103 rnConDecls tv_env False condecls `thenRn4` \ condecls' ->
104 rn_derivs tycon' src_loc derivings `thenRn4` \ derivings' ->
105 recoverQuietlyRn4 (DataPragmas [] []) (
106 rnDataPragmas tv_env pragmas
107 ) `thenRn4` \ pragmas' ->
108 returnRn4 (TyData context' tycon' tyvars' condecls' derivings' pragmas' src_loc)
111 rnTyDecl (TyNew context tycon tyvars condecl derivings pragmas src_loc)
112 = pushSrcLocRn4 src_loc (
113 lookupTyCon tycon `thenRn4` \ tycon' ->
114 mkTyVarNamesEnv src_loc tyvars `thenRn4` \ (tv_env, tyvars') ->
115 rnContext tv_env context `thenRn4` \ context' ->
116 rnConDecls tv_env False condecl `thenRn4` \ condecl' ->
117 rn_derivs tycon' src_loc derivings `thenRn4` \ derivings' ->
118 recoverQuietlyRn4 (DataPragmas [] []) (
119 rnDataPragmas tv_env pragmas
120 ) `thenRn4` \ pragmas' ->
121 returnRn4 (TyNew context' tycon' tyvars' condecl' derivings' pragmas' src_loc)
124 rnTyDecl (TySynonym name tyvars ty src_loc)
125 = pushSrcLocRn4 src_loc (
126 lookupTyCon name `thenRn4` \ name' ->
127 mkTyVarNamesEnv src_loc tyvars `thenRn4` \ (tv_env, tyvars') ->
128 rnMonoType False{-no invisible types-} tv_env ty
130 returnRn4 (TySynonym name' tyvars' ty' src_loc)
133 rn_derivs tycon2 locn Nothing -- derivs not specified
136 rn_derivs tycon2 locn (Just ds)
137 = mapRn4 (rn_deriv tycon2 locn) ds `thenRn4` \ derivs ->
138 returnRn4 (Just derivs)
140 rn_deriv tycon2 locn clas
141 = lookupClass clas `thenRn4` \ clas_name ->
143 ClassName key _ _ | key `is_elem` derivableClassKeys
144 -> returnRn4 clas_name
145 _ -> addErrRn4 (derivingNonStdClassErr clas locn) `thenRn4_`
148 is_elem = isIn "rn_deriv"
151 @rnConDecls@ uses the `global name function' to create a new
152 constructor in which local names have been replaced by their original
153 names, reporting any unknown names.
156 rnConDecls :: TyVarNamesEnv
157 -> Bool -- True <=> allowed to see invisible data-cons
158 -> [ProtoNameConDecl]
159 -> Rn4M [RenamedConDecl]
161 rnConDecls tv_env invisibles_allowed con_decls
162 = mapRn4 rn_decl con_decls
165 = if invisibles_allowed
166 then lookupValueEvenIfInvisible
169 rn_decl (ConDecl name tys src_loc)
170 = pushSrcLocRn4 src_loc (
171 lookup_fn name `thenRn4` \ new_name ->
172 mapRn4 rn_bang_ty tys `thenRn4` \ new_tys ->
173 returnRn4 (ConDecl new_name new_tys src_loc)
176 rn_decl (ConOpDecl ty1 op ty2 src_loc)
177 = pushSrcLocRn4 src_loc (
178 lookup_fn op `thenRn4` \ new_op ->
179 rn_bang_ty ty1 `thenRn4` \ new_ty1 ->
180 rn_bang_ty ty2 `thenRn4` \ new_ty2 ->
181 returnRn4 (ConOpDecl new_ty1 new_op new_ty2 src_loc)
184 rn_decl (NewConDecl name ty src_loc)
185 = pushSrcLocRn4 src_loc (
186 lookup_fn name `thenRn4` \ new_name ->
187 rn_mono_ty ty `thenRn4` \ new_ty ->
188 returnRn4 (NewConDecl new_name new_ty src_loc)
191 rn_decl (RecConDecl con fields src_loc)
192 = panic "rnConDecls:RecConDecl"
195 rn_mono_ty = rnMonoType invisibles_allowed tv_env
197 rn_bang_ty (Banged ty)
198 = rn_mono_ty ty `thenRn4` \ new_ty ->
199 returnRn4 (Banged new_ty)
200 rn_bang_ty (Unbanged ty)
201 = rn_mono_ty ty `thenRn4` \ new_ty ->
202 returnRn4 (Unbanged new_ty)
205 %*********************************************************
207 \subsection{SPECIALIZE data pragmas}
209 %*********************************************************
212 rnSpecDataSig :: ProtoNameSpecDataSig
213 -> Rn4M RenamedSpecDataSig
215 rnSpecDataSig (SpecDataSig tycon ty src_loc)
216 = pushSrcLocRn4 src_loc (
218 tyvars = extractMonoTyNames eqProtoName ty
220 mkTyVarNamesEnv src_loc tyvars `thenRn4` \ (tv_env,_) ->
221 lookupTyCon tycon `thenRn4` \ tycon' ->
222 rnMonoType False tv_env ty `thenRn4` \ ty' ->
223 returnRn4 (SpecDataSig tycon' ty' src_loc)
227 %*********************************************************
229 \subsection{Class declarations}
231 %*********************************************************
233 @rnClassDecl@ uses the `global name function' to create a new
234 class declaration in which local names have been replaced by their
235 original names, reporting any unknown names.
238 rnClassDecl :: ProtoNameClassDecl -> Rn4M RenamedClassDecl
240 rnClassDecl (ClassDecl context cname tyvar sigs mbinds pragmas src_loc)
241 = pushSrcLocRn4 src_loc (
242 mkTyVarNamesEnv src_loc [tyvar] `thenRn4` \ (tv_env, [tyvar']) ->
243 rnContext tv_env context `thenRn4` \ context' ->
244 lookupClass cname `thenRn4` \ cname' ->
245 mapRn4 (rn_op cname' tv_env) sigs `thenRn4` \ sigs' ->
246 rnMethodBinds cname' mbinds `thenRn4` \ mbinds' ->
247 recoverQuietlyRn4 NoClassPragmas (
248 rnClassPragmas pragmas
249 ) `thenRn4` \ pragmas' ->
250 returnRn4 (ClassDecl context' cname' tyvar' sigs' mbinds' pragmas' src_loc)
253 rn_op clas tv_env (ClassOpSig op ty pragma locn)
254 = pushSrcLocRn4 locn (
255 lookupClassOp clas op `thenRn4` \ op_name ->
256 rnPolyType False tv_env ty `thenRn4` \ new_ty ->
259 *** Please check here that tyvar' appears in new_ty ***
260 *** (used to be in tcClassSig, but it's better here)
261 *** not_elem = isn'tIn "tcClassSigs"
262 *** -- Check that the class type variable is mentioned
263 *** checkTc (clas_tyvar `not_elem` extractTyVarTemplatesFromTy local_ty)
264 *** (methodTypeLacksTyVarErr clas_tyvar (_UNPK_ op_name) src_loc) `thenTc_`
266 recoverQuietlyRn4 NoClassOpPragmas (
267 rnClassOpPragmas pragma
268 ) `thenRn4` \ new_pragma ->
269 returnRn4 (ClassOpSig op_name new_ty new_pragma locn)
274 %*********************************************************
276 \subsection{Instance declarations}
278 %*********************************************************
281 @rnInstDecl@ uses the `global name function' to create a new of
282 instance declaration in which local names have been replaced by their
283 original names, reporting any unknown names.
286 rnInstDecl :: ProtoNameInstDecl -> Rn4M RenamedInstDecl
288 rnInstDecl (InstDecl cname ty mbinds from_here modname uprags pragmas src_loc)
289 = pushSrcLocRn4 src_loc (
291 tyvars = extract_poly_ty_names ty
293 mkTyVarNamesEnv src_loc tyvars `thenRn4` \ (tv_env,_) ->
294 lookupClass cname `thenRn4` \ cname' ->
295 rnPolyType False{-no invisibles-} tv_env ty
297 rnMethodBinds cname' mbinds `thenRn4` \ mbinds' ->
298 mapRn4 (rn_uprag cname') uprags `thenRn4` \ new_uprags ->
299 recoverQuietlyRn4 NoInstancePragmas (
300 rnInstancePragmas cname' tv_env pragmas
301 ) `thenRn4` \ new_pragmas ->
302 returnRn4 (InstDecl cname' ty' mbinds'
303 from_here modname new_uprags new_pragmas src_loc)
306 rn_uprag class_name (SpecSig op ty using locn)
307 = ASSERT(not (maybeToBool using)) -- ToDo: SPEC method with explicit spec_id
308 pushSrcLocRn4 src_loc (
309 lookupClassOp class_name op `thenRn4` \ op_name ->
310 rnPolyType False nullTyVarNamesEnv ty `thenRn4` \ new_ty ->
311 returnRn4 (SpecSig op_name new_ty Nothing locn)
313 rn_uprag class_name (InlineSig op locn)
314 = pushSrcLocRn4 locn (
315 lookupClassOp class_name op `thenRn4` \ op_name ->
316 returnRn4 (InlineSig op_name locn)
318 rn_uprag class_name (DeforestSig op locn)
319 = pushSrcLocRn4 locn (
320 lookupClassOp class_name op `thenRn4` \ op_name ->
321 returnRn4 (DeforestSig op_name locn)
323 rn_uprag class_name (MagicUnfoldingSig op str locn)
324 = pushSrcLocRn4 locn (
325 lookupClassOp class_name op `thenRn4` \ op_name ->
326 returnRn4 (MagicUnfoldingSig op_name str locn)
330 %*********************************************************
332 \subsection{@SPECIALIZE instance@ user-pragmas}
334 %*********************************************************
337 rnSpecInstSig :: ProtoNameSpecInstSig
338 -> Rn4M RenamedSpecInstSig
340 rnSpecInstSig (SpecInstSig clas ty src_loc)
341 = pushSrcLocRn4 src_loc (
342 let tyvars = extractMonoTyNames eqProtoName ty in
343 mkTyVarNamesEnv src_loc tyvars `thenRn4` \ (tv_env,_) ->
344 lookupClass clas `thenRn4` \ new_clas ->
345 rnMonoType False tv_env ty `thenRn4` \ new_ty ->
346 returnRn4 (SpecInstSig new_clas new_ty src_loc)
350 %*********************************************************
352 \subsection{Default declarations}
354 %*********************************************************
356 @rnDefaultDecl@ uses the `global name function' to create a new set
357 of default declarations in which local names have been replaced by
358 their original names, reporting any unknown names.
361 rnDefaultDecl :: [ProtoNameDefaultDecl] -> Rn4M [RenamedDefaultDecl]
363 rnDefaultDecl [] = returnRn4 []
364 rnDefaultDecl [DefaultDecl tys src_loc]
365 = pushSrcLocRn4 src_loc $
366 mapRn4 (rnMonoType False nullTyVarNamesEnv) tys `thenRn4` \ tys' ->
367 returnRn4 [DefaultDecl tys' src_loc]
368 rnDefaultDecl defs@(d:ds)
369 = addErrRn4 (dupDefaultDeclErr defs) `thenRn4_`
373 %*************************************************************************
375 \subsection{Type signatures from interfaces}
377 %*************************************************************************
379 Non-interface type signatures (which may include user-pragmas) are
380 handled with @HsBinds@.
382 @ClassOpSigs@ are dealt with in class declarations.
385 rnIntSig :: ProtoNameSig -> Rn4M RenamedSig
387 rnIntSig (Sig name ty pragma src_loc)
388 = pushSrcLocRn4 src_loc (
389 lookupValue name `thenRn4` \ new_name ->
390 rnPolyType False nullTyVarNamesEnv ty `thenRn4` \ new_ty ->
391 recoverQuietlyRn4 NoGenPragmas (
393 ) `thenRn4` \ new_pragma ->
394 returnRn4 (Sig new_name new_ty new_pragma src_loc)
398 %*************************************************************************
400 \subsection{Fixity declarations}
402 %*************************************************************************
405 rnFixes :: [ProtoNameFixityDecl] -> Rn4M [RenamedFixityDecl]
408 = mapRn4 rn_fixity fixities `thenRn4` \ fixes_maybe ->
409 returnRn4 (catMaybes fixes_maybe)
411 rn_fixity (InfixL name i)
412 = lookupFixityOp name `thenRn4` \ res ->
415 Just name2 -> Just (InfixL name2 i)
419 rn_fixity (InfixR name i)
420 = lookupFixityOp name `thenRn4` \ res ->
423 Just name2 -> Just (InfixR name2 i)
427 rn_fixity (InfixN name i)
428 = lookupFixityOp name `thenRn4` \ res ->
431 Just name2 -> Just (InfixN name2 i)
436 %*********************************************************
438 \subsection{Support code to rename types}
440 %*********************************************************
443 rnPolyType :: Bool -- True <=> "invisible" tycons (in pragmas) allowed
446 -> Rn4M RenamedPolyType
448 rnPolyType invisibles_allowed tv_env (HsForAllTy tvs ctxt ty)
449 = rn_poly_help invisibles_allowed tv_env tvs ctxt ty
451 rnPolyType invisibles_allowed tv_env poly_ty@(HsPreForAllTy ctxt ty)
452 = rn_poly_help invisibles_allowed tv_env forall_tyvars ctxt ty
454 mentioned_tyvars = extract_poly_ty_names poly_ty
456 forall_tyvars = mentioned_tyvars `minus_list` domTyVarNamesEnv tv_env
458 -- URGH! Why is this here? SLPJ
459 -- Because we are doing very delicate comparisons
460 -- (eqProtoName and all that); if we got rid of
461 -- that, then we could use ListSetOps stuff. WDP
462 minus_list xs ys = [ x | x <- xs, not (x `elemProtoNames` ys)]
465 extract_poly_ty_names (HsPreForAllTy ctxt ty)
466 = extractCtxtTyNames eqProtoName ctxt
468 extractMonoTyNames eqProtoName ty
471 union_list [] [] = []
475 | a `elemProtoNames` b = union_list as b
476 | otherwise = a : union_list as b
484 -> Rn4M RenamedPolyType
486 rn_poly_help invisibles_allowed tv_env tyvars ctxt ty
487 = getSrcLocRn4 `thenRn4` \ src_loc ->
488 mkTyVarNamesEnv src_loc tyvars `thenRn4` \ (tv_env1, new_tyvars) ->
490 tv_env2 = catTyVarNamesEnvs tv_env1 tv_env
492 rnContext tv_env2 ctxt `thenRn4` \ new_ctxt ->
493 rnMonoType invisibles_allowed tv_env2 ty `thenRn4` \ new_ty ->
494 returnRn4 (HsForAllTy new_tyvars new_ctxt new_ty)
498 rnMonoType :: Bool -- allowed to look at invisible tycons
501 -> Rn4M RenamedMonoType
503 rnMonoType invisibles_allowed tv_env (MonoTyVar tyvar)
504 = lookupTyVarName tv_env tyvar `thenRn4` \ tyvar' ->
505 returnRn4 (MonoTyVar tyvar')
507 rnMonoType invisibles_allowed tv_env (MonoListTy ty)
508 = rnMonoType invisibles_allowed tv_env ty `thenRn4` \ ty' ->
509 returnRn4 (MonoListTy ty')
511 rnMonoType invisibles_allowed tv_env (MonoFunTy ty1 ty2)
512 = andRn4 MonoFunTy (rnMonoType invisibles_allowed tv_env ty1)
513 (rnMonoType invisibles_allowed tv_env ty2)
515 rnMonoType invisibles_allowed tv_env (MonoTupleTy tys)
516 = mapRn4 (rnMonoType invisibles_allowed tv_env) tys `thenRn4` \ tys' ->
517 returnRn4 (MonoTupleTy tys')
519 rnMonoType invisibles_allowed tv_env (MonoTyApp name tys)
521 lookup_fn = if isAvarid (getOccurrenceName name)
522 then lookupTyVarName tv_env
523 else if invisibles_allowed
524 then lookupTyConEvenIfInvisible
527 lookup_fn name `thenRn4` \ name' ->
528 mapRn4 (rnMonoType invisibles_allowed tv_env) tys `thenRn4` \ tys' ->
529 returnRn4 (MonoTyApp name' tys')
531 -- for unfoldings only:
533 rnMonoType invisibles_allowed tv_env (MonoForAllTy tyvars_w_kinds ty)
534 = getSrcLocRn4 `thenRn4` \ src_loc ->
535 mkTyVarNamesEnv src_loc tyvars `thenRn4` \ (tv_env1, new_tyvars) ->
537 tv_env2 = catTyVarNamesEnvs tv_env1 tv_env
539 rnMonoType invisibles_allowed tv_env2 ty `thenRn4` \ ty' ->
540 returnRn4 (MonoForAllTy (new_tyvars `zip` kinds) ty')
542 (tyvars, kinds) = unzip tyvars_w_kinds
544 rnMonoType invisibles_allowed tv_env (MonoDictTy clas ty)
545 = lookupClass clas `thenRn4` \ new_clas ->
546 rnMonoType invisibles_allowed tv_env ty `thenRn4` \ new_ty ->
547 returnRn4 (MonoDictTy new_clas new_ty)
551 rnContext :: TyVarNamesEnv -> ProtoNameContext -> Rn4M RenamedContext
553 rnContext tv_env ctxt
554 = mapRn4 rn_ctxt ctxt
556 rn_ctxt (clas, tyvar)
557 = lookupClass clas `thenRn4` \ clas_name ->
558 lookupTyVarName tv_env tyvar `thenRn4` \ tyvar_name ->
559 returnRn4 (clas_name, tyvar_name)
562 %*********************************************************
564 \subsection{Support code to rename various pragmas}
566 %*********************************************************
569 rnDataPragmas tv_env (DataPragmas cons specs)
570 = rnConDecls tv_env True{-invisibles allowed-} cons `thenRn4` \ new_cons ->
571 mapRn4 types_n_spec specs `thenRn4` \ new_specs ->
572 returnRn4 (DataPragmas new_cons new_specs)
574 types_n_spec ty_maybes
575 = mapRn4 (rn_ty_maybe nullTyVarNamesEnv) ty_maybes
579 rnClassOpPragmas NoClassOpPragmas = returnRn4 NoClassOpPragmas
581 rnClassOpPragmas (ClassOpPragmas dsel defm)
582 = recoverQuietlyRn4 NoGenPragmas (rnGenPragmas dsel) `thenRn4` \ new_dsel ->
583 recoverQuietlyRn4 NoGenPragmas (rnGenPragmas defm) `thenRn4` \ new_defm ->
584 returnRn4 (ClassOpPragmas new_dsel new_defm)
588 rnClassPragmas NoClassPragmas = returnRn4 NoClassPragmas
590 rnClassPragmas (SuperDictPragmas sds)
591 = mapRn4 rnGenPragmas sds `thenRn4` \ new_sds ->
592 returnRn4 (SuperDictPragmas new_sds)
595 NB: In various cases around here, we don't @recoverQuietlyRn4@ around
596 calls to @rnGenPragmas@; not really worth it.
599 rnInstancePragmas _ _ NoInstancePragmas = returnRn4 NoInstancePragmas
601 rnInstancePragmas _ _ (SimpleInstancePragma dfun)
602 = rnGenPragmas dfun `thenRn4` \ new_dfun ->
603 returnRn4 (SimpleInstancePragma new_dfun)
605 rnInstancePragmas clas tv_env (ConstantInstancePragma dfun constms)
606 = recoverQuietlyRn4 NoGenPragmas (
608 ) `thenRn4` \ new_dfun ->
609 mapRn4 name_n_gen constms `thenRn4` \ new_constms ->
610 returnRn4 (ConstantInstancePragma new_dfun new_constms)
613 = lookupClassOp clas op `thenRn4` \ new_op ->
614 rnGenPragmas gen `thenRn4` \ new_gen ->
615 returnRn4 (new_op, new_gen)
617 rnInstancePragmas clas tv_env (SpecialisedInstancePragma dfun specs)
618 = recoverQuietlyRn4 NoGenPragmas (
620 ) `thenRn4` \ new_dfun ->
621 mapRn4 types_n_spec specs `thenRn4` \ new_specs ->
622 returnRn4 (SpecialisedInstancePragma new_dfun new_specs)
624 types_n_spec (ty_maybes, dicts_to_ignore, inst)
625 = mapRn4 (rn_ty_maybe tv_env) ty_maybes `thenRn4` \ new_tys ->
626 rnInstancePragmas clas tv_env inst `thenRn4` \ new_inst ->
627 returnRn4 (new_tys, dicts_to_ignore, new_inst)
630 And some general pragma stuff: (Not sure what, if any, of this would
631 benefit from a TyVarNamesEnv passed in.... [ToDo])
633 rnGenPragmas :: ProtoNameGenPragmas -> Rn4M RenamedGenPragmas
635 rnGenPragmas NoGenPragmas = returnRn4 NoGenPragmas
637 rnGenPragmas (GenPragmas arity upd def strict unfold specs)
638 = recoverQuietlyRn4 NoImpUnfolding (
640 ) `thenRn4` \ new_unfold ->
641 rn_strictness strict `thenRn4` \ new_strict ->
642 recoverQuietlyRn4 [] (
643 mapRn4 types_n_gen specs
644 ) `thenRn4` \ new_specs ->
645 returnRn4 (GenPragmas arity upd def new_strict new_unfold new_specs)
647 rn_unfolding NoImpUnfolding = returnRn4 NoImpUnfolding
649 rn_unfolding (ImpMagicUnfolding str) = returnRn4 (ImpMagicUnfolding str)
651 rn_unfolding (ImpUnfolding guidance core)
652 = rn_core nullTyVarNamesEnv core `thenRn4` \ new_core ->
653 returnRn4 (ImpUnfolding guidance new_core)
656 rn_strictness NoImpStrictness = returnRn4 NoImpStrictness
658 rn_strictness (ImpStrictness is_bot ww_info wrkr_info)
659 = recoverQuietlyRn4 NoGenPragmas (
660 rnGenPragmas wrkr_info
661 ) `thenRn4` \ new_wrkr_info ->
662 returnRn4 (ImpStrictness is_bot ww_info new_wrkr_info)
665 types_n_gen (ty_maybes, dicts_to_ignore, gen)
666 = mapRn4 (rn_ty_maybe no_env) ty_maybes `thenRn4` \ new_tys ->
667 recoverQuietlyRn4 NoGenPragmas (
669 ) `thenRn4` \ new_gen ->
670 returnRn4 (new_tys, dicts_to_ignore, new_gen)
672 no_env = nullTyVarNamesEnv
675 rn_ty_maybe tv_env Nothing = returnRn4 Nothing
677 rn_ty_maybe tv_env (Just ty)
678 = rnMonoType True{-invisibles OK-} tv_env ty `thenRn4` \ new_ty ->
679 returnRn4 (Just new_ty)
682 rn_core tvenv (UfVar v)
683 = rn_uf_id tvenv v `thenRn4` \ vname ->
684 returnRn4 (UfVar vname)
686 rn_core tvenv (UfLit lit)
687 = returnRn4 (UfLit lit)
689 rn_core tvenv (UfCon con tys as)
690 = lookupValueEvenIfInvisible con `thenRn4` \ new_con ->
691 mapRn4 (rn_core_type tvenv) tys `thenRn4` \ new_tys ->
692 mapRn4 (rn_atom tvenv) as `thenRn4` \ new_as ->
693 returnRn4 (UfCon new_con new_tys new_as)
695 rn_core tvenv (UfPrim op tys as)
696 = rn_core_primop tvenv op `thenRn4` \ new_op ->
697 mapRn4 (rn_core_type tvenv) tys `thenRn4` \ new_tys ->
698 mapRn4 (rn_atom tvenv) as `thenRn4` \ new_as ->
699 returnRn4 (UfPrim new_op new_tys new_as)
701 rn_core tvenv (UfLam binder body)
702 = rn_binder tvenv binder `thenRn4` \ (b,ty) ->
703 extendSS [b] (rn_core tvenv body) `thenRn4` \ new_body ->
704 returnRn4 (UfLam (b,ty) new_body)
706 rn_core tvenv (UfApp fun arg)
707 = rn_core tvenv fun `thenRn4` \ new_fun ->
708 rn_atom tvenv arg `thenRn4` \ new_arg ->
709 returnRn4 (UfApp new_fun new_arg)
711 rn_core tvenv (UfCase expr alts)
712 = rn_core tvenv expr `thenRn4` \ new_expr ->
713 rn_alts alts `thenRn4` \ new_alts ->
714 returnRn4 (UfCase new_expr new_alts)
716 rn_alts (UfCoAlgAlts alg_alts deflt)
717 = mapRn4 rn_alg_alt alg_alts `thenRn4` \ new_alts ->
718 rn_deflt deflt `thenRn4` \ new_deflt ->
719 returnRn4 (UfCoAlgAlts new_alts new_deflt)
721 rn_alg_alt (con, params, rhs)
722 = lookupValueEvenIfInvisible con `thenRn4` \ new_con ->
723 mapRn4 (rn_binder tvenv) params `thenRn4` \ new_params ->
725 bs = [ b | (b, ty) <- new_params ]
727 extendSS bs (rn_core tvenv rhs) `thenRn4` \ new_rhs ->
728 returnRn4 (new_con, new_params, new_rhs)
730 rn_alts (UfCoPrimAlts prim_alts deflt)
731 = mapRn4 rn_prim_alt prim_alts `thenRn4` \ new_alts ->
732 rn_deflt deflt `thenRn4` \ new_deflt ->
733 returnRn4 (UfCoPrimAlts new_alts new_deflt)
735 rn_prim_alt (lit, rhs)
736 = rn_core tvenv rhs `thenRn4` \ new_rhs ->
737 returnRn4 (lit, new_rhs)
739 rn_deflt UfCoNoDefault = returnRn4 UfCoNoDefault
740 rn_deflt (UfCoBindDefault b rhs)
741 = rn_binder tvenv b `thenRn4` \ new_b@(binder, ty) ->
742 extendSS [binder] (rn_core tvenv rhs) `thenRn4` \ new_rhs ->
743 returnRn4 (UfCoBindDefault new_b new_rhs)
745 rn_core tvenv (UfLet bind body)
746 = rn_bind bind `thenRn4` \ (new_bind, new_binders) ->
747 extendSS new_binders (rn_core tvenv body) `thenRn4` \ new_body ->
748 returnRn4 (UfLet new_bind new_body)
750 rn_bind (UfCoNonRec b rhs)
751 = rn_binder tvenv b `thenRn4` \ new_b@(binder, ty) ->
752 rn_core tvenv rhs `thenRn4` \ new_rhs ->
753 returnRn4 (UfCoNonRec new_b new_rhs, [binder])
755 rn_bind (UfCoRec pairs)
756 = -- conjure up Names; we do this differently than
757 -- elsewhere for Core, because of the recursion here;
759 -- [BEFORE IT WAS "FIXED"... 94/05...]
760 -- [Andy -- It *was* a 'deep' issue to me...]
761 -- [Will -- Poor wee soul.]
763 getSrcLocRn4 `thenRn4` \ locn ->
764 namesFromProtoNames "core variable"
765 [ (b, locn) | ((b,_),_) <- pairs] `thenRn4` \ binders ->
767 extendSS binders (mapRn4 rn_pair (pairs `zip` binders)) `thenRn4` \ new_pairs ->
768 returnRn4 (UfCoRec new_pairs, binders)
770 rn_pair (((b, ty), rhs), new_b)
771 = rn_core_type tvenv ty `thenRn4` \ new_ty ->
772 rn_core tvenv rhs `thenRn4` \ new_rhs ->
773 returnRn4 ((new_b, new_ty), new_rhs)
775 rn_core tvenv (UfSCC uf_cc body)
776 = rn_cc uf_cc `thenRn4` \ new_cc ->
777 rn_core tvenv body `thenRn4` \ new_body ->
778 returnRn4 (UfSCC new_cc new_body)
780 rn_cc (UfAutoCC id m g is_dupd is_caf)
781 = rn_uf_id tvenv id `thenRn4` \ new_id ->
782 returnRn4 (UfAutoCC new_id m g is_dupd is_caf)
784 rn_cc (UfDictCC id m g is_caf is_dupd)
785 = rn_uf_id tvenv id `thenRn4` \ new_id ->
786 returnRn4 (UfDictCC new_id m g is_dupd is_caf)
788 -- the rest are boring:
789 rn_cc (UfPreludeDictsCC d) = returnRn4 (UfPreludeDictsCC d)
790 rn_cc (UfAllDictsCC m g d) = returnRn4 (UfAllDictsCC m g d)
791 rn_cc (UfUserCC n m g d c) = returnRn4 (UfUserCC n m g d c)
794 rn_core_primop tvenv (UfCCallOp str is_casm may_gc arg_tys res_ty)
795 = mapRn4 (rn_core_type tvenv) arg_tys `thenRn4` \ new_arg_tys ->
796 rn_core_type tvenv res_ty `thenRn4` \ new_res_ty ->
797 returnRn4 (UfCCallOp str is_casm may_gc new_arg_tys new_res_ty)
798 rn_core_primop tvenv (UfOtherOp op)
799 = returnRn4 (UfOtherOp op)
802 rn_uf_id tvenv (BoringUfId v)
803 = lookupValueEvenIfInvisible v `thenRn4` \ vname ->
804 returnRn4 (BoringUfId vname)
806 rn_uf_id tvenv (SuperDictSelUfId c sc)
807 = lookupClass{-EvenIfInvisible-} c `thenRn4` \ new_c ->
808 lookupClass{-EvenIfInvisible-} sc `thenRn4` \ new_sc ->
809 returnRn4 (SuperDictSelUfId new_c new_sc)
811 rn_uf_id tvenv (ClassOpUfId c op)
812 = lookupClass{-EvenIfInvisible-} c `thenRn4` \ new_c ->
813 lookupClassOp{-EvenIfInvisible-} new_c op `thenRn4` \ new_op ->
814 returnRn4 (ClassOpUfId new_c new_op)
816 rn_uf_id tvenv (DictFunUfId c ty)
817 = lookupClass{-EvenIfInvisible-} c `thenRn4` \ new_c ->
818 rn_core_type tvenv ty `thenRn4` \ new_ty ->
819 returnRn4 (DictFunUfId new_c new_ty)
821 rn_uf_id tvenv (ConstMethodUfId c op ty)
822 = lookupClass{-EvenIfInvisible-} c `thenRn4` \ new_c ->
823 lookupClassOp{-EvenIfInvisible-} new_c op `thenRn4` \ new_op ->
824 rn_core_type tvenv ty `thenRn4` \ new_ty ->
825 returnRn4 (ConstMethodUfId new_c new_op new_ty)
827 rn_uf_id tvenv (DefaultMethodUfId c op)
828 = lookupClass{-EvenIfInvisible-} c `thenRn4` \ new_c ->
829 lookupClassOp{-EvenIfInvisible-} new_c op `thenRn4` \ new_op ->
830 returnRn4 (DefaultMethodUfId new_c new_op)
832 rn_uf_id tvenv (SpecUfId unspec ty_maybes)
833 = rn_uf_id tvenv unspec `thenRn4` \ new_unspec ->
834 mapRn4 (rn_ty_maybe tvenv) ty_maybes `thenRn4` \ new_ty_maybes ->
835 returnRn4 (SpecUfId new_unspec new_ty_maybes)
837 rn_uf_id tvenv (WorkerUfId unwrkr)
838 = rn_uf_id tvenv unwrkr `thenRn4` \ new_unwrkr ->
839 returnRn4 (WorkerUfId new_unwrkr)
842 rn_binder tvenv (b, ty)
843 = getSrcLocRn4 `thenRn4` \ src_loc ->
844 namesFromProtoNames "binder in core unfolding" [(b, src_loc)]
845 `thenRn4` \ [new_b] ->
846 rn_core_type tvenv ty `thenRn4` \ new_ty ->
847 returnRn4 (new_b, new_ty)
850 rn_atom tvenv (UfCoLitAtom l) = returnRn4 (UfCoLitAtom l)
851 rn_atom tvenv (UfCoVarAtom v)
852 = rn_uf_id tvenv v `thenRn4` \ vname ->
853 returnRn4 (UfCoVarAtom vname)
856 rn_core_type_maybe tvenv Nothing = returnRn4 Nothing
857 rn_core_type_maybe tvenv (Just ty)
858 = rn_core_type tvenv ty `thenRn4` \ new_ty ->
859 returnRn4 (Just new_ty)
862 rn_core_type tvenv ty
863 = rnPolyType True{-invisible tycons OK-} tvenv ty
868 derivingNonStdClassErr clas locn sty
869 = ppHang (ppStr "Non-standard class in deriving")
870 4 (ppCat [ppr sty clas, ppr sty locn])
872 dupDefaultDeclErr defs sty
873 = ppHang (ppStr "Duplicate default declarations")
874 4 (ppAboves (map pp_def_loc defs))
876 pp_def_loc (DefaultDecl _ src_loc) = ppr sty src_loc