From 6a562dd51c1d264ce74a9f6fdf020e21ce34d143 Mon Sep 17 00:00:00 2001
From: simonpj <unknown>
Date: Fri, 14 Jul 2000 13:38:39 +0000
Subject: [PATCH] [project @ 2000-07-14 13:38:39 by simonpj] Arrange that type
signatures work right. Consider:
module A
import M( f )
f :: Int -> Int
f x = x
Here, the 'f' in the signature isn't ambiguous; it
refers to the locally defined f. (This isn't clear in
the Haskell 98 report, but it will be.)
---
ghc/compiler/rename/RnBinds.lhs | 4 +--
ghc/compiler/rename/RnEnv.lhs | 57 ++++++++++----------------------
ghc/compiler/rename/RnSource.lhs | 11 ++++--
3 files changed, 27 insertions(+), 45 deletions(-)
diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs
index 33d99ff7336a..ef5596b2d9e7 100644
--- a/ghc/compiler/rename/RnBinds.lhs
+++ b/ghc/compiler/rename/RnBinds.lhs
@@ -224,8 +224,8 @@ rnMonoBinds mbinds sigs thing_inside -- Non-empty monobinds
= -- Extract all the binders in this group,
-- and extend current scope, inventing new names for the new binders
-- This also checks that the names form a set
- bindLocatedLocalsRn (text "a binding group") mbinders_w_srclocs
- $ \ new_mbinders ->
+ bindLocatedLocalsRn (text "a binding group")
+ mbinders_w_srclocs $ \ new_mbinders ->
let
binder_set = mkNameSet new_mbinders
in
diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs
index 823a1222c2b2..15a46bfd9d51 100644
--- a/ghc/compiler/rename/RnEnv.lhs
+++ b/ghc/compiler/rename/RnEnv.lhs
@@ -24,7 +24,7 @@ import Name ( Name, Provenance(..), ExportFlag(..), NamedThing(..),
mkLocalName, mkImportedLocalName, mkGlobalName, mkUnboundName,
mkIPName, isWiredInName, hasBetterProv,
nameOccName, setNameModule, nameModule,
- pprOccName, isLocallyDefined, nameUnique, nameOccName,
+ pprOccName, isLocallyDefined, nameUnique,
setNameProvenance, getNameProvenance, pprNameProvenance,
extendNameEnv_C, plusNameEnv_C, nameEnvElts
)
@@ -322,6 +322,13 @@ bindCoreLocalsFVRn (b:bs) thing_inside = bindCoreLocalFVRn b $ \ name' ->
bindCoreLocalsFVRn bs $ \ names' ->
thing_inside (name':names')
+bindLocalNames names enclosed_scope
+ = getLocalNameEnv `thenRn` \ name_env ->
+ setLocalNameEnv (addListToRdrEnv name_env pairs)
+ enclosed_scope
+ where
+ pairs = [(mkRdrUnqual (nameOccName n), n) | n <- names]
+
-------------------------------------
bindLocalRn doc rdr_name enclosed_scope
= getSrcLocRn `thenRn` \ loc ->
@@ -350,15 +357,10 @@ bindUVarRn = bindLocalRn
extendTyVarEnvFVRn :: [HsTyVarBndr Name] -> RnMS (a, FreeVars) -> RnMS (a, FreeVars)
-- This tiresome function is used only in rnDecl on InstDecl
extendTyVarEnvFVRn tyvars enclosed_scope
- = getLocalNameEnv `thenRn` \ env ->
- let
- tyvar_names = hsTyVarNames tyvars
- new_env = addListToRdrEnv env [ (mkRdrUnqual (getOccName name), name)
- | name <- tyvar_names
- ]
- in
- setLocalNameEnv new_env enclosed_scope `thenRn` \ (thing, fvs) ->
+ = bindLocalNames tyvar_names enclosed_scope `thenRn` \ (thing, fvs) ->
returnRn (thing, delListFromNameSet fvs tyvar_names)
+ where
+ tyvar_names = hsTyVarNames tyvars
bindTyVarsRn :: SDoc -> [HsTyVarBndr RdrName]
-> ([HsTyVarBndr Name] -> RnMS a)
@@ -474,38 +476,13 @@ lookupGlobalOccRn rdr_name
-- import M( f )
-- f :: Int -> Int
-- f x = x
--- In a sense, it's clear that the 'f' in the signature must refer
--- to A.f, but the Haskell98 report does not stipulate this, so
--- I treat the 'f' in the signature as a reference to an unqualified
--- 'f' and hence fail with an ambiguous reference.
+-- It's clear that the 'f' in the signature must refer to A.f
+-- The Haskell98 report does not stipulate this, but it will!
+-- So we must treat the 'f' in the signature in the same way
+-- as the binding occurrence of 'f', using lookupBndrRn
lookupSigOccRn :: RdrName -> RnMS Name
-lookupSigOccRn = lookupOccRn
-
-{- OLD VERSION
--- This code tries to be cleverer than the above.
--- The variable in a signature must refer to a locally-defined thing,
--- even if there's an imported thing of the same name.
---
--- But this doesn't work for instance decls:
--- instance Enum Int where
--- {-# INLINE enumFrom #-}
--- ...
--- Here the enumFrom is an imported reference!
-lookupSigOccRn rdr_name
- = getNameEnvs `thenRn` \ (global_env, local_env) ->
- case (lookupRdrEnv local_env rdr_name, lookupRdrEnv global_env rdr_name) of
- (Just name, _) -> returnRn name
-
- (Nothing, Just names) -> case filter isLocallyDefined names of
- [n] -> returnRn n
- ns -> pprPanic "lookupSigOccRn" (ppr rdr_name <+> ppr names <+> ppr ns)
- -- There can't be a local top-level name-clash
- -- (That's dealt with elsewhere.)
-
- (Nothing, Nothing) -> failWithRn (mkUnboundName rdr_name)
- (unknownNameErr rdr_name)
--}
-
+lookupSigOccRn = lookupBndrRn
+
-- Look in both local and global env
lookup_occ global_env local_env rdr_name
diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs
index 1b19d4b69ff7..260b9c640b54 100644
--- a/ghc/compiler/rename/RnSource.lhs
+++ b/ghc/compiler/rename/RnSource.lhs
@@ -25,7 +25,7 @@ import RnEnv ( bindTyVarsRn, lookupBndrRn, lookupOccRn, getIPName,
lookupImplicitOccRn, lookupImplicitOccsRn,
bindLocalsRn, bindLocalRn, bindLocalsFVRn, bindUVarRn,
bindTyVarsFVRn, bindTyVarsFV2Rn, extendTyVarEnvFVRn,
- bindCoreLocalFVRn, bindCoreLocalsFVRn,
+ bindCoreLocalFVRn, bindCoreLocalsFVRn, bindLocalNames,
checkDupOrQualNames, checkDupNames,
mkImportedGlobalName, mkImportedGlobalFromRdrName,
newDFunName, getDFunKey, newImplicitBinder,
@@ -299,14 +299,19 @@ rnDecl (InstD (InstDecl inst_ty mbinds uprags dfun_rdr_name src_loc))
rnMethodBinds mbinds
) `thenRn` \ (mbinds', meth_fvs) ->
let
- binders = mkNameSet (map fst (bagToList (collectMonoBinders mbinds')))
+ binders = map fst (bagToList (collectMonoBinders mbinds'))
+ binder_set = mkNameSet binders
in
-- Rename the prags and signatures.
-- Note that the type variables are not in scope here,
-- so that instance Eq a => Eq (T a) where
-- {-# SPECIALISE instance Eq a => Eq (T [a]) #-}
-- works OK.
- renameSigs (okInstDclSig binders) uprags `thenRn` \ (new_uprags, prag_fvs) ->
+ --
+ -- But the (unqualified) method names are in scope
+ bindLocalNames binders (
+ renameSigs (okInstDclSig binder_set) uprags
+ ) `thenRn` \ (new_uprags, prag_fvs) ->
getModeRn `thenRn` \ mode ->
(case mode of
--
GitLab