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 = <blah> 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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}