From 459870b70715b066aadd6a9defc87fb1ffb45bf4 Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Thu, 10 Apr 2008 09:43:36 +0000 Subject: [PATCH] Fix Trac #2205, which I introduced recently --- compiler/rename/RnBinds.lhs | 12 ++--- compiler/rename/RnEnv.lhs | 88 ++++++++++++++++--------------------- compiler/rename/RnNames.lhs | 13 +++--- compiler/rename/RnSource.lhs | 21 +++++---- compiler/typecheck/TcRnDriver.lhs | 2 +- 5 files changed, 64 insertions(+), 72 deletions(-) diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs index 7c7046e..667885d 100644 --- a/compiler/rename/RnBinds.lhs +++ b/compiler/rename/RnBinds.lhs @@ -190,7 +190,7 @@ rnTopBindsRHS bound_names binds = rnTopBinds :: HsValBinds RdrName -> RnM (HsValBinds Name, DefUses) rnTopBinds b = - do nl <- rnTopBindsLHS emptyOccEnv b + do nl <- rnTopBindsLHS emptyFsEnv b let bound_names = map unLoc (collectHsValBinders nl) bindLocalNames bound_names $ rnTopBindsRHS bound_names nl @@ -413,18 +413,18 @@ rnValBindsAndThen binds@(ValBindsIn _ sigs) thing_inside makeMiniFixityEnv :: [LFixitySig RdrName] -> RnM MiniFixityEnv -makeMiniFixityEnv decls = foldlM add_one emptyOccEnv decls +makeMiniFixityEnv decls = foldlM add_one emptyFsEnv decls where add_one env (L loc (FixitySig (L name_loc name) fixity)) = do { -- this fixity decl is a duplicate iff -- the ReaderName's OccName's FastString is already in the env -- (we only need to check the local fix_env because -- definitions of non-local will be caught elsewhere) - let {occ = rdrNameOcc name; - fix_item = L loc fixity}; + let { fs = occNameFS (rdrNameOcc name) + ; fix_item = L loc fixity }; - case lookupOccEnv env occ of - Nothing -> return $ extendOccEnv env occ fix_item + case lookupFsEnv env fs of + Nothing -> return $ extendFsEnv env fs fix_item Just (L loc' _) -> do { setSrcSpan loc $ addLocErr (L name_loc name) (dupFixityDecl loc') diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index d9802f5..f6f725f 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -26,11 +26,11 @@ module RnEnv ( newLocalsRn, newIPNameRn, bindLocalNames, bindLocalNamesFV, - MiniFixityEnv, bindLocalNamesFV_WithFixities, + MiniFixityEnv, emptyFsEnv, extendFsEnv, lookupFsEnv, + bindLocalNamesFV_WithFixities, bindLocatedLocalsFV, bindLocatedLocalsRn, bindSigTyVarsFV, bindPatSigTyVars, bindPatSigTyVarsFV, bindTyVarsRn, extendTyVarEnvFVRn, - bindLocalFixities, checkDupRdrNames, checkDupNames, checkShadowedNames, checkDupAndShadowedRdrNames, @@ -528,61 +528,31 @@ lookupQualifiedName rdr_name %********************************************************* \begin{code} -lookupLocalDataTcNames :: RdrName -> RnM [Name] --- GHC extension: look up both the tycon and data con --- for con-like things --- Complain if neither is in scope -lookupLocalDataTcNames rdr_name - | Just n <- isExact_maybe rdr_name - -- Special case for (:), which doesn't get into the GlobalRdrEnv - = return [n] -- For this we don't need to try the tycon too - | otherwise - = do { mb_gres <- mapM lookupGreLocalRn (dataTcOccs rdr_name) - ; case [gre_name gre | Just gre <- mb_gres] of - [] -> do { - -- run for error reporting - ; unboundName rdr_name - ; return [] } - names -> return names - } +-------------------------------- +type FastStringEnv a = UniqFM a -- Keyed by FastString + + +emptyFsEnv :: FastStringEnv a +lookupFsEnv :: FastStringEnv a -> FastString -> Maybe a +extendFsEnv :: FastStringEnv a -> FastString -> a -> FastStringEnv a + +emptyFsEnv = emptyUFM +lookupFsEnv = lookupUFM +extendFsEnv = addToUFM -------------------------------- -type MiniFixityEnv = OccEnv (Located Fixity) +type MiniFixityEnv = FastStringEnv (Located Fixity) -- Mini fixity env for the names we're about -- to bind, in a single binding group -- + -- It is keyed by the *FastString*, not the *OccName*, because + -- the single fixity decl infix 3 T + -- affects both the data constructor T and the type constrctor T + -- -- We keep the location so that if we find -- a duplicate, we can report it sensibly -bindLocalFixities :: [FixitySig RdrName] -> (UniqFM (Located Fixity) -> RnM a) -> RnM a --- Used for nested fixity decls: --- bind the names that are in scope already; --- pass the rest to the continuation for later --- as a FastString->(Located Fixity) map --- --- No need to worry about type constructors here, --- Should check for duplicates? -bindLocalFixities fixes thing_inside - | null fixes = thing_inside emptyUFM - | otherwise = do ls <- mappM rn_sig fixes - let (now, later) = nowAndLater ls - extendFixityEnv now $ thing_inside later - where - rn_sig (FixitySig lv@(L loc v) fix) = do - vopt <- lookupBndrRn_maybe v - case vopt of - Just new_v -> returnM (Left (new_v, (FixItem (rdrNameOcc v) fix))) - Nothing -> returnM (Right (occNameFS $ rdrNameOcc v, (L loc fix))) - - nowAndLater :: [Either (Name, FixItem) (FastString, Located Fixity)] - -> ([(Name,FixItem)], UniqFM (Located Fixity)) - nowAndLater ls = - foldr (\ cur -> \ (now, later) -> - case cur of - Left (n, f) -> ((n, f) : now, later) - Right (fs, f) -> (now, addToUFM later fs f)) - ([], emptyUFM) ls - +-------------------------------- -- Used for nested fixity decls to bind names along with their fixities. -- the fixities are given as a UFM from an OccName's FastString to a fixity decl -- Also check for unused binders @@ -598,7 +568,7 @@ bindLocalNamesFV_WithFixities names fixities thing_inside boundFixities = foldr (\ name -> \ acc -> -- check whether this name has a fixity decl - case lookupOccEnv fixities (nameOccName name) of + case lookupFsEnv fixities (occNameFS (nameOccName name)) of Just (L _ fix) -> (name, FixItem (nameOccName name) fix) : acc Nothing -> acc) [] names -- bind the names; extend the fixity env; do the thing inside @@ -658,6 +628,24 @@ lookupTyFixityRn :: Located Name -> RnM Fixity lookupTyFixityRn (L loc n) = lookupFixityRn n --------------- +lookupLocalDataTcNames :: RdrName -> RnM [Name] +-- GHC extension: look up both the tycon and data con +-- for con-like things +-- Complain if neither is in scope +lookupLocalDataTcNames rdr_name + | Just n <- isExact_maybe rdr_name + -- Special case for (:), which doesn't get into the GlobalRdrEnv + = return [n] -- For this we don't need to try the tycon too + | otherwise + = do { mb_gres <- mapM lookupGreLocalRn (dataTcOccs rdr_name) + ; case [gre_name gre | Just gre <- mb_gres] of + [] -> do { + -- run for error reporting + ; unboundName rdr_name + ; return [] } + names -> return names + } + dataTcOccs :: RdrName -> [RdrName] -- If the input is a data constructor, return both it and a type -- constructor. This is useful when we aren't sure which we are diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs index 591d234..e5cd741 100644 --- a/compiler/rename/RnNames.lhs +++ b/compiler/rename/RnNames.lhs @@ -274,8 +274,8 @@ From the top-level declarations of this module produce * the ImportAvails created by its bindings. -Note [Shadowing in extendRdrEnvRn] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Shadowing in extendGlobalRdrEnvRn] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Usually when etending the GlobalRdrEnv we complain if a new binding duplicates an existing one. By adding the bindings one at a time, this check also complains if we add two new bindings for the same name. @@ -306,6 +306,7 @@ extendGlobalRdrEnvRn shadowP avails new_fixities -- Delete new_occs from global and local envs -- We are going to shadow them + -- See Note [Shadowing in extendGlobalRdrEnvRn] new_occs = map (nameOccName . gre_name) gres rdr_env1 = hideSomeUnquals rdr_env new_occs lcl_env1 = lcl_env { tcl_rdr = delListFromOccEnv (tcl_rdr lcl_env) new_occs } @@ -317,6 +318,7 @@ extendGlobalRdrEnvRn shadowP avails new_fixities ; (rdr_env', fix_env') <- foldlM extend (rdr_env2, fix_env) gres ; let gbl_env' = gbl_env { tcg_rdr_env = rdr_env', tcg_fix_env = fix_env' } + ; traceRn (text "extendGlobalRdrEnvRn" <+> (ppr new_fixities $$ ppr fix_env $$ ppr fix_env')) ; return (gbl_env', lcl_env2) } where gres = gresFromAvails LocalDef avails @@ -331,11 +333,10 @@ extendGlobalRdrEnvRn shadowP avails new_fixities simple_extend (rdr_env, fix_env) gre = (extendGlobalRdrEnv rdr_env gre, fix_env') where - -- If there is a fixity decl for the gre, - -- add it to the fixity env + -- If there is a fixity decl for the gre, add it to the fixity env name = gre_name gre - occ = nameOccName name - fix_env' = case lookupOccEnv new_fixities occ of + occ = nameOccName name + fix_env' = case lookupFsEnv new_fixities (occNameFS occ) of Nothing -> fix_env Just (L _ fi) -> extendNameEnv fix_env name (FixItem occ fi) \end{code} diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index b3fdd2e..8a2d0f4 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -190,15 +190,15 @@ rnSrcDecls shadowP group@(HsGroup {hs_valds = val_decls, -- (I) Compute the results and return let {rn_group = HsGroup { hs_valds = rn_val_decls, - hs_tyclds = rn_tycl_decls, - hs_instds = rn_inst_decls, + hs_tyclds = rn_tycl_decls, + hs_instds = rn_inst_decls, hs_derivds = rn_deriv_decls, - hs_fixds = rn_fix_decls, - hs_depds = [], -- deprecs are returned in the tcg_env (see below) - -- not in the HsGroup - hs_fords = rn_foreign_decls, - hs_defds = rn_default_decls, - hs_ruleds = rn_rule_decls, + hs_fixds = rn_fix_decls, + hs_depds = [], -- deprecs are returned in the tcg_env + -- (see below) not in the HsGroup + hs_fords = rn_foreign_decls, + hs_defds = rn_default_decls, + hs_ruleds = rn_rule_decls, hs_docs = rn_docs } ; other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs6, src_fvs3, @@ -272,6 +272,9 @@ rnSrcFixityDecls :: [LFixitySig RdrName] -> RnM [LFixitySig Name] -- Rename the fixity decls, so we can put -- the renamed decls in the renamed syntax tree -- Errors if the thing being fixed is not defined locally. +-- +-- The returned FixitySigs are not actually used for anything, +-- except perhaps the GHCi API rnSrcFixityDecls fix_decls = do fix_decls <- mapM rn_decl fix_decls return (concat fix_decls) @@ -280,7 +283,7 @@ rnSrcFixityDecls fix_decls -- GHC extension: look up both the tycon and data con -- for con-like things; hence returning a list -- If neither are in scope, report an error; otherwise - -- add both to the fixity env + -- return a fixity sig for each (slightly odd) rn_decl (L loc (FixitySig (L name_loc rdr_name) fixity)) = setSrcSpan name_loc $ -- this lookup will fail if the definition isn't local diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 1b09923..7d023dd 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -292,7 +292,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) -- this tcg_env at all) avails <- getLocalNonValBinders (mkFakeGroup ldecls) ; tc_envs <- extendGlobalRdrEnvRn False avails - emptyOccEnv {- no fixity decls -} ; + emptyFsEnv {- no fixity decls -} ; setEnvs tc_envs $ do { -- 1.7.10.4