Commit 61fae1d3 authored by simonpj's avatar simonpj
Browse files

[project @ 2001-12-06 10:45:42 by simonpj]

--------------------------
	Fix the instance-decl wart
	--------------------------

This commit implements the (proposed) H98 rule for
resolving the class-method name in an instance decl.

	module M( C( op1, op2 ) ) where
		-- NB: op3 not exported
	  class C a where
	    op1, op2, op3 :: a -> a


	module N where
	  import qualified M as P( C )
	  import qualified M as Q hiding( op2 )

	  instance P.C Int where
	    op1 x = x
	    -- op2, op3 both illegal here

The point is that
  a) only methods that can be named are legal
     in the instance decl
	(so op2, op3 are not legal)
  b) but it doesn't matter *how* they can be named
	(in this case Q.op1 is in scope, though
	the class is called P.C)

The AvailEnv carries the information about what's in scope,
so we now have to carry it around in the monad, so that
instance decl bindings can see it.  Quite simple really.

Same deal for export lists. E.g.

	module N( P.C( op1 ) ) where
	  import qualified M as P( C )
	  import qualified M as Q hiding( op2 )

Actually this is what GHC has always implemented!
parent 94cf74b8
...@@ -11,10 +11,11 @@ module HsTypes ( ...@@ -11,10 +11,11 @@ module HsTypes (
, hsUsOnce, hsUsMany , hsUsOnce, hsUsMany
, mkHsForAllTy, mkHsDictTy, mkHsIParamTy , mkHsForAllTy, mkHsDictTy, mkHsIParamTy
, hsTyVarName, hsTyVarNames, replaceTyVarName, , hsTyVarName, hsTyVarNames, replaceTyVarName
, getHsInstHead
-- Type place holder -- Type place holder
PostTcType, placeHolderType, , PostTcType, placeHolderType,
-- Printing -- Printing
, pprParendHsType, pprHsForAll, pprHsContext, pprHsTyVarBndr , pprParendHsType, pprHsForAll, pprHsContext, pprHsTyVarBndr
...@@ -172,6 +173,27 @@ replaceTyVarName (IfaceTyVar n k) n' = IfaceTyVar n' k ...@@ -172,6 +173,27 @@ replaceTyVarName (IfaceTyVar n k) n' = IfaceTyVar n' k
\end{code} \end{code}
\begin{code}
getHsInstHead :: HsType name -> ([HsTyVarBndr name], (name, [HsType name]))
-- Split up an instance decl type, returning the 'head' part
-- In interface fiels, the type of the decl is held like this:
-- forall a. Foo a -> Baz (T a)
-- so we have to strip off function argument types,
-- as well as the bit before the '=>' (which is always
-- empty in interface files)
--
-- The parser ensures the type will have the right shape.
-- (e.g. see ParseUtil.checkInstType)
getHsInstHead (HsForAllTy (Just tvs) _ tau) = (tvs, get_head1 tau)
getHsInstHead tau = ([], get_head1 tau)
get_head1 (HsFunTy _ ty) = get_head1 ty
get_head1 (HsPredTy (HsClassP cls tys)) = (cls,tys)
\end{code}
%************************************************************************ %************************************************************************
%* * %* *
\subsection{Pretty printing} \subsection{Pretty printing}
......
...@@ -32,7 +32,8 @@ module HscTypes ( ...@@ -32,7 +32,8 @@ module HscTypes (
PersistentRenamerState(..), IsBootInterface, DeclsMap, PersistentRenamerState(..), IsBootInterface, DeclsMap,
IfaceInsts, IfaceRules, GatedDecl, GatedDecls, GateFn, IsExported, IfaceInsts, IfaceRules, GatedDecl, GatedDecls, GateFn, IsExported,
NameSupply(..), OrigNameCache, OrigIParamCache, NameSupply(..), OrigNameCache, OrigIParamCache,
Avails, AvailEnv, GenAvailInfo(..), AvailInfo, RdrAvailInfo, Avails, AvailEnv, emptyAvailEnv,
GenAvailInfo(..), AvailInfo, RdrAvailInfo,
PersistentCompilerState(..), PersistentCompilerState(..),
Deprecations(..), lookupDeprec, Deprecations(..), lookupDeprec,
...@@ -444,7 +445,10 @@ data GenAvailInfo name = Avail name -- An ordinary identifier ...@@ -444,7 +445,10 @@ data GenAvailInfo name = Avail name -- An ordinary identifier
deriving( Eq ) deriving( Eq )
-- Equality used when deciding if the interface has changed -- Equality used when deciding if the interface has changed
type AvailEnv = NameEnv AvailInfo -- Maps a Name to the AvailInfo that contains it type AvailEnv = NameEnv AvailInfo -- Maps a Name to the AvailInfo that contains it
emptyAvailEnv :: AvailEnv
emptyAvailEnv = emptyNameEnv
instance Outputable n => Outputable (GenAvailInfo n) where instance Outputable n => Outputable (GenAvailInfo n) where
ppr = pprAvail ppr = pprAvail
......
...@@ -34,7 +34,7 @@ import RnHiFiles ( readIface, loadInterface, ...@@ -34,7 +34,7 @@ import RnHiFiles ( readIface, loadInterface,
loadExports, loadFixDecls, loadDeprecs, loadExports, loadFixDecls, loadDeprecs,
) )
import RnEnv ( availsToNameSet, mkIfaceGlobalRdrEnv, import RnEnv ( availsToNameSet, mkIfaceGlobalRdrEnv,
emptyAvailEnv, unitAvailEnv, availEnvElts, unitAvailEnv, availEnvElts,
plusAvailEnv, groupAvails, warnUnusedImports, plusAvailEnv, groupAvails, warnUnusedImports,
warnUnusedLocalBinds, warnUnusedModules, warnUnusedLocalBinds, warnUnusedModules,
lookupSrcName, getImplicitStmtFVs, lookupSrcName, getImplicitStmtFVs,
...@@ -106,7 +106,7 @@ renameStmt dflags hit hst pcs this_module ic stmt ...@@ -106,7 +106,7 @@ renameStmt dflags hit hst pcs this_module ic stmt
loadContextModule (ic_module ic) $ \ (rdr_env, print_unqual) -> loadContextModule (ic_module ic) $ \ (rdr_env, print_unqual) ->
-- Rename the stmt -- Rename the stmt
initRnMS rdr_env (ic_rn_env ic) emptyLocalFixityEnv CmdLineMode ( initRnMS rdr_env emptyAvailEnv (ic_rn_env ic) emptyLocalFixityEnv CmdLineMode (
rnStmt stmt $ \ stmt' -> rnStmt stmt $ \ stmt' ->
returnRn (([], stmt'), emptyFVs) returnRn (([], stmt'), emptyFVs)
) `thenRn` \ ((binders, stmt), fvs) -> ) `thenRn` \ ((binders, stmt), fvs) ->
...@@ -162,7 +162,7 @@ renameRdrName dflags hit hst pcs this_module ic rdr_names = ...@@ -162,7 +162,7 @@ renameRdrName dflags hit hst pcs this_module ic rdr_names =
loadContextModule (ic_module ic) $ \ (rdr_env, print_unqual) -> loadContextModule (ic_module ic) $ \ (rdr_env, print_unqual) ->
-- rename the rdr_name -- rename the rdr_name
initRnMS rdr_env (ic_rn_env ic) emptyLocalFixityEnv CmdLineMode initRnMS rdr_env emptyAvailEnv (ic_rn_env ic) emptyLocalFixityEnv CmdLineMode
(mapRn (tryRn.lookupOccRn) rdr_names) `thenRn` \ maybe_names -> (mapRn (tryRn.lookupOccRn) rdr_names) `thenRn` \ maybe_names ->
let let
ok_names = [ a | Right a <- maybe_names ] ok_names = [ a | Right a <- maybe_names ]
...@@ -269,7 +269,8 @@ rename this_module contents@(HsModule _ _ exports imports local_decls mod_deprec ...@@ -269,7 +269,8 @@ rename this_module contents@(HsModule _ _ exports imports local_decls mod_deprec
fixitiesFromLocalDecls local_gbl_env local_decls `thenRn` \ local_fixity_env -> fixitiesFromLocalDecls local_gbl_env local_decls `thenRn` \ local_fixity_env ->
-- RENAME THE SOURCE -- RENAME THE SOURCE
rnSourceDecls gbl_env local_fixity_env local_decls `thenRn` \ (rn_local_decls, source_fvs) -> rnSourceDecls gbl_env global_avail_env
local_fixity_env local_decls `thenRn` \ (rn_local_decls, source_fvs) ->
-- EXIT IF ERRORS FOUND -- EXIT IF ERRORS FOUND
-- We exit here if there are any errors in the source, *before* -- We exit here if there are any errors in the source, *before*
......
...@@ -26,7 +26,7 @@ import RnHsSyn ...@@ -26,7 +26,7 @@ import RnHsSyn
import RnMonad import RnMonad
import RnTypes ( rnHsSigType, rnHsType ) import RnTypes ( rnHsSigType, rnHsType )
import RnExpr ( rnMatch, rnGRHSs, rnPat, checkPrecMatch ) import RnExpr ( rnMatch, rnGRHSs, rnPat, checkPrecMatch )
import RnEnv ( bindLocatedLocalsRn, lookupBndrRn, import RnEnv ( bindLocatedLocalsRn, lookupBndrRn, lookupInstDeclBndr,
lookupGlobalOccRn, lookupSigOccRn, bindPatSigTyVars, lookupGlobalOccRn, lookupSigOccRn, bindPatSigTyVars,
warnUnusedLocalBinds, mapFvRn, extendTyVarEnvFVRn, warnUnusedLocalBinds, mapFvRn, extendTyVarEnvFVRn,
) )
...@@ -367,21 +367,22 @@ in many ways the @op@ in an instance decl is just like an occurrence, not ...@@ -367,21 +367,22 @@ in many ways the @op@ in an instance decl is just like an occurrence, not
a binder. a binder.
\begin{code} \begin{code}
rnMethodBinds :: [Name] -- Names for generic type variables rnMethodBinds :: Name -- Class name
-> [Name] -- Names for generic type variables
-> RdrNameMonoBinds -> RdrNameMonoBinds
-> RnMS (RenamedMonoBinds, FreeVars) -> RnMS (RenamedMonoBinds, FreeVars)
rnMethodBinds gen_tyvars EmptyMonoBinds = returnRn (EmptyMonoBinds, emptyFVs) rnMethodBinds cls gen_tyvars EmptyMonoBinds = returnRn (EmptyMonoBinds, emptyFVs)
rnMethodBinds gen_tyvars (AndMonoBinds mb1 mb2) rnMethodBinds cls gen_tyvars (AndMonoBinds mb1 mb2)
= rnMethodBinds gen_tyvars mb1 `thenRn` \ (mb1', fvs1) -> = rnMethodBinds cls gen_tyvars mb1 `thenRn` \ (mb1', fvs1) ->
rnMethodBinds gen_tyvars mb2 `thenRn` \ (mb2', fvs2) -> rnMethodBinds cls gen_tyvars mb2 `thenRn` \ (mb2', fvs2) ->
returnRn (mb1' `AndMonoBinds` mb2', fvs1 `plusFV` fvs2) returnRn (mb1' `AndMonoBinds` mb2', fvs1 `plusFV` fvs2)
rnMethodBinds gen_tyvars (FunMonoBind name inf matches locn) rnMethodBinds cls gen_tyvars (FunMonoBind name inf matches locn)
= pushSrcLocRn locn $ = pushSrcLocRn locn $
lookupGlobalOccRn name `thenRn` \ sel_name -> lookupInstDeclBndr cls name `thenRn` \ sel_name ->
-- We use the selector name as the binder -- We use the selector name as the binder
mapFvRn rn_match matches `thenRn` \ (new_matches, fvs) -> mapFvRn rn_match matches `thenRn` \ (new_matches, fvs) ->
...@@ -400,7 +401,7 @@ rnMethodBinds gen_tyvars (FunMonoBind name inf matches locn) ...@@ -400,7 +401,7 @@ rnMethodBinds gen_tyvars (FunMonoBind name inf matches locn)
-- Can't handle method pattern-bindings which bind multiple methods. -- Can't handle method pattern-bindings which bind multiple methods.
rnMethodBinds gen_tyvars mbind@(PatMonoBind other_pat _ locn) rnMethodBinds cls gen_tyvars mbind@(PatMonoBind other_pat _ locn)
= pushSrcLocRn locn $ = pushSrcLocRn locn $
failWithRn (EmptyMonoBinds, emptyFVs) (methodBindErr mbind) failWithRn (EmptyMonoBinds, emptyFVs) (methodBindErr mbind)
\end{code} \end{code}
......
...@@ -28,7 +28,7 @@ import HscTypes ( Provenance(..), pprNameProvenance, hasBetterProv, ...@@ -28,7 +28,7 @@ import HscTypes ( Provenance(..), pprNameProvenance, hasBetterProv,
import RnMonad import RnMonad
import Name ( Name, import Name ( Name,
getSrcLoc, nameIsLocalOrFrom, getSrcLoc, nameIsLocalOrFrom,
mkLocalName, mkGlobalName, mkLocalName, mkGlobalName, nameModule,
mkIPName, nameOccName, nameModule_maybe, mkIPName, nameOccName, nameModule_maybe,
setNameModuleAndLoc setNameModuleAndLoc
) )
...@@ -244,6 +244,28 @@ lookupTopBndrRn rdr_name ...@@ -244,6 +244,28 @@ lookupTopBndrRn rdr_name
lookupSigOccRn :: RdrName -> RnMS Name lookupSigOccRn :: RdrName -> RnMS Name
lookupSigOccRn = lookupBndrRn lookupSigOccRn = lookupBndrRn
-- lookupInstDeclBndr is used for the binders in an
-- instance declaration. Here we use the class name to
-- disambiguate.
lookupInstDeclBndr :: Name -> RdrName -> RnMS Name
-- We use the selector name as the binder
lookupInstDeclBndr cls_name rdr_name
| isOrig rdr_name -- Occurs in derived instances, where we just
-- refer diectly to the right method
= lookupOrigName rdr_name
| otherwise
= getGlobalAvails `thenRn` \ avail_env ->
case lookupNameEnv avail_env cls_name of
Just (AvailTC _ ns) -> case [n | n <- ns, nameOccName n == occ] of
(n:ns)-> ASSERT( null ns ) returnRn n
[] -> failWithRn (mkUnboundName rdr_name)
(unknownNameErr rdr_name)
other -> pprPanic "lookupInstDeclBndr" (ppr cls_name)
where
occ = rdrNameOcc rdr_name
-- lookupOccRn looks up an occurrence of a RdrName -- lookupOccRn looks up an occurrence of a RdrName
lookupOccRn :: RdrName -> RnMS Name lookupOccRn :: RdrName -> RnMS Name
lookupOccRn rdr_name lookupOccRn rdr_name
...@@ -797,7 +819,6 @@ plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [ppr a1,ppr a2]) ...@@ -797,7 +819,6 @@ plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [ppr a1,ppr a2])
addAvail :: AvailEnv -> AvailInfo -> AvailEnv addAvail :: AvailEnv -> AvailInfo -> AvailEnv
addAvail avails avail = extendNameEnv_C plusAvail avails (availName avail) avail addAvail avails avail = extendNameEnv_C plusAvail avails (availName avail) avail
emptyAvailEnv = emptyNameEnv
unitAvailEnv :: AvailInfo -> AvailEnv unitAvailEnv :: AvailInfo -> AvailEnv
unitAvailEnv a = unitNameEnv (availName a) a unitAvailEnv a = unitNameEnv (availName a) a
......
...@@ -29,7 +29,7 @@ import HscTypes ( ModuleLocation(..), ...@@ -29,7 +29,7 @@ import HscTypes ( ModuleLocation(..),
) )
import HsSyn ( TyClDecl(..), InstDecl(..), import HsSyn ( TyClDecl(..), InstDecl(..),
HsType(..), HsPred(..), FixitySig(..), RuleDecl(..), HsType(..), HsPred(..), FixitySig(..), RuleDecl(..),
tyClDeclNames, tyClDeclSysNames, hsTyVarNames tyClDeclNames, tyClDeclSysNames, hsTyVarNames, getHsInstHead,
) )
import RdrHsSyn ( RdrNameTyClDecl, RdrNameInstDecl, RdrNameRuleDecl ) import RdrHsSyn ( RdrNameTyClDecl, RdrNameInstDecl, RdrNameRuleDecl )
import RnHsSyn ( extractHsTyNames_s ) import RnHsSyn ( extractHsTyNames_s )
...@@ -384,7 +384,7 @@ loadInstDecl mod insts decl@(InstDecl inst_ty _ _ _ _) ...@@ -384,7 +384,7 @@ loadInstDecl mod insts decl@(InstDecl inst_ty _ _ _ _)
rnHsType (text "In an interface instance decl") inst_ty rnHsType (text "In an interface instance decl") inst_ty
) `thenRn` \ inst_ty' -> ) `thenRn` \ inst_ty' ->
let let
(tvs,(cls,tys)) = get_head inst_ty' (tvs,(cls,tys)) = getHsInstHead inst_ty'
free_tcs = nameSetToList (extractHsTyNames_s tys) `minusList` hsTyVarNames tvs free_tcs = nameSetToList (extractHsTyNames_s tys) `minusList` hsTyVarNames tvs
gate_fn vis_fn = vis_fn cls && (null free_tcs || any vis_fn free_tcs) gate_fn vis_fn = vis_fn cls && (null free_tcs || any vis_fn free_tcs)
...@@ -395,22 +395,6 @@ loadInstDecl mod insts decl@(InstDecl inst_ty _ _ _ _) ...@@ -395,22 +395,6 @@ loadInstDecl mod insts decl@(InstDecl inst_ty _ _ _ _)
returnRn ((gate_fn, (mod, decl)) `consBag` insts) returnRn ((gate_fn, (mod, decl)) `consBag` insts)
-- In interface files, the instance decls now look like
-- forall a. Foo a -> Baz (T a)
-- so we have to strip off function argument types,
-- as well as the bit before the '=>' (which is always
-- empty in interface files)
--
-- The parser ensures the type will have the right shape.
-- (e.g. see ParseUtil.checkInstType)
get_head (HsForAllTy (Just tvs) _ tau) = (tvs, get_head1 tau)
get_head tau = ([], get_head1 tau)
get_head1 (HsFunTy _ ty) = get_head1 ty
get_head1 (HsPredTy (HsClassP cls tys)) = (cls,tys)
----------------------------------------------------- -----------------------------------------------------
-- Loading Rules -- Loading Rules
......
...@@ -36,7 +36,7 @@ import IO ( hPutStr, stderr ) ...@@ -36,7 +36,7 @@ import IO ( hPutStr, stderr )
import HsSyn import HsSyn
import RdrHsSyn import RdrHsSyn
import RnHsSyn ( RenamedFixitySig ) import RnHsSyn ( RenamedFixitySig )
import HscTypes ( AvailEnv, lookupType, import HscTypes ( AvailEnv, emptyAvailEnv, lookupType,
NameSupply(..), NameSupply(..),
ImportedModuleInfo, WhetherHasOrphans, ImportVersion, ImportedModuleInfo, WhetherHasOrphans, ImportVersion,
PersistentRenamerState(..), Avails, PersistentRenamerState(..), Avails,
...@@ -148,6 +148,13 @@ data SDown = SDown { ...@@ -148,6 +148,13 @@ data SDown = SDown {
rn_genv :: GlobalRdrEnv, -- Top level environment rn_genv :: GlobalRdrEnv, -- Top level environment
rn_avails :: AvailEnv,
-- Top level AvailEnv; contains all the things that
-- are nameable in the top-level scope, regardless of
-- *how* they can be named (qualified, unqualified...)
-- It is used only to map a Class to its class ops, and
-- hence to resolve the binders in an instance decl
rn_lenv :: LocalRdrEnv, -- Local name envt rn_lenv :: LocalRdrEnv, -- Local name envt
-- Does *not* include global name envt; may shadow it -- Does *not* include global name envt; may shadow it
-- Includes both ordinary variables and type variables; -- Includes both ordinary variables and type variables;
...@@ -369,22 +376,24 @@ initRn dflags hit hst pcs mod do_rn ...@@ -369,22 +376,24 @@ initRn dflags hit hst pcs mod do_rn
return (new_pcs, (warns, errs), res) return (new_pcs, (warns, errs), res)
initRnMS :: GlobalRdrEnv -> LocalRdrEnv -> LocalFixityEnv -> RnMode initRnMS :: GlobalRdrEnv -> AvailEnv -> LocalRdrEnv -> LocalFixityEnv -> RnMode
-> RnMS a -> RnM d a -> RnMS a -> RnM d a
initRnMS rn_env local_env fixity_env mode thing_inside rn_down g_down initRnMS rn_env avails local_env fixity_env mode thing_inside rn_down g_down
-- The fixity_env appears in both the rn_fixenv field -- The fixity_env appears in both the rn_fixenv field
-- and in the HIT. See comments with RnHiFiles.lookupFixityRn -- and in the HIT. See comments with RnHiFiles.lookupFixityRn
= let = let
s_down = SDown { rn_genv = rn_env, rn_lenv = local_env, s_down = SDown { rn_genv = rn_env, rn_avails = avails,
rn_fixenv = fixity_env, rn_mode = mode } rn_lenv = local_env, rn_fixenv = fixity_env,
rn_mode = mode }
in in
thing_inside rn_down s_down thing_inside rn_down s_down
initIfaceRnMS :: Module -> RnMS r -> RnM d r initIfaceRnMS :: Module -> RnMS r -> RnM d r
initIfaceRnMS mod thing_inside initIfaceRnMS mod thing_inside
= initRnMS emptyRdrEnv emptyRdrEnv emptyLocalFixityEnv InterfaceMode $ = initRnMS emptyRdrEnv emptyAvailEnv emptyRdrEnv
setModuleRn mod thing_inside emptyLocalFixityEnv InterfaceMode
(setModuleRn mod thing_inside)
\end{code} \end{code}
@renameDerivedCode@ is used to rename stuff ``out-of-line''; @renameDerivedCode@ is used to rename stuff ``out-of-line'';
...@@ -420,8 +429,9 @@ renameDerivedCode dflags mod prs thing_inside ...@@ -420,8 +429,9 @@ renameDerivedCode dflags mod prs thing_inside
rn_hit = bogus "rn_hit", rn_hit = bogus "rn_hit",
rn_ifaces = bogus "rn_ifaces" rn_ifaces = bogus "rn_ifaces"
} }
; let s_down = SDown { rn_mode = InterfaceMode, ; let s_down = SDown { rn_mode = InterfaceMode,
-- So that we can refer to PrelBase.True etc -- So that we can refer to PrelBase.True etc
rn_avails = emptyAvailEnv,
rn_genv = emptyRdrEnv, rn_lenv = emptyRdrEnv, rn_genv = emptyRdrEnv, rn_lenv = emptyRdrEnv,
rn_fixenv = emptyLocalFixityEnv } rn_fixenv = emptyLocalFixityEnv }
...@@ -689,6 +699,10 @@ getGlobalNameEnv :: RnMS GlobalRdrEnv ...@@ -689,6 +699,10 @@ getGlobalNameEnv :: RnMS GlobalRdrEnv
getGlobalNameEnv rn_down (SDown {rn_genv = global_env}) getGlobalNameEnv rn_down (SDown {rn_genv = global_env})
= return global_env = return global_env
getGlobalAvails :: RnMS AvailEnv
getGlobalAvails rn_down (SDown {rn_avails = avails})
= return avails
setLocalNameEnv :: LocalRdrEnv -> RnMS a -> RnMS a setLocalNameEnv :: LocalRdrEnv -> RnMS a -> RnMS a
setLocalNameEnv local_env' m rn_down l_down setLocalNameEnv local_env' m rn_down l_down
= m rn_down (l_down {rn_lenv = local_env'}) = m rn_down (l_down {rn_lenv = local_env'})
......
...@@ -32,7 +32,7 @@ import NameSet ...@@ -32,7 +32,7 @@ import NameSet
import NameEnv import NameEnv
import HscTypes ( Provenance(..), ImportReason(..), GlobalRdrEnv, import HscTypes ( Provenance(..), ImportReason(..), GlobalRdrEnv,
GenAvailInfo(..), AvailInfo, Avails, AvailEnv, GenAvailInfo(..), AvailInfo, Avails, AvailEnv,
Deprecations(..), ModIface(..) Deprecations(..), ModIface(..), emptyAvailEnv
) )
import RdrName ( rdrNameOcc, setRdrNameOcc ) import RdrName ( rdrNameOcc, setRdrNameOcc )
import OccName ( setOccNameSpace, dataName ) import OccName ( setOccNameSpace, dataName )
......
...@@ -11,7 +11,7 @@ module RnSource ( rnTyClDecl, rnIfaceRuleDecl, rnInstDecl, rnSourceDecls, ...@@ -11,7 +11,7 @@ module RnSource ( rnTyClDecl, rnIfaceRuleDecl, rnInstDecl, rnSourceDecls,
import RnExpr import RnExpr
import HsSyn import HsSyn
import HscTypes ( GlobalRdrEnv ) import HscTypes ( GlobalRdrEnv, AvailEnv )
import RdrName ( RdrName, isRdrDataCon, elemRdrEnv ) import RdrName ( RdrName, isRdrDataCon, elemRdrEnv )
import RdrHsSyn ( RdrNameConDecl, RdrNameTyClDecl, import RdrHsSyn ( RdrNameConDecl, RdrNameTyClDecl,
extractGenericPatTyVars extractGenericPatTyVars
...@@ -73,13 +73,13 @@ Checks the @(..)@ etc constraints in the export list. ...@@ -73,13 +73,13 @@ Checks the @(..)@ etc constraints in the export list.
%********************************************************* %*********************************************************
\begin{code} \begin{code}
rnSourceDecls :: GlobalRdrEnv -> LocalFixityEnv rnSourceDecls :: GlobalRdrEnv -> AvailEnv -> LocalFixityEnv
-> [RdrNameHsDecl] -> [RdrNameHsDecl]
-> RnMG ([RenamedHsDecl], FreeVars) -> RnMG ([RenamedHsDecl], FreeVars)
-- The decls get reversed, but that's ok -- The decls get reversed, but that's ok
rnSourceDecls gbl_env local_fixity_env decls rnSourceDecls gbl_env avails local_fixity_env decls
= initRnMS gbl_env emptyRdrEnv local_fixity_env SourceMode (go emptyFVs [] decls) = initRnMS gbl_env avails emptyRdrEnv local_fixity_env SourceMode (go emptyFVs [] decls)
where where
-- Fixity and deprecations have been dealt with already; ignore them -- Fixity and deprecations have been dealt with already; ignore them
go fvs ds' [] = returnRn (ds', fvs) go fvs ds' [] = returnRn (ds', fvs)
...@@ -177,9 +177,7 @@ finishSourceInstDecl (InstDecl _ mbinds uprags _ _ ) ...@@ -177,9 +177,7 @@ finishSourceInstDecl (InstDecl _ mbinds uprags _ _ )
let let
meth_doc = text "In the bindings in an instance declaration" meth_doc = text "In the bindings in an instance declaration"
meth_names = collectLocatedMonoBinders mbinds meth_names = collectLocatedMonoBinders mbinds
inst_tyvars = case inst_ty of (inst_tyvars, (cls,_)) = getHsInstHead inst_ty
HsForAllTy (Just inst_tyvars) _ _ -> inst_tyvars
other -> []
-- (Slightly strangely) the forall-d tyvars scope over -- (Slightly strangely) the forall-d tyvars scope over
-- the method bindings too -- the method bindings too
in in
...@@ -188,7 +186,7 @@ finishSourceInstDecl (InstDecl _ mbinds uprags _ _ ) ...@@ -188,7 +186,7 @@ finishSourceInstDecl (InstDecl _ mbinds uprags _ _ )
-- NB meth_names can be qualified! -- NB meth_names can be qualified!
checkDupNames meth_doc meth_names `thenRn_` checkDupNames meth_doc meth_names `thenRn_`
extendTyVarEnvFVRn (map hsTyVarName inst_tyvars) ( extendTyVarEnvFVRn (map hsTyVarName inst_tyvars) (
rnMethodBinds [] mbinds rnMethodBinds cls [] mbinds
) `thenRn` \ (mbinds', meth_fvs) -> ) `thenRn` \ (mbinds', meth_fvs) ->
let let
binders = collectMonoBinders mbinds' binders = collectMonoBinders mbinds'
...@@ -411,7 +409,7 @@ finishSourceTyClDecl (TyData {tcdDerivs = Just derivs, tcdLoc = src_loc}) -- Der ...@@ -411,7 +409,7 @@ finishSourceTyClDecl (TyData {tcdDerivs = Just derivs, tcdLoc = src_loc}) -- Der
returnRn (rn_ty_decl {tcdDerivs = Just derivs'}, mkNameSet derivs') returnRn (rn_ty_decl {tcdDerivs = Just derivs'}, mkNameSet derivs')
finishSourceTyClDecl (ClassDecl {tcdMeths = Just mbinds, tcdLoc = src_loc}) -- Get mbinds from here finishSourceTyClDecl (ClassDecl {tcdMeths = Just mbinds, tcdLoc = src_loc}) -- Get mbinds from here
rn_cls_decl@(ClassDecl {tcdTyVars = tyvars}) -- Everything else is here rn_cls_decl@(ClassDecl {tcdName = cls, tcdTyVars = tyvars}) -- Everything else is here
-- There are some default-method bindings (abeit possibly empty) so -- There are some default-method bindings (abeit possibly empty) so
-- this is a source-code class declaration -- this is a source-code class declaration
= -- The newLocals call is tiresome: given a generic class decl = -- The newLocals call is tiresome: given a generic class decl
...@@ -433,7 +431,7 @@ finishSourceTyClDecl (ClassDecl {tcdMeths = Just mbinds, tcdLoc = src_loc}) -- G ...@@ -433,7 +431,7 @@ finishSourceTyClDecl (ClassDecl {tcdMeths = Just mbinds, tcdLoc = src_loc}) -- G
in in
checkDupOrQualNames meth_doc meth_rdr_names_w_locs `thenRn_` checkDupOrQualNames meth_doc meth_rdr_names_w_locs `thenRn_`
newLocalsRn gen_rdr_tyvars_w_locs `thenRn` \ gen_tyvars -> newLocalsRn gen_rdr_tyvars_w_locs `thenRn` \ gen_tyvars ->
rnMethodBinds gen_tyvars mbinds `thenRn` \ (mbinds', meth_fvs) -> rnMethodBinds cls gen_tyvars mbinds `thenRn` \ (mbinds', meth_fvs) ->
returnRn (rn_cls_decl {tcdMeths = Just mbinds'}, meth_fvs) returnRn (rn_cls_decl {tcdMeths = Just mbinds'}, meth_fvs)
where where
meth_doc = text "In the default-methods for class" <+> ppr (tcdName rn_cls_decl) meth_doc = text "In the default-methods for class" <+> ppr (tcdName rn_cls_decl)
......
...@@ -30,14 +30,14 @@ import RnMonad ( renameDerivedCode, thenRn, mapRn, returnRn ) ...@@ -30,14 +30,14 @@ import RnMonad ( renameDerivedCode, thenRn, mapRn, returnRn )
import HscTypes ( DFunId, PersistentRenamerState ) import HscTypes ( DFunId, PersistentRenamerState )
import BasicTypes ( Fixity ) import BasicTypes ( Fixity )
import Class ( classKey, Class ) import Class ( className, classKey, Class )
import ErrUtils ( dumpIfSet_dyn, Message ) import ErrUtils ( dumpIfSet_dyn, Message )
import MkId ( mkDictFunId ) import MkId ( mkDictFunId )
import DataCon ( dataConArgTys, isNullaryDataCon, isExistentialDataCon ) import DataCon ( dataConArgTys, isNullaryDataCon, isExistentialDataCon )
import PrelInfo ( needsDataDeclCtxtClassKeys ) import PrelInfo ( needsDataDeclCtxtClassKeys )
import Maybes ( maybeToBool, catMaybes ) import Maybes ( maybeToBool, catMaybes )
import Module ( Module ) import Module ( Module )
import Name ( Name, getSrcLoc ) import Name ( Name, getSrcLoc, nameUnique )
import RdrName ( RdrName ) import RdrName ( RdrName )
import TyCon ( tyConTyVars, tyConDataCons, import TyCon ( tyConTyVars, tyConDataCons,
...@@ -245,11 +245,10 @@ tcDeriving prs mod inst_env_in get_fixity tycl_decls ...@@ -245,11 +245,10 @@ tcDeriving prs mod inst_env_in get_fixity tycl_decls
-- Make a Real dfun instead of the dummy one we have so far -- Make a Real dfun instead of the dummy one we have so far
gen_inst_info :: DFunId -> RenamedMonoBinds -> InstInfo gen_inst_info :: DFunId -> RenamedMonoBinds -> InstInfo
gen_inst_info dfun binds gen_inst_info dfun binds
= InstInfo { iDFunId = dfun, = InstInfo { iDFunId = dfun, iBinds = binds, iPrags = [] }
iBinds = binds, iPrags = [] }
rn_meths meths = rnMethodBinds [] meths `thenRn` \ (meths', _) -> returnRn meths' rn_meths (cls, meths) = rnMethodBinds cls [] meths `thenRn` \ (meths', _) ->
-- Ignore the free vars returned returnRn meths' -- Ignore the free vars returned
\end{code} \end{code}
...@@ -508,24 +507,26 @@ the renamer. What a great hack! ...@@ -508,24 +507,26 @@ the renamer. What a great hack!
\begin{code} \begin{code}
-- Generate the method bindings for the required instance -- Generate the method bindings for the required instance
-- (paired with class name, as we need that when generating dict -- (paired with class name, as we need that when renaming
-- names.) -- the method binds)
gen_bind :: (Name -> Maybe Fixity) -> DFunId -> RdrNameMonoBinds gen_bind :: (Name -> Maybe Fixity) -> DFunId -> (Name, RdrNameMonoBinds)
gen_bind get_fixity dfun gen_bind get_fixity dfun
| clas `hasKey` showClassKey = gen_Show_binds get_fixity tycon = (cls_nm, binds)
| clas `hasKey` readClassKey = gen_Read_binds get_fixity tycon
| otherwise
= assoc "gen_bind:bad derived class"
[(eqClassKey, gen_Eq_binds)
,(ordClassKey, gen_Ord_binds)
,(enumClassKey, gen_Enum_binds)
,(boundedClassKey, gen_Bounded_binds)
,(ixClassKey, gen_Ix_binds)
]
(classKey clas)
tycon
where where
cls_nm = className clas
(clas, tycon) = simpleDFunClassTyCon dfun (clas, tycon) = simpleDFunClassTyCon dfun
binds = assoc "gen_bind:bad derived class" gen_list
(nameUnique cls_nm) tycon
gen_list = [(eqClassKey, gen_Eq_binds)
,(ordClassKey, gen_Ord_binds)
,(enumClassKey, gen_Enum_binds)
,(boundedClassKey, gen_Bounded_binds)
,(ixClassKey, gen_Ix_binds)
,(showClassKey, gen_Show_binds get_fixity)
,(readClassKey, gen_Read_binds get_fixity)
]
\end{code} \end{code}
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment