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 (
, hsUsOnce, hsUsMany
, mkHsForAllTy, mkHsDictTy, mkHsIParamTy
, hsTyVarName, hsTyVarNames, replaceTyVarName,
, hsTyVarName, hsTyVarNames, replaceTyVarName
, getHsInstHead
-- Type place holder
PostTcType, placeHolderType,
, PostTcType, placeHolderType,
-- Printing
, pprParendHsType, pprHsForAll, pprHsContext, pprHsTyVarBndr
......@@ -172,6 +173,27 @@ replaceTyVarName (IfaceTyVar n k) n' = IfaceTyVar n' k
\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}
......
......@@ -32,7 +32,8 @@ module HscTypes (
PersistentRenamerState(..), IsBootInterface, DeclsMap,
IfaceInsts, IfaceRules, GatedDecl, GatedDecls, GateFn, IsExported,
NameSupply(..), OrigNameCache, OrigIParamCache,
Avails, AvailEnv, GenAvailInfo(..), AvailInfo, RdrAvailInfo,
Avails, AvailEnv, emptyAvailEnv,
GenAvailInfo(..), AvailInfo, RdrAvailInfo,
PersistentCompilerState(..),
Deprecations(..), lookupDeprec,
......@@ -446,6 +447,9 @@ data GenAvailInfo name = Avail name -- An ordinary identifier
type AvailEnv = NameEnv AvailInfo -- Maps a Name to the AvailInfo that contains it
emptyAvailEnv :: AvailEnv
emptyAvailEnv = emptyNameEnv
instance Outputable n => Outputable (GenAvailInfo n) where
ppr = pprAvail
......
......@@ -34,7 +34,7 @@ import RnHiFiles ( readIface, loadInterface,
loadExports, loadFixDecls, loadDeprecs,
)
import RnEnv ( availsToNameSet, mkIfaceGlobalRdrEnv,
emptyAvailEnv, unitAvailEnv, availEnvElts,
unitAvailEnv, availEnvElts,
plusAvailEnv, groupAvails, warnUnusedImports,
warnUnusedLocalBinds, warnUnusedModules,
lookupSrcName, getImplicitStmtFVs,
......@@ -106,7 +106,7 @@ renameStmt dflags hit hst pcs this_module ic stmt
loadContextModule (ic_module ic) $ \ (rdr_env, print_unqual) ->
-- 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' ->
returnRn (([], stmt'), emptyFVs)
) `thenRn` \ ((binders, stmt), fvs) ->
......@@ -162,7 +162,7 @@ renameRdrName dflags hit hst pcs this_module ic rdr_names =
loadContextModule (ic_module ic) $ \ (rdr_env, print_unqual) ->
-- 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 ->
let
ok_names = [ a | Right a <- maybe_names ]
......@@ -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 ->
-- 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
-- We exit here if there are any errors in the source, *before*
......
......@@ -26,7 +26,7 @@ import RnHsSyn
import RnMonad
import RnTypes ( rnHsSigType, rnHsType )
import RnExpr ( rnMatch, rnGRHSs, rnPat, checkPrecMatch )
import RnEnv ( bindLocatedLocalsRn, lookupBndrRn,
import RnEnv ( bindLocatedLocalsRn, lookupBndrRn, lookupInstDeclBndr,
lookupGlobalOccRn, lookupSigOccRn, bindPatSigTyVars,
warnUnusedLocalBinds, mapFvRn, extendTyVarEnvFVRn,
)
......@@ -367,21 +367,22 @@ in many ways the @op@ in an instance decl is just like an occurrence, not
a binder.
\begin{code}
rnMethodBinds :: [Name] -- Names for generic type variables
rnMethodBinds :: Name -- Class name
-> [Name] -- Names for generic type variables
-> RdrNameMonoBinds
-> 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 gen_tyvars mb1 `thenRn` \ (mb1', fvs1) ->
rnMethodBinds gen_tyvars mb2 `thenRn` \ (mb2', fvs2) ->
rnMethodBinds cls gen_tyvars (AndMonoBinds mb1 mb2)
= rnMethodBinds cls gen_tyvars mb1 `thenRn` \ (mb1', fvs1) ->
rnMethodBinds cls gen_tyvars mb2 `thenRn` \ (mb2', 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 $
lookupGlobalOccRn name `thenRn` \ sel_name ->
lookupInstDeclBndr cls name `thenRn` \ sel_name ->
-- We use the selector name as the binder
mapFvRn rn_match matches `thenRn` \ (new_matches, fvs) ->
......@@ -400,7 +401,7 @@ rnMethodBinds gen_tyvars (FunMonoBind name inf matches locn)
-- 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 $
failWithRn (EmptyMonoBinds, emptyFVs) (methodBindErr mbind)
\end{code}
......
......@@ -28,7 +28,7 @@ import HscTypes ( Provenance(..), pprNameProvenance, hasBetterProv,
import RnMonad
import Name ( Name,
getSrcLoc, nameIsLocalOrFrom,
mkLocalName, mkGlobalName,
mkLocalName, mkGlobalName, nameModule,
mkIPName, nameOccName, nameModule_maybe,
setNameModuleAndLoc
)
......@@ -244,6 +244,28 @@ lookupTopBndrRn rdr_name
lookupSigOccRn :: RdrName -> RnMS Name
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 :: RdrName -> RnMS Name
lookupOccRn rdr_name
......@@ -797,7 +819,6 @@ plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [ppr a1,ppr a2])
addAvail :: AvailEnv -> AvailInfo -> AvailEnv
addAvail avails avail = extendNameEnv_C plusAvail avails (availName avail) avail
emptyAvailEnv = emptyNameEnv
unitAvailEnv :: AvailInfo -> AvailEnv
unitAvailEnv a = unitNameEnv (availName a) a
......
......@@ -29,7 +29,7 @@ import HscTypes ( ModuleLocation(..),
)
import HsSyn ( TyClDecl(..), InstDecl(..),
HsType(..), HsPred(..), FixitySig(..), RuleDecl(..),
tyClDeclNames, tyClDeclSysNames, hsTyVarNames
tyClDeclNames, tyClDeclSysNames, hsTyVarNames, getHsInstHead,
)
import RdrHsSyn ( RdrNameTyClDecl, RdrNameInstDecl, RdrNameRuleDecl )
import RnHsSyn ( extractHsTyNames_s )
......@@ -384,7 +384,7 @@ loadInstDecl mod insts decl@(InstDecl inst_ty _ _ _ _)
rnHsType (text "In an interface instance decl") inst_ty
) `thenRn` \ inst_ty' ->
let
(tvs,(cls,tys)) = get_head inst_ty'
(tvs,(cls,tys)) = getHsInstHead inst_ty'
free_tcs = nameSetToList (extractHsTyNames_s tys) `minusList` hsTyVarNames tvs
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 _ _ _ _)
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
......
......@@ -36,7 +36,7 @@ import IO ( hPutStr, stderr )
import HsSyn
import RdrHsSyn
import RnHsSyn ( RenamedFixitySig )
import HscTypes ( AvailEnv, lookupType,
import HscTypes ( AvailEnv, emptyAvailEnv, lookupType,
NameSupply(..),
ImportedModuleInfo, WhetherHasOrphans, ImportVersion,
PersistentRenamerState(..), Avails,
......@@ -148,6 +148,13 @@ data SDown = SDown {
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
-- Does *not* include global name envt; may shadow it
-- Includes both ordinary variables and type variables;
......@@ -369,22 +376,24 @@ initRn dflags hit hst pcs mod do_rn
return (new_pcs, (warns, errs), res)
initRnMS :: GlobalRdrEnv -> LocalRdrEnv -> LocalFixityEnv -> RnMode
initRnMS :: GlobalRdrEnv -> AvailEnv -> LocalRdrEnv -> LocalFixityEnv -> RnMode
-> 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
-- and in the HIT. See comments with RnHiFiles.lookupFixityRn
= let
s_down = SDown { rn_genv = rn_env, rn_lenv = local_env,
rn_fixenv = fixity_env, rn_mode = mode }
s_down = SDown { rn_genv = rn_env, rn_avails = avails,
rn_lenv = local_env, rn_fixenv = fixity_env,
rn_mode = mode }
in
thing_inside rn_down s_down
initIfaceRnMS :: Module -> RnMS r -> RnM d r
initIfaceRnMS mod thing_inside
= initRnMS emptyRdrEnv emptyRdrEnv emptyLocalFixityEnv InterfaceMode $
setModuleRn mod thing_inside
= initRnMS emptyRdrEnv emptyAvailEnv emptyRdrEnv
emptyLocalFixityEnv InterfaceMode
(setModuleRn mod thing_inside)
\end{code}
@renameDerivedCode@ is used to rename stuff ``out-of-line'';
......@@ -422,6 +431,7 @@ renameDerivedCode dflags mod prs thing_inside
}
; let s_down = SDown { rn_mode = InterfaceMode,
-- So that we can refer to PrelBase.True etc
rn_avails = emptyAvailEnv,
rn_genv = emptyRdrEnv, rn_lenv = emptyRdrEnv,
rn_fixenv = emptyLocalFixityEnv }
......@@ -689,6 +699,10 @@ getGlobalNameEnv :: RnMS GlobalRdrEnv
getGlobalNameEnv rn_down (SDown {rn_genv = global_env})
= return global_env
getGlobalAvails :: RnMS AvailEnv
getGlobalAvails rn_down (SDown {rn_avails = avails})
= return avails
setLocalNameEnv :: LocalRdrEnv -> RnMS a -> RnMS a
setLocalNameEnv local_env' m rn_down l_down
= m rn_down (l_down {rn_lenv = local_env'})
......
......@@ -32,7 +32,7 @@ import NameSet
import NameEnv
import HscTypes ( Provenance(..), ImportReason(..), GlobalRdrEnv,
GenAvailInfo(..), AvailInfo, Avails, AvailEnv,
Deprecations(..), ModIface(..)
Deprecations(..), ModIface(..), emptyAvailEnv
)
import RdrName ( rdrNameOcc, setRdrNameOcc )
import OccName ( setOccNameSpace, dataName )
......
......@@ -11,7 +11,7 @@ module RnSource ( rnTyClDecl, rnIfaceRuleDecl, rnInstDecl, rnSourceDecls,
import RnExpr
import HsSyn
import HscTypes ( GlobalRdrEnv )
import HscTypes ( GlobalRdrEnv, AvailEnv )
import RdrName ( RdrName, isRdrDataCon, elemRdrEnv )
import RdrHsSyn ( RdrNameConDecl, RdrNameTyClDecl,
extractGenericPatTyVars
......@@ -73,13 +73,13 @@ Checks the @(..)@ etc constraints in the export list.
%*********************************************************
\begin{code}
rnSourceDecls :: GlobalRdrEnv -> LocalFixityEnv
rnSourceDecls :: GlobalRdrEnv -> AvailEnv -> LocalFixityEnv
-> [RdrNameHsDecl]
-> RnMG ([RenamedHsDecl], FreeVars)
-- The decls get reversed, but that's ok
rnSourceDecls gbl_env local_fixity_env decls
= initRnMS gbl_env emptyRdrEnv local_fixity_env SourceMode (go emptyFVs [] decls)
rnSourceDecls gbl_env avails local_fixity_env decls
= initRnMS gbl_env avails emptyRdrEnv local_fixity_env SourceMode (go emptyFVs [] decls)
where
-- Fixity and deprecations have been dealt with already; ignore them
go fvs ds' [] = returnRn (ds', fvs)
......@@ -177,9 +177,7 @@ finishSourceInstDecl (InstDecl _ mbinds uprags _ _ )
let
meth_doc = text "In the bindings in an instance declaration"
meth_names = collectLocatedMonoBinders mbinds
inst_tyvars = case inst_ty of
HsForAllTy (Just inst_tyvars) _ _ -> inst_tyvars
other -> []
(inst_tyvars, (cls,_)) = getHsInstHead inst_ty
-- (Slightly strangely) the forall-d tyvars scope over
-- the method bindings too
in
......@@ -188,7 +186,7 @@ finishSourceInstDecl (InstDecl _ mbinds uprags _ _ )
-- NB meth_names can be qualified!
checkDupNames meth_doc meth_names `thenRn_`
extendTyVarEnvFVRn (map hsTyVarName inst_tyvars) (
rnMethodBinds [] mbinds
rnMethodBinds cls [] mbinds
) `thenRn` \ (mbinds', meth_fvs) ->
let
binders = collectMonoBinders mbinds'
......@@ -411,7 +409,7 @@ finishSourceTyClDecl (TyData {tcdDerivs = Just derivs, tcdLoc = src_loc}) -- Der
returnRn (rn_ty_decl {tcdDerivs = Just derivs'}, mkNameSet derivs')
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
-- this is a source-code class declaration
= -- The newLocals call is tiresome: given a generic class decl
......@@ -433,7 +431,7 @@ finishSourceTyClDecl (ClassDecl {tcdMeths = Just mbinds, tcdLoc = src_loc}) -- G
in
checkDupOrQualNames meth_doc meth_rdr_names_w_locs `thenRn_`
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)
where
meth_doc = text "In the default-methods for class" <+> ppr (tcdName rn_cls_decl)
......
......@@ -30,14 +30,14 @@ import RnMonad ( renameDerivedCode, thenRn, mapRn, returnRn )
import HscTypes ( DFunId, PersistentRenamerState )
import BasicTypes ( Fixity )
import Class ( classKey, Class )
import Class ( className, classKey, Class )
import ErrUtils ( dumpIfSet_dyn, Message )
import MkId ( mkDictFunId )
import DataCon ( dataConArgTys, isNullaryDataCon, isExistentialDataCon )
import PrelInfo ( needsDataDeclCtxtClassKeys )
import Maybes ( maybeToBool, catMaybes )
import Module ( Module )
import Name ( Name, getSrcLoc )
import Name ( Name, getSrcLoc, nameUnique )
import RdrName ( RdrName )
import TyCon ( tyConTyVars, tyConDataCons,
......@@ -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
gen_inst_info :: DFunId -> RenamedMonoBinds -> InstInfo
gen_inst_info dfun binds
= InstInfo { iDFunId = dfun,
iBinds = binds, iPrags = [] }
= InstInfo { iDFunId = dfun, iBinds = binds, iPrags = [] }
rn_meths meths = rnMethodBinds [] meths `thenRn` \ (meths', _) -> returnRn meths'
-- Ignore the free vars returned
rn_meths (cls, meths) = rnMethodBinds cls [] meths `thenRn` \ (meths', _) ->
returnRn meths' -- Ignore the free vars returned
\end{code}
......@@ -508,24 +507,26 @@ the renamer. What a great hack!
\begin{code}
-- Generate the method bindings for the required instance
-- (paired with class name, as we need that when generating dict
-- names.)
gen_bind :: (Name -> Maybe Fixity) -> DFunId -> RdrNameMonoBinds
-- (paired with class name, as we need that when renaming
-- the method binds)
gen_bind :: (Name -> Maybe Fixity) -> DFunId -> (Name, RdrNameMonoBinds)
gen_bind get_fixity dfun
| clas `hasKey` showClassKey = gen_Show_binds get_fixity tycon
| clas `hasKey` readClassKey = gen_Read_binds get_fixity tycon
| otherwise
= assoc "gen_bind:bad derived class"
[(eqClassKey, gen_Eq_binds)
= (cls_nm, binds)
where
cls_nm = className clas
(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)
]
(classKey clas)
tycon
where
(clas, tycon) = simpleDFunClassTyCon dfun
\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