diff options
Diffstat (limited to 'compiler/rename')
| -rw-r--r-- | compiler/rename/RnEnv.lhs | 305 | ||||
| -rw-r--r-- | compiler/rename/RnExpr.lhs | 20 | ||||
| -rw-r--r-- | compiler/rename/RnNames.lhs | 451 | ||||
| -rw-r--r-- | compiler/rename/RnPat.lhs | 75 | ||||
| -rw-r--r-- | compiler/rename/RnSource.lhs | 125 | ||||
| -rw-r--r-- | compiler/rename/RnTypes.lhs | 53 |
6 files changed, 780 insertions, 249 deletions
diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index b9bfcce531..ba56325e31 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -14,6 +14,7 @@ module RnEnv ( lookupLocalOccThLvl_maybe, lookupTypeOccRn, lookupKindOccRn, lookupGlobalOccRn, lookupGlobalOccRn_maybe, + lookupOccRn_overloaded, lookupGlobalOccRn_overloaded, reportUnboundName, HsSigCtxt(..), lookupLocalTcNames, lookupSigOccRn, @@ -22,6 +23,7 @@ module RnEnv ( lookupInstDeclBndr, lookupSubBndrOcc, lookupFamInstName, greRdrName, lookupSubBndrGREs, lookupConstructorFields, + lookupFldInstAxiom, lookupFldInstDFun, fieldLabelInScope, lookupSyntaxName, lookupSyntaxNames, lookupIfThenElse, lookupGreRn, lookupGreRn_maybe, lookupGreLocalRn_maybe, @@ -39,7 +41,7 @@ module RnEnv ( addFvRn, mapFvRn, mapMaybeFvRn, mapFvRnCPS, warnUnusedMatches, warnUnusedTopBinds, warnUnusedLocalBinds, - dataTcOccs, kindSigErr, perhapsForallMsg, + dataTcOccs, kindSigErr, perhapsForallMsg, unknownSubordinateErr, HsDocContext(..), docOfHsDocContext ) where @@ -50,17 +52,19 @@ import IfaceEnv import HsSyn import RdrName import HscTypes -import TcEnv ( tcLookupDataCon, tcLookupField, isBrackStage ) +import TcEnv import TcRnMonad -import Id ( isRecordSelector ) +import Id +import Var 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 CoAxiom import PrelNames ( mkUnboundName, isUnboundName, rOOT_MAIN, forall_tv_RDR ) import ErrUtils ( MsgDoc ) import BasicTypes ( Fixity(..), FixityDirection(..), minPrecedence, defaultFixity ) @@ -333,7 +337,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) @@ -346,7 +350,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 @@ -404,7 +408,7 @@ greRdrName gre Imported is -> used_rdr_name_from_is is where - occ = nameOccName (gre_name gre) + occ = greOccName gre unqual_rdr = mkRdrUnqual occ used_rdr_name_from_is imp_specs -- rdr_name is unqualified @@ -428,12 +432,16 @@ lookupSubBndrGREs env parent rdr_name ParentIs p | isUnqual rdr_name -> filter (parent_is p) gres | otherwise -> filter (parent_is p) (pickGREs rdr_name gres) + FldParent { par_is = 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 \end{code} Note [Family instance binders] @@ -692,6 +700,56 @@ lookupGlobalOccRn_maybe rdr_name Just gre -> return (Just (gre_name gre)) } +-- The following are possible results of lookupOccRn_overloaded: +-- 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 (l, xs)) -> ambiguous between the fields xs with label l; +-- fields are represented as (parent, selector) pairs + +lookupOccRn_overloaded :: RdrName -> RnM (Maybe (Either Name (FieldLabelString, [(Name, Name)]))) +lookupOccRn_overloaded 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 rdr_name + ; case mb_name of { + Just name -> return (Just name) ; + Nothing -> do + { dflags <- getDynFlags + ; is_ghci <- getIsGHCi -- This test is not expensive, + -- and only happens for failed lookups + ; lookupQualifiedNameGHCi_overloaded dflags is_ghci rdr_name } } } } } + +lookupGlobalOccRn_overloaded :: RdrName -> RnM (Maybe (Either Name (FieldLabelString, [(Name, Name)]))) +lookupGlobalOccRn_overloaded 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 + ; overload_ok <- xoptM Opt_OverloadedRecordFields + ; case lookupGRE_RdrName rdr_name env of + [] -> return Nothing + [gre] | Just lbl <- greLabel gre + -> do { addUsedRdrName True gre rdr_name + ; return (Just (Right (lbl, [greBits gre]))) } + [gre] -> do { addUsedRdrName True gre rdr_name + ; return (Just (Left (gre_name gre))) } + gres | all isRecFldGRE gres && overload_ok + -> do { mapM_ (\ gre -> addUsedRdrName True gre rdr_name) gres + ; return (Just (Right (expectJust "greLabel" (greLabel (head gres)), map greBits gres))) } + gres -> do { addNameClashErrRn rdr_name gres + ; return (Just (Left (gre_name (head gres)))) } } + where + greBits (GRE{ gre_name = n, gre_par = FldParent { par_is = p }}) = (p, n) + greBits gre = pprPanic "lookupGlobalOccRn_overloaded/greBits" (ppr gre) + + -------------------------------------------------- -- Lookup in the Global RdrEnv of the module -------------------------------------------------- @@ -735,6 +793,104 @@ lookupGreRn_help rdr_name lookup ; return (Just (head gres)) } } \end{code} + +%********************************************************* +%* * + Looking up record field instances +%* * +%********************************************************* + +The Has and Upd typeclasses, and the FldTy and UpdTy type families, +(all defined in GHC.Records) are magical, in that rather than looking +for instances in the usual way, we refer to the fields that are in +scope. When looking for a match for + + Has (T a b) "foo" t + FldTy (T a b) "foo" + etc. + +we check that the field foo belonging to type T is in scope, and look +up the dfun created by makeOverloadedRecFldInsts in TcFldInsts (see +Note [Instance scoping for OverloadedRecordFields] in TcFldInsts). + +The lookupFldInstAxiom and lookupFldInstDFun functions each call +lookupRecFieldLabel to perform most of the checks and find the +appropriate name. + + +Note [Duplicate field labels with data families] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following example: + + module M where + data family F a + data instance F Int = MkF1 { foo :: Int } + + module N where + import M + data instance F Char = MkF2 { foo :: Char } + +Both fields have the same lexical parent (the family tycon F)! Thus +it is not enough to lookup the field in the GlobalRdrEnv with +lookupSubBndrGREs: we also need to check the selector names to find +the one with the right representation tycon. + +\begin{code} +lookupRecFieldLabel :: FieldLabelString -> TyCon -> TyCon + -> TcM (Maybe FieldLabel) +-- Lookup the FieldLabel from a label string, parent tycon and +-- representation tycon +lookupRecFieldLabel lbl tc rep_tc + = case lookupFsEnv (tyConFieldLabelEnv rep_tc) lbl of + Nothing -> return Nothing -- This field doesn't belong to the datatype! + Just fl -> do { gbl_env <- getGblEnv + ; if fieldLabelInScope (tcg_rdr_env gbl_env) tc fl + then do { addUsedSelector (flSelector fl) + ; return $ Just fl } + else return Nothing } + +lookupFldInstAxiom :: FieldLabelString -> TyCon -> TyCon + -> Bool -> TcM (Maybe (CoAxiom Branched)) +-- Lookup a FldTy or UpdTy axiom from a label string, parent +-- tycon and representation tycon +lookupFldInstAxiom lbl tc rep_tc want_get + = do { mb_fl <- lookupRecFieldLabel lbl tc rep_tc + ; case mb_fl of + Nothing -> return Nothing + Just fl -> do { thing <- tcLookupGlobal (get_or_set fl) + ; case thing of -- See Note [Bogus instances] in TcFldInsts + ACoAxiom ax -> return $ Just ax + _ -> return Nothing } } + where + get_or_set | want_get = flFldTyAxiom + | otherwise = flUpdTyAxiom + +lookupFldInstDFun :: FieldLabelString -> TyCon -> TyCon + -> Bool -> TcM (Maybe DFunId) +-- Lookup a Has or Upd DFunId from a label string, parent tycon and +-- representation tycon +lookupFldInstDFun lbl tc rep_tc want_has + = do { mb_fl <- lookupRecFieldLabel lbl tc rep_tc + ; case mb_fl of + Nothing -> return Nothing + Just fl -> do { dfun <- tcLookupId (has_or_upd fl) + ; if isDFunId dfun -- See Note [Bogus instances] in TcFldInsts + then return $ Just dfun + else return Nothing } } + where + has_or_upd | want_has = flHasDFun + | otherwise = flUpdDFun + +fieldLabelInScope :: GlobalRdrEnv -> TyCon -> FieldLabel -> Bool +-- Determine whether a FieldLabel in scope, given its parent (family) +-- tycon. See Note [Duplicate field labels with data families]. +fieldLabelInScope env tc fl = any ((flSelector fl ==) . gre_name) gres + where + gres = lookupSubBndrGREs env (ParentIs (tyConName tc)) + (mkVarUnqual (flLabel fl)) +\end{code} + + %********************************************************* %* * Deprecations @@ -758,6 +914,12 @@ Note [Handling of deprecations] - the things exported by a module export 'module M' \begin{code} +addUsedSelector :: Name -> RnM () +-- Record usage of record selectors by OverloadedRecordFields +addUsedSelector n = do { env <- getGblEnv + ; updMutVar (tcg_used_selectors env) + (\s -> addOneToNameSet s n) } + addUsedRdrName :: Bool -> GlobalRdrElt -> RdrName -> RnM () -- Record usage of imported RdrNames addUsedRdrName warnIfDeprec gre rdr @@ -787,9 +949,10 @@ warnIfDeprecated gre@(GRE { gre_name = name, gre_prov = Imported (imp_spec : _) Just txt -> addWarn (mk_msg txt) Nothing -> return () } } where + occ = greOccName gre mk_msg 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 ] @@ -807,8 +970,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 \end{code} Note [Used names with interface not loaded] @@ -879,6 +1043,50 @@ lookupQualifiedNameGHCi dflags is_ghci rdr_name = return Nothing where doc = ptext (sLit "Need to find") <+> ppr rdr_name + +-- Overloaded counterpart to lookupQualifiedNameGHCi: a qualified name +-- should never be overloaded, so when we check for overloaded field +-- matches, generate name clash errors if we find more than one. +lookupQualifiedNameGHCi_overloaded :: DynFlags -> Bool -> RdrName + -> RnM (Maybe (Either Name (FieldLabelString, [(Name, Name)]))) +lookupQualifiedNameGHCi_overloaded dflags is_ghci rdr_name + | Just (mod,occ) <- isQual_maybe rdr_name + , is_ghci + , gopt Opt_ImplicitImportQualified dflags -- Enables this GHCi behaviour + , not (safeDirectImpsReq dflags) -- See Note [Safe Haskell and GHCi] + = -- We want to behave as we would for a source file import here, + -- and respect hiddenness of modules/packages, hence loadSrcInterface. + do { res <- loadSrcInterface_maybe doc mod False Nothing + ; case res of + Succeeded iface + | (n:ns) <- [ name + | avail <- mi_exports iface + , name <- availNames avail + , nameOccName name == occ ] + -> ASSERT(null ns) return (Just (Left n)) + + | xs@((p, lbl, sel):ys) <- [ (availName avail, lbl, sel) + | avail <- mi_exports iface + , (lbl, sel) <- availOverloadedFlds avail + , lbl == occNameFS occ ] + -> do { when (not (null ys)) $ + addNameClashErrRn rdr_name (map (toFakeGRE mod) xs) + ; return (Just (Right (lbl, [(p, sel)]))) } + + _ -> -- Either we couldn't load the interface, or + -- we could but we didn't find the name in it + do { traceRn (text "lookupQualifiedNameGHCI_overloaded" <+> ppr rdr_name) + ; return Nothing } } + | otherwise + = return Nothing + where + doc = ptext (sLit "Need to find") <+> ppr rdr_name + + -- Make up a fake GRE solely for error-reporting purposes. + toFakeGRE mod (p, lbl, sel) = GRE { gre_name = sel + , gre_par = FldParent p (Just lbl) + , gre_prov = Imported [imp_spec] } + where imp_spec = ImpSpec (ImpDeclSpec mod mod True noSrcSpan) ImpAll \end{code} Note [Looking up signature names] @@ -988,7 +1196,7 @@ lookupBindGroupOcc ctxt what rdr_name [] | null all_gres -> bale_out_with Outputable.empty | otherwise -> bale_out_with local_msg (gre:_) - | ParentIs {} <- gre_par gre + | gre_par gre /= NoParent , not meth_ok -> bale_out_with sub_msg | otherwise @@ -1386,18 +1594,10 @@ 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) } \end{code} @@ -1607,7 +1807,7 @@ warnUnusedTopBinds gres $ do isBoot <- tcIsHsBoot 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). @@ -1626,50 +1826,48 @@ check_unused flag bound_names used_names ------------------------- -- Helpers warnUnusedGREs :: [GlobalRdrElt] -> RnM () -warnUnusedGREs gres - = warnUnusedBinds [(n,p) | GRE {gre_name = n, gre_prov = p} <- gres] - -warnUnusedLocals :: [Name] -> RnM () -warnUnusedLocals names - = warnUnusedBinds [(n,LocalDef) | n<-names] - -warnUnusedBinds :: [(Name,Provenance)] -> RnM () -warnUnusedBinds names = mapM_ warnUnusedName (filter reportable names) - where reportable (name,_) +warnUnusedGREs gres = mapM_ warnUnusedGRE (filter reportable gres) + where reportable gre@(GRE { gre_name = name }) | isWiredInName name = False -- Don't report unused wired-in names -- Otherwise we get a zillion warnings -- from Data.Tuple - | otherwise = not (startsWithUnderscore (nameOccName name)) + | otherwise = not (startsWithUnderscore (greOccName gre)) + +warnUnusedLocals :: [Name] -> RnM () +warnUnusedLocals names + = warnUnusedGREs [GRE {gre_name = n, gre_par = NoParent, gre_prov = LocalDef} | n<-names] ------------------------- -warnUnusedName :: (Name, Provenance) -> RnM () -warnUnusedName (name, LocalDef) - = addUnusedWarning name (nameSrcSpan name) +warnUnusedGRE :: GlobalRdrElt -> RnM () +warnUnusedGRE gre = case gre_prov gre of + LocalDef -> addUnusedWarning gre (nameSrcSpan (gre_name gre)) (ptext (sLit "Defined but not used")) - -warnUnusedName (name, Imported is) - = mapM_ warn is - where - warn spec = addUnusedWarning name span msg + Imported is -> mapM_ warn is + where + warn spec = addUnusedWarning gre span msg where span = importSpecLoc spec pp_mod = quotes (ppr (importSpecModule spec)) msg = ptext (sLit "Imported from") <+> pp_mod <+> ptext (sLit "but not used") -addUnusedWarning :: Name -> SrcSpan -> SDoc -> RnM () -addUnusedWarning name span msg +addUnusedWarning :: GlobalRdrElt -> SrcSpan -> SDoc -> RnM () +addUnusedWarning gre span msg = addWarnAt span $ sep [msg <> colon, - nest 2 $ pprNonVarNameSpace (occNameSpace (nameOccName name)) - <+> quotes (ppr name)] + nest 2 $ pprNonVarNameSpace (occNameSpace (greOccName gre)) + <+> quotes pp_name] + where + pp_name | isOverloadedRecFldGRE gre = ppr (greOccName gre) + | otherwise = ppr (gre_name gre) \end{code} \begin{code} 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)]) @@ -1677,7 +1875,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.lhs b/compiler/rename/RnExpr.lhs index 79a944fb2f..5084a9c20c 100644 --- a/compiler/rename/RnExpr.lhs +++ b/compiler/rename/RnExpr.lhs @@ -92,19 +92,28 @@ finishHsVar name ; return (e, unitFV name) } } rnExpr (HsVar v) - = do { mb_name <- lookupOccRn_maybe v + = do { mb_name <- lookupOccRn_overloaded v ; case mb_name of { Nothing -> do { opt_TypeHoles <- woptM Opt_WarnTypedHoles ; if opt_TypeHoles && startsWithUnderscore (rdrNameOcc v) then return (HsUnboundVar v, emptyFVs) else do { n <- reportUnboundName v; finishHsVar n } } ; - 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 (fld, xs)) -> + do { overloaded <- xoptM Opt_OverloadedRecordFields + ; if overloaded + then do { when (isQual v && length xs > 1) $ + addErrTc $ qualifiedOverloadedRecordField v + ; return (HsOverloadedRecFld fld, mkFVs (map snd xs)) } + else case xs of + [(_, name)] -> return (HsSingleRecFld v name, unitFV name) + _ -> error "rnExpr/HsVar" } } } rnExpr (HsIPVar v) = return (HsIPVar v, emptyFVs) @@ -1346,4 +1355,9 @@ badIpBinds :: Outputable a => SDoc -> a -> SDoc badIpBinds what binds = hang (ptext (sLit "Implicit-parameter bindings illegal in") <+> what) 2 (ppr binds) + +qualifiedOverloadedRecordField :: RdrName -> SDoc +qualifiedOverloadedRecordField v + = hang (ptext (sLit "Overloaded record field should not be qualified:")) + 2 (quotes (ppr v)) \end{code} diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs index cd43d8a866..6a8c22950f 100644 --- a/compiler/rename/RnNames.lhs +++ b/compiler/rename/RnNames.lhs @@ -18,10 +18,11 @@ module RnNames ( import DynFlags import HsSyn -import TcEnv ( isBrackStage ) +import TcEnv import RnEnv import RnHsDoc ( rnHsDoc ) import LoadIface ( loadSrcInterface ) +import IfaceEnv import TcRnMonad import PrelNames import Module @@ -29,6 +30,7 @@ import Name import NameEnv import NameSet import Avail +import FieldLabel import HscTypes import RdrName import Outputable @@ -38,12 +40,15 @@ import BasicTypes ( TopLevelFlag(..) ) import ErrUtils import Util import FastString +import FastStringEnv import ListSetOps import Control.Monad import Data.Map ( Map ) import qualified Data.Map as Map -import Data.List ( partition, (\\), find ) +import Data.Monoid ( mconcat ) +import Data.Ord ( comparing ) +import Data.List ( partition, (\\), find, sortBy ) import qualified Data.Set as Set import System.FilePath ((</>)) import System.IO @@ -389,6 +394,7 @@ top level binders specially in two ways meant for the type checker, and here we are not interested in the fields of Brack, hence the error thunks in thRnBrack. + \begin{code} extendGlobalRdrEnvRn :: [AvailInfo] -> MiniFixityEnv @@ -459,7 +465,7 @@ used for source code. \begin{code} getLocalNonValBinders :: MiniFixityEnv -> HsGroup RdrName - -> RnM ((TcGblEnv, TcLclEnv), NameSet) + -> RnM ((TcGblEnv, TcLclEnv), NameSet, [(Name, [FieldLabel])]) -- Get all the top-level binders bound the group *except* -- for value bindings, which are treated separately -- Specifically we return AvailInfo for @@ -475,7 +481,8 @@ 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_OverloadedRecordFields + ; (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 { @@ -484,7 +491,7 @@ 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 for an ordinary module @@ -494,12 +501,14 @@ 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 `unionNameSets` availsToNameSet tc_avails + flds = concat nti_fldss ++ concat tc_fldss ; traceRn (text "getLocalNonValBinders 2" <+> ppr avails) ; envs <- extendGlobalRdrEnvRn avails fixity_env - ; return (envs, new_bndrs) } } + + ; return (envs, new_bndrs, flds) } } where for_hs_bndrs :: [Located RdrName] for_hs_bndrs = [ L decl_loc (unLoc nm) @@ -517,34 +526,84 @@ 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 + 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 : _) <- mapM newTopSrcBinder bndrs - ; return (AvailTC main_name names) } - - new_assoc :: LInstDecl RdrName -> RnM [AvailInfo] - new_assoc (L _ (TyFamInstD {})) = return [] + ; flds' <- mapM (new_rec_sel overload_ok (nameOccName main_name) . fstOf3) flds + ; let fld_env = case unLoc tc_decl of + DataDecl { tcdDataDefn = d } -> mk_fld_env d names flds' + _ -> [] + avail_flds = fieldLabelsToAvailFields flds' + ; return (AvailTC main_name names avail_flds, fld_env) } + + new_rec_sel :: Bool -> OccName -> Located RdrName -> RnM FieldLabel + new_rec_sel overload_ok tc (L loc fld) = + do { sel_name <- newTopSrcBinder $ L loc $ mkRdrUnqual sel_occ + ; mod <- getModule + ; has <- newGlobalBinder mod (flHasDFun fl) loc + ; upd <- newGlobalBinder mod (flUpdDFun fl) loc + ; get_ax <- newGlobalBinder mod (flFldTyAxiom fl) loc + ; set_ax <- newGlobalBinder mod (flUpdTyAxiom fl) loc + ; return $ fl { flSelector = sel_name + , flHasDFun = has + , flUpdDFun = upd + , flFldTyAxiom = get_ax + , flUpdTyAxiom = set_ax } } + where + lbl = occNameFS $ rdrNameOcc fld + fl = mkFieldLabelOccs lbl tc 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_name = L _ rdr, con_details = RecCon cdflds })) + = [(find_con_name rdr, map find_con_decl_fld cdflds)] + find_con_flds _ = [] + + find_con_name rdr = expectJust "getLocalNonValBinders/find_con_name" $ + find (\ n -> nameOccName n == rdrNameOcc rdr) names + find_con_decl_fld x = expectJust "getLocalNonValBinders/find_con_decl_fld" $ + find (\ fl -> flLabel fl == lbl) flds + where lbl = occNameFS (rdrNameOcc (unLoc (cd_fld_lbl x))) + + 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 } })) - | Just (_, _, L loc cls_rdr, _) <- splitLHsInstDeclTy_maybe inst_ty - = do { cls_nm <- setSrcSpan loc $ lookupGlobalOccRn cls_rdr - ; mapM (new_di (Just cls_nm) . unLoc) 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 inst_ty + = do { cls_nm <- setSrcSpan loc' $ lookupGlobalOccRn cls_rdr + ; (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 (rdrNameOcc (dfid_rep_tycon ti_decl)) . fstOf3) flds + ; let avail = AvailTC (unLoc main_name) sub_names + (fieldLabelsToAvailFields 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 \end{code} Note [Looking up family names in family instances] @@ -641,8 +700,8 @@ filterImports iface decl_spec (Just (want_hiding, 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) @@ -699,7 +758,7 @@ filterImports iface decl_spec (Just (want_hiding, import_items)) return ([(IEVar name, trimAvail avail name)], []) IEThingAll tc -> do - (name, avail@(AvailTC name2 subs), mb_parent) <- lookup_name tc + (name, avail@(AvailTC name2 subs fs), mb_parent) <- lookup_name tc let warns | null (drop 1 subs) = [DodgyImport tc] | not (is_qual decl_spec) = [MissingImportList] | otherwise = [] @@ -708,8 +767,8 @@ filterImports iface decl_spec (Just (want_hiding, import_items)) Nothing -> return ([(IEThingAll name, avail)], warns) -- associated ty Just parent -> return ([(IEThingAll name, - AvailTC name2 (subs \\ [name])), - (IEThingAll name, AvailTC parent [name])], + AvailTC name2 (subs \\ [name]) fs), + (IEThingAll name, AvailTC parent [name] [])], warns) IEThingAbs tc @@ -726,31 +785,32 @@ filterImports iface decl_spec (Just (want_hiding, import_items)) -> do nameAvail <- lookup_name tc return ([mkIEThingAbs nameAvail], []) - IEThingWith rdr_tc rdr_ns -> do - (name, AvailTC _ ns, mb_parent) <- lookup_name rdr_tc + IEThingWith rdr_tc rdr_ns 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, + let subnames = case ns of -- The tc is first in ns, [] -> [] -- if it is there at all -- See the AvailTC Invariant in Avail.hs (n1:ns1) | n1 == name -> ns1 | otherwise -> ns - mb_children = lookupChildren subnames rdr_ns + subs = map NonFldChild subnames ++ map availFieldToChild subflds + mb_children = lookupChildren subs (rdr_ns ++ availFieldsRdrNames rdr_fs) - children <- if any isNothing mb_children - then failLookupWith BadImport - else return (catMaybes mb_children) + (childnames, childflds) <- if any isNothing mb_children + then failLookupWith BadImport + else return (childrenNamesFlds (catMaybes mb_children)) case mb_parent of -- non-associated ty/cls - Nothing -> return ([(IEThingWith name children, - AvailTC name (name:children))], + Nothing -> return ([(IEThingWith name childnames childflds, + AvailTC name (name:childnames) childflds)], []) -- associated ty - Just parent -> return ([(IEThingWith name children, - AvailTC name children), - (IEThingWith name children, - AvailTC parent [name])], + Just parent -> return ([(IEThingWith name childnames childflds, + AvailTC name childnames childflds), + (IEThingWith name childnames childflds, + AvailTC parent [name] [])], []) _other -> failLookupWith IllegalImport @@ -759,7 +819,8 @@ filterImports iface decl_spec (Just (want_hiding, import_items)) where mkIEThingAbs (n, av, Nothing ) = (IEThingAbs n, trimAvail av n) - mkIEThingAbs (n, _, Just parent) = (IEThingAbs n, AvailTC parent [n]) + mkIEThingAbs (n, _, Just parent) = ( IEThingAbs n + , AvailTC parent [n] []) handle_bad_import m = catchIELookup m $ \err -> case err of BadImport | want_hiding -> return ([], [BadImportW]) @@ -800,9 +861,10 @@ catIELookupM ms = [ a | Succeeded a <- ms ] greExportAvail :: GlobalRdrElt -> AvailInfo greExportAvail gre = case gre_par gre of - ParentIs p -> AvailTC p [me] - NoParent | isTyConName me -> AvailTC me [me] - | otherwise -> Avail me + ParentIs p -> AvailTC p [me] [] + FldParent p lbl -> AvailTC p [] [(me, lbl)] + NoParent | isTyConName me -> AvailTC me [me] [] + | otherwise -> Avail me where me = gre_name gre @@ -810,20 +872,28 @@ 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)) - (True,False) -> AvailTC n1 (s1 : (ss1 `unionLists` (s2:ss2))) - (False,True) -> AvailTC n1 (s2 : ((s1:ss1) `unionLists` ss2)) - (False,False) -> AvailTC n1 ((s1:ss1) `unionLists` (s2:ss2)) + (True,True) -> AvailTC n1 (s1 : (ss1 `unionLists` ss2)) (fs1 `plusAvailFields` fs2) + (True,False) -> AvailTC n1 (s1 : (ss1 `unionLists` (s2:ss2))) (fs1 `plusAvailFields` fs2) + (False,True) -> AvailTC n1 (s2 : ((s1:ss1) `unionLists` ss2)) (fs1 `plusAvailFields` fs2) + (False,False) -> AvailTC n1 ((s1:ss1) `unionLists` (s2:ss2)) (fs1 `plusAvailFields` fs2) +plusAvail (AvailTC n1 ss1 fs1) (AvailTC _ [] fs2) = AvailTC n1 ss1 (fs1 `plusAvailFields` fs2) +plusAvail (AvailTC n1 [] fs1) (AvailTC _ ss2 fs2) = AvailTC n1 ss2 (fs1 `plusAvailFields` fs2) plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [ppr a1,ppr a2]) +plusAvailFields :: AvailFields -> AvailFields -> AvailFields +plusAvailFields = unionLists + +-- | 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) . fst) 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] @@ -835,14 +905,15 @@ 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 . fst) 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] gresFromIE decl_spec (L loc ie, avail) - = gresFromAvail prov_fn avail + = gresFromAvail prov_fn prov_fld avail where is_explicit = case ie of IEThingAll name -> \n -> n == name @@ -852,16 +923,69 @@ gresFromIE decl_spec (L loc ie, avail) imp_spec = ImpSpec { is_decl = decl_spec, is_item = item_spec } item_spec = ImpSome { is_explicit = is_explicit name, is_iloc = loc } -mkChildEnv :: [GlobalRdrElt] -> NameEnv [Name] -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 + is_explicit_fld = case ie of + IEThingAll _ -> False + _ -> True + prov_fld = Imported [imp_spec] + where + imp_spec = ImpSpec { is_decl = decl_spec, is_item = item_spec } + item_spec = ImpSome { is_explicit = is_explicit_fld, is_iloc = loc } + -findChildren :: NameEnv [Name] -> Name -> [Name] +{- +Note [ChildNames for overloaded record fields] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the module + + {-# LANGUAGE OverloadedRecordFields #-} + 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, an OverloadedFldChild contains a list of selector names, not +just a single name. +-} + +-- | Represents the name of a child in an export item, +-- e.g. the x in import M (T(x)). +data ChildName = NonFldChild Name -- ^ Not a field + | FldChild Name -- ^ A non-overloaded field + | OverloadedFldChild FieldLabelString [Name] + -- ^ One or more overloaded fields with a common label + -- See Note [ChildNames for overloaded record fields] + +mkOverloadedFldChild :: FieldLabelString -> Name -> ChildName +mkOverloadedFldChild lbl n = OverloadedFldChild lbl [n] + +availFieldToChild :: AvailField -> ChildName +availFieldToChild (n, Nothing) = FldChild n +availFieldToChild (n, Just lbl) = OverloadedFldChild lbl [n] + +childOccName :: ChildName -> OccName +childOccName (NonFldChild n) = nameOccName n +childOccName (FldChild n) = nameOccName n +childOccName (OverloadedFldChild lbl _) = mkVarOccFS lbl + + +mkChildEnv :: [GlobalRdrElt] -> NameEnv [ChildName] +mkChildEnv gres = foldr add emptyNameEnv gres + where + add gre env = case greChild gre of + Just c -> extendNameEnv_Acc (:) singleton env (par_is (gre_par gre)) c + Nothing -> env + greChild gre = case gre_par gre of + FldParent _ (Just lbl) -> Just (mkOverloadedFldChild lbl n) + FldParent _ Nothing -> Just (FldChild n) + ParentIs _ -> Just (NonFldChild n) + NoParent -> Nothing + where n = gre_name gre + +findChildren :: NameEnv [ChildName] -> Name -> [ChildName] findChildren env n = lookupNameEnv env n `orElse` [] -lookupChildren :: [Name] -> [RdrName] -> [Maybe Name] +lookupChildren :: [ChildName] -> [RdrName] -> [Maybe ChildName] -- (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 @@ -872,7 +996,28 @@ lookupChildren :: [Name] -> [RdrName] -> [Maybe Name] lookupChildren all_kids rdr_items = map (lookupFsEnv kid_env . occNameFS . rdrNameOcc) rdr_items where - kid_env = mkFsEnv [(occNameFS (nameOccName n), n) | n <- all_kids] + kid_env = extendFsEnvList_C plusChildName emptyFsEnv + [(occNameFS (childOccName n), n) | n <- all_kids] + + plusChildName (OverloadedFldChild lbl xs) (OverloadedFldChild _ ys) + = OverloadedFldChild lbl (xs ++ ys) + plusChildName (OverloadedFldChild lbl xs) (FldChild n) + = OverloadedFldChild lbl (n:xs) + plusChildName (FldChild n) (OverloadedFldChild lbl xs) + = OverloadedFldChild lbl (n:xs) + plusChildName (FldChild m) (FldChild n) + = OverloadedFldChild (occNameFS (nameOccName m)) [m, n] + plusChildName _ y = y -- This can happen if we have both + -- Example{tc} and Example{d} in all_kids; + -- take the second because it will be the + -- data constructor (AvailTC invariant) + +childrenNamesFlds :: [ChildName] -> ([Name], AvailFields) +childrenNamesFlds xs = mconcat (map bisect xs) + where + bisect (NonFldChild n) = ([n], []) + bisect (FldChild n) = ([], [(n, Nothing)]) + bisect (OverloadedFldChild lbl ns) = ([], map (\ n -> (n, Just lbl)) ns) -- | Combines 'AvailInfo's from the same family -- 'avails' may have several items with the same availName @@ -990,7 +1135,7 @@ rnExports explicit_mod exports Nothing -> Nothing Just _ -> rn_exports, tcg_dus = tcg_dus tcg_env `plusDU` - usesOnly (availsToNameSet final_avails) }) } + usesOnly (availsToNameSetWithSelectors final_avails) }) } exports_from_avail :: Maybe [LIE RdrName] -- Nothing => no explicit export list @@ -1017,7 +1162,8 @@ exports_from_avail (Just 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 [ChildName] kids_env = mkChildEnv (globalRdrEnvElts rdr_env) imported_modules = [ qual_name @@ -1093,7 +1239,8 @@ exports_from_avail (Just rdr_items) rdr_env imports this_mod lookup_ie ie@(IEThingAll rdr) = do name <- lookupGlobalOccRn rdr - let kids = findChildren kids_env name + let kids = findChildren kids_env name + (names, flds) = childrenNamesFlds kids addUsedKids rdr kids warnDodgyExports <- woptM Opt_WarnDodgyExports when (null kids) $ @@ -1103,20 +1250,25 @@ exports_from_avail (Just rdr_items) rdr_env imports this_mod -- only import T abstractly, or T is a synonym. addErr (exportItemErr ie) - return (IEThingAll name, AvailTC name (name:kids)) + return (IEThingAll name, AvailTC name (name:names) flds) - lookup_ie ie@(IEThingWith rdr sub_rdrs) + lookup_ie ie@(IEThingWith rdr sub_rdrs sub_flds) = do name <- lookupGlobalOccRn rdr if isUnboundName name - then return (IEThingWith name [], AvailTC name [name]) + then return (IEThingWith name [] [] + , AvailTC name [name] []) else do - let mb_names = lookupChildren (findChildren kids_env name) sub_rdrs + let mb_names = lookupChildren (findChildren kids_env name) + (sub_rdrs ++ availFieldsRdrNames sub_flds) if any isNothing mb_names then do addErr (exportItemErr ie) - return (IEThingWith name [], AvailTC name [name]) - else do let names = catMaybes mb_names - addUsedKids rdr names - return (IEThingWith name names, AvailTC name (name:names)) + return ( IEThingWith name [] [] + , AvailTC name [name] []) + else do let kids = catMaybes mb_names + (names, flds) = childrenNamesFlds kids + addUsedKids rdr kids + return ( IEThingWith name names flds + , AvailTC name (name:names) flds) lookup_ie _ = panic "lookup_ie" -- Other cases covered earlier @@ -1132,7 +1284,7 @@ exports_from_avail (Just 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 . childOccName) kid_names where mk_kid_rdr = case isQual_maybe parent_rdr of Nothing -> mkRdrUnqual @@ -1144,6 +1296,12 @@ isDoc (IEDocNamed _) = True isDoc (IEGroup _ _) = True isDoc _ = False +availFieldsRdrNames :: AvailFlds RdrName -> [RdrName] +availFieldsRdrNames = map availFieldRdrName + where + availFieldRdrName (n, Nothing) = n + availFieldRdrName (_, Just lbl) = mkVarUnqual lbl + ------------------------------- isModuleExported :: Bool -> ModuleName -> GlobalRdrElt -> Bool -- True if the thing is in scope *both* unqualified, *and* with qualifier M @@ -1243,8 +1401,9 @@ reportUnusedNames :: Maybe [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 @@ -1268,9 +1427,13 @@ 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 used_child (findChildren kids_env name) -- A use of C implies a use of T, -- if C was brought into scope by T(..) or T(C) + where + used_child (NonFldChild n) = n `elemNameSet` used_names + used_child (FldChild n) = n `elemNameSet` used_names + used_child (OverloadedFldChild _ ns) = any (`elemNameSet` used_names) ns -- Filter out the ones that are -- (a) defined in this module, and @@ -1280,6 +1443,10 @@ reportUnusedNames _export_decls gbl_env unused_locals = filter is_unused_local defined_but_not_used 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 :: NameSet -> GlobalRdrElt -> Bool + used_as_selector sel_uses gre = isRecFldGRE gre && gre_name gre `elemNameSet` sel_uses \end{code} %********************************************************* @@ -1303,6 +1470,7 @@ type ImportDeclUsage warnUnusedImportDecls :: TcGblEnv -> RnM () warnUnusedImportDecls gbl_env = do { uses <- 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 @@ -1310,12 +1478,20 @@ warnUnusedImportDecls gbl_env rdr_env = tcg_rdr_env gbl_env ; let usage :: [ImportDeclUsage] - usage = findImportUsage user_imports rdr_env (Set.elems uses) + usage = findImportUsage user_imports rdr_env (Set.elems uses) sel_uses fld_env + + fld_env = mkNameEnv [ (gre_name gre, (lbl, par_is par)) + | gres <- occEnvElts rdr_env + , gre <- gres + , isOverloadedRecFldGRE gre + , let par = gre_par gre + Just lbl = par_lbl par ] ; traceRn (vcat [ ptext (sLit "Uses:") <+> ppr (Set.elems uses) + , ptext (sLit "Selector uses:") <+> ppr (nameSetToList 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 } @@ -1348,21 +1524,25 @@ type ImportMap = Map SrcLoc [AvailInfo] -- See [The ImportMap] findImportUsage :: [LImportDecl Name] -> GlobalRdrEnv -> [RdrName] + -> NameSet + -> NameEnv (FieldLabelString, Name) -> [ImportDeclUsage] -findImportUsage imports rdr_env rdrs +findImportUsage imports rdr_env rdrs sel_names fld_env = map unused_decl imports where import_usage :: ImportMap - import_usage = foldr (extendImportMap rdr_env) Map.empty rdrs + import_usage = foldr (extendImportMap fld_env rdr_env . Right) + (foldr (extendImportMap fld_env rdr_env . Left) Map.empty rdrs) + (nameSetToList sel_names) unused_decl decl@(L loc (ImportDecl { ideclHiding = imps })) = (decl, nubAvails used_avails, nameSetToList 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 @@ -1370,11 +1550,11 @@ findImportUsage imports rdr_env rdrs _other -> emptyNameSet -- No explicit import list => no unused-name list add_unused :: IE Name -> NameSet -> NameSet - add_unused (IEVar n) acc = add_unused_name n acc - add_unused (IEThingAbs n) acc = add_unused_name n acc - add_unused (IEThingAll n) acc = add_unused_all n acc - add_unused (IEThingWith p ns) acc = add_unused_with p ns acc - add_unused _ acc = acc + add_unused (IEVar n) acc = add_unused_name n acc + add_unused (IEThingAbs n) acc = add_unused_name n acc + add_unused (IEThingAll n) acc = add_unused_all n acc + add_unused (IEThingWith p ns fs) acc = add_unused_with p (ns ++ availFieldsNamesWithSelectors fs) acc + add_unused _ acc = acc add_unused_name n acc | n `elemNameSet` used_names = acc @@ -1392,15 +1572,23 @@ 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 :: NameEnv (FieldLabelString, Name) -> GlobalRdrEnv -> Either RdrName Name + -> ImportMap -> ImportMap -- For a used RdrName, 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 - | [gre] <- lookupGRE_RdrName rdr rdr_env +extendImportMap fld_env rdr_env rdr_or_sel imp_map + | Left rdr <- rdr_or_sel + , [gre] <- lookupGRE_RdrName rdr rdr_env + , Imported imps <- gre_prov gre + = add_imp gre (bestImport imps) imp_map + + | Right sel <- rdr_or_sel + , Just (lbl, _) <- lookupNameEnv fld_env sel + , [gre] <- lookupGRE_Field_Name rdr_env sel lbl , Imported imps <- gre_prov gre = add_imp gre (bestImport imps) imp_map + | otherwise = imp_map where @@ -1430,8 +1618,8 @@ extendImportMap rdr_env rdr imp_map \end{code} \begin{code} -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,[]) <- ideclHiding decl = return () -- Do not warn for 'import M()' @@ -1448,7 +1636,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 (pprWithCommas ppr_possible_field sort_unused), text "from module" <+> quotes pp_mod <+> pp_not_used] pp_herald = text "The" <+> pp_qual <+> text "import of" pp_qual @@ -1456,6 +1644,13 @@ warnUnusedImport (L loc decl, used, unused) | otherwise = Outputable.empty 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 = sortBy (comparing nameOccName) unused \end{code} Note [Do not warn about Prelude hiding] @@ -1522,18 +1717,26 @@ 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 n] - to_ie _ (AvailTC n [m]) + to_ie _ (AvailTC n [m] []) | n==m = [IEThingAbs n] - to_ie iface (AvailTC n ns) - = case [xs | AvailTC x xs <- mi_exports iface - , x == n - , x `elem` xs -- Note [Partial export] - ] of + 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 n] - | otherwise -> [IEThingWith n (filter (/= n) ns)] - _other -> map IEVar ns + | otherwise -> [IEThingWith n (filter (/= n) ns) fs] + -- Note [Overloaded field import] + _other | all_non_overloaded fs -> map IEVar (ns ++ availFieldsNames fs) + | otherwise -> [IEThingWith n (filter (/= n) ns) fs] where - all_used avail_occs = all (`elem` ns) avail_occs + fld_lbls = availFieldsLabels fs + + all_used (avail_occs, avail_flds) + = all (`elem` ns) avail_occs + && all (`elem` fld_lbls) (availFieldsLabels avail_flds) + + all_non_overloaded = all (isNothing . snd) \end{code} Note [Partial export] @@ -1556,6 +1759,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 OverloadedRecordFields #-} + 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 OverloadedRecordFields is enabled, field selectors are +not in scope without their enclosing datatype. + + %************************************************************************ %* * \subsection{Errors} @@ -1606,7 +1827,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.lhs b/compiler/rename/RnPat.lhs index aa41361655..9d05a392c2 100644 --- a/compiler/rename/RnPat.lhs +++ b/compiler/rename/RnPat.lhs @@ -49,20 +49,20 @@ import DynFlags import PrelNames import TyCon ( tyConName ) import ConLike -import DataCon ( dataConTyCon ) import TypeRep ( TyThing(..) ) import Name import NameSet import RdrName import BasicTypes import Util +import Maybes import ListSetOps ( removeDups ) import Outputable import SrcLoc import FastString import Literal ( inCharRange ) import TysWiredIn ( nilDataCon ) -import DataCon ( dataConName ) +import DataCon import Control.Monad ( when, liftM, ap ) import Data.Ratio \end{code} @@ -525,8 +525,9 @@ rnHsRecFields rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }) = do { pun_ok <- xoptM Opt_RecordPuns ; disambig_ok <- xoptM Opt_DisambiguateRecordFields + ; overload_ok <- xoptM Opt_OverloadedRecordFields ; parent <- check_disambiguation disambig_ok mb_con - ; flds1 <- mapM (rn_fld pun_ok parent) flds + ; flds1 <- mapM (rn_fld pun_ok overload_ok parent) flds ; mapM_ (addErr . dupFieldErr ctxt) dup_flds ; dotdot_flds <- rn_dotdot dotdot mb_con flds1 @@ -555,15 +556,26 @@ 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 (HsRecField { hsRecFieldId = fld - , hsRecFieldArg = arg - , hsRecPun = pun }) - = do { fld'@(L loc fld_nm) <- wrapLocM (lookupSubBndrOcc True parent doc) fld + rn_fld pun_ok overload_ok parent (HsRecField { hsRecFieldLbl = L loc lbl + , hsRecFieldArg = arg + , hsRecPun = pun }) + = do { sel <- setSrcSpan loc $ case parent of + -- Defer renaming of overloaded fields to the typechecker + -- See Note [Disambiguating record updates] in TcExpr + NoParent | overload_ok -> + do { mb <- lookupOccRn_overloaded lbl + ; case mb of + Nothing -> do { addErr (unknownSubordinateErr doc lbl) + ; return (Right []) } + Just (Left sel) -> return (Left sel) + Just (Right (_, xs)) -> return (Right xs) } + _ -> fmap Left $ 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 (HsRecField { hsRecFieldId = fld' + ; return (HsRecField { hsRecFieldLbl = L loc lbl + , hsRecFieldSel = sel , hsRecFieldArg = arg' , hsRecPun = pun }) } @@ -586,7 +598,7 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }) ; checkErr dd_flag (needFlagDotDot ctxt) ; (rdr_env, lcl_env) <- getRdrEnvs ; con_fields <- lookupConstructorFields 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) @@ -594,32 +606,36 @@ 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, 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 greRdrName dot_dot_gres) + ; addUsedRdrNames (map (greRdrName . snd) dot_dot_gres) ; return [ HsRecField - { hsRecFieldId = L loc fld + { hsRecFieldLbl = L loc arg_rdr + , hsRecFieldSel = Left fld , hsRecFieldArg = L loc (mk_arg arg_rdr) , hsRecPun = False } - | gre <- dot_dot_gres + | (lbl, gre) <- dot_dot_gres , let fld = gre_name gre - arg_rdr = mkRdrUnqual (nameOccName fld) ] } + arg_rdr = mkVarUnqual lbl ] } check_disambiguation :: Bool -> Maybe Name -> RnM Parent -- When disambiguation is on, @@ -646,10 +662,13 @@ 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 :: [HsRecField id arg] -> [id] -getFieldIds flds = map (unLoc . hsRecFieldId) flds +getFieldIds flds = mapMaybe (fmap unLoc . hsRecFieldId_maybe) flds + +getFieldLbls :: [HsRecField id arg] -> [RdrName] +getFieldLbls flds = map (unLoc . hsRecFieldLbl) flds needFlagDotDot :: HsRecFieldContext -> SDoc needFlagDotDot ctxt = vcat [ptext (sLit "Illegal `..' in record") <+> pprRFC ctxt, diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index ef93cfb616..7cad9d6f2b 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -26,6 +26,7 @@ import RnHsDoc ( rnHsDoc, rnMbLHsDoc ) import TcAnnotations ( annCtxt ) import TcRnMonad +import IfaceEnv import ForeignCall ( CCallTarget(..) ) import Module import HscTypes ( Warnings(..), plusWarns ) @@ -35,6 +36,7 @@ import Name import NameSet import NameEnv import Avail +import DataCon import Outputable import Bag import BasicTypes ( RuleName ) @@ -45,6 +47,7 @@ import HscTypes ( HscEnv, hsc_dflags ) import ListSetOps ( findDupsEq, removeDups ) import Digraph ( SCC, flattenSCC, stronglyConnCompFromEdgedVertices ) import Util ( mapSnd ) +import State import Control.Monad import Data.List( partition, sortBy ) @@ -75,10 +78,10 @@ Checks the @(..)@ etc constraints in the export list. -- does NOT assume that anything is in scope already rnSrcDecls :: [Name] -> HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name) -- Rename a HsGroup; used for normal source files *and* hs-boot files -rnSrcDecls extra_deps group@(HsGroup { hs_valds = val_decls, +rnSrcDecls extra_deps group0@(HsGroup { hs_valds = val_decls, hs_splcds = splice_decls, hs_tyclds = tycl_decls, - hs_instds = inst_decls, + hs_instds = inst_decls0, hs_derivds = deriv_decls, hs_fixds = fix_decls, hs_warnds = warn_decls, @@ -88,17 +91,23 @@ rnSrcDecls extra_deps group@(HsGroup { hs_valds = val_decls, hs_ruleds = rule_decls, hs_vects = vect_decls, hs_docs = docs }) + = do { -- (A) Process the fixity declarations, creating a mapping from -- FastStrings to FixItems. -- Also checks for duplcates. local_fix_env <- makeMiniFixityEnv fix_decls ; - -- (B) Bring top level binders (and their fixities) into scope, + -- (B) See Note [Assigning names to instance declarations] + inst_decls <- assignInstDeclNames inst_decls0 ; + let { group = group0 { hs_instds = inst_decls } } ; + + -- (C) Bring top level binders (and their fixities) into scope, -- *except* for the value bindings, which get brought in below. -- However *do* include class ops, data constructors - -- And for hs-boot files *do* include the value signatures - (tc_envs, tc_bndrs) <- getLocalNonValBinders local_fix_env group ; + -- and for hs-boot files *do* include the value signatures. + (tc_envs, tc_bndrs, flds) <- getLocalNonValBinders local_fix_env group ; + setEnvs tc_envs $ do { failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations @@ -107,7 +116,7 @@ rnSrcDecls extra_deps group@(HsGroup { hs_valds = val_decls, -- 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 { + inNewEnv (extendRecordFieldEnv flds) $ \ _ -> do { -- (D) Rename the left-hand sides of the value bindings. -- This depends on everything from (B) being in scope, @@ -186,7 +195,7 @@ rnSrcDecls extra_deps group@(HsGroup { hs_valds = val_decls, hs_vects = rn_vect_decls, hs_docs = rn_docs } ; - tycl_bndrs = hsTyClDeclsBinders rn_tycl_decls rn_inst_decls ; + (tycl_bndrs, _) = hsTyClDeclsBinders rn_tycl_decls rn_inst_decls ; ford_bndrs = hsForeignDeclsBinders rn_foreign_decls ; other_def = (Just (mkNameSet tycl_bndrs `unionNameSets` mkNameSet ford_bndrs), emptyNameSet) ; other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs3, src_fvs4, @@ -224,6 +233,57 @@ rnList f xs = mapFvRn (wrapLocFstM f) xs \end{code} +Note [Assigning names to instance declarations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Here we generate OccNames for the representation tycons of data +families, and store them in the dfid_rep_tycon field of +DataFamInstDecl. This has to happen prior to getLocalNonValBinders, +because we need them in order to bring overloaded record fields into +scope. + +FIXME: it should be possible to do the same thing for ClsInstDecl and +TyFamInstDecl, and hence get rid of the tcg_dfun_n mutable reference +altogether (along with newDFunName and newFamInstTyConName). However, +this requires some refactoring of the uses in TcDeriv and TcGenGenerics. + +\begin{code} +assignInstDeclNames :: [LInstDecl RdrName] -> RnM [LInstDecl RdrName] +assignInstDeclNames ds = do + ref <- fmap tcg_dfun_n getGblEnv + occs <- readTcRef ref + let (ds', occs') = runState (traverse (traverse assignNamesInstDecl) ds) occs + writeTcRef ref occs' + return ds' + +assignNamesInstDecl :: InstDecl RdrName -> State OccSet (InstDecl RdrName) +assignNamesInstDecl (ClsInstD cid) = ClsInstD <$> assignNamesClsInstDecl cid +assignNamesInstDecl (DataFamInstD dfid) = DataFamInstD <$> assignNamesDataFamInstDecl dfid +assignNamesInstDecl (TyFamInstD tfid) = return $ TyFamInstD tfid + +assignNamesClsInstDecl :: ClsInstDecl RdrName -> State OccSet (ClsInstDecl RdrName) +assignNamesClsInstDecl cid = do + datafam_insts <- traverse (traverse assignNamesDataFamInstDecl) (cid_datafam_insts cid) + return cid { cid_datafam_insts = datafam_insts } + +assignNamesDataFamInstDecl :: DataFamInstDecl RdrName -> State OccSet (DataFamInstDecl RdrName) +assignNamesDataFamInstDecl dfid = do + occ <- assignOccName (mkInstTyTcOcc info_string) + return dfid { dfid_rep_tycon = mkRdrUnqual occ } + where + info_string = occNameString (rdrNameOcc $ unLoc $ dfid_tycon dfid) + ++ concatMap (getDFunHsTypeKey . unLoc) (hswb_cts (dfid_pats dfid)) + +assignOccName :: (OccSet -> OccName) -> State OccSet OccName +assignOccName f = do + occs <- get + let occ = f occs + put (extendOccSet occs occ) + return occ +\end{code} + + + %********************************************************* %* * HsDoc stuff @@ -595,11 +655,15 @@ rnDataFamInstDecl :: Maybe (Name, [Name]) -> DataFamInstDecl RdrName -> RnM (DataFamInstDecl Name, FreeVars) rnDataFamInstDecl mb_cls (DataFamInstDecl { dfid_tycon = tycon + , dfid_rep_tycon = rep_tycon , dfid_pats = HsWB { hswb_cts = pats } , dfid_defn = defn }) = do { (tycon', pats', defn', fvs) <- rnFamInstDecl (TyDataCtx tycon) mb_cls tycon pats defn rnDataDefn + ; mod <- getModule + ; rep_tycon' <- newGlobalBinder mod (rdrNameOcc rep_tycon) (getLoc tycon) ; return (DataFamInstDecl { dfid_tycon = tycon' + , dfid_rep_tycon = rep_tycon' , dfid_pats = pats' , dfid_defn = defn' , dfid_fvs = fvs }, fvs) } @@ -1302,7 +1366,7 @@ rnConDecl decl@(ConDecl { con_name = name, 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 new_name) doc details ; (new_details', new_res_ty, fvs3) <- rnConResult doc (unLoc new_name) new_details res_ty ; return (decl { con_name = new_name, con_qvars = new_tyvars, con_cxt = new_context , con_details = new_details', con_res = new_res_ty, con_doc = mb_doc' }, @@ -1342,20 +1406,21 @@ rnConResult doc con details (ResTyGADT ty) | otherwise -> return (PrefixCon arg_tys, ResTyGADT res_ty, fvs) } -rnConDeclDetails :: HsDocContext +rnConDeclDetails :: Name + -> HsDocContext -> HsConDetails (LHsType RdrName) [ConDeclField RdrName] -> RnM (HsConDetails (LHsType Name) [ConDeclField 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 fields) - = do { (new_fields, fvs) <- rnConDeclFields doc fields +rnConDeclDetails con doc (RecCon fields) + = do { (new_fields, fvs) <- rnConDeclFields con doc fields -- No need to check for duplicate fields -- since that is done by RnNames.extendGlobalRdrEnvRn ; return (RecCon new_fields, fvs) } @@ -1392,37 +1457,15 @@ For example: %********************************************************* Get the mapping from constructors to fields for this module. -It's convenient to do this after the data type decls have been renamed +This used to be complicated, but now all the work is done by +RnNames.getLocalNonValBinders. + \begin{code} -extendRecordFieldEnv :: [TyClGroup RdrName] -> [LInstDecl RdrName] -> TcM TcGblEnv -extendRecordFieldEnv tycl_decls inst_decls +extendRecordFieldEnv :: [(Name, [FieldLabel])] -> TcM TcGblEnv +extendRecordFieldEnv flds = do { tcg_env <- getGblEnv - ; field_env' <- foldrM get_con (tcg_field_env tcg_env) all_data_cons + ; let field_env' = extendNameEnvList (tcg_field_env tcg_env) flds ; 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_name = con, con_details = RecCon flds }) - (RecFields env fld_set) - = do { con' <- lookup con - ; flds' <- mapM 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/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs index 38985a45d9..b13c26e289 100644 --- a/compiler/rename/RnTypes.lhs +++ b/compiler/rename/RnTypes.lhs @@ -38,6 +38,7 @@ import TysPrim ( funTyConName ) import Name import SrcLoc import NameSet +import FieldLabel import Util import BasicTypes ( compareFixity, funTyFixity, negateFixity, @@ -45,7 +46,7 @@ import BasicTypes ( compareFixity, funTyFixity, negateFixity, import Outputable import FastString import Maybes -import Data.List ( nub ) +import Data.List ( nub, find ) import Control.Monad ( unless, when ) #include "HsVersions.h" @@ -212,9 +213,9 @@ rnHsTyKi isType doc (HsBangTy b ty) ; return (HsBangTy b ty', fvs) } rnHsTyKi _ doc ty@(HsRecTy flds) - = do { addErr (hang (ptext (sLit "Record syntax is illegal here:")) - 2 (ppr ty)) - ; (flds', fvs) <- rnConDeclFields doc flds + = do { addErr (recordSyntaxIllegalErr False ty) + ; let bogus_con = mkUnboundName (mkRdrUnqual (mkTcOcc "bogus_con")) + ; (flds', fvs) <- rnConDeclFields bogus_con doc flds ; return (HsRecTy flds', fvs) } rnHsTyKi isType doc (HsFunTy ty1 ty2) @@ -268,6 +269,13 @@ rnHsTyKi isType _ tyLit@(HsTyLit t) negLit (HsNumTy i) = i < 0 negLitErr = ptext (sLit "Illegal literal in type (type literals must not be negative):") <+> ppr tyLit +rnHsTyKi isType doc ty@(HsAppTy ty1 (L loc (HsRecTy flds))) + = do { overload_ok <- xoptM Opt_OverloadedRecordFields + ; unless (overload_ok && isType) $ addErr (recordSyntaxIllegalErr isType ty) + ; (ty1', fvs1) <- rnLHsTyKi isType doc ty1 + ; (flds', fvs2) <- setSrcSpan loc $ rnOverloadedRecordFields doc flds + ; return (HsAppTy ty1' (L loc (HsRecTy flds')), fvs1 `plusFV` fvs2) } + rnHsTyKi isType doc (HsAppTy ty1 ty2) = do { (ty1', fvs1) <- rnLHsTyKi isType doc ty1 ; (ty2', fvs2) <- rnLHsTyKi isType doc ty2 @@ -502,6 +510,16 @@ dataKindsErr is_type thing where what | is_type = ptext (sLit "type") | otherwise = ptext (sLit "kind") + +recordSyntaxIllegalErr :: Bool -> HsType RdrName -> SDoc +recordSyntaxIllegalErr suggest_overloaded ty + = hang (hang (ptext (sLit "Record syntax is illegal here:")) + 2 (ppr ty)) + 4 suggestion + where + suggestion | suggest_overloaded + = ptext (sLit "Perhaps you intended to use -XOverloadedRecordFields") + | otherwise = empty \end{code} Note [Renaming associated types] @@ -536,21 +554,36 @@ but it seems tiresome to do so. %********************************************************* \begin{code} -rnConDeclFields :: HsDocContext -> [ConDeclField RdrName] +rnConDeclFields :: Name -> HsDocContext -> [ConDeclField RdrName] -> RnM ([ConDeclField Name], FreeVars) -rnConDeclFields doc fields = mapFvRn (rnField doc) fields +rnConDeclFields con doc fields = mapFvRn (rnField con doc) fields -rnField :: HsDocContext -> ConDeclField RdrName -> RnM (ConDeclField Name, FreeVars) -rnField doc (ConDeclField name ty haddock_doc) - = do { new_name <- lookupLocatedTopBndrRn name +rnField :: Name -> HsDocContext -> ConDeclField RdrName -> RnM (ConDeclField Name, FreeVars) +rnField con doc (ConDeclField name _ ty haddock_doc) + = do { flds <- lookupConstructorFields con + ; let lbl = occNameFS $ rdrNameOcc $ unLoc name + ; let fl = expectJust "rnField" $ find ((== lbl) . flLabel) flds ; (new_ty, fvs) <- rnLHsType doc ty ; new_haddock_doc <- rnMbLHsDoc haddock_doc - ; return (ConDeclField new_name new_ty new_haddock_doc, fvs) } + ; return (ConDeclField name (flSelector fl) new_ty new_haddock_doc, fvs) } rnContext :: HsDocContext -> LHsContext RdrName -> RnM (LHsContext Name, FreeVars) rnContext doc (L loc cxt) = do { (cxt', fvs) <- rnLHsTypes doc cxt ; return (L loc cxt', fvs) } + +-- Handles r { x :: t } syntax for overloaded record field constraints +-- Unlike rnConDeclFields, this can occur in normal types +rnOverloadedRecordFields :: HsDocContext -> [ConDeclField RdrName] + -> RnM ([ConDeclField Name], FreeVars) +rnOverloadedRecordFields doc flds = mapFvRn (rnOverloadedField doc) flds + +rnOverloadedField :: HsDocContext -> ConDeclField RdrName -> RnM (ConDeclField Name, FreeVars) +rnOverloadedField doc (ConDeclField name _ ty haddock_doc) + = do { (new_ty, fvs) <- rnLHsType doc ty + ; when (isJust haddock_doc) $ + addErr (ptext (sLit "Haddock docs are forbidden on overloaded record fields")) + ; return (ConDeclField name (mkUnboundName (unLoc name)) new_ty haddock_doc, fvs) } \end{code} |