diff options
Diffstat (limited to 'ghc/compiler/rename/Rename4.lhs')
| -rw-r--r-- | ghc/compiler/rename/Rename4.lhs | 829 |
1 files changed, 829 insertions, 0 deletions
diff --git a/ghc/compiler/rename/Rename4.lhs b/ghc/compiler/rename/Rename4.lhs new file mode 100644 index 0000000000..746078bfe0 --- /dev/null +++ b/ghc/compiler/rename/Rename4.lhs @@ -0,0 +1,829 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[Rename4]{Fourth of the renaming passes} + +\begin{code} +#include "HsVersions.h" + +module Rename4 ( + rnModule4, rnPolyType4, rnGenPragmas4, + + initRn4, Rn4M(..), TyVarNamesEnv(..), -- re-exported from the monad + + -- for completeness + + Module, Bag, InPat, ProtoNamePat(..), RenamedPat(..), + PolyType, Maybe, Name, ProtoName, GlobalNameFun(..), + SrcLoc, SplitUniqSupply, Error(..), PprStyle, + Pretty(..), PrettyRep + ) where + +IMPORT_Trace -- ToDo: rm (debugging) +import Outputable +import Pretty + +import AbsSyn +import AbsUniType ( derivableClassKeys ) +import Errors +import HsCore -- ****** NEED TO SEE CONSTRUCTORS ****** +import HsPragmas -- ****** NEED TO SEE CONSTRUCTORS ****** +import Maybes ( catMaybes, Maybe(..) ) +import ProtoName ( eqProtoName, elemProtoNames ) +import RenameBinds4 ( rnTopBinds4, rnMethodBinds4 ) +import RenameMonad4 +import Util +\end{code} + +This pass `renames' the module+imported info, simultaneously +performing dependency analysis. It also does the following error +checks: +\begin{enumerate} +\item +Checks that tyvars are used properly. This includes checking +for undefined tyvars, and tyvars in contexts that are ambiguous. +\item +Checks that local variables are defined. +\end{enumerate} + +\begin{code} +rnModule4 :: ProtoNameModule -> Rn4M RenamedModule + +rnModule4 (Module mod_name exports _ fixes ty_decls absty_sigs + class_decls inst_decls specinst_sigs defaults + binds int_sigs src_loc) + + = pushSrcLocRn4 src_loc ( + + mapRn4 rnTyDecl4 ty_decls `thenRn4` \ new_ty_decls -> + + mapRn4 rnTySig4 absty_sigs `thenRn4` \ new_absty_sigs -> + + mapRn4 rnClassDecl4 class_decls `thenRn4` \ new_class_decls -> + + mapRn4 rnInstDecl4 inst_decls `thenRn4` \ new_inst_decls -> + + mapRn4 rnInstSpecSig4 specinst_sigs `thenRn4` \ new_specinst_sigs -> + + mapRn4 rnDefaultDecl4 defaults `thenRn4` \ new_defaults -> + + rnTopBinds4 binds `thenRn4` \ new_binds -> + + mapRn4 rnIntSig4 int_sigs `thenRn4` \ new_int_sigs -> + + rnFixes4 fixes `thenRn4` \ new_fixes -> + + returnRn4 (Module mod_name + exports [{-imports finally clobbered-}] new_fixes + new_ty_decls new_absty_sigs new_class_decls + new_inst_decls new_specinst_sigs new_defaults + new_binds new_int_sigs src_loc) + ) +\end{code} + + +%********************************************************* +%* * +\subsection{Type declarations} +%* * +%********************************************************* + +@rnTyDecl4@ uses the `global name function' to create a new type +declaration in which local names have been replaced by their original +names, reporting any unknown names. + +Renaming type variables is a pain. Because they now contain uniques, +it is necessary to pass in an association list which maps a parsed +tyvar to its Name representation. In some cases (type signatures of +values), it is even necessary to go over the type first in order to +get the set of tyvars used by it, make an assoc list, and then go over +it again to rename the tyvars! However, we can also do some scoping +checks at the same time. + +\begin{code} +rnTyDecl4 :: ProtoNameTyDecl -> Rn4M RenamedTyDecl + +rnTyDecl4 (TyData context tycon tyvars condecls derivings pragmas src_loc) + = pushSrcLocRn4 src_loc ( + lookupTyCon tycon `thenRn4` \ tycon' -> + mkTyVarNamesEnv src_loc tyvars `thenRn4` \ (tv_env, tyvars') -> + rnContext4 tv_env context `thenRn4` \ context' -> + rnConDecls4 tv_env False condecls `thenRn4` \ condecls' -> + mapRn4 (rn_deriv tycon' src_loc) derivings `thenRn4` \ derivings' -> + recoverQuietlyRn4 (DataPragmas [] []) ( + rnDataPragmas4 tv_env pragmas + ) `thenRn4` \ pragmas' -> + returnRn4 (TyData context' tycon' tyvars' condecls' derivings' pragmas' src_loc) + ) + where + rn_deriv tycon2 locn deriv + = lookupClass deriv `thenRn4` \ clas_name -> + case clas_name of + PreludeClass key _ | key `is_elem` derivableClassKeys + -> returnRn4 clas_name + _ -> addErrRn4 (derivingNonStdClassErr tycon2 deriv locn) `thenRn4_` + returnRn4 clas_name + where + is_elem = isIn "rn_deriv" + +rnTyDecl4 (TySynonym name tyvars ty pragmas src_loc) + = pushSrcLocRn4 src_loc ( + lookupTyCon name `thenRn4` \ name' -> + mkTyVarNamesEnv src_loc tyvars `thenRn4` \ (tv_env, tyvars') -> + rnMonoType4 False{-no invisible types-} tv_env ty + `thenRn4` \ ty' -> + returnRn4 (TySynonym name' tyvars' ty' pragmas src_loc) + ) +\end{code} + +@rnConDecls4@ uses the `global name function' to create a new +constructor in which local names have been replaced by their original +names, reporting any unknown names. + +\begin{code} +rnConDecls4 :: TyVarNamesEnv + -> Bool -- True <=> allowed to see invisible data-cons + -> [ProtoNameConDecl] + -> Rn4M [RenamedConDecl] + +rnConDecls4 tv_env invisibles_allowed con_decls + = mapRn4 rn_decl con_decls + where + lookup_fn + = if invisibles_allowed + then lookupValueEvenIfInvisible + else lookupValue + + rn_decl (ConDecl name tys src_loc) + = pushSrcLocRn4 src_loc ( + lookup_fn name `thenRn4` \ new_name -> + mapRn4 (rnMonoType4 invisibles_allowed tv_env) tys + `thenRn4` \ new_tys -> + + returnRn4 (ConDecl new_name new_tys src_loc) + ) +\end{code} + +%********************************************************* +%* * +\subsection{ABSTRACT type-synonym pragmas} +%* * +%********************************************************* + +\begin{code} +rnTySig4 :: ProtoNameDataTypeSig + -> Rn4M RenamedDataTypeSig + +rnTySig4 (AbstractTypeSig tycon src_loc) + = pushSrcLocRn4 src_loc ( + lookupTyCon tycon `thenRn4` \ tycon' -> + returnRn4 (AbstractTypeSig tycon' src_loc) + ) + +rnTySig4 (SpecDataSig tycon ty src_loc) + = pushSrcLocRn4 src_loc ( + let + tyvars = extractMonoTyNames eqProtoName ty + in + mkTyVarNamesEnv src_loc tyvars `thenRn4` \ (tv_env,_) -> + lookupTyCon tycon `thenRn4` \ tycon' -> + rnMonoType4 False tv_env ty `thenRn4` \ ty' -> + returnRn4 (SpecDataSig tycon' ty' src_loc) + ) +\end{code} + +%********************************************************* +%* * +\subsection{Class declarations} +%* * +%********************************************************* + +@rnClassDecl4@ uses the `global name function' to create a new +class declaration in which local names have been replaced by their +original names, reporting any unknown names. + +\begin{code} +rnClassDecl4 :: ProtoNameClassDecl -> Rn4M RenamedClassDecl + +rnClassDecl4 (ClassDecl context cname tyvar sigs mbinds pragmas src_loc) + = pushSrcLocRn4 src_loc ( + mkTyVarNamesEnv src_loc [tyvar] `thenRn4` \ (tv_env, [tyvar']) -> + rnContext4 tv_env context `thenRn4` \ context' -> + lookupClass cname `thenRn4` \ cname' -> + mapRn4 (rn_op cname' tv_env) sigs `thenRn4` \ sigs' -> + rnMethodBinds4 cname' mbinds `thenRn4` \ mbinds' -> + recoverQuietlyRn4 NoClassPragmas ( + rnClassPragmas4 pragmas + ) `thenRn4` \ pragmas' -> + returnRn4 (ClassDecl context' cname' tyvar' sigs' mbinds' pragmas' src_loc) + ) + where + rn_op clas tv_env (ClassOpSig op ty pragma locn) + = pushSrcLocRn4 locn ( + lookupClassOp clas op `thenRn4` \ op_name -> + rnPolyType4 False True tv_env ty `thenRn4` \ new_ty -> + recoverQuietlyRn4 NoClassOpPragmas ( + rnClassOpPragmas4 pragma + ) `thenRn4` \ new_pragma -> + returnRn4 (ClassOpSig op_name new_ty new_pragma locn) + ) +\end{code} + + +%********************************************************* +%* * +\subsection{Instance declarations} +%* * +%********************************************************* + + +@rnInstDecl4@ uses the `global name function' to create a new of +instance declaration in which local names have been replaced by their +original names, reporting any unknown names. + +\begin{code} +rnInstDecl4 :: ProtoNameInstDecl -> Rn4M RenamedInstDecl + +rnInstDecl4 (InstDecl context cname ty mbinds from_here modname imod uprags pragmas src_loc) + = pushSrcLocRn4 src_loc ( + let tyvars = extractMonoTyNames eqProtoName ty in + mkTyVarNamesEnv src_loc tyvars `thenRn4` \ (tv_env,_) -> + rnContext4 tv_env context `thenRn4` \ context' -> + lookupClass cname `thenRn4` \ cname' -> + rnMonoType4 False{-no invisibles-} tv_env ty + `thenRn4` \ ty' -> + rnMethodBinds4 cname' mbinds `thenRn4` \ mbinds' -> + mapRn4 rn_uprag uprags `thenRn4` \ new_uprags -> + recoverQuietlyRn4 NoInstancePragmas ( + rnInstancePragmas4 cname' tv_env pragmas + ) `thenRn4` \ new_pragmas -> + returnRn4 (InstDecl context' cname' ty' mbinds' + from_here modname imod new_uprags new_pragmas src_loc) + ) + where + rn_uprag (InlineSig var guide locn) + = pushSrcLocRn4 locn ( + lookupValue var `thenRn4` \ new_var -> + returnRn4 (InlineSig new_var guide locn) + ) + rn_uprag (DeforestSig var locn) + = pushSrcLocRn4 locn ( + lookupValue var `thenRn4` \ new_var -> + returnRn4 (DeforestSig new_var locn) + ) + rn_uprag (MagicUnfoldingSig var str locn) + = pushSrcLocRn4 locn ( + lookupValue var `thenRn4` \ new_var -> + returnRn4 (MagicUnfoldingSig new_var str locn) + ) +\end{code} + +%********************************************************* +%* * +\subsection{@SPECIALIZE instance@ user-pragmas} +%* * +%********************************************************* + +\begin{code} +rnInstSpecSig4 :: ProtoNameSpecialisedInstanceSig + -> Rn4M RenamedSpecialisedInstanceSig + +rnInstSpecSig4 (InstSpecSig clas ty src_loc) + = pushSrcLocRn4 src_loc ( + let tyvars = extractMonoTyNames eqProtoName ty in + mkTyVarNamesEnv src_loc tyvars `thenRn4` \ (tv_env,_) -> + lookupClass clas `thenRn4` \ new_clas -> + rnMonoType4 False tv_env ty `thenRn4` \ new_ty -> + returnRn4 (InstSpecSig new_clas new_ty src_loc) + ) +\end{code} + +%********************************************************* +%* * +\subsection{Default declarations} +%* * +%********************************************************* + +@rnDefaultDecl4@ uses the `global name function' to create a new set +of default declarations in which local names have been replaced by +their original names, reporting any unknown names. + +\begin{code} +rnDefaultDecl4 :: ProtoNameDefaultDecl -> Rn4M RenamedDefaultDecl + +rnDefaultDecl4 (DefaultDecl tys src_loc) + = pushSrcLocRn4 src_loc ( + mapRn4 (rnMonoType4 False nullTyVarNamesEnv) tys `thenRn4` \ tys' -> + returnRn4 (DefaultDecl tys' src_loc) + ) +\end{code} + +%************************************************************************* +%* * +\subsection{Type signatures from interfaces} +%* * +%************************************************************************* + +Non-interface type signatures (which may include user-pragmas) are +handled with @Binds@. + +@ClassOpSigs@ are dealt with in class declarations. + +\begin{code} +rnIntSig4 :: ProtoNameSig -> Rn4M RenamedSig + +rnIntSig4 (Sig name ty pragma src_loc) + = pushSrcLocRn4 src_loc ( + lookupValue name `thenRn4` \ new_name -> + rnPolyType4 False True nullTyVarNamesEnv ty `thenRn4` \ new_ty -> + recoverQuietlyRn4 NoGenPragmas ( + rnGenPragmas4 pragma + ) `thenRn4` \ new_pragma -> + returnRn4 (Sig new_name new_ty new_pragma src_loc) + ) +\end{code} + +%************************************************************************* +%* * +\subsection{Fixity declarations} +%* * +%************************************************************************* + +\begin{code} +rnFixes4 :: [ProtoNameFixityDecl] -> Rn4M [RenamedFixityDecl] + +rnFixes4 fixities + = mapRn4 rn_fixity fixities `thenRn4` \ fixes_maybe -> + returnRn4 (catMaybes fixes_maybe) + where + rn_fixity (InfixL name i) + = lookupFixityOp name `thenRn4` \ res -> + returnRn4 ( + case res of + Just name2 -> Just (InfixL name2 i) + Nothing -> Nothing + ) + + rn_fixity (InfixR name i) + = lookupFixityOp name `thenRn4` \ res -> + returnRn4 ( + case res of + Just name2 -> Just (InfixR name2 i) + Nothing -> Nothing + ) + + rn_fixity (InfixN name i) + = lookupFixityOp name `thenRn4` \ res -> + returnRn4 ( + case res of + Just name2 -> Just (InfixN name2 i) + Nothing -> Nothing + ) +\end{code} + +%********************************************************* +%* * +\subsection{Support code to rename types} +%* * +%********************************************************* + +\begin{code} +rnPolyType4 :: Bool -- True <=> "invisible" tycons (in pragmas) allowed + -> Bool -- True <=> snaffle tyvars from ty and + -- stuff them in tyvar env; True for + -- signatures and things; False for type + -- synonym defns and things. + -> TyVarNamesEnv + -> ProtoNamePolyType + -> Rn4M RenamedPolyType + +rnPolyType4 invisibles_allowed snaffle_tyvars tv_env (UnoverloadedTy ty) + = rn_poly_help invisibles_allowed snaffle_tyvars tv_env [] ty `thenRn4` \ (_, new_ty) -> + returnRn4 (UnoverloadedTy new_ty) + +rnPolyType4 invisibles_allowed snaffle_tyvars tv_env (OverloadedTy ctxt ty) + = rn_poly_help invisibles_allowed snaffle_tyvars tv_env ctxt ty `thenRn4` \ (new_ctxt, new_ty) -> + returnRn4 (OverloadedTy new_ctxt new_ty) + +rnPolyType4 invisibles_allowed snaffle_tyvars tv_env (ForAllTy tvs ty) + = getSrcLocRn4 `thenRn4` \ src_loc -> + mkTyVarNamesEnv src_loc tvs `thenRn4` \ (tvenv2, new_tvs) -> + let + new_tvenv = catTyVarNamesEnvs tvenv2 tv_env + in + rnMonoType4 invisibles_allowed new_tvenv ty `thenRn4` \ new_ty -> + returnRn4 (ForAllTy new_tvs new_ty) + +------------ +rn_poly_help invisibles_allowed snaffle_tyvars tv_env ctxt ty + = getSrcLocRn4 `thenRn4` \ src_loc -> + let + -- ToDo: this randomly-grabbing-tyvar names out + -- of the type seems a little weird to me + -- (WDP 94/11) + + new_tyvars + = extractMonoTyNames eqProtoName ty + `minus_list` domTyVarNamesEnv tv_env + in + mkTyVarNamesEnv src_loc new_tyvars `thenRn4` \ (tv_env2, _) -> + let + tv_env3 = if snaffle_tyvars + then catTyVarNamesEnvs tv_env2 tv_env + else tv_env -- leave it alone + in + rnContext4 tv_env3 ctxt `thenRn4` \ new_ctxt -> + rnMonoType4 invisibles_allowed tv_env3 ty + `thenRn4` \ new_ty -> + returnRn4 (new_ctxt, new_ty) + where + minus_list xs ys = [ x | x <- xs, not (x `elemProtoNames` ys)] +\end{code} + +\begin{code} +rnMonoType4 :: Bool -- allowed to look at invisible tycons + -> TyVarNamesEnv + -> ProtoNameMonoType + -> Rn4M RenamedMonoType + +rnMonoType4 invisibles_allowed tv_env (MonoTyVar tyvar) + = lookupTyVarName tv_env tyvar `thenRn4` \ tyvar' -> + returnRn4 (MonoTyVar tyvar') + +rnMonoType4 invisibles_allowed tv_env (ListMonoTy ty) + = rnMonoType4 invisibles_allowed tv_env ty `thenRn4` \ ty' -> + returnRn4 (ListMonoTy ty') + +rnMonoType4 invisibles_allowed tv_env (FunMonoTy ty1 ty2) + = andRn4 FunMonoTy (rnMonoType4 invisibles_allowed tv_env ty1) + (rnMonoType4 invisibles_allowed tv_env ty2) + +rnMonoType4 invisibles_allowed tv_env (TupleMonoTy tys) + = mapRn4 (rnPolyType4 invisibles_allowed False tv_env) tys `thenRn4` \ tys' -> + returnRn4 (TupleMonoTy tys') + +rnMonoType4 invisibles_allowed tv_env (MonoTyCon name tys) + = let + lookup_fn = if invisibles_allowed + then lookupTyConEvenIfInvisible + else lookupTyCon + in + lookup_fn name `thenRn4` \ tycon_name' -> + mapRn4 (rnMonoType4 invisibles_allowed tv_env) tys `thenRn4` \ tys' -> + returnRn4 (MonoTyCon tycon_name' tys') + +-- for unfoldings only: + +rnMonoType4 invisibles_allowed tv_env (MonoTyVarTemplate name) + = --pprTrace "rnMonoType4:MonoTyVarTemplate:" (ppAbove (ppr PprDebug name) (ppr PprDebug tv_env)) ( + lookupTyVarName tv_env name `thenRn4` \ new_name -> + returnRn4 (MonoTyVarTemplate new_name) + --) + +rnMonoType4 invisibles_allowed tv_env (MonoDict clas ty) + = lookupClass clas `thenRn4` \ new_clas -> + rnMonoType4 invisibles_allowed tv_env ty `thenRn4` \ new_ty -> + returnRn4 (MonoDict new_clas new_ty) + +#ifdef DPH +rnMonoType4 invisibles_allowed tv_env (MonoTyProc tys ty) + = mapRn4 (rnMonoType4 invisibles_allowed tv_env) tys `thenRn4` \ tys' -> + rnMonoType4 invisibles_allowed tv_env ty `thenRn4` \ ty' -> + returnRn4 (MonoTyProc tys' ty') + +rnMonoType4 invisibles_allowed tv_env (MonoTyPod ty) + = rnMonoType4 invisibles_allowed tv_env ty `thenRn4` \ ty' -> + returnRn4 (MonoTyPod ty') +#endif {- Data Parallel Haskell -} +\end{code} + +\begin{code} +rnContext4 :: TyVarNamesEnv -> ProtoNameContext -> Rn4M RenamedContext + +rnContext4 tv_env ctxt + = mapRn4 rn_ctxt ctxt + where + rn_ctxt (clas, tyvar) + = lookupClass clas `thenRn4` \ clas_name -> + lookupTyVarName tv_env tyvar `thenRn4` \ tyvar_name -> + returnRn4 (clas_name, tyvar_name) +\end{code} + +%********************************************************* +%* * +\subsection{Support code to rename various pragmas} +%* * +%********************************************************* + +\begin{code} +rnDataPragmas4 tv_env (DataPragmas cons specs) + = rnConDecls4 tv_env True{-invisibles allowed-} cons `thenRn4` \ new_cons -> + mapRn4 types_n_spec specs `thenRn4` \ new_specs -> + returnRn4 (DataPragmas new_cons new_specs) + where + types_n_spec ty_maybes + = mapRn4 (rn_ty_maybe nullTyVarNamesEnv) ty_maybes +\end{code} + +\begin{code} +rnClassOpPragmas4 NoClassOpPragmas = returnRn4 NoClassOpPragmas + +rnClassOpPragmas4 (ClassOpPragmas dsel defm) + = recoverQuietlyRn4 NoGenPragmas (rnGenPragmas4 dsel) `thenRn4` \ new_dsel -> + recoverQuietlyRn4 NoGenPragmas (rnGenPragmas4 defm) `thenRn4` \ new_defm -> + returnRn4 (ClassOpPragmas new_dsel new_defm) +\end{code} + +\begin{code} +rnClassPragmas4 NoClassPragmas = returnRn4 NoClassPragmas + +rnClassPragmas4 (SuperDictPragmas sds) + = mapRn4 rnGenPragmas4 sds `thenRn4` \ new_sds -> + returnRn4 (SuperDictPragmas new_sds) +\end{code} + +NB: In various cases around here, we don't @recoverQuietlyRn4@ around +calls to @rnGenPragmas4@; not really worth it. + +\begin{code} +rnInstancePragmas4 _ _ NoInstancePragmas = returnRn4 NoInstancePragmas + +rnInstancePragmas4 _ _ (SimpleInstancePragma dfun) + = rnGenPragmas4 dfun `thenRn4` \ new_dfun -> + returnRn4 (SimpleInstancePragma new_dfun) + +rnInstancePragmas4 clas tv_env (ConstantInstancePragma dfun constms) + = recoverQuietlyRn4 NoGenPragmas ( + rnGenPragmas4 dfun + ) `thenRn4` \ new_dfun -> + mapRn4 name_n_gen constms `thenRn4` \ new_constms -> + returnRn4 (ConstantInstancePragma new_dfun new_constms) + where + name_n_gen (op, gen) + = lookupClassOp clas op `thenRn4` \ new_op -> + rnGenPragmas4 gen `thenRn4` \ new_gen -> + returnRn4 (new_op, new_gen) + +rnInstancePragmas4 clas tv_env (SpecialisedInstancePragma dfun specs) + = recoverQuietlyRn4 NoGenPragmas ( + rnGenPragmas4 dfun + ) `thenRn4` \ new_dfun -> + mapRn4 types_n_spec specs `thenRn4` \ new_specs -> + returnRn4 (SpecialisedInstancePragma new_dfun new_specs) + where + types_n_spec (ty_maybes, dicts_to_ignore, inst) + = mapRn4 (rn_ty_maybe tv_env) ty_maybes `thenRn4` \ new_tys -> + rnInstancePragmas4 clas tv_env inst `thenRn4` \ new_inst -> + returnRn4 (new_tys, dicts_to_ignore, new_inst) +\end{code} + +And some general pragma stuff: (Not sure what, if any, of this would +benefit from a TyVarNamesEnv passed in.... [ToDo]) +\begin{code} +rnGenPragmas4 NoGenPragmas = returnRn4 NoGenPragmas + +rnGenPragmas4 (GenPragmas arity upd def strict unfold specs) + = recoverQuietlyRn4 NoImpUnfolding ( + rn_unfolding unfold + ) `thenRn4` \ new_unfold -> + rn_strictness strict `thenRn4` \ new_strict -> + recoverQuietlyRn4 [] ( + mapRn4 types_n_gen specs + ) `thenRn4` \ new_specs -> + returnRn4 (GenPragmas arity upd def new_strict new_unfold new_specs) + where + rn_unfolding NoImpUnfolding = returnRn4 NoImpUnfolding + + rn_unfolding (ImpMagicUnfolding str) = returnRn4 (ImpMagicUnfolding str) + + rn_unfolding (ImpUnfolding guidance core) + = rn_core nullTyVarNamesEnv core `thenRn4` \ new_core -> + returnRn4 (ImpUnfolding guidance new_core) + + ------------ + rn_strictness NoImpStrictness = returnRn4 NoImpStrictness + + rn_strictness (ImpStrictness is_bot ww_info wrkr_info) + = recoverQuietlyRn4 NoGenPragmas ( + rnGenPragmas4 wrkr_info + ) `thenRn4` \ new_wrkr_info -> + returnRn4 (ImpStrictness is_bot ww_info new_wrkr_info) + + ------------- + types_n_gen (ty_maybes, dicts_to_ignore, gen) + = mapRn4 (rn_ty_maybe no_env) ty_maybes `thenRn4` \ new_tys -> + recoverQuietlyRn4 NoGenPragmas ( + rnGenPragmas4 gen + ) `thenRn4` \ new_gen -> + returnRn4 (new_tys, dicts_to_ignore, new_gen) + where + no_env = nullTyVarNamesEnv + +------------ +rn_ty_maybe tv_env Nothing = returnRn4 Nothing + +rn_ty_maybe tv_env (Just ty) + = rnMonoType4 True{-invisibles OK-} tv_env ty `thenRn4` \ new_ty -> + returnRn4 (Just new_ty) + +------------ +rn_core tvenv (UfCoVar v) + = rn_uf_id tvenv v `thenRn4` \ vname -> + returnRn4 (UfCoVar vname) + +rn_core tvenv (UfCoLit lit) + = returnRn4 (UfCoLit lit) + +rn_core tvenv (UfCoCon con tys as) + = lookupValueEvenIfInvisible con `thenRn4` \ new_con -> + mapRn4 (rn_core_type tvenv) tys `thenRn4` \ new_tys -> + mapRn4 (rn_atom tvenv) as `thenRn4` \ new_as -> + returnRn4 (UfCoCon new_con new_tys new_as) + +rn_core tvenv (UfCoPrim op tys as) + = rn_core_primop tvenv op `thenRn4` \ new_op -> + mapRn4 (rn_core_type tvenv) tys `thenRn4` \ new_tys -> + mapRn4 (rn_atom tvenv) as `thenRn4` \ new_as -> + returnRn4 (UfCoPrim new_op new_tys new_as) + +rn_core tvenv (UfCoLam binders body) + = mapRn4 (rn_binder tvenv) binders `thenRn4` \ new_binders -> + let + bs = [ b | (b, ty) <- new_binders ] + in + extendSS bs (rn_core tvenv body) `thenRn4` \ new_body -> + returnRn4 (UfCoLam new_binders new_body) + +rn_core tvenv (UfCoTyLam tv body) + = getSrcLocRn4 `thenRn4` \ src_loc -> + mkTyVarNamesEnv src_loc [tv] `thenRn4` \ (tvenv2, [new_tv]) -> + let + new_tvenv = catTyVarNamesEnvs tvenv2 tvenv + in + rn_core new_tvenv body `thenRn4` \ new_body -> + returnRn4 (UfCoTyLam new_tv new_body) + +rn_core tvenv (UfCoApp fun arg) + = rn_core tvenv fun `thenRn4` \ new_fun -> + rn_atom tvenv arg `thenRn4` \ new_arg -> + returnRn4 (UfCoApp new_fun new_arg) + +rn_core tvenv (UfCoTyApp expr ty) + = rn_core tvenv expr `thenRn4` \ new_expr -> + rn_core_type tvenv ty `thenRn4` \ new_ty -> + returnRn4 (UfCoTyApp new_expr new_ty) + +rn_core tvenv (UfCoCase expr alts) + = rn_core tvenv expr `thenRn4` \ new_expr -> + rn_alts alts `thenRn4` \ new_alts -> + returnRn4 (UfCoCase new_expr new_alts) + where + rn_alts (UfCoAlgAlts alg_alts deflt) + = mapRn4 rn_alg_alt alg_alts `thenRn4` \ new_alts -> + rn_deflt deflt `thenRn4` \ new_deflt -> + returnRn4 (UfCoAlgAlts new_alts new_deflt) + where + rn_alg_alt (con, params, rhs) + = lookupValueEvenIfInvisible con `thenRn4` \ new_con -> + mapRn4 (rn_binder tvenv) params `thenRn4` \ new_params -> + let + bs = [ b | (b, ty) <- new_params ] + in + extendSS bs (rn_core tvenv rhs) `thenRn4` \ new_rhs -> + returnRn4 (new_con, new_params, new_rhs) + + rn_alts (UfCoPrimAlts prim_alts deflt) + = mapRn4 rn_prim_alt prim_alts `thenRn4` \ new_alts -> + rn_deflt deflt `thenRn4` \ new_deflt -> + returnRn4 (UfCoPrimAlts new_alts new_deflt) + where + rn_prim_alt (lit, rhs) + = rn_core tvenv rhs `thenRn4` \ new_rhs -> + returnRn4 (lit, new_rhs) + + rn_deflt UfCoNoDefault = returnRn4 UfCoNoDefault + rn_deflt (UfCoBindDefault b rhs) + = rn_binder tvenv b `thenRn4` \ new_b@(binder, ty) -> + extendSS [binder] (rn_core tvenv rhs) `thenRn4` \ new_rhs -> + returnRn4 (UfCoBindDefault new_b new_rhs) + +rn_core tvenv (UfCoLet bind body) + = rn_bind bind `thenRn4` \ (new_bind, new_binders) -> + extendSS new_binders (rn_core tvenv body) `thenRn4` \ new_body -> + returnRn4 (UfCoLet new_bind new_body) + where + rn_bind (UfCoNonRec b rhs) + = rn_binder tvenv b `thenRn4` \ new_b@(binder, ty) -> + rn_core tvenv rhs `thenRn4` \ new_rhs -> + returnRn4 (UfCoNonRec new_b new_rhs, [binder]) + + rn_bind (UfCoRec pairs) + = -- conjure up Names; we do this differently than + -- elsewhere for Core, because of the recursion here; + -- no deep issue. + -- [BEFORE IT WAS "FIXED"... 94/05...] + -- [Andy -- It *was* a 'deep' issue to me...] + -- [Will -- Poor wee soul.] + + getSrcLocRn4 `thenRn4` \ locn -> + namesFromProtoNames "core variable" + [ (b, locn) | ((b,_),_) <- pairs] `thenRn4` \ binders -> + + extendSS binders (mapRn4 rn_pair (pairs `zip` binders)) `thenRn4` \ new_pairs -> + returnRn4 (UfCoRec new_pairs, binders) + where + rn_pair (((b, ty), rhs), new_b) + = rn_core_type tvenv ty `thenRn4` \ new_ty -> + rn_core tvenv rhs `thenRn4` \ new_rhs -> + returnRn4 ((new_b, new_ty), new_rhs) + +rn_core tvenv (UfCoSCC uf_cc body) + = rn_cc uf_cc `thenRn4` \ new_cc -> + rn_core tvenv body `thenRn4` \ new_body -> + returnRn4 (UfCoSCC new_cc new_body) + where + rn_cc (UfAutoCC id m g is_dupd is_caf) + = rn_uf_id tvenv id `thenRn4` \ new_id -> + returnRn4 (UfAutoCC new_id m g is_dupd is_caf) + + rn_cc (UfDictCC id m g is_caf is_dupd) + = rn_uf_id tvenv id `thenRn4` \ new_id -> + returnRn4 (UfDictCC new_id m g is_dupd is_caf) + + -- the rest are boring: + rn_cc (UfPreludeDictsCC d) = returnRn4 (UfPreludeDictsCC d) + rn_cc (UfAllDictsCC m g d) = returnRn4 (UfAllDictsCC m g d) + rn_cc (UfUserCC n m g d c) = returnRn4 (UfUserCC n m g d c) + +------------ +rn_core_primop tvenv (UfCCallOp str is_casm may_gc arg_tys res_ty) + = mapRn4 (rn_core_type tvenv) arg_tys `thenRn4` \ new_arg_tys -> + rn_core_type tvenv res_ty `thenRn4` \ new_res_ty -> + returnRn4 (UfCCallOp str is_casm may_gc new_arg_tys new_res_ty) +rn_core_primop tvenv (UfOtherOp op) + = returnRn4 (UfOtherOp op) + +------------ +rn_uf_id tvenv (BoringUfId v) + = lookupValueEvenIfInvisible v `thenRn4` \ vname -> + returnRn4 (BoringUfId vname) + +rn_uf_id tvenv (SuperDictSelUfId c sc) + = lookupClass{-EvenIfInvisible-} c `thenRn4` \ new_c -> + lookupClass{-EvenIfInvisible-} sc `thenRn4` \ new_sc -> + returnRn4 (SuperDictSelUfId new_c new_sc) + +rn_uf_id tvenv (ClassOpUfId c op) + = lookupClass{-EvenIfInvisible-} c `thenRn4` \ new_c -> + lookupClassOp{-EvenIfInvisible-} new_c op `thenRn4` \ new_op -> + returnRn4 (ClassOpUfId new_c new_op) + +rn_uf_id tvenv (DictFunUfId c ty) + = lookupClass{-EvenIfInvisible-} c `thenRn4` \ new_c -> + rn_core_type tvenv ty `thenRn4` \ new_ty -> + returnRn4 (DictFunUfId new_c new_ty) + +rn_uf_id tvenv (ConstMethodUfId c op ty) + = lookupClass{-EvenIfInvisible-} c `thenRn4` \ new_c -> + lookupClassOp{-EvenIfInvisible-} new_c op `thenRn4` \ new_op -> + rn_core_type tvenv ty `thenRn4` \ new_ty -> + returnRn4 (ConstMethodUfId new_c new_op new_ty) + +rn_uf_id tvenv (DefaultMethodUfId c op) + = lookupClass{-EvenIfInvisible-} c `thenRn4` \ new_c -> + lookupClassOp{-EvenIfInvisible-} new_c op `thenRn4` \ new_op -> + returnRn4 (DefaultMethodUfId new_c new_op) + +rn_uf_id tvenv (SpecUfId unspec ty_maybes) + = rn_uf_id tvenv unspec `thenRn4` \ new_unspec -> + mapRn4 (rn_ty_maybe tvenv) ty_maybes `thenRn4` \ new_ty_maybes -> + returnRn4 (SpecUfId new_unspec new_ty_maybes) + +rn_uf_id tvenv (WorkerUfId unwrkr) + = rn_uf_id tvenv unwrkr `thenRn4` \ new_unwrkr -> + returnRn4 (WorkerUfId new_unwrkr) + +------------ +rn_binder tvenv (b, ty) + = getSrcLocRn4 `thenRn4` \ src_loc -> + namesFromProtoNames "binder in core unfolding" [(b, src_loc)] + `thenRn4` \ [new_b] -> + rn_core_type tvenv ty `thenRn4` \ new_ty -> + returnRn4 (new_b, new_ty) + +------------ +rn_atom tvenv (UfCoLitAtom l) = returnRn4 (UfCoLitAtom l) +rn_atom tvenv (UfCoVarAtom v) + = rn_uf_id tvenv v `thenRn4` \ vname -> + returnRn4 (UfCoVarAtom vname) + +------------ +rn_core_type_maybe tvenv Nothing = returnRn4 Nothing +rn_core_type_maybe tvenv (Just ty) + = rn_core_type tvenv ty `thenRn4` \ new_ty -> + returnRn4 (Just new_ty) + +------------ +rn_core_type tvenv ty + = rnPolyType4 True{-invisible tycons OK-} False tvenv ty +\end{code} |