From: simonpj@microsoft.com Date: Tue, 28 Oct 2008 11:04:45 +0000 (+0000) Subject: Fix Trac #2723: keep track of record field names in the renamer X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=61bcd16d4f3d4cf84b26bf7bb92f16f0440b7071 Fix Trac #2723: keep track of record field names in the renamer The idea here is that with -XNamedFieldPuns and -XRecordWildCards we don't want to report shadowing errors for let fld = in C { .. } But to suppress such shadowing errors, the renamer needs to know that 'fld' *is* a record selector. Hence the new NameSet in TcRnFypes.RecFieldEnv --- diff --git a/compiler/basicTypes/RdrName.lhs b/compiler/basicTypes/RdrName.lhs index 56d4d20..31ffe6a 100644 --- a/compiler/basicTypes/RdrName.lhs +++ b/compiler/basicTypes/RdrName.lhs @@ -367,6 +367,12 @@ data GlobalRdrElt gre_prov :: Provenance -- ^ Why it's in scope } +-- | The children of a Name are the things that are abbreviated by the ".." +-- notation in export lists. Specifically: +-- TyCon Children are * data constructors +-- * record field ids +-- Class Children are * class operations +-- Each child has the parent thing as its Parent data Parent = NoParent | ParentIs Name deriving (Eq) diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index b95937d..e1d90e8 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -41,8 +41,9 @@ import HsSyn import RdrHsSyn ( extractHsTyRdrTyVars ) import RdrName import HscTypes ( availNames, ModIface(..), FixItem(..), lookupFixity) -import TcEnv ( tcLookupDataCon, isBrackStage ) +import TcEnv ( tcLookupDataCon, tcLookupField, isBrackStage ) import TcRnMonad +import Id ( isRecordSelector ) import Name ( Name, nameIsLocalOrFrom, mkInternalName, isWiredInName, nameSrcLoc, nameSrcSpan, nameOccName, nameModule, isExternalName ) import NameSet @@ -230,9 +231,16 @@ lookupInstDeclBndr cls rdr = lookup_located_sub_bndr is_op doc rdr ----------------------------------------------- lookupRecordBndr :: Maybe (Located Name) -> Located RdrName -> RnM (Located Name) -- Used for record construction and pattern matching --- When the -fdisambiguate-record-fields flag is on, take account of the +-- When the -XDisambiguateRecordFields flag is on, take account of the -- constructor name to disambiguate which field to use; it's just the -- same as for instance decls +-- +-- NB: Consider this: +-- module Foo where { data R = R { fld :: Int } } +-- module Odd where { import Foo; fld x = x { fld = 3 } } +-- Arguably this should work, because the reference to 'fld' is +-- unambiguous because there is only one field id 'fld' in scope. +-- But currently it's rejected. lookupRecordBndr Nothing rdr_name = lookupLocatedGlobalOccRn rdr_name lookupRecordBndr (Just (L _ data_con)) rdr_name @@ -261,7 +269,7 @@ lookupConstructorFields :: Name -> RnM [Name] lookupConstructorFields con_name = do { this_mod <- getModule ; if nameIsLocalOrFrom this_mod con_name then - do { field_env <- getRecFieldEnv + do { RecFields field_env _ <- getRecFieldEnv ; return (lookupNameEnv field_env con_name `orElse` []) } else do { con <- tcLookupDataCon con_name @@ -913,14 +921,31 @@ checkShadowedNames doc_str (global_env,local_env) loc_rdr_names where check_shadow (loc, occ) | Just n <- mb_local = complain [ptext (sLit "bound at") <+> ppr (nameSrcLoc n)] - | not (null gres) = complain (map pprNameProvenance gres) - | otherwise = return () + | otherwise = do { gres' <- filterM is_shadowed_gre gres + ; complain (map pprNameProvenance gres') } where + complain [] = return () complain pp_locs = addWarnAt loc (shadowedNameWarn doc_str occ pp_locs) mb_local = lookupLocalRdrOcc local_env occ gres = lookupGRE_RdrName (mkRdrUnqual occ) global_env -- Make an Unqualified RdrName and look that up, so that -- we don't find any GREs that are in scope qualified-only + + is_shadowed_gre :: GlobalRdrElt -> RnM Bool + -- Returns False for record selectors that are shadowed, when + -- punning or wild-cards are on (cf Trac #2723) + is_shadowed_gre gre@(GRE { gre_par = ParentIs _ }) + = do { dflags <- getDOpts + ; if (dopt Opt_RecordPuns dflags || dopt Opt_RecordWildCards dflags) + then do { is_fld <- is_rec_fld gre; return (not is_fld) } + else return True } + is_shadowed_gre _other = return True + + is_rec_fld gre -- Return True for record selector ids + | isLocalGRE gre = do { RecFields _ fld_set <- getRecFieldEnv + ; return (gre_name gre `elemNameSet` fld_set) } + | otherwise = do { sel_id <- tcLookupField (gre_name gre) + ; return (isRecordSelector sel_id) } \end{code} diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 00ab971..521d715 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -1047,14 +1047,16 @@ extendRecordFieldEnv decls ; return $ unLoc x'} get (L _ (TyData { tcdCons = cons })) env = foldrM get_con env cons - get _ env = return env + get _ env = return env - get_con (L _ (ConDecl { con_name = con, con_details = RecCon flds })) env + get_con (L _ (ConDecl { con_name = con, con_details = RecCon flds })) + (RecFields env fld_set) = do { con' <- lookup con - ; flds' <- mappM lookup (map cd_fld_name flds) - ; return $ extendNameEnv env con' flds' } - get_con _ env - = return env + ; flds' <- mappM lookup (map cd_fld_name flds) + ; let env' = extendNameEnv env con' flds' + fld_set' = addListToNameSet fld_set flds' + ; return $ (RecFields env' fld_set') } + get_con _ env = return env \end{code} %********************************************************* diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs index b0678c7..d038845 100644 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.lhs @@ -140,7 +140,7 @@ Then the renamer (which does not keep track of what is a record selector and what is not) will rename the definition thus f_7 = e { f_7 = True } Now the type checker will find f_7 in the *local* type environment, not -the global one. It's wrong, of course, but we want to report a tidy +the global (imported) one. It's wrong, of course, but we want to report a tidy error, not in TcEnv.notFound. -} tcLookupDataCon :: Name -> TcM DataCon diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index 11036f4..eedf00b 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -85,7 +85,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this tcg_src = hsc_src, tcg_rdr_env = hsc_global_rdr_env hsc_env, tcg_fix_env = emptyNameEnv, - tcg_field_env = emptyNameEnv, + tcg_field_env = RecFields emptyNameEnv emptyNameSet, tcg_default = Nothing, tcg_type_env = hsc_global_type_env hsc_env, tcg_type_env_var = type_env_var, diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index 45907fe..7b4f85a 100644 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@ -13,7 +13,7 @@ module TcRnTypes( IfGblEnv(..), IfLclEnv(..), -- Ranamer types - ErrCtxt, RecFieldEnv, + ErrCtxt, RecFieldEnv(..), ImportAvails(..), emptyImportAvails, plusImportAvails, WhereFrom(..), mkModDeps, @@ -225,11 +225,16 @@ data TcGblEnv tcg_hpc :: AnyHpcUsage -- True if any part of the prog uses hpc instrumentation. } -type RecFieldEnv = NameEnv [Name] -- Maps a constructor name *in this module* - -- to the fields for that constructor +data RecFieldEnv + = RecFields (NameEnv [Name]) -- Maps a constructor name *in this module* + -- to the fields for that constructor + NameSet -- Set of all fields declared *in this module*; + -- used to suppress name-shadowing complaints + -- when using record wild cards + -- E.g. let fld = e in C {..} -- This is used when dealing with ".." notation in record -- construction and pattern matching. - -- The FieldEnv deals *only* with constructors defined in *thie* + -- The FieldEnv deals *only* with constructors defined in *this* -- module. For imported modules, we get the same info from the -- TypeEnv \end{code}