summaryrefslogtreecommitdiff
path: root/compiler/rename
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/rename')
-rw-r--r--compiler/rename/RnEnv.hs192
-rw-r--r--compiler/rename/RnExpr.hs11
-rw-r--r--compiler/rename/RnNames.hs425
-rw-r--r--compiler/rename/RnPat.hs161
-rw-r--r--compiler/rename/RnSource.hs74
-rw-r--r--compiler/rename/RnTypes.hs42
6 files changed, 601 insertions, 304 deletions
diff --git a/compiler/rename/RnEnv.hs b/compiler/rename/RnEnv.hs
index fa0e010635..79f0c0826e 100644
--- a/compiler/rename/RnEnv.hs
+++ b/compiler/rename/RnEnv.hs
@@ -14,6 +14,7 @@ module RnEnv (
lookupLocalOccThLvl_maybe,
lookupTypeOccRn, lookupKindOccRn,
lookupGlobalOccRn, lookupGlobalOccRn_maybe,
+ lookupOccRn_overloaded, lookupGlobalOccRn_overloaded,
reportUnboundName, unknownNameSuggestions,
HsSigCtxt(..), lookupLocalTcNames, lookupSigOccRn,
@@ -25,6 +26,7 @@ module RnEnv (
lookupSyntaxName, lookupSyntaxNames, lookupIfThenElse,
lookupGreAvailRn,
getLookupOccRn, addUsedRdrNames,
+ addUsedRdrName,
newLocalBndrRn, newLocalBndrsRn,
bindLocalNames, bindLocalNamesFV,
@@ -38,7 +40,8 @@ module RnEnv (
addFvRn, mapFvRn, mapMaybeFvRn, mapFvRnCPS,
warnUnusedMatches,
warnUnusedTopBinds, warnUnusedLocalBinds,
- dataTcOccs, kindSigErr, perhapsForallMsg,
+ mkFieldEnv,
+ dataTcOccs, kindSigErr, perhapsForallMsg, unknownSubordinateErr,
HsDocContext(..), docOfHsDocContext
) where
@@ -49,18 +52,17 @@ import IfaceEnv
import HsSyn
import RdrName
import HscTypes
-import TcEnv ( tcLookupDataCon, tcLookupField, isBrackStage )
+import TcEnv
import TcRnMonad
import RdrHsSyn ( setRdrNameSpace )
-import Id ( isRecordSelector )
import Name
import NameSet
import NameEnv
import Avail
import Module
import ConLike
-import DataCon ( dataConFieldLabels, dataConTyCon )
-import TyCon ( isTupleTyCon, tyConArity )
+import DataCon
+import TyCon
import PrelNames ( mkUnboundName, isUnboundName, rOOT_MAIN, forall_tv_RDR )
import ErrUtils ( MsgDoc )
import BasicTypes ( Fixity(..), FixityDirection(..), minPrecedence, defaultFixity )
@@ -413,7 +415,7 @@ lookupInstDeclBndr cls what rdr
-- warnings when a deprecated class
-- method is defined. We only warn
-- when it's used
- (ParentIs cls) doc rdr }
+ (Just cls) doc rdr }
where
doc = what <+> ptext (sLit "of class") <+> quotes (ppr cls)
@@ -428,7 +430,7 @@ lookupFamInstName Nothing tc_rdr -- Family instance; tc_rdr is an *occurrenc
= lookupLocatedOccRn tc_rdr
-----------------------------------------------
-lookupConstructorFields :: Name -> RnM [Name]
+lookupConstructorFields :: Name -> RnM [FieldLabel]
-- Look up the fields of a given constructor
-- * For constructors from this module, use the record field env,
-- which is itself gathered from the (as yet un-typechecked)
@@ -441,7 +443,7 @@ lookupConstructorFields :: Name -> RnM [Name]
lookupConstructorFields con_name
= do { this_mod <- getModule
; if nameIsLocalOrFrom this_mod con_name then
- do { RecFields field_env _ <- getRecFieldEnv
+ do { field_env <- getRecFieldEnv
; return (lookupNameEnv field_env con_name `orElse` []) }
else
do { con <- tcLookupDataCon con_name
@@ -459,10 +461,9 @@ lookupConstructorFields con_name
-- 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.
-
lookupSubBndrOcc :: Bool
- -> Parent -- NoParent => just look it up as usual
- -- ParentIs p => use p to disambiguate
+ -> Maybe Name -- Nothing => just look it up as usual
+ -- Just p => use parent p to disambiguate
-> SDoc -> RdrName
-> RnM Name
lookupSubBndrOcc warnIfDeprec parent doc rdr_name
@@ -497,24 +498,25 @@ lookupSubBndrOcc warnIfDeprec parent doc rdr_name
| isQual rdr_name = rdr_name
| otherwise = greUsedRdrName gre
-lookupSubBndrGREs :: GlobalRdrEnv -> Parent -> RdrName -> [GlobalRdrElt]
--- If Parent = NoParent, just do a normal lookup
--- If Parent = Parent p then find all GREs that
+lookupSubBndrGREs :: GlobalRdrEnv -> Maybe Name -> RdrName -> [GlobalRdrElt]
+-- If parent = Nothing, just do a normal lookup
+-- If parent = Just p then find all GREs that
-- (a) have parent p
-- (b) for Unqual, are in scope qualified or unqualified
-- for Qual, are in scope with that qualification
lookupSubBndrGREs env parent rdr_name
= case parent of
- NoParent -> pickGREs rdr_name gres
- ParentIs p
+ Nothing -> pickGREs rdr_name gres
+ Just p
| isUnqual rdr_name -> filter (parent_is p) gres
| otherwise -> filter (parent_is p) (pickGREs rdr_name gres)
where
gres = lookupGlobalRdrEnv env (rdrNameOcc rdr_name)
- parent_is p (GRE { gre_par = ParentIs p' }) = p == p'
- parent_is _ _ = False
+ parent_is p (GRE { gre_par = ParentIs p' }) = p == p'
+ parent_is p (GRE { gre_par = FldParent { par_is = p'}}) = p == p'
+ parent_is _ _ = False
{-
Note [Family instance binders]
@@ -823,6 +825,60 @@ lookupGlobalOccRn_maybe rdr_name
Just gre -> return (Just (gre_name gre)) }
+-- | Like 'lookupOccRn_maybe', but with a more informative result if
+-- the 'RdrName' happens to be a record selector:
+--
+-- * Nothing -> name not in scope (no error reported)
+-- * Just (Left x) -> name uniquely refers to x,
+-- or there is a name clash (reported)
+-- * Just (Right xs) -> name refers to one or more record selectors;
+-- if overload_ok was False, this list will be
+-- a singleton.
+lookupOccRn_overloaded :: Bool -> RdrName -> RnM (Maybe (Either Name [FieldOcc Name]))
+lookupOccRn_overloaded overload_ok rdr_name
+ = do { local_env <- getLocalRdrEnv
+ ; case lookupLocalRdrEnv local_env rdr_name of {
+ Just name -> return (Just (Left name)) ;
+ Nothing -> do
+ { mb_name <- lookupGlobalOccRn_overloaded overload_ok rdr_name
+ ; case mb_name of {
+ Just name -> return (Just name) ;
+ Nothing -> do
+ { ns <- lookupQualifiedNameGHCi rdr_name
+ -- This test is not expensive,
+ -- and only happens for failed lookups
+ ; case ns of
+ (n:_) -> return $ Just $ Left n -- Unlikely to be more than one...?
+ [] -> return Nothing } } } } }
+
+lookupGlobalOccRn_overloaded :: Bool -> RdrName -> RnM (Maybe (Either Name [FieldOcc Name]))
+lookupGlobalOccRn_overloaded overload_ok rdr_name
+ | Just n <- isExact_maybe rdr_name -- This happens in derived code
+ = do { n' <- lookupExactOcc n; return (Just (Left n')) }
+
+ | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name
+ = do { n <- lookupOrig rdr_mod rdr_occ
+ ; return (Just (Left n)) }
+
+ | otherwise
+ = do { env <- getGlobalRdrEnv
+ ; case lookupGRE_RdrName rdr_name env of
+ [] -> return Nothing
+ [gre] | isRecFldGRE gre
+ -> do { addUsedRdrName True gre rdr_name
+ ; let fld_occ = FieldOcc rdr_name (gre_name gre)
+ ; return (Just (Right [fld_occ])) }
+ | otherwise
+ -> do { addUsedRdrName True gre rdr_name
+ ; return (Just (Left (gre_name gre))) }
+ gres | all isRecFldGRE gres && overload_ok
+ -- Don't record usage for ambiguous selectors
+ -- until we know which is meant
+ -> return (Just (Right (map (FieldOcc rdr_name . gre_name) gres)))
+ gres -> do { addNameClashErrRn rdr_name gres
+ ; return (Just (Left (gre_name (head gres)))) } }
+
+
--------------------------------------------------
-- Lookup in the Global RdrEnv of the module
--------------------------------------------------
@@ -899,15 +955,28 @@ Note [Handling of deprecations]
addUsedRdrName :: Bool -> GlobalRdrElt -> RdrName -> RnM ()
-- Record usage of imported RdrNames
addUsedRdrName warn_if_deprec gre rdr
- = do { unless (isLocalGRE gre) $
- do { env <- getGblEnv
- ; traceRn (text "addUsedRdrName 1" <+> ppr gre)
- ; updMutVar (tcg_used_rdrnames env)
- (\s -> Set.insert rdr s) }
+ = do { if isRecFldGRE gre
+ then addUsedSelector (FieldOcc rdr (gre_name gre))
+ else unless (isLocalGRE gre) $ addOneUsedRdrName rdr
; when warn_if_deprec $
warnIfDeprecated gre }
+addUsedSelector :: FieldOcc Name -> RnM ()
+-- Record usage of record selectors by DuplicateRecordFields
+addUsedSelector n
+ = do { env <- getGblEnv
+ ; traceRn (text "addUsedSelector " <+> ppr n)
+ ; updMutVar (tcg_used_selectors env)
+ (\s -> Set.insert n s) }
+
+addOneUsedRdrName :: RdrName -> RnM ()
+addOneUsedRdrName rdr
+ = do { env <- getGblEnv
+ ; traceRn (text "addUsedRdrName 1" <+> ppr rdr)
+ ; updMutVar (tcg_used_rdrnames env)
+ (\s -> Set.insert rdr s) }
+
addUsedRdrNames :: [RdrName] -> RnM ()
-- Record used sub-binders
-- We don't check for imported-ness here, because it's inconvenient
@@ -934,13 +1003,14 @@ warnIfDeprecated gre@(GRE { gre_name = name, gre_imp = iss })
| otherwise
= return ()
where
+ occ = greOccName gre
name_mod = ASSERT2( isExternalName name, ppr name ) nameModule name
- doc = ptext (sLit "The name") <+> quotes (ppr name) <+> ptext (sLit "is mentioned explicitly")
+ doc = ptext (sLit "The name") <+> quotes (ppr occ) <+> ptext (sLit "is mentioned explicitly")
mk_msg imp_spec txt
= sep [ sep [ ptext (sLit "In the use of")
- <+> pprNonVarNameSpace (occNameSpace (nameOccName name))
- <+> quotes (ppr name)
+ <+> pprNonVarNameSpace (occNameSpace occ)
+ <+> quotes (ppr occ)
, parens imp_msg <> colon ]
, ppr txt ]
where
@@ -953,8 +1023,9 @@ lookupImpDeprec :: ModIface -> GlobalRdrElt -> Maybe WarningTxt
lookupImpDeprec iface gre
= mi_warn_fn iface (gre_name gre) `mplus` -- Bleat if the thing,
case gre_par gre of -- or its parent, is warn'd
- ParentIs p -> mi_warn_fn iface p
- NoParent -> Nothing
+ ParentIs p -> mi_warn_fn iface p
+ FldParent { par_is = p } -> mi_warn_fn iface p
+ NoParent -> Nothing
{-
Note [Used names with interface not loaded]
@@ -1134,7 +1205,7 @@ lookupBindGroupOcc ctxt what rdr_name
where
lookup_cls_op cls
= do { env <- getGlobalRdrEnv
- ; let gres = lookupSubBndrGREs env (ParentIs cls) rdr_name
+ ; let gres = lookupSubBndrGREs env (Just cls) rdr_name
; case gres of
[] -> return (Left (unknownSubordinateErr doc rdr_name))
(gre:_) -> return (Right (gre_name gre)) }
@@ -1541,19 +1612,11 @@ checkShadowedOccs (global_env,local_env) get_loc_occ ns
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 _ })
+ is_shadowed_gre gre | isRecFldGRE gre
= do { dflags <- getDynFlags
- ; if (xopt Opt_RecordPuns dflags || xopt Opt_RecordWildCards dflags)
- then do { is_fld <- is_rec_fld gre; return (not is_fld) }
- else return True }
+ ; return $ not (xopt Opt_RecordPuns dflags || xopt Opt_RecordWildCards dflags) }
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) }
-
{-
************************************************************************
* *
@@ -1772,7 +1835,7 @@ warnUnusedTopBinds gres
let isBoot = tcg_src env == HsBootFile
let noParent gre = case gre_par gre of
NoParent -> True
- ParentIs _ -> False
+ _ -> False
-- Don't warn about unused bindings with parents in
-- .hs-boot files, as you are sometimes required to give
-- unused bindings (trac #3449).
@@ -1797,25 +1860,42 @@ warnUnusedGREs :: [GlobalRdrElt] -> RnM ()
warnUnusedGREs gres = mapM_ warnUnusedGRE gres
warnUnusedLocals :: [Name] -> RnM ()
-warnUnusedLocals names = mapM_ warnUnusedLocal names
+warnUnusedLocals names = do
+ fld_env <- mkFieldEnv <$> getGlobalRdrEnv
+ mapM_ (warnUnusedLocal fld_env) names
-warnUnusedLocal :: Name -> RnM ()
-warnUnusedLocal name
+warnUnusedLocal :: NameEnv (FieldLabelString, Name) -> Name -> RnM ()
+warnUnusedLocal fld_env name
= when (reportable name) $
- addUnusedWarning name (nameSrcSpan name)
+ addUnusedWarning occ (nameSrcSpan name)
(ptext (sLit "Defined but not used"))
+ where
+ occ = case lookupNameEnv fld_env name of
+ Just (fl, _) -> mkVarOccFS fl
+ Nothing -> nameOccName name
warnUnusedGRE :: GlobalRdrElt -> RnM ()
-warnUnusedGRE (GRE { gre_name = name, gre_lcl = lcl, gre_imp = is })
- | lcl = warnUnusedLocal name
+warnUnusedGRE gre@(GRE { gre_name = name, gre_lcl = lcl, gre_imp = is })
+ | lcl = do fld_env <- mkFieldEnv <$> getGlobalRdrEnv
+ warnUnusedLocal fld_env name
| otherwise = when (reportable name) (mapM_ warn is)
where
- warn spec = addUnusedWarning name span msg
+ occ = greOccName gre
+ warn spec = addUnusedWarning occ span msg
where
span = importSpecLoc spec
pp_mod = quotes (ppr (importSpecModule spec))
msg = ptext (sLit "Imported from") <+> pp_mod <+> ptext (sLit "but not used")
+-- | Make a map from selector names to field labels and parent tycon
+-- names, to be used when reporting unused record fields.
+mkFieldEnv :: GlobalRdrEnv -> NameEnv (FieldLabelString, Name)
+mkFieldEnv rdr_env = mkNameEnv [ (gre_name gre, (lbl, par_is (gre_par gre)))
+ | gres <- occEnvElts rdr_env
+ , gre <- gres
+ , Just lbl <- [greLabel gre]
+ ]
+
reportable :: Name -> Bool
reportable name
| isWiredInName name = False -- Don't report unused wired-in names
@@ -1823,17 +1903,18 @@ reportable name
-- from Data.Tuple
| otherwise = not (startsWithUnderscore (nameOccName name))
-addUnusedWarning :: Name -> SrcSpan -> SDoc -> RnM ()
-addUnusedWarning name span msg
+addUnusedWarning :: OccName -> SrcSpan -> SDoc -> RnM ()
+addUnusedWarning occ span msg
= addWarnAt span $
sep [msg <> colon,
- nest 2 $ pprNonVarNameSpace (occNameSpace (nameOccName name))
- <+> quotes (ppr name)]
+ nest 2 $ pprNonVarNameSpace (occNameSpace occ)
+ <+> quotes (ppr occ)]
addNameClashErrRn :: RdrName -> [GlobalRdrElt] -> RnM ()
addNameClashErrRn rdr_name gres
- | all isLocalGRE gres -- If there are two or more *local* defns, we'll have reported
- = return () -- that already, and we don't want an error cascade
+ | all isLocalGRE gres && not (all isRecFldGRE gres)
+ -- If there are two or more *local* defns, we'll have reported
+ = return () -- that already, and we don't want an error cascade
| otherwise
= addErr (vcat [ptext (sLit "Ambiguous occurrence") <+> quotes (ppr rdr_name),
ptext (sLit "It could refer to") <+> vcat (msg1 : msgs)])
@@ -1841,7 +1922,10 @@ addNameClashErrRn rdr_name gres
(np1:nps) = gres
msg1 = ptext (sLit "either") <+> mk_ref np1
msgs = [ptext (sLit " or") <+> mk_ref np | np <- nps]
- mk_ref gre = sep [quotes (ppr (gre_name gre)) <> comma, pprNameProvenance gre]
+ mk_ref gre = sep [nom <> comma, pprNameProvenance gre]
+ where nom = case gre_par gre of
+ FldParent { par_lbl = Just lbl } -> text "the field" <+> quotes (ppr lbl)
+ _ -> quotes (ppr (gre_name gre))
shadowedNameWarn :: OccName -> [SDoc] -> SDoc
shadowedNameWarn occ shadowed_locs
diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs
index d4b5e7288d..ade117cf69 100644
--- a/compiler/rename/RnExpr.hs
+++ b/compiler/rename/RnExpr.hs
@@ -98,16 +98,19 @@ rnUnboundVar v
in_untyped_bracket _ = False
rnExpr (HsVar v)
- = do { mb_name <- lookupOccRn_maybe v
+ = do { mb_name <- lookupOccRn_overloaded False v
; case mb_name of {
Nothing -> rnUnboundVar v ;
- Just name
+ Just (Left name)
| name == nilDataConName -- Treat [] as an ExplicitList, so that
-- OverloadedLists works correctly
-> rnExpr (ExplicitList placeHolderType Nothing [])
| otherwise
- -> finishHsVar name }}
+ -> finishHsVar name ;
+ Just (Right (f:fs)) -> ASSERT( null fs )
+ return (HsSingleRecFld f, unitFV (selectorFieldOcc f)) ;
+ Just (Right []) -> error "runExpr/HsVar" } }
rnExpr (HsIPVar v)
= return (HsIPVar v, emptyFVs)
@@ -257,7 +260,7 @@ rnExpr (RecordCon con_id _ rbinds)
rnExpr (RecordUpd expr rbinds _ _ _)
= do { (expr', fvExpr) <- rnLExpr expr
- ; (rbinds', fvRbinds) <- rnHsRecBinds HsRecFieldUpd rbinds
+ ; (rbinds', fvRbinds) <- rnHsRecUpdFields rbinds
; return (RecordUpd expr' rbinds' PlaceHolder PlaceHolder PlaceHolder,
fvExpr `plusFV` fvRbinds) }
diff --git a/compiler/rename/RnNames.hs b/compiler/rename/RnNames.hs
index a92c8d9c6a..c371d47067 100644
--- a/compiler/rename/RnNames.hs
+++ b/compiler/rename/RnNames.hs
@@ -19,7 +19,7 @@ module RnNames (
import DynFlags
import HsSyn
-import TcEnv ( isBrackStage )
+import TcEnv
import RnEnv
import RnHsDoc ( rnHsDoc )
import LoadIface ( loadSrcInterface )
@@ -30,6 +30,7 @@ import Name
import NameEnv
import NameSet
import Avail
+import FieldLabel
import HscTypes
import RdrName
import RdrHsSyn ( setRdrNameSpace )
@@ -40,12 +41,16 @@ import BasicTypes ( TopLevelFlag(..), StringLiteral(..) )
import ErrUtils
import Util
import FastString
+import FastStringEnv
import ListSetOps
import Control.Monad
+import Data.Either ( partitionEithers, isRight, rights )
+import qualified Data.Foldable as Foldable
import Data.Map ( Map )
import qualified Data.Map as Map
-import Data.List ( partition, (\\), find )
+import Data.Ord ( comparing )
+import Data.List ( partition, (\\), find, sortBy )
import qualified Data.Set as Set
import System.FilePath ((</>))
import System.IO
@@ -509,7 +514,7 @@ extendGlobalRdrEnvRn avails new_fixities
********************************************************************* -}
getLocalNonValBinders :: MiniFixityEnv -> HsGroup RdrName
- -> RnM ((TcGblEnv, TcLclEnv), NameSet)
+ -> RnM ((TcGblEnv, TcLclEnv), NameSet)
-- Get all the top-level binders bound the group *except*
-- for value bindings, which are treated separately
-- Specifically we return AvailInfo for
@@ -525,7 +530,9 @@ getLocalNonValBinders fixity_env
hs_instds = inst_decls,
hs_fords = foreign_decls })
= do { -- Process all type/class decls *except* family instances
- ; tc_avails <- mapM new_tc (tyClGroupConcat tycl_decls)
+ ; overload_ok <- xoptM Opt_DuplicateRecordFields
+ ; (tc_avails, tc_fldss) <- fmap unzip $ mapM (new_tc overload_ok)
+ (tyClGroupConcat tycl_decls)
; traceRn (text "getLocalNonValBinders 1" <+> ppr tc_avails)
; envs <- extendGlobalRdrEnvRn tc_avails fixity_env
; setEnvs envs $ do {
@@ -534,7 +541,8 @@ getLocalNonValBinders fixity_env
-- Process all family instances
-- to bring new data constructors into scope
- ; nti_avails <- concatMapM new_assoc inst_decls
+ ; (nti_availss, nti_fldss) <- mapAndUnzipM (new_assoc overload_ok)
+ inst_decls
-- Finish off with value binders:
-- foreign decls and pattern synonyms for an ordinary module
@@ -544,11 +552,18 @@ getLocalNonValBinders fixity_env
| otherwise = for_hs_bndrs
; val_avails <- mapM new_simple val_bndrs
- ; let avails = nti_avails ++ val_avails
+ ; let avails = concat nti_availss ++ val_avails
new_bndrs = availsToNameSet avails `unionNameSet`
availsToNameSet tc_avails
+ flds = concat nti_fldss ++ concat tc_fldss
; traceRn (text "getLocalNonValBinders 2" <+> ppr avails)
- ; envs <- extendGlobalRdrEnvRn avails fixity_env
+ ; (tcg_env, tcl_env) <- extendGlobalRdrEnvRn avails fixity_env
+
+ -- Extend tcg_field_env with new fields (this used to be the
+ -- work of extendRecordFieldEnv)
+ ; let field_env = extendNameEnvList (tcg_field_env tcg_env) flds
+ envs = (tcg_env { tcg_field_env = field_env }, tcl_env)
+
; return (envs, new_bndrs) } }
where
ValBindsIn _val_binds val_sigs = binds
@@ -567,35 +582,85 @@ getLocalNonValBinders fixity_env
new_simple rdr_name = do{ nm <- newTopSrcBinder rdr_name
; return (Avail nm) }
- new_tc tc_decl -- NOT for type/data instances
- = do { let bndrs = hsLTyClDeclBinders tc_decl
- ; names@(main_name : _) <- mapM newTopSrcBinder bndrs
- ; return (AvailTC main_name names) }
-
- new_assoc :: LInstDecl RdrName -> RnM [AvailInfo]
- new_assoc (L _ (TyFamInstD {})) = return []
+ new_tc :: Bool -> LTyClDecl RdrName
+ -> RnM (AvailInfo, [(Name, [FieldLabel])])
+ new_tc overload_ok tc_decl -- NOT for type/data instances
+ = do { let (bndrs, flds) = hsLTyClDeclBinders tc_decl
+ ; names@(main_name : sub_names) <- mapM newTopSrcBinder bndrs
+ ; flds' <- mapM (new_rec_sel overload_ok sub_names) flds
+ ; let fld_env = case unLoc tc_decl of
+ DataDecl { tcdDataDefn = d } -> mk_fld_env d names flds'
+ _ -> []
+ ; return (AvailTC main_name names flds', fld_env) }
+
+ new_rec_sel :: Bool -> [Name] -> LFieldOcc RdrName -> RnM FieldLabel
+ new_rec_sel _ [] _ = error "new_rec_sel: datatype has no constructors!"
+ new_rec_sel overload_ok (dc:_) (L loc (FieldOcc fld _)) =
+ do { sel_name <- newTopSrcBinder $ L loc $ mkRdrUnqual sel_occ
+ ; return $ fl { flSelector = sel_name } }
+ where
+ lbl = occNameFS $ rdrNameOcc fld
+ fl = mkFieldLabelOccs lbl (nameOccName dc) overload_ok
+ sel_occ = flSelector fl
+
+ -- Calculate the mapping from constructor names to fields, which
+ -- will go in tcg_field_env. It's convenient to do this here where
+ -- we are working with a single datatype definition.
+ mk_fld_env :: HsDataDefn RdrName -> [Name] -> [FieldLabel] -> [(Name, [FieldLabel])]
+ mk_fld_env d names flds = concatMap find_con_flds (dd_cons d)
+ where
+ find_con_flds (L _ (ConDecl { con_names = rdrs
+ , con_details = RecCon cdflds }))
+ = map (\ (L _ rdr) -> ( find_con_name rdr
+ , concatMap find_con_decl_flds (unLoc cdflds)))
+ rdrs
+ find_con_flds _ = []
+
+ find_con_name rdr
+ = expectJust "getLocalNonValBinders/find_con_name" $
+ find (\ n -> nameOccName n == rdrNameOcc rdr) names
+ find_con_decl_flds (L _ x)
+ = map find_con_decl_fld (cd_fld_names x)
+ find_con_decl_fld (L _ (FieldOcc rdr _))
+ = expectJust "getLocalNonValBinders/find_con_decl_fld" $
+ find (\ fl -> flLabel fl == lbl) flds
+ where lbl = occNameFS (rdrNameOcc rdr)
+
+ new_assoc :: Bool -> LInstDecl RdrName
+ -> RnM ([AvailInfo], [(Name, [FieldLabel])])
+ new_assoc _ (L _ (TyFamInstD {})) = return ([], [])
-- type instances don't bind new names
- new_assoc (L _ (DataFamInstD { dfid_inst = d }))
- = do { avail <- new_di Nothing d
- ; return [avail] }
- new_assoc (L _ (ClsInstD { cid_inst = ClsInstDecl
- { cid_poly_ty = inst_ty
- , cid_datafam_insts = adts } }))
+ new_assoc overload_ok (L _ (DataFamInstD d))
+ = do { (avail, flds) <- new_di overload_ok Nothing d
+ ; return ([avail], flds) }
+ new_assoc overload_ok (L _ (ClsInstD (ClsInstDecl { cid_poly_ty = inst_ty
+ , cid_datafam_insts = adts })))
| Just (_, _, L loc cls_rdr, _) <-
splitLHsInstDeclTy_maybe (flattenTopLevelLHsForAllTy inst_ty)
= do { cls_nm <- setSrcSpan loc $ lookupGlobalOccRn cls_rdr
- ; mapM (new_di (Just cls_nm) . unLoc) adts }
+ ; (avails, fldss)
+ <- mapAndUnzipM (new_loc_di overload_ok (Just cls_nm)) adts
+ ; return (avails, concat fldss) }
| otherwise
- = return [] -- Do not crash on ill-formed instances
- -- Eg instance !Show Int Trac #3811c
+ = return ([], []) -- Do not crash on ill-formed instances
+ -- Eg instance !Show Int Trac #3811c
- new_di :: Maybe Name -> DataFamInstDecl RdrName -> RnM AvailInfo
- new_di mb_cls ti_decl
+ new_di :: Bool -> Maybe Name -> DataFamInstDecl RdrName
+ -> RnM (AvailInfo, [(Name, [FieldLabel])])
+ new_di overload_ok mb_cls ti_decl
= do { main_name <- lookupFamInstName mb_cls (dfid_tycon ti_decl)
- ; sub_names <- mapM newTopSrcBinder (hsDataFamInstBinders ti_decl)
- ; return (AvailTC (unLoc main_name) sub_names) }
- -- main_name is not bound here!
+ ; let (bndrs, flds) = hsDataFamInstBinders ti_decl
+ ; sub_names <- mapM newTopSrcBinder bndrs
+ ; flds' <- mapM (new_rec_sel overload_ok sub_names) flds
+ ; let avail = AvailTC (unLoc main_name) sub_names flds'
+ -- main_name is not bound here!
+ fld_env = mk_fld_env (dfid_defn ti_decl) sub_names flds'
+ ; return (avail, fld_env) }
+
+ new_loc_di :: Bool -> Maybe Name -> LDataFamInstDecl RdrName
+ -> RnM (AvailInfo, [(Name, [FieldLabel])])
+ new_loc_di overload_ok mb_cls (L _ d) = new_di overload_ok mb_cls d
{-
Note [Looking up family names in family instances]
@@ -697,8 +762,8 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items))
-- 'combine' is only called for associated types which appear twice
-- in the all_avails. In the example, we combine
-- T(T,T1,T2,T3) and C(C,T) to give (T, T(T,T1,T2,T3), Just C)
- combine (name1, a1@(AvailTC p1 _), mp1)
- (name2, a2@(AvailTC p2 _), mp2)
+ combine (name1, a1@(AvailTC p1 _ []), mp1)
+ (name2, a2@(AvailTC p2 _ []), mp2)
= ASSERT( name1 == name2 && isNothing mp1 && isNothing mp2 )
if p1 == name1 then (name1, a1, Just p2)
else (name1, a2, Just p1)
@@ -760,8 +825,8 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items))
Avail {} -- e.g. f(..)
-> [DodgyImport tc]
- AvailTC _ subs
- | null (drop 1 subs) -- e.g. T(..) where T is a synonym
+ AvailTC _ subs fs
+ | null (drop 1 subs) && null fs -- e.g. T(..) where T is a synonym
-> [DodgyImport tc]
| not (is_qual decl_spec) -- e.g. import M( T(..) )
@@ -772,12 +837,12 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items))
renamed_ie = IEThingAll (L l name)
sub_avails = case avail of
- Avail {} -> []
- AvailTC name2 subs -> [(renamed_ie, AvailTC name2 (subs \\ [name]))]
+ Avail {} -> []
+ AvailTC name2 subs fs -> [(renamed_ie, AvailTC name2 (subs \\ [name]) fs)]
case mb_parent of
Nothing -> return ([(renamed_ie, avail)], warns)
-- non-associated ty/cls
- Just parent -> return ((renamed_ie, AvailTC parent [name]) : sub_avails, warns)
+ Just parent -> return ((renamed_ie, AvailTC parent [name] []) : sub_avails, warns)
-- associated type
IEThingAbs (L l tc)
@@ -794,8 +859,8 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items))
-> do nameAvail <- lookup_name tc
return ([mkIEThingAbs l nameAvail], [])
- IEThingWith (L l rdr_tc) rdr_ns -> do
- (name, AvailTC _ ns, mb_parent) <- lookup_name rdr_tc
+ IEThingWith (L l rdr_tc) rdr_ns rdr_fs -> ASSERT2(null rdr_fs, ppr rdr_fs) do
+ (name, AvailTC _ ns subflds, mb_parent) <- lookup_name rdr_tc
-- Look up the children in the sub-names of the parent
let subnames = case ns of -- The tc is first in ns,
@@ -803,23 +868,22 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items))
-- See the AvailTC Invariant in Avail.hs
(n1:ns1) | n1 == name -> ns1
| otherwise -> ns
- mb_children = lookupChildren subnames rdr_ns
-
- children <- if any isNothing mb_children
- then failLookupWith BadImport
- else return (catMaybes mb_children)
-
- case mb_parent of
- -- non-associated ty/cls
- Nothing -> return ([(IEThingWith (L l name) children,
- AvailTC name (name:map unLoc children))],
- [])
- -- associated ty
- Just parent -> return ([(IEThingWith (L l name) children,
- AvailTC name (map unLoc children)),
- (IEThingWith (L l name) children,
- AvailTC parent [name])],
- [])
+ case lookupChildren (map Left subnames ++ map Right subflds) rdr_ns of
+ Nothing -> failLookupWith BadImport
+ Just (childnames, childflds) ->
+ case mb_parent of
+ -- non-associated ty/cls
+ Nothing
+ -> return ([(IEThingWith (L l name) childnames childflds,
+ AvailTC name (name:map unLoc childnames) (map unLoc childflds))],
+ [])
+ -- associated ty
+ Just parent
+ -> return ([(IEThingWith (L l name) childnames childflds,
+ AvailTC name (map unLoc childnames) (map unLoc childflds)),
+ (IEThingWith (L l name) childnames childflds,
+ AvailTC parent [name] [])],
+ [])
_other -> failLookupWith IllegalImport
-- could be IEModuleContents, IEGroup, IEDoc, IEDocNamed
@@ -829,7 +893,7 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items))
mkIEThingAbs l (n, av, Nothing ) = (IEThingAbs (L l n),
trimAvail av n)
mkIEThingAbs l (n, _, Just parent) = (IEThingAbs (L l n),
- AvailTC parent [n])
+ AvailTC parent [n] [])
handle_bad_import m = catchIELookup m $ \err -> case err of
BadImport | want_hiding -> return ([], [BadImportW])
@@ -871,20 +935,31 @@ plusAvail :: AvailInfo -> AvailInfo -> AvailInfo
plusAvail a1 a2
| debugIsOn && availName a1 /= availName a2
= pprPanic "RnEnv.plusAvail names differ" (hsep [ppr a1,ppr a2])
-plusAvail a1@(Avail {}) (Avail {}) = a1
-plusAvail (AvailTC _ []) a2@(AvailTC {}) = a2
-plusAvail a1@(AvailTC {}) (AvailTC _ []) = a1
-plusAvail (AvailTC n1 (s1:ss1)) (AvailTC n2 (s2:ss2))
+plusAvail a1@(Avail {}) (Avail {}) = a1
+plusAvail (AvailTC _ [] []) a2@(AvailTC {}) = a2
+plusAvail a1@(AvailTC {}) (AvailTC _ [] []) = a1
+plusAvail (AvailTC n1 (s1:ss1) fs1) (AvailTC n2 (s2:ss2) fs2)
= case (n1==s1, n2==s2) of -- Maintain invariant the parent is first
(True,True) -> AvailTC n1 (s1 : (ss1 `unionLists` ss2))
+ (fs1 `unionLists` fs2)
(True,False) -> AvailTC n1 (s1 : (ss1 `unionLists` (s2:ss2)))
+ (fs1 `unionLists` fs2)
(False,True) -> AvailTC n1 (s2 : ((s1:ss1) `unionLists` ss2))
+ (fs1 `unionLists` fs2)
(False,False) -> AvailTC n1 ((s1:ss1) `unionLists` (s2:ss2))
+ (fs1 `unionLists` fs2)
+plusAvail (AvailTC n1 ss1 fs1) (AvailTC _ [] fs2)
+ = AvailTC n1 ss1 (fs1 `unionLists` fs2)
+plusAvail (AvailTC n1 [] fs1) (AvailTC _ ss2 fs2)
+ = AvailTC n1 ss2 (fs1 `unionLists` fs2)
plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [ppr a1,ppr a2])
+-- | trims an 'AvailInfo' to keep only a single name
trimAvail :: AvailInfo -> Name -> AvailInfo
-trimAvail (Avail n) _ = Avail n
-trimAvail (AvailTC n ns) m = ASSERT( m `elem` ns) AvailTC n [m]
+trimAvail (Avail n) _ = Avail n
+trimAvail (AvailTC n ns fs) m = case find ((== m) . flSelector) fs of
+ Just x -> AvailTC n [] [x]
+ Nothing -> ASSERT (m `elem` ns) AvailTC n [m] []
-- | filters 'AvailInfo's by the given predicate
filterAvails :: (Name -> Bool) -> [AvailInfo] -> [AvailInfo]
@@ -896,9 +971,10 @@ filterAvail keep ie rest =
case ie of
Avail n | keep n -> ie : rest
| otherwise -> rest
- AvailTC tc ns ->
- let left = filter keep ns in
- if null left then rest else AvailTC tc left : rest
+ AvailTC tc ns fs ->
+ let ns' = filter keep ns
+ fs' = filter (keep . flSelector) fs in
+ if null ns' && null fs' then rest else AvailTC tc ns' fs' : rest
-- | Given an import\/export spec, construct the appropriate 'GlobalRdrElt's.
gresFromIE :: ImpDeclSpec -> (LIE Name, AvailInfo) -> [GlobalRdrElt]
@@ -913,16 +989,36 @@ gresFromIE decl_spec (L loc ie, avail)
where
item_spec = ImpSome { is_explicit = is_explicit name, is_iloc = loc }
-mkChildEnv :: [GlobalRdrElt] -> NameEnv [Name]
+
+{-
+Note [Children for duplicate record fields]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider the module
+
+ {-# LANGUAGE DuplicateRecordFields #-}
+ module M (F(foo, MkFInt, MkFBool)) where
+ data family F a
+ data instance F Int = MkFInt { foo :: Int }
+ data instance F Bool = MkFBool { foo :: Bool }
+
+The `foo` in the export list refers to *both* selectors! For this
+reason, lookupChildren builds an environment that maps the FastString
+to a list of items, rather than a single item.
+-}
+
+mkChildEnv :: [GlobalRdrElt] -> NameEnv [GlobalRdrElt]
mkChildEnv gres = foldr add emptyNameEnv gres
- where
- add (GRE { gre_name = n, gre_par = ParentIs p }) env = extendNameEnv_Acc (:) singleton env p n
- add _ env = env
+ where
+ add gre env = case gre_par gre of
+ FldParent p _ -> extendNameEnv_Acc (:) singleton env p gre
+ ParentIs p -> extendNameEnv_Acc (:) singleton env p gre
+ NoParent -> env
-findChildren :: NameEnv [Name] -> Name -> [Name]
+findChildren :: NameEnv [a] -> Name -> [a]
findChildren env n = lookupNameEnv env n `orElse` []
-lookupChildren :: [Name] -> [Located RdrName] -> [Maybe (Located Name)]
+lookupChildren :: [Either Name FieldLabel] -> [Located RdrName]
+ -> Maybe ([Located Name], [Located FieldLabel])
-- (lookupChildren all_kids rdr_items) maps each rdr_item to its
-- corresponding Name all_kids, if the former exists
-- The matching is done by FastString, not OccName, so that
@@ -931,14 +1027,30 @@ lookupChildren :: [Name] -> [Located RdrName] -> [Maybe (Located Name)]
-- the RdrName for AssocTy may have a (bogus) DataName namespace
-- (Really the rdr_items should be FastStrings in the first place.)
lookupChildren all_kids rdr_items
- -- = map (lookupFsEnv kid_env . occNameFS . rdrNameOcc) rdr_items
- = map doOne rdr_items
+ = do xs <- mapM doOne rdr_items
+ return (fmap concat (partitionEithers xs))
where
doOne (L l r) = case (lookupFsEnv kid_env . occNameFS . rdrNameOcc) r of
- Just n -> Just (L l n)
- Nothing -> Nothing
+ Just [Left n] -> Just (Left (L l n))
+ Just rs | all isRight rs -> Just (Right (map (L l) (rights rs)))
+ _ -> Nothing
+
+ -- See Note [Children for duplicate record fields]
+ kid_env = extendFsEnvList_C (++) emptyFsEnv
+ [(either (occNameFS . nameOccName) flLabel x, [x]) | x <- all_kids]
+
+
+classifyGREs :: [GlobalRdrElt] -> ([Name], [FieldLabel])
+classifyGREs = partitionEithers . map classifyGRE
+
+classifyGRE :: GlobalRdrElt -> Either Name FieldLabel
+classifyGRE gre = case gre_par gre of
+ FldParent _ Nothing -> Right (FieldLabel (occNameFS (nameOccName n)) False n)
+ FldParent _ (Just lbl) -> Right (FieldLabel lbl True n)
+ _ -> Left n
+ where
+ n = gre_name gre
- kid_env = mkFsEnv [(occNameFS (nameOccName n), n) | n <- all_kids]
-- | Combines 'AvailInfo's from the same family
-- 'avails' may have several items with the same availName
@@ -1048,6 +1160,7 @@ rnExports explicit_mod exports
; (rn_exports, avails) <- exports_from_avail real_exports rdr_env imports this_mod
; let final_avails = nubAvails avails -- Combine families
+ final_ns = availsToNameSetWithSelectors final_avails
; traceRn (text "rnExports: Exports:" <+> ppr final_avails)
@@ -1056,7 +1169,7 @@ rnExports explicit_mod exports
Nothing -> Nothing
Just _ -> rn_exports,
tcg_dus = tcg_dus tcg_env `plusDU`
- usesOnly (availsToNameSet final_avails) }) }
+ usesOnly final_ns }) }
exports_from_avail :: Maybe (Located [LIE RdrName])
-- Nothing => no explicit export list
@@ -1082,7 +1195,8 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
do_litem :: ExportAccum -> LIE RdrName -> RnM ExportAccum
do_litem acc lie = setSrcSpan (getLoc lie) (exports_from_item acc lie)
- kids_env :: NameEnv [Name] -- Maps a parent to its in-scope children
+ -- Maps a parent to its in-scope children
+ kids_env :: NameEnv [GlobalRdrElt]
kids_env = mkChildEnv (globalRdrEnvElts rdr_env)
imported_modules = [ qual_name
@@ -1157,31 +1271,33 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
lookup_ie ie@(IEThingAll (L l rdr))
= do name <- lookupGlobalOccRn rdr
- let kids = findChildren kids_env name
- addUsedKids rdr kids
+ let gres = findChildren kids_env name
+ (non_flds, flds) = classifyGREs gres
+ addUsedKids rdr gres
warnDodgyExports <- woptM Opt_WarnDodgyExports
- when (null kids) $
+ when (null gres) $
if isTyConName name
then when warnDodgyExports $ addWarn (dodgyExportWarn name)
else -- This occurs when you export T(..), but
-- only import T abstractly, or T is a synonym.
addErr (exportItemErr ie)
+ return ( IEThingAll (L l name)
+ , AvailTC name (name:non_flds) flds )
- return (IEThingAll (L l name), AvailTC name (name:kids))
-
- lookup_ie ie@(IEThingWith (L l rdr) sub_rdrs)
- = do name <- lookupGlobalOccRn rdr
+ lookup_ie ie@(IEThingWith (L l rdr) sub_rdrs sub_flds) = ASSERT2(null sub_flds, ppr sub_flds)
+ do name <- lookupGlobalOccRn rdr
+ let gres = findChildren kids_env name
if isUnboundName name
- then return (IEThingWith (L l name) [], AvailTC name [name])
- else do
- let mb_names = lookupChildren (findChildren kids_env name) sub_rdrs
- if any isNothing mb_names
- then do addErr (exportItemErr ie)
- return (IEThingWith (L l name) [], AvailTC name [name])
- else do let names = catMaybes mb_names
- addUsedKids rdr (map unLoc names)
- return (IEThingWith (L l name) names
- , AvailTC name (name:map unLoc names))
+ then return ( IEThingWith (L l name) [] []
+ , AvailTC name [name] [] )
+ else case lookupChildren (map classifyGRE gres) sub_rdrs of
+ Nothing -> do addErr (exportItemErr ie)
+ return ( IEThingWith (L l name) [] []
+ , AvailTC name [name] [] )
+ Just (non_flds, flds) ->
+ do addUsedKids rdr gres
+ return ( IEThingWith (L l name) non_flds flds
+ , AvailTC name (name:map unLoc non_flds) (map unLoc flds) )
lookup_ie _ = panic "lookup_ie" -- Other cases covered earlier
@@ -1197,7 +1313,7 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
-- In an export item M.T(A,B,C), we want to treat the uses of
-- A,B,C as if they were M.A, M.B, M.C
addUsedKids parent_rdr kid_names
- = addUsedRdrNames $ map (mk_kid_rdr . nameOccName) kid_names
+ = addUsedRdrNames $ map (mk_kid_rdr . greOccName) kid_names
where
mk_kid_rdr = case isQual_maybe parent_rdr of
Nothing -> mkRdrUnqual
@@ -1209,6 +1325,7 @@ isDoc (IEDocNamed _) = True
isDoc (IEGroup _ _) = True
isDoc _ = False
+
-------------------------------
isModuleExported :: Bool -> ModuleName -> GlobalRdrElt -> Bool
-- True if the thing is in scope *both* unqualified, *and* with qualifier M
@@ -1307,8 +1424,10 @@ reportUnusedNames :: Maybe (Located [LIE RdrName]) -- Export list
-> TcGblEnv -> RnM ()
reportUnusedNames _export_decls gbl_env
= do { traceRn ((text "RUN") <+> (ppr (tcg_dus gbl_env)))
+ ; sel_uses <- readMutVar (tcg_used_selectors gbl_env)
; warnUnusedImportDecls gbl_env
- ; warnUnusedTopBinds unused_locals }
+ ; warnUnusedTopBinds $ filterOut (used_as_selector sel_uses)
+ unused_locals }
where
used_names :: NameSet
used_names = findUses (tcg_dus gbl_env) emptyNameSet
@@ -1332,7 +1451,7 @@ reportUnusedNames _export_decls gbl_env
gre_is_used :: NameSet -> GlobalRdrElt -> Bool
gre_is_used used_names (GRE {gre_name = name})
= name `elemNameSet` used_names
- || any (`elemNameSet` used_names) (findChildren kids_env name)
+ || any (\ gre -> gre_name gre `elemNameSet` used_names) (findChildren kids_env name)
-- A use of C implies a use of T,
-- if C was brought into scope by T(..) or T(C)
@@ -1345,6 +1464,12 @@ reportUnusedNames _export_decls gbl_env
is_unused_local :: GlobalRdrElt -> Bool
is_unused_local gre = isLocalGRE gre && isExternalName (gre_name gre)
+ -- Remove uses of record selectors recorded in the typechecker
+ used_as_selector :: Set.Set (FieldOcc Name) -> GlobalRdrElt -> Bool
+ used_as_selector sel_uses gre
+ = isRecFldGRE gre && Foldable.any ((==) (gre_name gre) . selectorFieldOcc) sel_uses
+
+
{-
*********************************************************
* *
@@ -1364,20 +1489,23 @@ type ImportDeclUsage
warnUnusedImportDecls :: TcGblEnv -> RnM ()
warnUnusedImportDecls gbl_env
- = do { uses <- readMutVar (tcg_used_rdrnames gbl_env)
+ = do { uses <- fmap Set.elems $ readMutVar (tcg_used_rdrnames gbl_env)
+ ; sel_uses <- readMutVar (tcg_used_selectors gbl_env)
; let user_imports = filterOut (ideclImplicit . unLoc) (tcg_rn_imports gbl_env)
-- This whole function deals only with *user* imports
-- both for warning about unnecessary ones, and for
-- deciding the minimal ones
rdr_env = tcg_rdr_env gbl_env
+ fld_env = mkFieldEnv rdr_env
; let usage :: [ImportDeclUsage]
- usage = findImportUsage user_imports rdr_env (Set.elems uses)
+ usage = findImportUsage user_imports rdr_env uses sel_uses
- ; traceRn (vcat [ ptext (sLit "Uses:") <+> ppr (Set.elems uses)
+ ; traceRn (vcat [ ptext (sLit "Uses:") <+> ppr uses
+ , ptext (sLit "Selector uses:") <+> ppr sel_uses
, ptext (sLit "Import usage") <+> ppr usage])
; whenWOptM Opt_WarnUnusedImports $
- mapM_ warnUnusedImport usage
+ mapM_ (warnUnusedImport fld_env) usage
; whenGOptM Opt_D_dump_minimal_imports $
printMinimalImports usage }
@@ -1409,21 +1537,25 @@ type ImportMap = Map SrcLoc [AvailInfo] -- See [The ImportMap]
findImportUsage :: [LImportDecl Name]
-> GlobalRdrEnv
-> [RdrName]
+ -> Set.Set (FieldOcc Name)
-> [ImportDeclUsage]
-findImportUsage imports rdr_env rdrs
+findImportUsage imports rdr_env rdrs sel_names
= map unused_decl imports
where
import_usage :: ImportMap
- import_usage = foldr (extendImportMap rdr_env) Map.empty rdrs
+ import_usage
+ = foldr (extendImportMap_Field rdr_env)
+ (foldr (extendImportMap rdr_env) Map.empty rdrs)
+ (Set.elems sel_names)
unused_decl decl@(L loc (ImportDecl { ideclHiding = imps }))
= (decl, nubAvails used_avails, nameSetElems unused_imps)
where
used_avails = Map.lookup (srcSpanEnd loc) import_usage `orElse` []
-- srcSpanEnd: see Note [The ImportMap]
- used_names = availsToNameSet used_avails
- used_parents = mkNameSet [n | AvailTC n _ <- used_avails]
+ used_names = availsToNameSetWithSelectors used_avails
+ used_parents = mkNameSet [n | AvailTC n _ _ <- used_avails]
unused_imps -- Not trivial; see eg Trac #7454
= case imps of
@@ -1435,8 +1567,8 @@ findImportUsage imports rdr_env rdrs
add_unused (IEVar (L _ n)) acc = add_unused_name n acc
add_unused (IEThingAbs (L _ n)) acc = add_unused_name n acc
add_unused (IEThingAll (L _ n)) acc = add_unused_all n acc
- add_unused (IEThingWith (L _ p) ns) acc
- = add_unused_with p (map unLoc ns) acc
+ add_unused (IEThingWith (L _ p) ns fs) acc = add_unused_with p xs acc
+ where xs = map unLoc ns ++ map (flSelector . unLoc) fs
add_unused _ acc = acc
add_unused_name n acc
@@ -1455,16 +1587,29 @@ findImportUsage imports rdr_env rdrs
-- imported Num(signum). We don't want to complain that
-- Num is not itself mentioned. Hence the two cases in add_unused_with.
+extendImportMap :: GlobalRdrEnv
+ -> RdrName
+ -> ImportMap -> ImportMap
+extendImportMap rdr_env rdr =
+ extendImportMap_GRE (lookupGRE_RdrName rdr rdr_env)
+
+extendImportMap_Field :: GlobalRdrEnv
+ -> FieldOcc Name
+ -> ImportMap -> ImportMap
+extendImportMap_Field rdr_env (FieldOcc rdr sel) =
+ extendImportMap_GRE (pickGREs rdr (lookupGRE_Field_Name rdr_env sel lbl))
+ where
+ lbl = occNameFS (rdrNameOcc rdr)
-extendImportMap :: GlobalRdrEnv -> RdrName -> ImportMap -> ImportMap
--- For a used RdrName, find all the import decls that brought
+-- For each of a list of used GREs, find all the import decls that brought
-- it into scope; choose one of them (bestImport), and record
-- the RdrName in that import decl's entry in the ImportMap
-extendImportMap rdr_env rdr imp_map
+extendImportMap_GRE :: [GlobalRdrElt] -> ImportMap -> ImportMap
+extendImportMap_GRE gres imp_map
= foldr recordRdrName imp_map nonLocalGREs
where
recordRdrName gre m = add_imp gre (bestImport (gre_imp gre)) m
- nonLocalGREs = filter (not . gre_lcl) (lookupGRE_RdrName rdr rdr_env)
+ nonLocalGREs = filter (not . gre_lcl) gres
add_imp :: GlobalRdrElt -> ImportSpec -> ImportMap -> ImportMap
add_imp gre (ImpSpec { is_decl = imp_decl_spec }) imp_map
@@ -1490,8 +1635,9 @@ extendImportMap rdr_env rdr imp_map
isImpAll (ImpSpec { is_item = ImpAll }) = True
isImpAll _other = False
-warnUnusedImport :: ImportDeclUsage -> RnM ()
-warnUnusedImport (L loc decl, used, unused)
+warnUnusedImport :: NameEnv (FieldLabelString, Name) -> ImportDeclUsage
+ -> RnM ()
+warnUnusedImport fld_env (L loc decl, used, unused)
| Just (False,L _ []) <- ideclHiding decl
= return () -- Do not warn for 'import M()'
@@ -1508,7 +1654,7 @@ warnUnusedImport (L loc decl, used, unused)
<+> quotes pp_mod),
ptext (sLit "To import instances alone, use:")
<+> ptext (sLit "import") <+> pp_mod <> parens Outputable.empty ]
- msg2 = sep [pp_herald <+> quotes (pprWithCommas ppr unused),
+ msg2 = sep [pp_herald <+> quotes sort_unused,
text "from module" <+> quotes pp_mod <+> pp_not_used]
pp_herald = text "The" <+> pp_qual <+> text "import of"
pp_qual
@@ -1517,6 +1663,14 @@ warnUnusedImport (L loc decl, used, unused)
pp_mod = ppr (unLoc (ideclName decl))
pp_not_used = text "is redundant"
+ ppr_possible_field n = case lookupNameEnv fld_env n of
+ Just (fld, p) -> ppr p <> parens (ppr fld)
+ Nothing -> ppr n
+
+ -- Print unused names in a deterministic (lexicographic) order
+ sort_unused = pprWithCommas ppr_possible_field $
+ sortBy (comparing nameOccName) unused
+
{-
Note [Do not warn about Prelude hiding]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1582,19 +1736,30 @@ printMinimalImports imports_w_usage
-- to say "T(A,B,C)". So we have to find out what the module exports.
to_ie _ (Avail n)
= [IEVar (noLoc n)]
- to_ie _ (AvailTC n [m])
+ to_ie _ (AvailTC n [m] [])
| n==m = [IEThingAbs (noLoc n)]
- to_ie iface (AvailTC n ns)
- = case [xs | AvailTC x xs <- mi_exports iface
+ to_ie iface (AvailTC n ns fs)
+ = case [(xs,gs) | AvailTC x xs gs <- mi_exports iface
, x == n
, x `elem` xs -- Note [Partial export]
] of
[xs] | all_used xs -> [IEThingAll (noLoc n)]
| otherwise -> [IEThingWith (noLoc n)
- (map noLoc (filter (/= n) ns))]
- _other -> map (IEVar . noLoc) ns
+ (map noLoc (filter (/= n) ns))
+ (map noLoc fs)]
+ -- Note [Overloaded field import]
+ _other | all_non_overloaded fs
+ -> map (IEVar . noLoc) $ ns ++ map flSelector fs
+ | otherwise -> [IEThingWith (noLoc n)
+ (map noLoc (filter (/= n) ns)) (map noLoc fs)]
where
- all_used avail_occs = all (`elem` ns) avail_occs
+ fld_lbls = map flLabel fs
+
+ all_used (avail_occs, avail_flds)
+ = all (`elem` ns) avail_occs
+ && all (`elem` fld_lbls) (map flLabel avail_flds)
+
+ all_non_overloaded = all (not . flIsOverloaded)
{-
Note [Partial export]
@@ -1617,6 +1782,24 @@ which we would usually generate if C was exported from B. Hence
the (x `elem` xs) test when deciding what to generate.
+Note [Overloaded field import]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+On the other hand, if we have
+
+ {-# LANGUAGE DuplicateRecordFields #-}
+ module A where
+ data T = MkT { foo :: Int }
+
+ module B where
+ import A
+ f = ...foo...
+
+then the minimal import for module B must be
+ import A ( T(foo) )
+because when DuplicateRecordFields is enabled, field selectors are
+not in scope without their enclosing datatype.
+
+
************************************************************************
* *
\subsection{Errors}
@@ -1668,7 +1851,7 @@ badImportItemErr iface decl_spec ie avails
Just con -> badImportItemErrDataCon (availOccName con) iface decl_spec ie
Nothing -> badImportItemErrStd iface decl_spec ie
where
- checkIfDataCon (AvailTC _ ns) =
+ checkIfDataCon (AvailTC _ ns _) =
case find (\n -> importedFS == nameOccNameFS n) ns of
Just n -> isDataConName n
Nothing -> False
diff --git a/compiler/rename/RnPat.hs b/compiler/rename/RnPat.hs
index 48c4f1dfc7..f6d02eb2c8 100644
--- a/compiler/rename/RnPat.hs
+++ b/compiler/rename/RnPat.hs
@@ -21,6 +21,7 @@ module RnPat (-- main entry points
isTopRecNameMaker,
rnHsRecFields, HsRecFieldContext(..),
+ rnHsRecUpdFields,
-- CpsRn monad
CpsRn, liftCps,
@@ -48,7 +49,6 @@ import DynFlags
import PrelNames
import TyCon ( tyConName )
import ConLike
-import DataCon ( dataConTyCon )
import TypeRep ( TyThing(..) )
import Name
import NameSet
@@ -61,7 +61,7 @@ import SrcLoc
import FastString
import Literal ( inCharRange )
import TysWiredIn ( nilDataCon )
-import DataCon ( dataConName )
+import DataCon
import Control.Monad ( when, liftM, ap )
import Data.Ratio
@@ -525,6 +525,8 @@ rnHsRecFields
-- b) fills in puns and dot-dot stuff
-- When we we've finished, we've renamed the LHS, but not the RHS,
-- of each x=e binding
+--
+-- This is used for record construction and pattern-matching, but not updates.
rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
= do { pun_ok <- xoptM Opt_RecordPuns
@@ -533,15 +535,6 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
; flds1 <- mapM (rn_fld pun_ok parent) flds
; mapM_ (addErr . dupFieldErr ctxt) dup_flds
; dotdot_flds <- rn_dotdot dotdot mb_con flds1
-
- -- Check for an empty record update e {}
- -- NB: don't complain about e { .. }, because rn_dotdot has done that already
- ; case ctxt of
- HsRecFieldUpd | Nothing <- dotdot
- , null flds
- -> addErr emptyUpdateErr
- _ -> return ()
-
; let all_flds | null dotdot_flds = flds1
| otherwise = flds1 ++ dotdot_flds
; return (all_flds, mkFVs (getFieldIds all_flds)) }
@@ -559,30 +552,29 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
Nothing -> ptext (sLit "constructor field name")
Just con -> ptext (sLit "field of constructor") <+> quotes (ppr con)
- rn_fld pun_ok parent (L l (HsRecField { hsRecFieldId = fld
+ rn_fld :: Bool -> Maybe Name -> LHsRecField RdrName (Located arg)
+ -> RnM (LHsRecField Name (Located arg))
+ rn_fld pun_ok parent (L l (HsRecField { hsRecFieldLbl = L loc (FieldOcc lbl _)
, hsRecFieldArg = arg
- , hsRecPun = pun }))
- = do { fld'@(L loc fld_nm) <- wrapLocM (lookupSubBndrOcc True parent doc) fld
+ , hsRecPun = pun }))
+ = do { sel <- setSrcSpan loc $ lookupSubBndrOcc True parent doc lbl
; arg' <- if pun
- then do { checkErr pun_ok (badPun fld)
- ; return (L loc (mk_arg (mkRdrUnqual (nameOccName fld_nm)))) }
+ then do { checkErr pun_ok (badPun (L loc lbl))
+ ; return (L loc (mk_arg lbl)) }
else return arg
- ; return (L l (HsRecField { hsRecFieldId = fld'
+ ; return (L l (HsRecField { hsRecFieldLbl = L loc (FieldOcc lbl sel)
, hsRecFieldArg = arg'
- , hsRecPun = pun })) }
+ , hsRecPun = pun })) }
rn_dotdot :: Maybe Int -- See Note [DotDot fields] in HsPat
- -> Maybe Name -- The constructor (Nothing for an update
- -- or out of scope constructor)
+ -> Maybe Name -- The constructor (Nothing for an
+ -- out of scope constructor)
-> [LHsRecField Name (Located arg)] -- Explicit fields
-> RnM [LHsRecField Name (Located arg)] -- Filled in .. fields
rn_dotdot Nothing _mb_con _flds -- No ".." at all
= return []
- rn_dotdot (Just {}) Nothing _flds -- ".." on record update
- = do { case ctxt of
- HsRecFieldUpd -> addErr badDotDotUpd
- _ -> return ()
- ; return [] }
+ rn_dotdot (Just {}) Nothing _flds -- Constructor out of scope
+ = return []
rn_dotdot (Just n) (Just con) flds -- ".." on record construction / pat match
= ASSERT( n == length flds )
do { loc <- getSrcSpanM -- Rather approximate
@@ -591,7 +583,7 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
; (rdr_env, lcl_env) <- getRdrEnvs
; con_fields <- lookupConstructorFields con
; when (null con_fields) (addErr (badDotDotCon con))
- ; let present_flds = getFieldIds flds
+ ; let present_flds = map (occNameFS . rdrNameOcc) $ getFieldLbls flds
parent_tc = find_tycon rdr_env con
-- For constructor uses (but not patterns)
@@ -599,39 +591,41 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
-- ignoring the record field itself
-- Eg. data R = R { x,y :: Int }
-- f x = R { .. } -- Should expand to R {x=x}, not R{x=x,y=y}
- arg_in_scope fld
+ arg_in_scope lbl
= rdr `elemLocalRdrEnv` lcl_env
|| notNull [ gre | gre <- lookupGRE_RdrName rdr rdr_env
, case gre_par gre of
- ParentIs p -> p /= parent_tc
- _ -> True ]
+ ParentIs p -> p /= parent_tc
+ FldParent { par_is = p } -> p /= parent_tc
+ NoParent -> True ]
where
- rdr = mkRdrUnqual (nameOccName fld)
-
- dot_dot_gres = [ head gres
- | fld <- con_fields
- , not (fld `elem` present_flds)
- , let gres = lookupGRE_Name rdr_env fld
- , not (null gres) -- Check field is in scope
+ rdr = mkVarUnqual lbl
+
+ dot_dot_gres = [ (lbl, sel, head gres)
+ | fl <- con_fields
+ , let lbl = flLabel fl
+ , let sel = flSelector fl
+ , not (lbl `elem` present_flds)
+ , let gres = lookupGRE_Field_Name rdr_env sel lbl
+ , not (null gres) -- Check selector is in scope
, case ctxt of
- HsRecFieldCon {} -> arg_in_scope fld
+ HsRecFieldCon {} -> arg_in_scope lbl
_other -> True ]
- ; addUsedRdrNames (map greUsedRdrName dot_dot_gres)
+ ; addUsedRdrNames (map (\ (_, _, gre) -> greUsedRdrName gre) dot_dot_gres)
; return [ L loc (HsRecField
- { hsRecFieldId = L loc fld
+ { hsRecFieldLbl = L loc (FieldOcc arg_rdr sel)
, hsRecFieldArg = L loc (mk_arg arg_rdr)
, hsRecPun = False })
- | gre <- dot_dot_gres
- , let fld = gre_name gre
- arg_rdr = mkRdrUnqual (nameOccName fld) ] }
+ | (lbl, sel, _) <- dot_dot_gres
+ , let arg_rdr = mkVarUnqual lbl ] }
- check_disambiguation :: Bool -> Maybe Name -> RnM Parent
- -- When disambiguation is on,
+ check_disambiguation :: Bool -> Maybe Name -> RnM (Maybe Name)
+ -- When disambiguation is on, return name of parent tycon.
check_disambiguation disambig_ok mb_con
| disambig_ok, Just con <- mb_con
- = do { env <- getGlobalRdrEnv; return (ParentIs (find_tycon env con)) }
- | otherwise = return NoParent
+ = do { env <- getGlobalRdrEnv; return (Just (find_tycon env con)) }
+ | otherwise = return Nothing
find_tycon :: GlobalRdrEnv -> Name {- DataCon -} -> Name {- TyCon -}
-- Return the parent *type constructor* of the data constructor
@@ -651,10 +645,76 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
-- Each list represents a RdrName that occurred more than once
-- (the list contains all occurrences)
-- Each list in dup_fields is non-empty
- (_, dup_flds) = removeDups compare (getFieldIds flds)
+ (_, dup_flds) = removeDups compare (getFieldLbls flds)
+
-getFieldIds :: [LHsRecField id arg] -> [id]
-getFieldIds flds = map (unLoc . hsRecFieldId . unLoc) flds
+rnHsRecUpdFields
+ :: [LHsRecUpdField RdrName]
+ -> RnM ([LHsRecUpdField Name], FreeVars)
+rnHsRecUpdFields flds
+ = do { pun_ok <- xoptM Opt_RecordPuns
+ ; overload_ok <- xoptM Opt_DuplicateRecordFields
+ ; (flds1, fvss) <- mapAndUnzipM (rn_fld pun_ok overload_ok) flds
+ ; mapM_ (addErr . dupFieldErr HsRecFieldUpd) dup_flds
+
+ -- Check for an empty record update e {}
+ -- NB: don't complain about e { .. }, because rn_dotdot has done that already
+ ; when (null flds) $ addErr emptyUpdateErr
+
+ ; return (flds1, plusFVs fvss) }
+ where
+ doc = ptext (sLit "constructor field name")
+
+ rn_fld :: Bool -> Bool -> LHsRecUpdField RdrName -> RnM (LHsRecUpdField Name, FreeVars)
+ rn_fld pun_ok overload_ok (L l (HsRecField { hsRecFieldLbl = L loc f
+ , hsRecFieldArg = arg
+ , hsRecPun = pun }))
+ = do { let lbl = rdrNameAmbiguousFieldOcc f
+ ; sel <- setSrcSpan loc $
+ -- Defer renaming of overloaded fields to the typechecker
+ -- See Note [Disambiguating record updates] in TcExpr
+ if overload_ok
+ then do { mb <- lookupGlobalOccRn_overloaded overload_ok lbl
+ ; case mb of
+ Nothing -> do { addErr (unknownSubordinateErr doc lbl)
+ ; return (Right []) }
+ Just r -> return r }
+ else fmap Left $ lookupSubBndrOcc True Nothing doc lbl
+ ; arg' <- if pun
+ then do { checkErr pun_ok (badPun (L loc lbl))
+ ; return (L loc (HsVar lbl)) }
+ else return arg
+ ; (arg'', fvs) <- rnLExpr arg'
+
+ ; let fvs' = case sel of
+ Left sel_name -> fvs `addOneFV` sel_name
+ Right [FieldOcc _ sel_name] -> fvs `addOneFV` sel_name
+ Right _ -> fvs
+ lbl' = case sel of
+ Left sel_name -> L loc (Unambiguous lbl sel_name)
+ Right [FieldOcc lbl sel_name] -> L loc (Unambiguous lbl sel_name)
+ Right _ -> L loc (Ambiguous lbl PlaceHolder)
+
+ ; return (L l (HsRecField { hsRecFieldLbl = lbl'
+ , hsRecFieldArg = arg''
+ , hsRecPun = pun }), fvs') }
+
+ dup_flds :: [[RdrName]]
+ -- Each list represents a RdrName that occurred more than once
+ -- (the list contains all occurrences)
+ -- Each list in dup_fields is non-empty
+ (_, dup_flds) = removeDups compare (getFieldUpdLbls flds)
+
+
+
+getFieldIds :: [LHsRecField Name arg] -> [Name]
+getFieldIds flds = map (unLoc . hsRecFieldSel . unLoc) flds
+
+getFieldLbls :: [LHsRecField id arg] -> [RdrName]
+getFieldLbls flds = map (rdrNameFieldOcc . unLoc . hsRecFieldLbl . unLoc) flds
+
+getFieldUpdLbls :: [LHsRecUpdField id] -> [RdrName]
+getFieldUpdLbls flds = map (rdrNameAmbiguousFieldOcc . unLoc . hsRecFieldLbl . unLoc) flds
needFlagDotDot :: HsRecFieldContext -> SDoc
needFlagDotDot ctxt = vcat [ptext (sLit "Illegal `..' in record") <+> pprRFC ctxt,
@@ -665,9 +725,6 @@ badDotDotCon con
= vcat [ ptext (sLit "Illegal `..' notation for constructor") <+> quotes (ppr con)
, nest 2 (ptext (sLit "The constructor has no labelled fields")) ]
-badDotDotUpd :: SDoc
-badDotDotUpd = ptext (sLit "You cannot use `..' in a record update")
-
emptyUpdateErr :: SDoc
emptyUpdateErr = ptext (sLit "Empty record update")
diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs
index 19f05c3ca2..f89f1b2ceb 100644
--- a/compiler/rename/RnSource.hs
+++ b/compiler/rename/RnSource.hs
@@ -104,16 +104,11 @@ rnSrcDecls group@(HsGroup { hs_valds = val_decls,
-- Again, they have no value declarations
--
(tc_envs, tc_bndrs) <- getLocalNonValBinders local_fix_env group ;
+
setEnvs tc_envs $ do {
failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations
- -- (C) Extract the mapping from data constructors to field names and
- -- extend the record field env.
- -- This depends on the data constructors and field names being in
- -- scope from (B) above
- inNewEnv (extendRecordFieldEnv tycl_decls inst_decls) $ \ _ -> do {
-
-- (D1) Bring pattern synonyms into scope.
-- Need to do this before (D2) because rnTopBindsLHS
-- looks up those pattern synonyms (Trac #9889)
@@ -218,13 +213,7 @@ rnSrcDecls group@(HsGroup { hs_valds = val_decls,
traceRn (text "finish rnSrc" <+> ppr rn_group) ;
traceRn (text "finish Dus" <+> ppr src_dus ) ;
return (final_tcg_env, rn_group)
- }}}}}
-
--- some utils because we do this a bunch above
--- compute and install the new env
-inNewEnv :: TcM TcGblEnv -> (TcGblEnv -> TcM a) -> TcM a
-inNewEnv env cont = do e <- env
- setGblEnv e $ cont e
+ }}}}
addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv
-- This function could be defined lower down in the module hierarchy,
@@ -1483,7 +1472,7 @@ rnConDecl decl@(ConDecl { con_names = names, con_qvars = tvs
; bindHsTyVars doc Nothing free_kvs new_tvs $ \new_tyvars -> do
{ (new_context, fvs1) <- rnContext doc lcxt
- ; (new_details, fvs2) <- rnConDeclDetails doc details
+ ; (new_details, fvs2) <- rnConDeclDetails (unLoc $ head new_names) doc details
; (new_details', new_res_ty, fvs3)
<- rnConResult doc (map unLoc new_names) new_details res_ty
; return (decl { con_names = new_names, con_qvars = new_tyvars
@@ -1518,20 +1507,22 @@ rnConResult doc _con details (ResTyGADT ls ty)
PrefixCon {} -> return (PrefixCon arg_tys, ResTyGADT ls res_ty, fvs)}
rnConDeclDetails
- :: HsDocContext
+ :: Name
+ -> HsDocContext
-> HsConDetails (LHsType RdrName) (Located [LConDeclField RdrName])
-> RnM (HsConDetails (LHsType Name) (Located [LConDeclField Name]), FreeVars)
-rnConDeclDetails doc (PrefixCon tys)
+rnConDeclDetails _ doc (PrefixCon tys)
= do { (new_tys, fvs) <- rnLHsTypes doc tys
; return (PrefixCon new_tys, fvs) }
-rnConDeclDetails doc (InfixCon ty1 ty2)
+rnConDeclDetails _ doc (InfixCon ty1 ty2)
= do { (new_ty1, fvs1) <- rnLHsType doc ty1
; (new_ty2, fvs2) <- rnLHsType doc ty2
; return (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2) }
-rnConDeclDetails doc (RecCon (L l fields))
- = do { (new_fields, fvs) <- rnConDeclFields doc fields
+rnConDeclDetails con doc (RecCon (L l fields))
+ = do { fls <- lookupConstructorFields con
+ ; (new_fields, fvs) <- rnConDeclFields fls doc fields
-- No need to check for duplicate fields
-- since that is done by RnNames.extendGlobalRdrEnvRn
; return (RecCon (L l new_fields), fvs) }
@@ -1550,51 +1541,6 @@ badRecResTy doc = ptext (sLit "Malformed constructor signature") $$ doc
{-
*********************************************************
* *
-\subsection{Support code for type/data declarations}
-* *
-*********************************************************
-
-Get the mapping from constructors to fields for this module.
-It's convenient to do this after the data type decls have been renamed
--}
-
-extendRecordFieldEnv :: [TyClGroup RdrName] -> [LInstDecl RdrName] -> TcM TcGblEnv
-extendRecordFieldEnv tycl_decls inst_decls
- = do { tcg_env <- getGblEnv
- ; field_env' <- foldrM get_con (tcg_field_env tcg_env) all_data_cons
- ; return (tcg_env { tcg_field_env = field_env' }) }
- where
- -- we want to lookup:
- -- (a) a datatype constructor
- -- (b) a record field
- -- knowing that they're from this module.
- -- lookupLocatedTopBndrRn does this, because it does a lookupGreLocalRn_maybe,
- -- which keeps only the local ones.
- lookup x = do { x' <- lookupLocatedTopBndrRn x
- ; return $ unLoc x'}
-
- all_data_cons :: [ConDecl RdrName]
- all_data_cons = [con | HsDataDefn { dd_cons = cons } <- all_ty_defs
- , L _ con <- cons ]
- all_ty_defs = [ defn | L _ (DataDecl { tcdDataDefn = defn })
- <- tyClGroupConcat tycl_decls ]
- ++ map dfid_defn (instDeclDataFamInsts inst_decls)
- -- Do not forget associated types!
-
- get_con (ConDecl { con_names = cons, con_details = RecCon flds })
- (RecFields env fld_set)
- = do { cons' <- mapM lookup cons
- ; flds' <- mapM lookup (concatMap (cd_fld_names . unLoc)
- (unLoc flds))
- ; let env' = foldl (\e c -> extendNameEnv e c flds') env cons'
-
- fld_set' = extendNameSetList fld_set flds'
- ; return $ (RecFields env' fld_set') }
- get_con _ env = return env
-
-{-
-*********************************************************
-* *
\subsection{Support code to rename types}
* *
*********************************************************
diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs
index 8b709dee36..69eebd417a 100644
--- a/compiler/rename/RnTypes.hs
+++ b/compiler/rename/RnTypes.hs
@@ -40,6 +40,7 @@ import TysPrim ( funTyConName )
import Name
import SrcLoc
import NameSet
+import FieldLabel
import Util
import BasicTypes ( compareFixity, funTyFixity, negateFixity,
@@ -177,7 +178,7 @@ rnHsTyKi isType doc (HsBangTy b ty)
rnHsTyKi _ doc ty@(HsRecTy flds)
= do { addErr (hang (ptext (sLit "Record syntax is illegal here:"))
2 (ppr ty))
- ; (flds', fvs) <- rnConDeclFields doc flds
+ ; (flds', fvs) <- rnConDeclFields [] doc flds
; return (HsRecTy flds', fvs) }
rnHsTyKi isType doc (HsFunTy ty1 ty2)
@@ -705,23 +706,46 @@ checkValidPartialType doc lty
{-
*********************************************************
-* *
-\subsection{Contexts and predicates}
-* *
+* *
+ ConDeclField
+* *
*********************************************************
+
+When renaming a ConDeclField, we have to find the FieldLabel
+associated with each field. But we already have all the FieldLabels
+available (since they were brought into scope by
+RnNames.getLocalNonValBinders), so we just take the list as an
+argument, build a map and look them up.
-}
-rnConDeclFields :: HsDocContext -> [LConDeclField RdrName]
+rnConDeclFields :: [FieldLabel] -> HsDocContext -> [LConDeclField RdrName]
-> RnM ([LConDeclField Name], FreeVars)
-rnConDeclFields doc fields = mapFvRn (rnField doc) fields
+rnConDeclFields fls doc fields = mapFvRn (rnField fl_env doc) fields
+ where
+ fl_env = mkFsEnv [ (flLabel fl, fl) | fl <- fls ]
-rnField :: HsDocContext -> LConDeclField RdrName
+rnField :: FastStringEnv FieldLabel -> HsDocContext -> LConDeclField RdrName
-> RnM (LConDeclField Name, FreeVars)
-rnField doc (L l (ConDeclField names ty haddock_doc))
- = do { new_names <- mapM lookupLocatedTopBndrRn names
+rnField fl_env doc (L l (ConDeclField names ty haddock_doc))
+ = do { let new_names = map (fmap lookupField) names
; (new_ty, fvs) <- rnLHsType doc ty
; new_haddock_doc <- rnMbLHsDoc haddock_doc
; return (L l (ConDeclField new_names new_ty new_haddock_doc), fvs) }
+ where
+ lookupField :: FieldOcc RdrName -> FieldOcc Name
+ lookupField (FieldOcc rdr _) = FieldOcc rdr (flSelector fl)
+ where
+ lbl = occNameFS $ rdrNameOcc rdr
+ fl = expectJust "rnField" $ lookupFsEnv fl_env lbl
+
+
+{-
+*********************************************************
+* *
+ Contexts
+* *
+*********************************************************
+-}
rnContext :: HsDocContext -> LHsContext RdrName -> RnM (LHsContext Name, FreeVars)
rnContext doc (L loc cxt)
View Lorry Controller Status