, hsUsOnce, hsUsMany
, mkHsForAllTy, mkHsDictTy, mkHsIParamTy
- , hsTyVarName, hsTyVarNames, replaceTyVarName,
+ , hsTyVarName, hsTyVarNames, replaceTyVarName
+ , getHsInstHead
-- Type place holder
- PostTcType, placeHolderType,
+ , PostTcType, placeHolderType,
-- Printing
, pprParendHsType, pprHsForAll, pprHsContext, pprHsTyVarBndr
\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}
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,
deriving( Eq )
-- 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
ppr = pprAvail
loadExports, loadFixDecls, loadDeprecs,
)
import RnEnv ( availsToNameSet, mkIfaceGlobalRdrEnv,
- emptyAvailEnv, unitAvailEnv, availEnvElts,
+ unitAvailEnv, availEnvElts,
plusAvailEnv, groupAvails, warnUnusedImports,
warnUnusedLocalBinds, warnUnusedModules,
lookupSrcName, getImplicitStmtFVs,
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) ->
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 ]
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*
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,
)
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) ->
-- 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}
import RnMonad
import Name ( Name,
getSrcLoc, nameIsLocalOrFrom,
- mkLocalName, mkGlobalName,
+ mkLocalName, mkGlobalName, nameModule,
mkIPName, nameOccName, nameModule_maybe,
setNameModuleAndLoc
)
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
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
)
import HsSyn ( TyClDecl(..), InstDecl(..),
HsType(..), HsPred(..), FixitySig(..), RuleDecl(..),
- tyClDeclNames, tyClDeclSysNames, hsTyVarNames
+ tyClDeclNames, tyClDeclSysNames, hsTyVarNames, getHsInstHead,
)
import RdrHsSyn ( RdrNameTyClDecl, RdrNameInstDecl, RdrNameRuleDecl )
import RnHsSyn ( extractHsTyNames_s )
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)
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
import HsSyn
import RdrHsSyn
import RnHsSyn ( RenamedFixitySig )
-import HscTypes ( AvailEnv, lookupType,
+import HscTypes ( AvailEnv, emptyAvailEnv, lookupType,
NameSupply(..),
ImportedModuleInfo, WhetherHasOrphans, ImportVersion,
PersistentRenamerState(..), Avails,
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;
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'';
rn_hit = bogus "rn_hit",
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
+ rn_avails = emptyAvailEnv,
rn_genv = emptyRdrEnv, rn_lenv = emptyRdrEnv,
rn_fixenv = emptyLocalFixityEnv }
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'})
import NameEnv
import HscTypes ( Provenance(..), ImportReason(..), GlobalRdrEnv,
GenAvailInfo(..), AvailInfo, Avails, AvailEnv,
- Deprecations(..), ModIface(..)
+ Deprecations(..), ModIface(..), emptyAvailEnv
)
import RdrName ( rdrNameOcc, setRdrNameOcc )
import OccName ( setOccNameSpace, dataName )
import RnExpr
import HsSyn
-import HscTypes ( GlobalRdrEnv )
+import HscTypes ( GlobalRdrEnv, AvailEnv )
import RdrName ( RdrName, isRdrDataCon, elemRdrEnv )
import RdrHsSyn ( RdrNameConDecl, RdrNameTyClDecl,
extractGenericPatTyVars
%*********************************************************
\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)
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
-- 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'
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
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)
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,
-- 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}
\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)
- ,(ordClassKey, gen_Ord_binds)
- ,(enumClassKey, gen_Enum_binds)
- ,(boundedClassKey, gen_Bounded_binds)
- ,(ixClassKey, gen_Ix_binds)
- ]
- (classKey clas)
- tycon
+ = (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)
+ ]
\end{code}
projects / ghc-hetmet.git / commitdiff