%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
-\section[Rename4]{Fourth of the renaming passes}
+\section[RnPass4]{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, maybeToBool, Maybe(..) )
-import ProtoName ( eqProtoName, elemProtoNames )
-import RenameBinds4 ( rnTopBinds4, rnMethodBinds4 )
-import RenameMonad4
-import Util
+module RnPass4 ( rnModule, rnPolyType, rnGenPragmas ) where
+
+import Ubiq{-uitous-}
+import RnLoop -- *check* the RnPass4/RnExpr4/RnBinds4 loop-breaking
+
+import HsSyn
+import RdrHsSyn
+import RnHsSyn
+import HsPragmas -- all of it
+import HsCore -- all of it
+import RnMonad4
+
+import Class ( derivableClassKeys )
+import Maybes ( maybeToBool, catMaybes )
+import Name ( Name(..) )
+import Outputable ( Outputable(..), isAvarid )
+import Pretty ( ppHang, ppStr, ppCat, ppAboves )
+import ProtoName ( eqProtoName, elemProtoNames, ProtoName{-instance-} )
+import RnBinds4 ( rnTopBinds, rnMethodBinds )
+import SrcLoc ( SrcLoc{-instance-} )
+import Unique ( Unique{-instances-} )
+import UniqSet ( UniqSet(..) )
+import Util ( isIn, panic, assertPanic )
\end{code}
This pass `renames' the module+imported info, simultaneously
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.
+Checks that local variables are defined.
\end{enumerate}
\begin{code}
-rnModule4 :: ProtoNameModule -> Rn4M RenamedModule
+rnModule :: ProtoNameHsModule -> Rn4M RenamedHsModule
-rnModule4 (Module mod_name exports _ fixes ty_decls absty_sigs
+rnModule (HsModule mod_name exports _ fixes ty_decls specdata_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
+ mapRn4 rnTyDecl ty_decls `thenRn4` \ new_ty_decls ->
+ mapRn4 rnSpecDataSig specdata_sigs `thenRn4` \ new_specdata_sigs ->
+ mapRn4 rnClassDecl class_decls `thenRn4` \ new_class_decls ->
+ mapRn4 rnInstDecl inst_decls `thenRn4` \ new_inst_decls ->
+ mapRn4 rnSpecInstSig specinst_sigs `thenRn4` \ new_specinst_sigs ->
+ rnDefaultDecl defaults `thenRn4` \ new_defaults ->
+ rnTopBinds binds `thenRn4` \ new_binds ->
+ mapRn4 rnIntSig int_sigs `thenRn4` \ new_int_sigs ->
+ rnFixes fixes `thenRn4` \ new_fixes ->
+ rnExports exports `thenRn4` \ new_exports ->
+
+ returnRn4 (HsModule mod_name
+ new_exports [{-imports finally clobbered-}] new_fixes
+ new_ty_decls new_specdata_sigs new_class_decls
new_inst_decls new_specinst_sigs new_defaults
new_binds new_int_sigs src_loc)
)
-\end{code}
+rnExports Nothing = returnRn4 Nothing
+rnExports (Just exp_list)
+ = returnRn4 (Just (_trace "rnExports:trashing exports" []))
+\end{code}
%*********************************************************
%* *
%* *
%*********************************************************
-@rnTyDecl4@ uses the `global name function' to create a new type
+@rnTyDecl@ 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.
checks at the same time.
\begin{code}
-rnTyDecl4 :: ProtoNameTyDecl -> Rn4M RenamedTyDecl
+rnTyDecl :: ProtoNameTyDecl -> Rn4M RenamedTyDecl
-rnTyDecl4 (TyData context tycon tyvars condecls derivings pragmas src_loc)
+rnTyDecl (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' ->
+ rnContext tv_env context `thenRn4` \ context' ->
+ rnConDecls tv_env False condecls `thenRn4` \ condecls' ->
+ rn_derivs tycon' src_loc derivings `thenRn4` \ derivings' ->
recoverQuietlyRn4 (DataPragmas [] []) (
- rnDataPragmas4 tv_env pragmas
+ rnDataPragmas 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)
+rnTyDecl (TyNew context tycon tyvars condecl derivings pragmas src_loc)
+ = pushSrcLocRn4 src_loc (
+ lookupTyCon tycon `thenRn4` \ tycon' ->
+ mkTyVarNamesEnv src_loc tyvars `thenRn4` \ (tv_env, tyvars') ->
+ rnContext tv_env context `thenRn4` \ context' ->
+ rnConDecls tv_env False condecl `thenRn4` \ condecl' ->
+ rn_derivs tycon' src_loc derivings `thenRn4` \ derivings' ->
+ recoverQuietlyRn4 (DataPragmas [] []) (
+ rnDataPragmas tv_env pragmas
+ ) `thenRn4` \ pragmas' ->
+ returnRn4 (TyNew context' tycon' tyvars' condecl' derivings' pragmas' src_loc)
+ )
+
+rnTyDecl (TySynonym name tyvars ty 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
+ rnMonoType False{-no invisible types-} tv_env ty
`thenRn4` \ ty' ->
- returnRn4 (TySynonym name' tyvars' ty' pragmas src_loc)
+ returnRn4 (TySynonym name' tyvars' ty' src_loc)
)
+
+rn_derivs tycon2 locn Nothing -- derivs not specified
+ = returnRn4 Nothing
+
+rn_derivs tycon2 locn (Just ds)
+ = mapRn4 (rn_deriv tycon2 locn) ds `thenRn4` \ derivs ->
+ returnRn4 (Just derivs)
+ where
+ rn_deriv tycon2 locn clas
+ = lookupClass clas `thenRn4` \ clas_name ->
+ case clas_name of
+ ClassName key _ _ | key `is_elem` derivableClassKeys
+ -> returnRn4 clas_name
+ _ -> addErrRn4 (derivingNonStdClassErr clas locn) `thenRn4_`
+ returnRn4 clas_name
+ where
+ is_elem = isIn "rn_deriv"
\end{code}
-@rnConDecls4@ uses the `global name function' to create a new
+@rnConDecls@ 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
+rnConDecls :: TyVarNamesEnv
-> Bool -- True <=> allowed to see invisible data-cons
-> [ProtoNameConDecl]
-> Rn4M [RenamedConDecl]
-rnConDecls4 tv_env invisibles_allowed con_decls
+rnConDecls tv_env invisibles_allowed con_decls
= mapRn4 rn_decl con_decls
where
lookup_fn
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 ->
-
+ lookup_fn name `thenRn4` \ new_name ->
+ mapRn4 rn_bang_ty tys `thenRn4` \ new_tys ->
returnRn4 (ConDecl new_name new_tys src_loc)
)
+
+ rn_decl (ConOpDecl ty1 op ty2 src_loc)
+ = pushSrcLocRn4 src_loc (
+ lookup_fn op `thenRn4` \ new_op ->
+ rn_bang_ty ty1 `thenRn4` \ new_ty1 ->
+ rn_bang_ty ty2 `thenRn4` \ new_ty2 ->
+ returnRn4 (ConOpDecl new_ty1 new_op new_ty2 src_loc)
+ )
+
+ rn_decl (NewConDecl name ty src_loc)
+ = pushSrcLocRn4 src_loc (
+ lookup_fn name `thenRn4` \ new_name ->
+ rn_mono_ty ty `thenRn4` \ new_ty ->
+ returnRn4 (NewConDecl new_name new_ty src_loc)
+ )
+
+ rn_decl (RecConDecl con fields src_loc)
+ = panic "rnConDecls:RecConDecl"
+
+ ----------
+ rn_mono_ty = rnMonoType invisibles_allowed tv_env
+
+ rn_bang_ty (Banged ty)
+ = rn_mono_ty ty `thenRn4` \ new_ty ->
+ returnRn4 (Banged new_ty)
+ rn_bang_ty (Unbanged ty)
+ = rn_mono_ty ty `thenRn4` \ new_ty ->
+ returnRn4 (Unbanged new_ty)
\end{code}
%*********************************************************
%* *
-\subsection{ABSTRACT type-synonym pragmas}
+\subsection{SPECIALIZE data pragmas}
%* *
%*********************************************************
\begin{code}
-rnTySig4 :: ProtoNameDataTypeSig
- -> Rn4M RenamedDataTypeSig
-
-rnTySig4 (AbstractTypeSig tycon src_loc)
- = pushSrcLocRn4 src_loc (
- lookupTyCon tycon `thenRn4` \ tycon' ->
- returnRn4 (AbstractTypeSig tycon' src_loc)
- )
+rnSpecDataSig :: ProtoNameSpecDataSig
+ -> Rn4M RenamedSpecDataSig
-rnTySig4 (SpecDataSig tycon ty src_loc)
+rnSpecDataSig (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' ->
+ rnMonoType False tv_env ty `thenRn4` \ ty' ->
returnRn4 (SpecDataSig tycon' ty' src_loc)
)
\end{code}
%* *
%*********************************************************
-@rnClassDecl4@ uses the `global name function' to create a new
+@rnClassDecl@ 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
+rnClassDecl :: ProtoNameClassDecl -> Rn4M RenamedClassDecl
-rnClassDecl4 (ClassDecl context cname tyvar sigs mbinds pragmas src_loc)
+rnClassDecl (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' ->
+ rnContext tv_env context `thenRn4` \ context' ->
lookupClass cname `thenRn4` \ cname' ->
mapRn4 (rn_op cname' tv_env) sigs `thenRn4` \ sigs' ->
- rnMethodBinds4 cname' mbinds `thenRn4` \ mbinds' ->
+ rnMethodBinds cname' mbinds `thenRn4` \ mbinds' ->
recoverQuietlyRn4 NoClassPragmas (
- rnClassPragmas4 pragmas
+ rnClassPragmas 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 ->
+ lookupClassOp clas op `thenRn4` \ op_name ->
+ rnPolyType False tv_env ty `thenRn4` \ new_ty ->
+
+{-
+*** Please check here that tyvar' appears in new_ty ***
+*** (used to be in tcClassSig, but it's better here)
+*** not_elem = isn'tIn "tcClassSigs"
+*** -- Check that the class type variable is mentioned
+*** checkTc (clas_tyvar `not_elem` extractTyVarTemplatesFromTy local_ty)
+*** (methodTypeLacksTyVarErr clas_tyvar (_UNPK_ op_name) src_loc) `thenTc_`
+-}
recoverQuietlyRn4 NoClassOpPragmas (
- rnClassOpPragmas4 pragma
- ) `thenRn4` \ new_pragma ->
+ rnClassOpPragmas pragma
+ ) `thenRn4` \ new_pragma ->
returnRn4 (ClassOpSig op_name new_ty new_pragma locn)
)
\end{code}
%*********************************************************
-@rnInstDecl4@ uses the `global name function' to create a new of
+@rnInstDecl@ 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
+rnInstDecl :: ProtoNameInstDecl -> Rn4M RenamedInstDecl
-rnInstDecl4 (InstDecl context cname ty mbinds from_here modname imod uprags pragmas src_loc)
+rnInstDecl (InstDecl cname ty mbinds from_here modname uprags pragmas src_loc)
= pushSrcLocRn4 src_loc (
- let tyvars = extractMonoTyNames eqProtoName ty in
+ let
+ tyvars = extract_poly_ty_names 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
+ rnPolyType False{-no invisibles-} tv_env ty
`thenRn4` \ ty' ->
- rnMethodBinds4 cname' mbinds `thenRn4` \ mbinds' ->
+ rnMethodBinds cname' mbinds `thenRn4` \ mbinds' ->
mapRn4 (rn_uprag cname') uprags `thenRn4` \ new_uprags ->
recoverQuietlyRn4 NoInstancePragmas (
- rnInstancePragmas4 cname' tv_env pragmas
+ rnInstancePragmas cname' tv_env pragmas
) `thenRn4` \ new_pragmas ->
- returnRn4 (InstDecl context' cname' ty' mbinds'
- from_here modname imod new_uprags new_pragmas src_loc)
+ returnRn4 (InstDecl cname' ty' mbinds'
+ from_here modname new_uprags new_pragmas src_loc)
)
where
rn_uprag class_name (SpecSig op ty using locn)
= ASSERT(not (maybeToBool using)) -- ToDo: SPEC method with explicit spec_id
pushSrcLocRn4 src_loc (
- lookupClassOp class_name op `thenRn4` \ op_name ->
- rnPolyType4 False True nullTyVarNamesEnv ty `thenRn4` \ new_ty ->
+ lookupClassOp class_name op `thenRn4` \ op_name ->
+ rnPolyType False nullTyVarNamesEnv ty `thenRn4` \ new_ty ->
returnRn4 (SpecSig op_name new_ty Nothing locn)
)
- rn_uprag class_name (InlineSig op guide locn)
+ rn_uprag class_name (InlineSig op locn)
= pushSrcLocRn4 locn (
lookupClassOp class_name op `thenRn4` \ op_name ->
- returnRn4 (InlineSig op_name guide locn)
+ returnRn4 (InlineSig op_name locn)
)
rn_uprag class_name (DeforestSig op locn)
= pushSrcLocRn4 locn (
%*********************************************************
\begin{code}
-rnInstSpecSig4 :: ProtoNameSpecialisedInstanceSig
- -> Rn4M RenamedSpecialisedInstanceSig
+rnSpecInstSig :: ProtoNameSpecInstSig
+ -> Rn4M RenamedSpecInstSig
-rnInstSpecSig4 (InstSpecSig clas ty src_loc)
+rnSpecInstSig (SpecInstSig 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)
+ rnMonoType False tv_env ty `thenRn4` \ new_ty ->
+ returnRn4 (SpecInstSig new_clas new_ty src_loc)
)
\end{code}
%* *
%*********************************************************
-@rnDefaultDecl4@ uses the `global name function' to create a new set
+@rnDefaultDecl@ 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)
- )
+rnDefaultDecl :: [ProtoNameDefaultDecl] -> Rn4M [RenamedDefaultDecl]
+
+rnDefaultDecl [] = returnRn4 []
+rnDefaultDecl [DefaultDecl tys src_loc]
+ = pushSrcLocRn4 src_loc $
+ mapRn4 (rnMonoType False nullTyVarNamesEnv) tys `thenRn4` \ tys' ->
+ returnRn4 [DefaultDecl tys' src_loc]
+rnDefaultDecl defs@(d:ds)
+ = addErrRn4 (dupDefaultDeclErr defs) `thenRn4_`
+ rnDefaultDecl [d]
\end{code}
%*************************************************************************
%*************************************************************************
Non-interface type signatures (which may include user-pragmas) are
-handled with @Binds@.
+handled with @HsBinds@.
@ClassOpSigs@ are dealt with in class declarations.
\begin{code}
-rnIntSig4 :: ProtoNameSig -> Rn4M RenamedSig
+rnIntSig :: ProtoNameSig -> Rn4M RenamedSig
-rnIntSig4 (Sig name ty pragma src_loc)
+rnIntSig (Sig name ty pragma src_loc)
= pushSrcLocRn4 src_loc (
lookupValue name `thenRn4` \ new_name ->
- rnPolyType4 False True nullTyVarNamesEnv ty `thenRn4` \ new_ty ->
+ rnPolyType False nullTyVarNamesEnv ty `thenRn4` \ new_ty ->
recoverQuietlyRn4 NoGenPragmas (
- rnGenPragmas4 pragma
+ rnGenPragmas pragma
) `thenRn4` \ new_pragma ->
returnRn4 (Sig new_name new_ty new_pragma src_loc)
)
%*************************************************************************
\begin{code}
-rnFixes4 :: [ProtoNameFixityDecl] -> Rn4M [RenamedFixityDecl]
+rnFixes :: [ProtoNameFixityDecl] -> Rn4M [RenamedFixityDecl]
-rnFixes4 fixities
+rnFixes fixities
= mapRn4 rn_fixity fixities `thenRn4` \ fixes_maybe ->
returnRn4 (catMaybes fixes_maybe)
where
%*********************************************************
\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.
+rnPolyType :: Bool -- True <=> "invisible" tycons (in pragmas) allowed
-> 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)
+rnPolyType invisibles_allowed tv_env (HsForAllTy tvs ctxt ty)
+ = rn_poly_help invisibles_allowed tv_env tvs ctxt 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)
+rnPolyType invisibles_allowed tv_env poly_ty@(HsPreForAllTy ctxt ty)
+ = rn_poly_help invisibles_allowed tv_env forall_tyvars ctxt ty
+ where
+ mentioned_tyvars = extract_poly_ty_names poly_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)
+ forall_tyvars = mentioned_tyvars `minus_list` domTyVarNamesEnv tv_env
+
+ -- URGH! Why is this here? SLPJ
+ -- Because we are doing very delicate comparisons
+ -- (eqProtoName and all that); if we got rid of
+ -- that, then we could use ListSetOps stuff. WDP
+ minus_list xs ys = [ x | x <- xs, not (x `elemProtoNames` ys)]
------------
-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)
+extract_poly_ty_names (HsPreForAllTy ctxt ty)
+ = extractCtxtTyNames eqProtoName ctxt
+ `union_list`
+ extractMonoTyNames eqProtoName ty
+ where
+ -- see comment above
+ union_list [] [] = []
+ union_list [] b = b
+ union_list a [] = a
+ union_list (a:as) b
+ | a `elemProtoNames` b = union_list as b
+ | otherwise = a : union_list as b
- new_tyvars
- = extractMonoTyNames eqProtoName ty
- `minus_list` domTyVarNamesEnv tv_env
- in
- mkTyVarNamesEnv src_loc new_tyvars `thenRn4` \ (tv_env2, _) ->
+------------
+rn_poly_help :: Bool
+ -> TyVarNamesEnv
+ -> [ProtoName]
+ -> ProtoNameContext
+ -> ProtoNameMonoType
+ -> Rn4M RenamedPolyType
+
+rn_poly_help invisibles_allowed tv_env tyvars ctxt ty
+ = getSrcLocRn4 `thenRn4` \ src_loc ->
+ mkTyVarNamesEnv src_loc tyvars `thenRn4` \ (tv_env1, new_tyvars) ->
let
- tv_env3 = if snaffle_tyvars
- then catTyVarNamesEnvs tv_env2 tv_env
- else tv_env -- leave it alone
+ tv_env2 = catTyVarNamesEnvs tv_env1 tv_env
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)]
+ rnContext tv_env2 ctxt `thenRn4` \ new_ctxt ->
+ rnMonoType invisibles_allowed tv_env2 ty `thenRn4` \ new_ty ->
+ returnRn4 (HsForAllTy new_tyvars new_ctxt new_ty)
\end{code}
\begin{code}
-rnMonoType4 :: Bool -- allowed to look at invisible tycons
+rnMonoType :: Bool -- allowed to look at invisible tycons
-> TyVarNamesEnv
-> ProtoNameMonoType
-> Rn4M RenamedMonoType
-rnMonoType4 invisibles_allowed tv_env (MonoTyVar tyvar)
+rnMonoType 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')
+rnMonoType invisibles_allowed tv_env (MonoListTy ty)
+ = rnMonoType invisibles_allowed tv_env ty `thenRn4` \ ty' ->
+ returnRn4 (MonoListTy ty')
-rnMonoType4 invisibles_allowed tv_env (FunMonoTy ty1 ty2)
- = andRn4 FunMonoTy (rnMonoType4 invisibles_allowed tv_env ty1)
- (rnMonoType4 invisibles_allowed tv_env ty2)
+rnMonoType invisibles_allowed tv_env (MonoFunTy ty1 ty2)
+ = andRn4 MonoFunTy (rnMonoType invisibles_allowed tv_env ty1)
+ (rnMonoType 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')
+rnMonoType invisibles_allowed tv_env (MonoTupleTy tys)
+ = mapRn4 (rnMonoType invisibles_allowed tv_env) tys `thenRn4` \ tys' ->
+ returnRn4 (MonoTupleTy tys')
-rnMonoType4 invisibles_allowed tv_env (MonoTyCon name tys)
+rnMonoType invisibles_allowed tv_env (MonoTyApp name tys)
= let
- lookup_fn = if invisibles_allowed
- then lookupTyConEvenIfInvisible
- else lookupTyCon
+ lookup_fn = if isAvarid (getOccurrenceName name)
+ then lookupTyVarName tv_env
+ else 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')
+ lookup_fn name `thenRn4` \ name' ->
+ mapRn4 (rnMonoType invisibles_allowed tv_env) tys `thenRn4` \ tys' ->
+ returnRn4 (MonoTyApp 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)
- --)
+rnMonoType invisibles_allowed tv_env (MonoForAllTy tyvars_w_kinds ty)
+ = getSrcLocRn4 `thenRn4` \ src_loc ->
+ mkTyVarNamesEnv src_loc tyvars `thenRn4` \ (tv_env1, new_tyvars) ->
+ let
+ tv_env2 = catTyVarNamesEnvs tv_env1 tv_env
+ in
+ rnMonoType invisibles_allowed tv_env2 ty `thenRn4` \ ty' ->
+ returnRn4 (MonoForAllTy (new_tyvars `zip` kinds) ty')
+ where
+ (tyvars, kinds) = unzip tyvars_w_kinds
-rnMonoType4 invisibles_allowed tv_env (MonoDict clas ty)
+rnMonoType invisibles_allowed tv_env (MonoDictTy 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 -}
+ rnMonoType invisibles_allowed tv_env ty `thenRn4` \ new_ty ->
+ returnRn4 (MonoDictTy new_clas new_ty)
\end{code}
\begin{code}
-rnContext4 :: TyVarNamesEnv -> ProtoNameContext -> Rn4M RenamedContext
+rnContext :: TyVarNamesEnv -> ProtoNameContext -> Rn4M RenamedContext
-rnContext4 tv_env ctxt
+rnContext tv_env ctxt
= mapRn4 rn_ctxt ctxt
where
rn_ctxt (clas, tyvar)
%*********************************************************
\begin{code}
-rnDataPragmas4 tv_env (DataPragmas cons specs)
- = rnConDecls4 tv_env True{-invisibles allowed-} cons `thenRn4` \ new_cons ->
+rnDataPragmas tv_env (DataPragmas cons specs)
+ = rnConDecls tv_env True{-invisibles allowed-} cons `thenRn4` \ new_cons ->
mapRn4 types_n_spec specs `thenRn4` \ new_specs ->
returnRn4 (DataPragmas new_cons new_specs)
where
\end{code}
\begin{code}
-rnClassOpPragmas4 NoClassOpPragmas = returnRn4 NoClassOpPragmas
+rnClassOpPragmas NoClassOpPragmas = returnRn4 NoClassOpPragmas
-rnClassOpPragmas4 (ClassOpPragmas dsel defm)
- = recoverQuietlyRn4 NoGenPragmas (rnGenPragmas4 dsel) `thenRn4` \ new_dsel ->
- recoverQuietlyRn4 NoGenPragmas (rnGenPragmas4 defm) `thenRn4` \ new_defm ->
+rnClassOpPragmas (ClassOpPragmas dsel defm)
+ = recoverQuietlyRn4 NoGenPragmas (rnGenPragmas dsel) `thenRn4` \ new_dsel ->
+ recoverQuietlyRn4 NoGenPragmas (rnGenPragmas defm) `thenRn4` \ new_defm ->
returnRn4 (ClassOpPragmas new_dsel new_defm)
\end{code}
\begin{code}
-rnClassPragmas4 NoClassPragmas = returnRn4 NoClassPragmas
+rnClassPragmas NoClassPragmas = returnRn4 NoClassPragmas
-rnClassPragmas4 (SuperDictPragmas sds)
- = mapRn4 rnGenPragmas4 sds `thenRn4` \ new_sds ->
+rnClassPragmas (SuperDictPragmas sds)
+ = mapRn4 rnGenPragmas 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.
+calls to @rnGenPragmas@; not really worth it.
\begin{code}
-rnInstancePragmas4 _ _ NoInstancePragmas = returnRn4 NoInstancePragmas
+rnInstancePragmas _ _ NoInstancePragmas = returnRn4 NoInstancePragmas
-rnInstancePragmas4 _ _ (SimpleInstancePragma dfun)
- = rnGenPragmas4 dfun `thenRn4` \ new_dfun ->
+rnInstancePragmas _ _ (SimpleInstancePragma dfun)
+ = rnGenPragmas dfun `thenRn4` \ new_dfun ->
returnRn4 (SimpleInstancePragma new_dfun)
-rnInstancePragmas4 clas tv_env (ConstantInstancePragma dfun constms)
+rnInstancePragmas clas tv_env (ConstantInstancePragma dfun constms)
= recoverQuietlyRn4 NoGenPragmas (
- rnGenPragmas4 dfun
+ rnGenPragmas 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 ->
+ rnGenPragmas gen `thenRn4` \ new_gen ->
returnRn4 (new_op, new_gen)
-rnInstancePragmas4 clas tv_env (SpecialisedInstancePragma dfun specs)
+rnInstancePragmas clas tv_env (SpecialisedInstancePragma dfun specs)
= recoverQuietlyRn4 NoGenPragmas (
- rnGenPragmas4 dfun
+ rnGenPragmas 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 ->
+ rnInstancePragmas 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
+rnGenPragmas :: ProtoNameGenPragmas -> Rn4M RenamedGenPragmas
-rnGenPragmas4 (GenPragmas arity upd def strict unfold specs)
+rnGenPragmas NoGenPragmas = returnRn4 NoGenPragmas
+
+rnGenPragmas (GenPragmas arity upd def strict unfold specs)
= recoverQuietlyRn4 NoImpUnfolding (
rn_unfolding unfold
) `thenRn4` \ new_unfold ->
rn_strictness (ImpStrictness is_bot ww_info wrkr_info)
= recoverQuietlyRn4 NoGenPragmas (
- rnGenPragmas4 wrkr_info
+ rnGenPragmas 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
+ rnGenPragmas gen
) `thenRn4` \ new_gen ->
returnRn4 (new_tys, dicts_to_ignore, new_gen)
where
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 ->
+ = rnMonoType True{-invisibles OK-} tv_env ty `thenRn4` \ new_ty ->
returnRn4 (Just new_ty)
------------
-rn_core tvenv (UfCoVar v)
+rn_core tvenv (UfVar v)
= rn_uf_id tvenv v `thenRn4` \ vname ->
- returnRn4 (UfCoVar vname)
+ returnRn4 (UfVar vname)
-rn_core tvenv (UfCoLit lit)
- = returnRn4 (UfCoLit lit)
+rn_core tvenv (UfLit lit)
+ = returnRn4 (UfLit lit)
-rn_core tvenv (UfCoCon con tys as)
+rn_core tvenv (UfCon 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)
+ returnRn4 (UfCon new_con new_tys new_as)
-rn_core tvenv (UfCoPrim op tys as)
+rn_core tvenv (UfPrim 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)
+ returnRn4 (UfPrim 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 (UfLam binder body)
+ = rn_binder tvenv binder `thenRn4` \ (b,ty) ->
+ extendSS [b] (rn_core tvenv body) `thenRn4` \ new_body ->
+ returnRn4 (UfLam (b,ty) 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 (UfApp 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)
+ returnRn4 (UfApp new_fun new_arg)
-rn_core tvenv (UfCoCase expr alts)
+rn_core tvenv (UfCase expr alts)
= rn_core tvenv expr `thenRn4` \ new_expr ->
rn_alts alts `thenRn4` \ new_alts ->
- returnRn4 (UfCoCase new_expr new_alts)
+ returnRn4 (UfCase 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 ->
+ rn_deflt deflt `thenRn4` \ new_deflt ->
returnRn4 (UfCoAlgAlts new_alts new_deflt)
where
- rn_alg_alt (con, params, rhs)
+ rn_alg_alt (con, params, rhs)
= lookupValueEvenIfInvisible con `thenRn4` \ new_con ->
mapRn4 (rn_binder tvenv) params `thenRn4` \ new_params ->
let
rn_alts (UfCoPrimAlts prim_alts deflt)
= mapRn4 rn_prim_alt prim_alts `thenRn4` \ new_alts ->
- rn_deflt deflt `thenRn4` \ new_deflt ->
+ rn_deflt deflt `thenRn4` \ new_deflt ->
returnRn4 (UfCoPrimAlts new_alts new_deflt)
where
- rn_prim_alt (lit, rhs)
+ rn_prim_alt (lit, rhs)
= rn_core tvenv rhs `thenRn4` \ new_rhs ->
returnRn4 (lit, new_rhs)
extendSS [binder] (rn_core tvenv rhs) `thenRn4` \ new_rhs ->
returnRn4 (UfCoBindDefault new_b new_rhs)
-rn_core tvenv (UfCoLet bind body)
+rn_core tvenv (UfLet 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)
+ returnRn4 (UfLet 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 ->
+ rn_core tvenv rhs `thenRn4` \ new_rhs ->
returnRn4 (UfCoNonRec new_b new_rhs, [binder])
rn_bind (UfCoRec pairs)
rn_core tvenv rhs `thenRn4` \ new_rhs ->
returnRn4 ((new_b, new_ty), new_rhs)
-rn_core tvenv (UfCoSCC uf_cc body)
+rn_core tvenv (UfSCC uf_cc body)
= rn_cc uf_cc `thenRn4` \ new_cc ->
rn_core tvenv body `thenRn4` \ new_body ->
- returnRn4 (UfCoSCC new_cc new_body)
+ returnRn4 (UfSCC new_cc new_body)
where
rn_cc (UfAutoCC id m g is_dupd is_caf)
= rn_uf_id tvenv id `thenRn4` \ new_id ->
------------
rn_core_type tvenv ty
- = rnPolyType4 True{-invisible tycons OK-} False tvenv ty
+ = rnPolyType True{-invisible tycons OK-} tvenv ty
+\end{code}
+
+
+\begin{code}
+derivingNonStdClassErr clas locn sty
+ = ppHang (ppStr "Non-standard class in deriving")
+ 4 (ppCat [ppr sty clas, ppr sty locn])
+
+dupDefaultDeclErr defs sty
+ = ppHang (ppStr "Duplicate default declarations")
+ 4 (ppAboves (map pp_def_loc defs))
+ where
+ pp_def_loc (DefaultDecl _ src_loc) = ppr sty src_loc
\end{code}
projects / ghc-hetmet.git / blobdiff