diff options
275 files changed, 6237 insertions, 4222 deletions
diff --git a/compiler/GHC.hs b/compiler/GHC.hs index a6cce31837..0182b5a2a1 100644 --- a/compiler/GHC.hs +++ b/compiler/GHC.hs @@ -1,7 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE NondecreasingIndentation, ScopedTypeVariables #-} {-# LANGUAGE TupleSections, NamedFieldPuns #-} -{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE TypeFamilies #-} -- ----------------------------------------------------------------------------- @@ -342,7 +341,7 @@ import GHC.Builtin.Types.Prim ( alphaTyVars ) import GHC.Data.StringBuffer import GHC.Data.FastString import qualified GHC.LanguageExtensions as LangExt -import GHC.Rename.Names (renamePkgQual, renameRawPkgQual) +import GHC.Rename.Names (renamePkgQual, renameRawPkgQual, gresFromAvails) import GHC.Tc.Utils.Monad ( finalSafeMode, fixSafeInstances, initIfaceTcRn ) import GHC.Tc.Types @@ -353,6 +352,7 @@ import GHC.Tc.Instance.Family import GHC.Utils.TmpFs import GHC.Utils.Error +import GHC.Utils.Exception import GHC.Utils.Monad import GHC.Utils.Misc import GHC.Utils.Outputable @@ -373,6 +373,8 @@ import GHC.Core.FamInstEnv ( FamInst, famInstEnvElts, orphNamesOfFamInst ) import GHC.Core.InstEnv import GHC.Core +import GHC.Data.Maybe + import GHC.Types.Id import GHC.Types.Name hiding ( varName ) import GHC.Types.Avail @@ -405,29 +407,26 @@ import GHC.Unit.Module.ModSummary import GHC.Unit.Module.Graph import GHC.Unit.Home.ModInfo +import Control.Applicative ((<|>)) +import Control.Concurrent +import Control.Monad +import Control.Monad.Catch as MC import Data.Foldable +import Data.IORef +import Data.List (isPrefixOf) +import Data.Typeable ( Typeable ) +import Data.Word ( Word8 ) + import qualified Data.Map.Strict as Map import Data.Set (Set) +import qualified Data.Set as S import qualified Data.Sequence as Seq -import Data.Maybe -import Data.Typeable ( Typeable ) -import Data.Word ( Word8 ) -import Control.Monad + +import System.Directory +import System.Environment ( getEnv, getProgName ) import System.Exit ( exitWith, ExitCode(..) ) -import GHC.Utils.Exception -import Data.IORef import System.FilePath -import Control.Concurrent -import Control.Applicative ((<|>)) -import Control.Monad.Catch as MC - -import GHC.Data.Maybe import System.IO.Error ( isDoesNotExistError ) -import System.Environment ( getEnv, getProgName ) -import System.Directory -import Data.List (isPrefixOf) -import qualified Data.Set as S - -- %************************************************************************ -- %* * @@ -1201,6 +1200,9 @@ typecheckModule pmod = do details <- makeSimpleDetails lcl_logger tc_gbl_env safe <- finalSafeMode lcl_dflags tc_gbl_env + let !rdr_env = forceGlobalRdrEnv $ tcg_rdr_env tc_gbl_env + -- See Note [Forcing GREInfo] in GHC.Types.GREInfo. + return $ TypecheckedModule { tm_internals_ = (tc_gbl_env, details), @@ -1211,7 +1213,7 @@ typecheckModule pmod = do ModuleInfo { minf_type_env = md_types details, minf_exports = md_exports details, - minf_rdr_env = Just (tcg_rdr_env tc_gbl_env), + minf_rdr_env = Just rdr_env, minf_instances = fixSafeInstances safe $ instEnvElts $ md_insts details, minf_iface = Nothing, minf_safe = safe, @@ -1364,7 +1366,7 @@ getNamePprCtx = withSession $ \hsc_env -> do data ModuleInfo = ModuleInfo { minf_type_env :: TypeEnv, minf_exports :: [AvailInfo], - minf_rdr_env :: Maybe GlobalRdrEnv, -- Nothing for a compiled/package mod + minf_rdr_env :: Maybe IfGlobalRdrEnv, -- Nothing for a compiled/package mod minf_instances :: [ClsInst], minf_iface :: Maybe ModIface, minf_safe :: SafeHaskellMode, @@ -1390,40 +1392,45 @@ getPackageModuleInfo hsc_env mdl pte = eps_PTE eps tys = [ ty | name <- concatMap availNames avails, Just ty <- [lookupTypeEnv pte name] ] - -- + + let !rdr_env = availsToGlobalRdrEnv hsc_env (moduleName mdl) avails + -- See Note [Forcing GREInfo] in GHC.Types.GREInfo. + return (Just (ModuleInfo { minf_type_env = mkTypeEnv tys, minf_exports = avails, - minf_rdr_env = Just $! availsToGlobalRdrEnv (moduleName mdl) avails, + minf_rdr_env = Just rdr_env, minf_instances = error "getModuleInfo: instances for package module unimplemented", minf_iface = Just iface, minf_safe = getSafeMode $ mi_trust iface, minf_modBreaks = emptyModBreaks })) -availsToGlobalRdrEnv :: ModuleName -> [AvailInfo] -> GlobalRdrEnv -availsToGlobalRdrEnv mod_name avails - = mkGlobalRdrEnv (gresFromAvails (Just imp_spec) avails) +availsToGlobalRdrEnv :: HasDebugCallStack => HscEnv -> ModuleName -> [AvailInfo] -> IfGlobalRdrEnv +availsToGlobalRdrEnv hsc_env mod avails + = forceGlobalRdrEnv rdr_env + -- See Note [Forcing GREInfo] in GHC.Types.GREInfo. where + rdr_env = mkGlobalRdrEnv (gresFromAvails hsc_env (Just imp_spec) avails) -- We're building a GlobalRdrEnv as if the user imported -- all the specified modules into the global interactive module imp_spec = ImpSpec { is_decl = decl, is_item = ImpAll} - decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name, + decl = ImpDeclSpec { is_mod = mod, is_as = mod, is_qual = False, is_dloc = srcLocSpan interactiveSrcLoc } - getHomeModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo) getHomeModuleInfo hsc_env mdl = case lookupHugByModule mdl (hsc_HUG hsc_env) of Nothing -> return Nothing Just hmi -> do - let details = hm_details hmi - iface = hm_iface hmi + let details = hm_details hmi + iface = hm_iface hmi return (Just (ModuleInfo { minf_type_env = md_types details, minf_exports = md_exports details, - minf_rdr_env = mi_globals $! hm_iface hmi, + minf_rdr_env = mi_globals $ hm_iface hmi, + -- NB: already forced. See Note [Forcing GREInfo] in GHC.Types.GREInfo. minf_instances = instEnvElts $ md_insts details, minf_iface = Just iface, minf_safe = getSafeMode $ mi_trust iface @@ -1436,13 +1443,15 @@ modInfoTyThings minf = typeEnvElts (minf_type_env minf) modInfoTopLevelScope :: ModuleInfo -> Maybe [Name] modInfoTopLevelScope minf - = fmap (map greMangledName . globalRdrEnvElts) (minf_rdr_env minf) + = fmap (map greName . globalRdrEnvElts) (minf_rdr_env minf) + -- NB: no need to force this again. + -- See Note [Forcing GREInfo] in GHC.Types.GREInfo. modInfoExports :: ModuleInfo -> [Name] modInfoExports minf = concatMap availNames $! minf_exports minf modInfoExportsWithSelectors :: ModuleInfo -> [Name] -modInfoExportsWithSelectors minf = concatMap availNamesWithSelectors $! minf_exports minf +modInfoExportsWithSelectors minf = concatMap availNames $! minf_exports minf -- | Returns the instances defined by the specified module. -- Warning: currently unimplemented for package modules. @@ -1472,7 +1481,7 @@ modInfoLookupName minf name = withSession $ \hsc_env -> do modInfoIface :: ModuleInfo -> Maybe ModIface modInfoIface = minf_iface -modInfoRdrEnv :: ModuleInfo -> Maybe GlobalRdrEnv +modInfoRdrEnv :: ModuleInfo -> Maybe IfGlobalRdrEnv modInfoRdrEnv = minf_rdr_env -- | Retrieve module safe haskell mode diff --git a/compiler/GHC/Builtin/Names.hs b/compiler/GHC/Builtin/Names.hs index 34bd17a23f..8671b5521f 100644 --- a/compiler/GHC/Builtin/Names.hs +++ b/compiler/GHC/Builtin/Names.hs @@ -868,10 +868,10 @@ r1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "R1") prodDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit ":*:") comp1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Comp1") -unPar1_RDR = varQual_RDR gHC_GENERICS (fsLit "unPar1") -unRec1_RDR = varQual_RDR gHC_GENERICS (fsLit "unRec1") -unK1_RDR = varQual_RDR gHC_GENERICS (fsLit "unK1") -unComp1_RDR = varQual_RDR gHC_GENERICS (fsLit "unComp1") +unPar1_RDR = fieldQual_RDR gHC_GENERICS (fsLit "Par1") (fsLit "unPar1") +unRec1_RDR = fieldQual_RDR gHC_GENERICS (fsLit "Rec1") (fsLit "unRec1") +unK1_RDR = fieldQual_RDR gHC_GENERICS (fsLit "K1") (fsLit "unK1") +unComp1_RDR = fieldQual_RDR gHC_GENERICS (fsLit "Comp1") (fsLit "unComp1") from_RDR = varQual_RDR gHC_GENERICS (fsLit "from") from1_RDR = varQual_RDR gHC_GENERICS (fsLit "from1") @@ -900,12 +900,12 @@ uFloatDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "UFloat") uIntDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "UInt") uWordDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "UWord") -uAddrHash_RDR = varQual_RDR gHC_GENERICS (fsLit "uAddr#") -uCharHash_RDR = varQual_RDR gHC_GENERICS (fsLit "uChar#") -uDoubleHash_RDR = varQual_RDR gHC_GENERICS (fsLit "uDouble#") -uFloatHash_RDR = varQual_RDR gHC_GENERICS (fsLit "uFloat#") -uIntHash_RDR = varQual_RDR gHC_GENERICS (fsLit "uInt#") -uWordHash_RDR = varQual_RDR gHC_GENERICS (fsLit "uWord#") +uAddrHash_RDR = fieldQual_RDR gHC_GENERICS (fsLit "UAddr") (fsLit "uAddr#") +uCharHash_RDR = fieldQual_RDR gHC_GENERICS (fsLit "UChar") (fsLit "uChar#") +uDoubleHash_RDR = fieldQual_RDR gHC_GENERICS (fsLit "UDouble") (fsLit "uDouble#") +uFloatHash_RDR = fieldQual_RDR gHC_GENERICS (fsLit "UFloat") (fsLit "uFloat#") +uIntHash_RDR = fieldQual_RDR gHC_GENERICS (fsLit "UInt") (fsLit "uInt#") +uWordHash_RDR = fieldQual_RDR gHC_GENERICS (fsLit "UWord") (fsLit "uWord#") fmap_RDR, replace_RDR, pure_RDR, ap_RDR, liftA2_RDR, foldable_foldr_RDR, foldMap_RDR, null_RDR, all_RDR, traverse_RDR, mempty_RDR, @@ -931,6 +931,9 @@ tcQual_RDR mod str = mkOrig mod (mkOccNameFS tcName str) clsQual_RDR mod str = mkOrig mod (mkOccNameFS clsName str) dataQual_RDR mod str = mkOrig mod (mkOccNameFS dataName str) +fieldQual_RDR :: Module -> FastString -> FastString -> RdrName +fieldQual_RDR mod con str = mkOrig mod (mkOccNameFS (fieldName con) str) + {- ************************************************************************ * * diff --git a/compiler/GHC/Builtin/Names/TH.hs b/compiler/GHC/Builtin/Names/TH.hs index bea3b9715f..c7e817c47e 100644 --- a/compiler/GHC/Builtin/Names/TH.hs +++ b/compiler/GHC/Builtin/Names/TH.hs @@ -11,9 +11,9 @@ import GHC.Prelude () import GHC.Builtin.Names( mk_known_key_name ) import GHC.Unit.Types import GHC.Types.Name( Name ) -import GHC.Types.Name.Occurrence( tcName, clsName, dataName, varName ) +import GHC.Types.Name.Occurrence( tcName, clsName, dataName, varName, fieldName ) import GHC.Types.Name.Reader( RdrName, nameRdrName ) -import GHC.Types.Unique +import GHC.Types.Unique ( Unique ) import GHC.Builtin.Uniques import GHC.Data.FastString @@ -31,7 +31,8 @@ templateHaskellNames :: [Name] templateHaskellNames = [ returnQName, bindQName, sequenceQName, newNameName, liftName, liftTypedName, - mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameLName, + mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameG_fldName, + mkNameLName, mkNameSName, mkNameQName, mkModNameName, liftStringName, @@ -174,14 +175,19 @@ qqLib = mkTHModule (fsLit "Language.Haskell.TH.Quote") mkTHModule :: FastString -> Module mkTHModule m = mkModule thUnit (mkModuleNameFS m) -libFun, libTc, thFun, thTc, thCls, thCon, qqFun :: FastString -> Unique -> Name +libFun, libTc, thFun, thTc, thCls, thCon :: FastString -> Unique -> Name libFun = mk_known_key_name varName thLib libTc = mk_known_key_name tcName thLib thFun = mk_known_key_name varName thSyn thTc = mk_known_key_name tcName thSyn thCls = mk_known_key_name clsName thSyn thCon = mk_known_key_name dataName thSyn -qqFun = mk_known_key_name varName qqLib + +thFld :: FastString -> FastString -> Unique -> Name +thFld con = mk_known_key_name (fieldName con) thSyn + +qqFld :: FastString -> Unique -> Name +qqFld = mk_known_key_name (fieldName (fsLit "QuasiQuoter")) qqLib -------------------- TH.Syntax ----------------------- liftClassName :: Name @@ -214,7 +220,7 @@ overlapTyConName = thTc (fsLit "Overlap") overlapTyConKey modNameTyConName = thTc (fsLit "ModName") modNameTyConKey returnQName, bindQName, sequenceQName, newNameName, liftName, - mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, + mkNameName, mkNameG_vName, mkNameG_fldName, mkNameG_dName, mkNameG_tcName, mkNameLName, mkNameSName, liftStringName, unTypeName, unTypeCodeName, unsafeCodeCoerceName, liftTypedName, mkModNameName, mkNameQName :: Name returnQName = thFun (fsLit "returnQ") returnQIdKey @@ -227,11 +233,12 @@ mkNameName = thFun (fsLit "mkName") mkNameIdKey mkNameG_vName = thFun (fsLit "mkNameG_v") mkNameG_vIdKey mkNameG_dName = thFun (fsLit "mkNameG_d") mkNameG_dIdKey mkNameG_tcName = thFun (fsLit "mkNameG_tc") mkNameG_tcIdKey +mkNameG_fldName= thFun (fsLit "mkNameG_fld") mkNameG_fldIdKey mkNameLName = thFun (fsLit "mkNameL") mkNameLIdKey mkNameQName = thFun (fsLit "mkNameQ") mkNameQIdKey mkNameSName = thFun (fsLit "mkNameS") mkNameSIdKey mkModNameName = thFun (fsLit "mkModName") mkModNameIdKey -unTypeName = thFun (fsLit "unType") unTypeIdKey +unTypeName = thFld (fsLit "TExp") (fsLit "unType") unTypeIdKey unTypeCodeName = thFun (fsLit "unTypeCode") unTypeCodeIdKey unsafeCodeCoerceName = thFun (fsLit "unsafeCodeCoerce") unsafeCodeCoerceIdKey liftTypedName = thFun (fsLit "liftTyped") liftTypedIdKey @@ -593,10 +600,10 @@ derivStrategyTyConName = thTc (fsLit "DerivStrategy") derivStrategyTyConKey -- quasiquoting quoteExpName, quotePatName, quoteDecName, quoteTypeName :: Name -quoteExpName = qqFun (fsLit "quoteExp") quoteExpKey -quotePatName = qqFun (fsLit "quotePat") quotePatKey -quoteDecName = qqFun (fsLit "quoteDec") quoteDecKey -quoteTypeName = qqFun (fsLit "quoteType") quoteTypeKey +quoteExpName = qqFld (fsLit "quoteExp") quoteExpKey +quotePatName = qqFld (fsLit "quotePat") quotePatKey +quoteDecName = qqFld (fsLit "quoteDec") quoteDecKey +quoteTypeName = qqFld (fsLit "quoteType") quoteTypeKey -- data Inline = ... noInlineDataConName, inlineDataConName, inlinableDataConName :: Name @@ -741,7 +748,7 @@ incoherentDataConKey = mkPreludeDataConUnique 212 -- If you want to change this, make sure you check in GHC.Builtin.Names returnQIdKey, bindQIdKey, sequenceQIdKey, liftIdKey, newNameIdKey, - mkNameIdKey, mkNameG_vIdKey, mkNameG_dIdKey, mkNameG_tcIdKey, + mkNameIdKey, mkNameG_vIdKey, mkNameG_fldIdKey, mkNameG_dIdKey, mkNameG_tcIdKey, mkNameLIdKey, mkNameSIdKey, unTypeIdKey, unTypeCodeIdKey, unsafeCodeCoerceIdKey, liftTypedIdKey, mkModNameIdKey, mkNameQIdKey :: Unique returnQIdKey = mkPreludeMiscIdUnique 200 @@ -761,6 +768,7 @@ liftTypedIdKey = mkPreludeMiscIdUnique 214 mkModNameIdKey = mkPreludeMiscIdUnique 215 unsafeCodeCoerceIdKey = mkPreludeMiscIdUnique 216 mkNameQIdKey = mkPreludeMiscIdUnique 217 +mkNameG_fldIdKey = mkPreludeMiscIdUnique 218 -- data Lit = ... @@ -1114,12 +1122,14 @@ inferredSpecKey = mkPreludeMiscIdUnique 499 ************************************************************************ -} -lift_RDR, liftTyped_RDR, mkNameG_dRDR, mkNameG_vRDR, unsafeCodeCoerce_RDR :: RdrName +lift_RDR, liftTyped_RDR, mkNameG_dRDR, mkNameG_vRDR, mkNameG_fldRDR, + unsafeCodeCoerce_RDR :: RdrName lift_RDR = nameRdrName liftName liftTyped_RDR = nameRdrName liftTypedName unsafeCodeCoerce_RDR = nameRdrName unsafeCodeCoerceName mkNameG_dRDR = nameRdrName mkNameG_dName mkNameG_vRDR = nameRdrName mkNameG_vName +mkNameG_fldRDR = nameRdrName mkNameG_fldName -- data Exp = ... conE_RDR, litE_RDR, appE_RDR, infixApp_RDR :: RdrName diff --git a/compiler/GHC/Builtin/Uniques.hs b/compiler/GHC/Builtin/Uniques.hs index 1a440792e5..7b95c5d11e 100644 --- a/compiler/GHC/Builtin/Uniques.hs +++ b/compiler/GHC/Builtin/Uniques.hs @@ -31,10 +31,12 @@ module GHC.Builtin.Uniques , mkPreludeMiscIdUnique, mkPreludeDataConUnique , mkPreludeTyConUnique, mkPreludeClassUnique - , mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique , mkRegSingleUnique, mkRegPairUnique, mkRegClassUnique, mkRegSubUnique , mkCostCentreUnique + , varNSUnique, dataNSUnique, tvNSUnique, tcNSUnique + , mkFldNSUnique, isFldNSUnique + , mkBuiltinUnique , mkPseudoUniqueE @@ -378,12 +380,18 @@ mkRegClassUnique = mkUnique 'L' mkCostCentreUnique :: Int -> Unique mkCostCentreUnique = mkUnique 'C' -mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique :: FastString -> Unique --- See Note [The Unique of an OccName] in GHC.Types.Name.Occurrence -mkVarOccUnique fs = mkUnique 'i' (uniqueOfFS fs) -mkDataOccUnique fs = mkUnique 'd' (uniqueOfFS fs) -mkTvOccUnique fs = mkUnique 'v' (uniqueOfFS fs) -mkTcOccUnique fs = mkUnique 'c' (uniqueOfFS fs) +varNSUnique, dataNSUnique, tvNSUnique, tcNSUnique :: Unique +varNSUnique = mkUnique 'i' 0 +dataNSUnique = mkUnique 'd' 0 +tvNSUnique = mkUnique 'v' 0 +tcNSUnique = mkUnique 'c' 0 + +mkFldNSUnique :: FastString -> Unique +mkFldNSUnique fs = mkUnique 'f' (uniqueOfFS fs) + +isFldNSUnique :: Unique -> Bool +isFldNSUnique uniq = case unpkUnique uniq of + (tag, _) -> tag == 'f' initExitJoinUnique :: Unique initExitJoinUnique = mkUnique 's' 0 diff --git a/compiler/GHC/Builtin/Uniques.hs-boot b/compiler/GHC/Builtin/Uniques.hs-boot index 7c012262b1..2ec48fa293 100644 --- a/compiler/GHC/Builtin/Uniques.hs-boot +++ b/compiler/GHC/Builtin/Uniques.hs-boot @@ -4,7 +4,6 @@ import GHC.Prelude import GHC.Types.Unique import {-# SOURCE #-} GHC.Types.Name import GHC.Types.Basic -import GHC.Data.FastString -- Needed by GHC.Builtin.Types knownUniqueName :: Unique -> Maybe Name @@ -27,7 +26,6 @@ mkPreludeMiscIdUnique :: Int -> Unique mkPseudoUniqueE, mkBuiltinUnique :: Int -> Unique mkRegSingleUnique, mkRegPairUnique, mkRegSubUnique, mkRegClassUnique :: Int -> Unique -mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique :: FastString -> Unique initExitJoinUnique :: Unique diff --git a/compiler/GHC/Builtin/Utils.hs b/compiler/GHC/Builtin/Utils.hs index a815c5e5bb..10fb526752 100644 --- a/compiler/GHC/Builtin/Utils.hs +++ b/compiler/GHC/Builtin/Utils.hs @@ -239,10 +239,10 @@ sense of them in interface pragmas. It's cool, though they all have ghcPrimExports :: [IfaceExport] ghcPrimExports - = map (avail . idName) ghcPrimIds ++ - map (avail . idName) allThePrimOpIds ++ - [ availTC n [n] [] - | tc <- exposedPrimTyCons, let n = tyConName tc ] + = map (Avail . idName) ghcPrimIds ++ + map (Avail . idName) allThePrimOpIds ++ + [ AvailTC n [n] + | tc <- exposedPrimTyCons, let n = tyConName tc ] ghcPrimDeclDocs :: Docs ghcPrimDeclDocs = emptyDocs { docs_decls = listToUniqMap $ mapMaybe findName primOpDocs } diff --git a/compiler/GHC/ByteCode/Linker.hs b/compiler/GHC/ByteCode/Linker.hs index 8a7a24ae1a..4419309788 100644 --- a/compiler/GHC/ByteCode/Linker.hs +++ b/compiler/GHC/ByteCode/Linker.hs @@ -194,7 +194,7 @@ nameToCLabel n suffix = mkFastString label mod -> mod packagePart = encodeZ (unitFS pkgKey) modulePart = encodeZ (moduleNameFS modName) - occPart = encodeZ (occNameFS (nameOccName n)) + occPart = encodeZ $ occNameMangledFS (nameOccName n) label = concat [ if pkgKey == mainUnit then "" else packagePart ++ "_" diff --git a/compiler/GHC/Core/ConLike.hs b/compiler/GHC/Core/ConLike.hs index f1b147c972..e609bd4b51 100644 --- a/compiler/GHC/Core/ConLike.hs +++ b/compiler/GHC/Core/ConLike.hs @@ -9,9 +9,11 @@ module GHC.Core.ConLike ( ConLike(..) + , conLikeConLikeName , isVanillaConLike , conLikeArity , conLikeFieldLabels + , conLikeConInfo , conLikeInstOrigArgTys , conLikeUserTyVarBinders , conLikeExTyCoVars @@ -29,16 +31,19 @@ module GHC.Core.ConLike ( import GHC.Prelude import GHC.Core.DataCon +import GHC.Core.Multiplicity import GHC.Core.PatSyn -import GHC.Utils.Outputable +import GHC.Core.TyCo.Rep (Type, ThetaType) +import GHC.Core.Type(mkTyConApp) import GHC.Types.Unique -import GHC.Utils.Misc import GHC.Types.Name +import GHC.Types.Name.Reader import GHC.Types.Basic -import GHC.Core.TyCo.Rep (Type, ThetaType) + +import GHC.Types.GREInfo import GHC.Types.Var -import GHC.Core.Type(mkTyConApp) -import GHC.Core.Multiplicity +import GHC.Utils.Misc +import GHC.Utils.Outputable import Data.Maybe( isJust ) import qualified Data.Data as Data @@ -61,6 +66,10 @@ isVanillaConLike :: ConLike -> Bool isVanillaConLike (RealDataCon con) = isVanillaDataCon con isVanillaConLike (PatSynCon ps ) = isVanillaPatSyn ps +conLikeConLikeName :: ConLike -> ConLikeName +conLikeConLikeName (RealDataCon dc) = DataConName (dataConName dc) +conLikeConLikeName (PatSynCon ps) = PatSynName (patSynName ps) + {- ************************************************************************ * * @@ -113,6 +122,11 @@ conLikeFieldLabels :: ConLike -> [FieldLabel] conLikeFieldLabels (RealDataCon data_con) = dataConFieldLabels data_con conLikeFieldLabels (PatSynCon pat_syn) = patSynFieldLabels pat_syn +-- | The 'ConInfo' (arity and field labels) associated to a 'ConLike'. +conLikeConInfo :: ConLike -> ConInfo +conLikeConInfo con = + mkConInfo (conLikeArity con) (conLikeFieldLabels con) + -- | Returns just the instantiated /value/ argument types of a 'ConLike', -- (excluding dictionary args) conLikeInstOrigArgTys :: ConLike -> [Type] -> [Scaled Type] diff --git a/compiler/GHC/Core/DataCon.hs b/compiler/GHC/Core/DataCon.hs index f54f42d99d..c86e2c8625 100644 --- a/compiler/GHC/Core/DataCon.hs +++ b/compiler/GHC/Core/DataCon.hs @@ -22,7 +22,7 @@ module GHC.Core.DataCon ( eqSpecPair, eqSpecPreds, -- ** Field labels - FieldLabel(..), FieldLabelString, + FieldLabel(..), flLabel, FieldLabelString, -- ** Type construction mkDataCon, fIRST_TAG, diff --git a/compiler/GHC/Core/LateCC.hs b/compiler/GHC/Core/LateCC.hs index 9a2d43a9cb..ba65820784 100644 --- a/compiler/GHC/Core/LateCC.hs +++ b/compiler/GHC/Core/LateCC.hs @@ -117,7 +117,7 @@ doBndr env bndr rhs | otherwise = doBndr' env bndr rhs --- We want to put the cost centra below the lambda as we only care about executions of the RHS. +-- We want to put the cost centre below the lambda as we only care about executions of the RHS. doBndr' :: Env -> Id -> CoreExpr -> State LateCCState CoreExpr doBndr' env bndr (Lam b rhs) = Lam b <$> doBndr' env bndr rhs doBndr' env bndr rhs = do diff --git a/compiler/GHC/Core/Map/Type.hs b/compiler/GHC/Core/Map/Type.hs index 3629bc11a9..d94f97fb19 100644 --- a/compiler/GHC/Core/Map/Type.hs +++ b/compiler/GHC/Core/Map/Type.hs @@ -397,7 +397,7 @@ xtTyLit l f m = CharTyLit n -> m { tlm_char = Map.alter f n (tlm_char m) } foldTyLit :: (a -> b -> b) -> TyLitMap a -> b -> b -foldTyLit l m = flip (foldUFM l) (tlm_string m) +foldTyLit l m = flip (nonDetFoldUFM l) (tlm_string m) . flip (Map.foldr l) (tlm_number m) . flip (Map.foldr l) (tlm_char m) diff --git a/compiler/GHC/Core/TyCon.hs b/compiler/GHC/Core/TyCon.hs index d251d071fd..d06565deec 100644 --- a/compiler/GHC/Core/TyCon.hs +++ b/compiler/GHC/Core/TyCon.hs @@ -899,7 +899,7 @@ data TyConDetails = tctc_is_poly :: Bool, -- ^ Is this TcTyCon already generalized? -- Used only to make zonking more efficient - tctc_flavour :: TyConFlavour + tctc_flavour :: TyConFlavour TyCon -- ^ What sort of 'TyCon' this represents. } @@ -1845,7 +1845,7 @@ mkTcTyCon :: Name -> [(Name,TcTyVar)] -- ^ Scoped type variables; -- see Note [How TcTyCons work] in GHC.Tc.TyCl -> Bool -- ^ Is this TcTyCon generalised already? - -> TyConFlavour -- ^ What sort of 'TyCon' this represents + -> TyConFlavour TyCon -- ^ What sort of 'TyCon' this represents -> TyCon mkTcTyCon name binders res_kind scoped_tvs poly flav = mkTyCon name binders res_kind (constRoles binders Nominal) $ @@ -2178,12 +2178,6 @@ isTyConAssoc = isJust . tyConAssoc_maybe tyConAssoc_maybe :: TyCon -> Maybe TyCon tyConAssoc_maybe = tyConFlavourAssoc_maybe . tyConFlavour --- | Get the enclosing class TyCon (if there is one) for the given TyConFlavour -tyConFlavourAssoc_maybe :: TyConFlavour -> Maybe TyCon -tyConFlavourAssoc_maybe (DataFamilyFlavour mb_parent) = mb_parent -tyConFlavourAssoc_maybe (OpenTypeFamilyFlavour mb_parent) = mb_parent -tyConFlavourAssoc_maybe _ = Nothing - -- The unit tycon didn't used to be classed as a tuple tycon -- but I thought that was silly so I've undone it -- If it can't be for some reason, it should be a AlgTyCon @@ -2363,7 +2357,7 @@ isConcreteTyCon = isConcreteTyConFlavour . tyConFlavour -- | Is this 'TyConFlavour' concrete (i.e. not a synonym/type family)? -- -- Used for representation polymorphism checks. -isConcreteTyConFlavour :: TyConFlavour -> Bool +isConcreteTyConFlavour :: TyConFlavour tc -> Bool isConcreteTyConFlavour = \case ClassFlavour -> True TupleFlavour {} -> True @@ -2371,8 +2365,7 @@ isConcreteTyConFlavour = \case DataTypeFlavour -> True NewtypeFlavour -> True AbstractTypeFlavour -> True -- See Note [Concrete types] in GHC.Tc.Utils.Concrete - DataFamilyFlavour {} -> False - OpenTypeFamilyFlavour {} -> False + OpenFamilyFlavour {} -> False ClosedTypeFamilyFlavour -> False TypeSynonymFlavour -> False BuiltInTypeFlavour -> True @@ -2725,43 +2718,7 @@ instance Outputable TyCon where then text "[tc]" else empty --- | Paints a picture of what a 'TyCon' represents, in broad strokes. --- This is used towards more informative error messages. -data TyConFlavour - = ClassFlavour - | TupleFlavour Boxity - | SumFlavour - | DataTypeFlavour - | NewtypeFlavour - | AbstractTypeFlavour - | DataFamilyFlavour (Maybe TyCon) -- Just tc <=> (tc == associated class) - | OpenTypeFamilyFlavour (Maybe TyCon) -- Just tc <=> (tc == associated class) - | ClosedTypeFamilyFlavour - | TypeSynonymFlavour - | BuiltInTypeFlavour -- ^ e.g., the @(->)@ 'TyCon'. - | PromotedDataConFlavour - deriving Eq - -instance Outputable TyConFlavour where - ppr = text . go - where - go ClassFlavour = "class" - go (TupleFlavour boxed) | isBoxed boxed = "tuple" - | otherwise = "unboxed tuple" - go SumFlavour = "unboxed sum" - go DataTypeFlavour = "data type" - go NewtypeFlavour = "newtype" - go AbstractTypeFlavour = "abstract type" - go (DataFamilyFlavour (Just _)) = "associated data family" - go (DataFamilyFlavour Nothing) = "data family" - go (OpenTypeFamilyFlavour (Just _)) = "associated type family" - go (OpenTypeFamilyFlavour Nothing) = "type family" - go ClosedTypeFamilyFlavour = "type family" - go TypeSynonymFlavour = "type synonym" - go BuiltInTypeFlavour = "built-in type" - go PromotedDataConFlavour = "promoted data constructor" - -tyConFlavour :: TyCon -> TyConFlavour +tyConFlavour :: TyCon -> TyConFlavour TyCon tyConFlavour (TyCon { tyConDetails = details }) | AlgTyCon { algTcFlavour = parent, algTcRhs = rhs } <- details = case parent of @@ -2776,8 +2733,8 @@ tyConFlavour (TyCon { tyConDetails = details }) | FamilyTyCon { famTcFlav = flav, famTcParent = parent } <- details = case flav of - DataFamilyTyCon{} -> DataFamilyFlavour parent - OpenSynFamilyTyCon -> OpenTypeFamilyFlavour parent + DataFamilyTyCon{} -> OpenFamilyFlavour IAmData parent + OpenSynFamilyTyCon -> OpenFamilyFlavour IAmType parent ClosedSynFamilyTyCon{} -> ClosedTypeFamilyFlavour AbstractClosedSynFamilyTyCon -> ClosedTypeFamilyFlavour BuiltInSynFamTyCon{} -> ClosedTypeFamilyFlavour @@ -2788,24 +2745,22 @@ tyConFlavour (TyCon { tyConDetails = details }) | TcTyCon { tctc_flavour = flav } <-details = flav -- | Can this flavour of 'TyCon' appear unsaturated? -tcFlavourMustBeSaturated :: TyConFlavour -> Bool +tcFlavourMustBeSaturated :: TyConFlavour tc -> Bool tcFlavourMustBeSaturated ClassFlavour = False tcFlavourMustBeSaturated DataTypeFlavour = False tcFlavourMustBeSaturated NewtypeFlavour = False -tcFlavourMustBeSaturated DataFamilyFlavour{} = False tcFlavourMustBeSaturated TupleFlavour{} = False tcFlavourMustBeSaturated SumFlavour = False tcFlavourMustBeSaturated AbstractTypeFlavour {} = False tcFlavourMustBeSaturated BuiltInTypeFlavour = False tcFlavourMustBeSaturated PromotedDataConFlavour = False +tcFlavourMustBeSaturated (OpenFamilyFlavour td _)= case td of { IAmData -> False; IAmType -> True } tcFlavourMustBeSaturated TypeSynonymFlavour = True -tcFlavourMustBeSaturated OpenTypeFamilyFlavour{} = True tcFlavourMustBeSaturated ClosedTypeFamilyFlavour = True -- | Is this flavour of 'TyCon' an open type family or a data family? -tcFlavourIsOpen :: TyConFlavour -> Bool -tcFlavourIsOpen DataFamilyFlavour{} = True -tcFlavourIsOpen OpenTypeFamilyFlavour{} = True +tcFlavourIsOpen :: TyConFlavour tc -> Bool +tcFlavourIsOpen OpenFamilyFlavour{} = True tcFlavourIsOpen ClosedTypeFamilyFlavour = False tcFlavourIsOpen ClassFlavour = False tcFlavourIsOpen DataTypeFlavour = False diff --git a/compiler/GHC/Core/TyCon/Env.hs b/compiler/GHC/Core/TyCon/Env.hs index ff9b954324..3bdc0085be 100644 --- a/compiler/GHC/Core/TyCon/Env.hs +++ b/compiler/GHC/Core/TyCon/Env.hs @@ -100,7 +100,7 @@ extendTyConEnvList_C x y z = addListToUFM_C x y z delFromTyConEnv x y = delFromUFM x y delListFromTyConEnv x y = delListFromUFM x y filterTyConEnv x y = filterUFM x y -anyTyConEnv f x = foldUFM ((||) . f) False x +anyTyConEnv f x = nonDetFoldUFM ((||) . f) False x disjointTyConEnv x y = disjointUFM x y lookupTyConEnv_NF env n = expectJust "lookupTyConEnv_NF" (lookupTyConEnv env n) diff --git a/compiler/GHC/CoreToIface.hs b/compiler/GHC/CoreToIface.hs index f0e2c0ad5f..e6d3fe93b7 100644 --- a/compiler/GHC/CoreToIface.hs +++ b/compiler/GHC/CoreToIface.hs @@ -452,14 +452,15 @@ toIfaceTopBndr id toIfaceIdDetails :: IdDetails -> IfaceIdDetails toIfaceIdDetails VanillaId = IfVanillaId -toIfaceIdDetails (WorkerLikeId dmds) = IfWorkerLikeId dmds +toIfaceIdDetails (WorkerLikeId dmds) = IfWorkerLikeId dmds toIfaceIdDetails (DFunId {}) = IfDFunId toIfaceIdDetails (RecSelId { sel_naughty = n - , sel_tycon = tc }) = - let iface = case tc of - RecSelData ty_con -> Left (toIfaceTyCon ty_con) - RecSelPatSyn pat_syn -> Right (patSynToIfaceDecl pat_syn) - in IfRecSelId iface n + , sel_tycon = tc + , sel_fieldLabel = fl }) = + let (iface, first_con) = case tc of + RecSelData ty_con -> ( Left (toIfaceTyCon ty_con), dataConName $ head $ tyConDataCons ty_con) + RecSelPatSyn pat_syn -> ( Right (patSynToIfaceDecl pat_syn), patSynName pat_syn) + in IfRecSelId iface first_con n fl -- The remaining cases are all "implicit Ids" which don't -- appear in interface files at all @@ -661,7 +662,7 @@ toIfaceVar v -- Foreign calls have special syntax | isExternalName name = IfaceExt name - | otherwise = IfaceLcl (getOccFS name) + | otherwise = IfaceLcl (occNameFS $ nameOccName name) where name = idName v ty = idType v diff --git a/compiler/GHC/Data/FastString/Env.hs b/compiler/GHC/Data/FastString/Env.hs index 05db9ace2a..7c692634f3 100644 --- a/compiler/GHC/Data/FastString/Env.hs +++ b/compiler/GHC/Data/FastString/Env.hs @@ -18,7 +18,8 @@ module GHC.Data.FastString.Env ( filterFsEnv, plusFsEnv, plusFsEnv_C, alterFsEnv, lookupFsEnv, lookupFsEnv_NF, delFromFsEnv, delListFromFsEnv, - elemFsEnv, mapFsEnv, + elemFsEnv, mapFsEnv, strictMapFsEnv, mapMaybeFsEnv, + nonDetFoldFsEnv, -- * Deterministic FastString environments (maps) DFastStringEnv, @@ -60,6 +61,7 @@ lookupFsEnv :: FastStringEnv a -> FastString -> Maybe a lookupFsEnv_NF :: FastStringEnv a -> FastString -> a filterFsEnv :: (elt -> Bool) -> FastStringEnv elt -> FastStringEnv elt mapFsEnv :: (elt1 -> elt2) -> FastStringEnv elt1 -> FastStringEnv elt2 +mapMaybeFsEnv :: (elt1 -> Maybe elt2) -> FastStringEnv elt1 -> FastStringEnv elt2 emptyFsEnv = emptyUFM unitFsEnv x y = unitUFM x y @@ -78,9 +80,20 @@ extendFsEnvList_C x y z = addListToUFM_C x y z delFromFsEnv x y = delFromUFM x y delListFromFsEnv x y = delListFromUFM x y filterFsEnv x y = filterUFM x y +mapMaybeFsEnv f x = mapMaybeUFM f x lookupFsEnv_NF env n = expectJust "lookupFsEnv_NF" (lookupFsEnv env n) +strictMapFsEnv :: (a -> b) -> FastStringEnv a -> FastStringEnv b +strictMapFsEnv = strictMapUFM + +-- | Fold over a 'FastStringEnv'. +-- +-- Non-deterministic, unless the folding function is commutative +-- (i.e. @a1 `f` ( a2 `f` b ) == a2 `f` ( a1 `f` b )@ for all @a1@, @a2@, @b@). +nonDetFoldFsEnv :: (a -> b -> b) -> b -> FastStringEnv a -> b +nonDetFoldFsEnv = nonDetFoldUFM + -- Deterministic FastStringEnv -- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM for explanation why we need -- DFastStringEnv. diff --git a/compiler/GHC/Driver/Env.hs b/compiler/GHC/Driver/Env.hs index 13898f85f4..c9967c7120 100644 --- a/compiler/GHC/Driver/Env.hs +++ b/compiler/GHC/Driver/Env.hs @@ -327,20 +327,23 @@ lookupType :: HscEnv -> Name -> IO (Maybe TyThing) lookupType hsc_env name = do eps <- liftIO $ hscEPS hsc_env let pte = eps_PTE eps - hpt = hsc_HUG hsc_env - - mod = assertPpr (isExternalName name) (ppr name) $ - if isHoleName name - then mkHomeModule (hsc_home_unit hsc_env) (moduleName (nameModule name)) - else nameModule name - - !ty = if isOneShot (ghcMode (hsc_dflags hsc_env)) - -- in one-shot, we don't use the HPT - then lookupNameEnv pte name - else case lookupHugByModule mod hpt of - Just hm -> lookupNameEnv (md_types (hm_details hm)) name - Nothing -> lookupNameEnv pte name - pure ty + return $ lookupTypeInPTE hsc_env pte name + +lookupTypeInPTE :: HscEnv -> PackageTypeEnv -> Name -> Maybe TyThing +lookupTypeInPTE hsc_env pte name = ty + where + hpt = hsc_HUG hsc_env + mod = assertPpr (isExternalName name) (ppr name) $ + if isHoleName name + then mkHomeModule (hsc_home_unit hsc_env) (moduleName (nameModule name)) + else nameModule name + + !ty = if isOneShot (ghcMode (hsc_dflags hsc_env)) + -- in one-shot, we don't use the HPT + then lookupNameEnv pte name + else case lookupHugByModule mod hpt of + Just hm -> lookupNameEnv (md_types (hm_details hm)) name + Nothing -> lookupNameEnv pte name -- | Find the 'ModIface' for a 'Module', searching in both the loaded home -- and external package module information diff --git a/compiler/GHC/Hs/Decls.hs b/compiler/GHC/Hs/Decls.hs index fa62c6a49c..201adc5467 100644 --- a/compiler/GHC/Hs/Decls.hs +++ b/compiler/GHC/Hs/Decls.hs @@ -124,7 +124,6 @@ import GHC.Utils.Panic import GHC.Types.SrcLoc import GHC.Types.SourceText import GHC.Core.Type -import GHC.Core.TyCon (TyConFlavour(NewtypeFlavour,DataTypeFlavour)) import GHC.Types.ForeignCall import GHC.Unit.Module.Warnings (WarningTxt(..)) @@ -704,7 +703,7 @@ ppDataDefnHeader pp_hdr HsDataDefn | isTypeDataDefnCons condecls = text "type" | otherwise = empty pp_ct = case mb_ct of - Nothing -> empty + Nothing -> empty Just ct -> ppr ct pp_sig = case mb_sig of Nothing -> empty @@ -935,7 +934,7 @@ instDeclDataFamInsts inst_decls do_one (L _ (TyFamInstD {})) = [] -- | Convert a 'NewOrData' to a 'TyConFlavour' -newOrDataToFlavour :: NewOrData -> TyConFlavour +newOrDataToFlavour :: NewOrData -> TyConFlavour tc newOrDataToFlavour NewType = NewtypeFlavour newOrDataToFlavour DataType = DataTypeFlavour diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs index 621848920d..4a8abe8404 100644 --- a/compiler/GHC/Hs/Expr.hs +++ b/compiler/GHC/Hs/Expr.hs @@ -44,6 +44,7 @@ import GHC.Parser.Annotation -- others: import GHC.Tc.Types.Evidence +import GHC.Types.Id.Info ( RecSelParent ) import GHC.Types.Name import GHC.Types.Name.Reader import GHC.Types.Name.Set @@ -52,7 +53,8 @@ import GHC.Types.Fixity import GHC.Types.SourceText import GHC.Types.SrcLoc import GHC.Types.Tickish (CoreTickish) -import GHC.Core.ConLike +import GHC.Types.Unique.Set (UniqSet) +import GHC.Core.ConLike ( conLikeName, ConLike ) import GHC.Unit.Module (ModuleName) import GHC.Utils.Misc import GHC.Utils.Outputable @@ -74,6 +76,7 @@ import qualified Data.Kind import Data.Maybe (isJust) import Data.Foldable ( toList ) import Data.List (uncons) +import Data.List.NonEmpty (NonEmpty) import Data.Bifunctor (first) {- ********************************************************************* @@ -324,6 +327,31 @@ type instance XRecordUpd GhcTc = DataConCantHappen -- See [Handling overloaded and rebindable constructs], -- and [Record Updates] in GHC.Tc.Gen.Expr. +-- | Information about the parent of a record update: +-- +-- - the parent type constructor or pattern synonym, +-- - the relevant con-likes, +-- - the field labels. +data family HsRecUpdParent x + +data instance HsRecUpdParent GhcPs +data instance HsRecUpdParent GhcRn + = RnRecUpdParent + { rnRecUpdLabels :: NonEmpty FieldGlobalRdrElt + , rnRecUpdCons :: UniqSet ConLikeName } +data instance HsRecUpdParent GhcTc + = TcRecUpdParent + { tcRecUpdParent :: RecSelParent + , tcRecUpdLabels :: NonEmpty FieldGlobalRdrElt + , tcRecUpdCons :: UniqSet ConLike } + +type instance XLHsRecUpdLabels GhcPs = NoExtField +type instance XLHsRecUpdLabels GhcRn = NonEmpty (HsRecUpdParent GhcRn) + -- Possible parents for the record update. +type instance XLHsRecUpdLabels GhcTc = DataConCantHappen + +type instance XLHsOLRecUpdLabels p = NoExtField + type instance XGetField GhcPs = EpAnnCO type instance XGetField GhcRn = NoExtField type instance XGetField GhcTc = DataConCantHappen @@ -625,8 +653,10 @@ ppr_expr (RecordCon { rcon_con = con, rcon_flds = rbinds }) ppr_expr (RecordUpd { rupd_expr = L _ aexp, rupd_flds = flds }) = case flds of - Left rbinds -> hang (ppr aexp) 2 (braces (fsep (punctuate comma (map ppr rbinds)))) - Right pbinds -> hang (ppr aexp) 2 (braces (fsep (punctuate comma (map ppr pbinds)))) + RegularRecUpdFields { recUpdFields= rbinds } -> + hang (ppr aexp) 2 (braces (fsep (punctuate comma (map ppr rbinds)))) + OverloadedRecUpdFields { olRecUpdFields = pbinds } -> + hang (ppr aexp) 2 (braces (fsep (punctuate comma (map ppr pbinds)))) ppr_expr (HsGetField { gf_expr = L _ fexp, gf_field = field }) = ppr fexp <> dot <> ppr field diff --git a/compiler/GHC/Hs/ImpExp.hs b/compiler/GHC/Hs/ImpExp.hs index c25a72c079..83f5cfbb88 100644 --- a/compiler/GHC/Hs/ImpExp.hs +++ b/compiler/GHC/Hs/ImpExp.hs @@ -21,25 +21,26 @@ module GHC.Hs.ImpExp , module GHC.Hs.ImpExp ) where +import Language.Haskell.Syntax.Extension +import Language.Haskell.Syntax.Module.Name +import Language.Haskell.Syntax.ImpExp + import GHC.Prelude import GHC.Types.SourceText ( SourceText(..) ) -import GHC.Types.FieldLabel ( FieldLabel ) - -import GHC.Utils.Outputable -import GHC.Utils.Panic import GHC.Types.SrcLoc -import GHC.Parser.Annotation -import GHC.Hs.Extension import GHC.Types.Name import GHC.Types.PkgQual +import GHC.Parser.Annotation +import GHC.Hs.Extension + +import GHC.Utils.Outputable +import GHC.Utils.Panic + import Data.Data import Data.Maybe -import Language.Haskell.Syntax.Extension -import Language.Haskell.Syntax.Module.Name -import Language.Haskell.Syntax.ImpExp {- ************************************************************************ @@ -203,11 +204,7 @@ type instance XIEVar GhcTc = NoExtField type instance XIEThingAbs (GhcPass _) = EpAnn [AddEpAnn] type instance XIEThingAll (GhcPass _) = EpAnn [AddEpAnn] - --- See Note [IEThingWith] -type instance XIEThingWith (GhcPass 'Parsed) = EpAnn [AddEpAnn] -type instance XIEThingWith (GhcPass 'Renamed) = [Located FieldLabel] -type instance XIEThingWith (GhcPass 'Typechecked) = NoExtField +type instance XIEThingWith (GhcPass _) = EpAnn [AddEpAnn] type instance XIEModuleContents GhcPs = EpAnn [AddEpAnn] type instance XIEModuleContents GhcRn = NoExtField @@ -220,32 +217,6 @@ type instance XXIE (GhcPass _) = DataConCantHappen type instance Anno (LocatedA (IE (GhcPass p))) = SrcSpanAnnA -{- -Note [IEThingWith] -~~~~~~~~~~~~~~~~~~ -A definition like - - {-# LANGUAGE DuplicateRecordFields #-} - module M ( T(MkT, x) ) where - data T = MkT { x :: Int } - -gives rise to this in the output of the parser: - - IEThingWith NoExtField T [MkT, x] NoIEWildcard - -But in the renamer we need to attach the correct field label, -because the selector Name is mangled (see Note [FieldLabel] in -GHC.Types.FieldLabel). Hence we change this to: - - IEThingWith [FieldLabel "x" True $sel:x:MkT)] T [MkT] NoIEWildcard - -using the TTG extension field to store the list of fields in renamed syntax -only. (Record fields always appear in this list, regardless of whether -DuplicateRecordFields was in use at the definition site or not.) - -See Note [Representing fields in AvailInfo] in GHC.Types.Avail for more details. --} - ieName :: IE (GhcPass p) -> IdP (GhcPass p) ieName (IEVar _ (L _ n)) = ieWrappedName n ieName (IEThingAbs _ (L _ n)) = ieWrappedName n @@ -292,9 +263,8 @@ instance OutputableBndrId p => Outputable (IE (GhcPass p)) where ppr (IEVar _ var) = ppr (unLoc var) ppr (IEThingAbs _ thing) = ppr (unLoc thing) ppr (IEThingAll _ thing) = hcat [ppr (unLoc thing), text "(..)"] - ppr (IEThingWith flds thing wc withs) - = ppr (unLoc thing) <> parens (fsep (punctuate comma - (ppWiths ++ ppFields) )) + ppr (IEThingWith _ thing wc withs) + = ppr (unLoc thing) <> parens (fsep (punctuate comma ppWiths)) where ppWiths = case wc of @@ -303,10 +273,6 @@ instance OutputableBndrId p => Outputable (IE (GhcPass p)) where IEWildcard pos -> let (bs, as) = splitAt pos (map (ppr . unLoc) withs) in bs ++ [text ".."] ++ as - ppFields = - case ghcPass @p of - GhcRn -> map ppr flds - _ -> [] ppr (IEModuleContents _ mod') = text "module" <+> ppr mod' ppr (IEGroup _ n _) = text ("<IEGroup: " ++ show n ++ ">") diff --git a/compiler/GHC/Hs/Instances.hs b/compiler/GHC/Hs/Instances.hs index 74d75fb7be..5c8e403bb3 100644 --- a/compiler/GHC/Hs/Instances.hs +++ b/compiler/GHC/Hs/Instances.hs @@ -287,6 +287,14 @@ deriving instance Data (FieldLabelStrings GhcPs) deriving instance Data (FieldLabelStrings GhcRn) deriving instance Data (FieldLabelStrings GhcTc) +deriving instance Data (HsRecUpdParent GhcPs) +deriving instance Data (HsRecUpdParent GhcRn) +deriving instance Data (HsRecUpdParent GhcTc) + +deriving instance Data (LHsRecUpdFields GhcPs) +deriving instance Data (LHsRecUpdFields GhcRn) +deriving instance Data (LHsRecUpdFields GhcTc) + deriving instance Data (DotFieldOcc GhcPs) deriving instance Data (DotFieldOcc GhcRn) deriving instance Data (DotFieldOcc GhcTc) diff --git a/compiler/GHC/Hs/Pat.hs b/compiler/GHC/Hs/Pat.hs index bc0b51457e..2591efc732 100644 --- a/compiler/GHC/Hs/Pat.hs +++ b/compiler/GHC/Hs/Pat.hs @@ -244,8 +244,8 @@ data ConPatTc hsRecFieldId :: HsRecField GhcTc arg -> Id hsRecFieldId = hsRecFieldSel -hsRecUpdFieldRdr :: HsRecUpdField (GhcPass p) -> Located RdrName -hsRecUpdFieldRdr = fmap rdrNameAmbiguousFieldOcc . reLoc . hfbLHS +hsRecUpdFieldRdr :: HsRecUpdField (GhcPass p) q -> Located RdrName +hsRecUpdFieldRdr = fmap ambiguousFieldOccRdrName . reLoc . hfbLHS hsRecUpdFieldId :: HsFieldBind (LAmbiguousFieldOcc GhcTc) arg -> Located Id hsRecUpdFieldId = fmap foExt . reLoc . hsRecUpdFieldOcc diff --git a/compiler/GHC/Hs/Type.hs b/compiler/GHC/Hs/Type.hs index 313b8e8fe2..968fc99b73 100644 --- a/compiler/GHC/Hs/Type.hs +++ b/compiler/GHC/Hs/Type.hs @@ -56,7 +56,8 @@ module GHC.Hs.Type ( FieldOcc(..), LFieldOcc, mkFieldOcc, AmbiguousFieldOcc(..), LAmbiguousFieldOcc, mkAmbiguousFieldOcc, - rdrNameAmbiguousFieldOcc, selectorAmbiguousFieldOcc, + ambiguousFieldOccRdrName, ambiguousFieldOccLRdrName, + selectorAmbiguousFieldOcc, unambiguousFieldOcc, ambiguousFieldOcc, mkAnonWildCardTy, pprAnonWildCard, @@ -104,7 +105,7 @@ import GHC.Parser.Annotation import GHC.Types.Fixity ( LexicalFixity(..) ) import GHC.Types.Id ( Id ) import GHC.Types.SourceText -import GHC.Types.Name( Name, NamedThing(getName), tcName, dataName ) +import GHC.Types.Name import GHC.Types.Name.Reader ( RdrName ) import GHC.Types.Var ( VarBndr, visArgTypeLike ) import GHC.Core.TyCo.Rep ( Type(..) ) @@ -915,11 +916,11 @@ type instance XAmbiguous GhcTc = Id type instance XXAmbiguousFieldOcc (GhcPass _) = DataConCantHappen instance Outputable (AmbiguousFieldOcc (GhcPass p)) where - ppr = ppr . rdrNameAmbiguousFieldOcc + ppr = ppr . ambiguousFieldOccRdrName instance OutputableBndr (AmbiguousFieldOcc (GhcPass p)) where - pprInfixOcc = pprInfixOcc . rdrNameAmbiguousFieldOcc - pprPrefixOcc = pprPrefixOcc . rdrNameAmbiguousFieldOcc + pprInfixOcc = pprInfixOcc . ambiguousFieldOccRdrName + pprPrefixOcc = pprPrefixOcc . ambiguousFieldOccRdrName instance OutputableBndr (Located (AmbiguousFieldOcc (GhcPass p))) where pprInfixOcc = pprInfixOcc . unLoc @@ -928,9 +929,12 @@ instance OutputableBndr (Located (AmbiguousFieldOcc (GhcPass p))) where mkAmbiguousFieldOcc :: LocatedN RdrName -> AmbiguousFieldOcc GhcPs mkAmbiguousFieldOcc rdr = Unambiguous noExtField rdr -rdrNameAmbiguousFieldOcc :: AmbiguousFieldOcc (GhcPass p) -> RdrName -rdrNameAmbiguousFieldOcc (Unambiguous _ (L _ rdr)) = rdr -rdrNameAmbiguousFieldOcc (Ambiguous _ (L _ rdr)) = rdr +ambiguousFieldOccRdrName :: AmbiguousFieldOcc (GhcPass p) -> RdrName +ambiguousFieldOccRdrName = unLoc . ambiguousFieldOccLRdrName + +ambiguousFieldOccLRdrName :: AmbiguousFieldOcc (GhcPass p) -> LocatedN RdrName +ambiguousFieldOccLRdrName (Unambiguous _ rdr) = rdr +ambiguousFieldOccLRdrName (Ambiguous _ rdr) = rdr selectorAmbiguousFieldOcc :: AmbiguousFieldOcc GhcTc -> Id selectorAmbiguousFieldOcc (Unambiguous sel _) = sel diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs index 5866243824..008469b458 100644 --- a/compiler/GHC/Hs/Utils.hs +++ b/compiler/GHC/Hs/Utils.hs @@ -1,4 +1,6 @@ {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TupleSections #-} + {-| Module : GHC.Hs.Utils Description : Generic helpers for the HsSyn type. @@ -97,6 +99,7 @@ module GHC.Hs.Utils( collectLStmtBinders, collectStmtBinders, CollectPass(..), CollectFlag(..), + TyDeclBinders(..), LConsWithFields(..), hsLTyClDeclBinders, hsTyClForeignBinders, hsPatSynSelectors, getPatSynBinds, hsForeignDeclsBinders, hsGroupBinders, hsDataFamInstBinders, @@ -113,6 +116,7 @@ import GHC.Hs.Expr import GHC.Hs.Pat import GHC.Hs.Type import GHC.Hs.Lit +import Language.Haskell.Syntax.Decls import Language.Haskell.Syntax.Extension import GHC.Hs.Extension import GHC.Parser.Annotation @@ -146,13 +150,18 @@ import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic -import Data.Either +import Control.Arrow ( first ) +import Data.Either ( partitionEithers ) import Data.Foldable ( toList ) -import Data.Function -import Data.List ( partition, deleteBy ) +import Data.List ( partition ) import Data.List.NonEmpty ( nonEmpty ) import qualified Data.List.NonEmpty as NE +import Data.IntMap ( IntMap ) +import qualified Data.IntMap.Strict as IntMap +import Data.Map ( Map ) +import qualified Data.Map.Strict as Map + {- ************************************************************************ * * @@ -1356,17 +1365,31 @@ hsTyClForeignBinders :: [TyClGroup GhcRn] hsTyClForeignBinders tycl_decls foreign_decls = map unLoc (hsForeignDeclsBinders foreign_decls) ++ getSelectorNames - (foldMap (foldMap hsLTyClDeclBinders . group_tyclds) tycl_decls + (foldMap (foldMap (tyDeclBinders . hsLTyClDeclBinders) . group_tyclds) tycl_decls `mappend` - foldMap (foldMap hsLInstDeclBinders . group_instds) tycl_decls) + (foldMap (foldMap hsLInstDeclBinders . group_instds) tycl_decls)) where getSelectorNames :: ([LocatedA Name], [LFieldOcc GhcRn]) -> [Name] getSelectorNames (ns, fs) = map unLoc ns ++ map (foExt . unLoc) fs ------------------- -hsLTyClDeclBinders :: IsPass p + +data TyDeclBinders p + = TyDeclBinders + { tyDeclMainBinder :: !(LocatedA (IdP (GhcPass p)), TyConFlavour ()) + , tyDeclATs :: ![(LocatedA (IdP (GhcPass p)), TyConFlavour ())] + , tyDeclOpSigs :: ![LocatedA (IdP (GhcPass p))] + , tyDeclConsWithFields :: !(LConsWithFields p) } + +tyDeclBinders :: TyDeclBinders p -> ([LocatedA (IdP (GhcPass p))], [LFieldOcc (GhcPass p)]) +tyDeclBinders (TyDeclBinders main ats sigs consWithFields) + = (fst main : (fmap fst ats ++ sigs ++ cons), flds) + where + (cons, flds) = lconsWithFieldsBinders consWithFields + +hsLTyClDeclBinders :: (IsPass p, OutputableBndrId p) => LocatedA (TyClDecl (GhcPass p)) - -> ([LocatedA (IdP (GhcPass p))], [LFieldOcc (GhcPass p)]) + -> TyDeclBinders p -- ^ Returns all the /binding/ names of the decl. The first one is -- guaranteed to be the name of the decl. The first component -- represents all binding names except record fields; the second @@ -1377,27 +1400,40 @@ hsLTyClDeclBinders :: IsPass p -- See Note [SrcSpan for binders] hsLTyClDeclBinders (L loc (FamDecl { tcdFam = FamilyDecl - { fdLName = (L _ name) } })) - = ([L loc name], []) + { fdLName = (L _ name) + , fdInfo = fd_info } })) + = TyDeclBinders + { tyDeclMainBinder = (L loc name, familyInfoTyConFlavour Nothing fd_info) + , tyDeclATs = [], tyDeclOpSigs = [] + , tyDeclConsWithFields = emptyLConsWithFields } hsLTyClDeclBinders (L loc (SynDecl { tcdLName = (L _ name) })) - = ([L loc name], []) + = TyDeclBinders + { tyDeclMainBinder = (L loc name, TypeSynonymFlavour) + , tyDeclATs = [], tyDeclOpSigs = [] + , tyDeclConsWithFields = emptyLConsWithFields } hsLTyClDeclBinders (L loc (ClassDecl { tcdLName = (L _ cls_name) , tcdSigs = sigs , tcdATs = ats })) - = (L loc cls_name : - [ L fam_loc fam_name | (L fam_loc (FamilyDecl - { fdLName = L _ fam_name })) <- ats ] - ++ - [ L mem_loc mem_name - | (L mem_loc (ClassOpSig _ False ns _)) <- sigs - , (L _ mem_name) <- ns ] - , []) + = TyDeclBinders + { tyDeclMainBinder = (L loc cls_name, ClassFlavour) + , tyDeclATs = [ (L fam_loc fam_name, familyInfoTyConFlavour (Just ()) fd_info) + | (L fam_loc (FamilyDecl { fdLName = L _ fam_name + , fdInfo = fd_info })) <- ats ] + , tyDeclOpSigs = [ L mem_loc mem_name + | (L mem_loc (ClassOpSig _ False ns _)) <- sigs + , (L _ mem_name) <- ns ] + , tyDeclConsWithFields = emptyLConsWithFields } hsLTyClDeclBinders (L loc (DataDecl { tcdLName = (L _ name) , tcdDataDefn = defn })) - = (\ (xs, ys) -> (L loc name : xs, ys)) $ hsDataDefnBinders defn - + = TyDeclBinders + { tyDeclMainBinder = (L loc name, flav ) + , tyDeclATs = [] + , tyDeclOpSigs = [] + , tyDeclConsWithFields = hsDataDefnBinders defn } + where + flav = newOrDataToFlavour $ dataDefnConsNewOrData $ dd_cons defn ------------------- hsForeignDeclsBinders :: forall p a. (UnXRec (GhcPass p), IsSrcSpanAnn p a) @@ -1430,94 +1466,170 @@ getPatSynBinds binds , (unXRec @id -> (PatSynBind _ psb)) <- bagToList lbinds ] ------------------- -hsLInstDeclBinders :: IsPass p +hsLInstDeclBinders :: (IsPass p, OutputableBndrId p) => LInstDecl (GhcPass p) - -> ([LocatedA (IdP (GhcPass p))], [LFieldOcc (GhcPass p)]) + -> ([(LocatedA (IdP (GhcPass p)))], [LFieldOcc (GhcPass p)]) hsLInstDeclBinders (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = dfis }})) - = foldMap (hsDataFamInstBinders . unLoc) dfis + = foldMap (lconsWithFieldsBinders . hsDataFamInstBinders . unLoc) dfis hsLInstDeclBinders (L _ (DataFamInstD { dfid_inst = fi })) - = hsDataFamInstBinders fi + = lconsWithFieldsBinders $ hsDataFamInstBinders fi hsLInstDeclBinders (L _ (TyFamInstD {})) = mempty ------------------- -- | the 'SrcLoc' returned are for the whole declarations, not just the names -hsDataFamInstBinders :: IsPass p +hsDataFamInstBinders :: (IsPass p, OutputableBndrId p) => DataFamInstDecl (GhcPass p) - -> ([LocatedA (IdP (GhcPass p))], [LFieldOcc (GhcPass p)]) + -> LConsWithFields p hsDataFamInstBinders (DataFamInstDecl { dfid_eqn = FamEqn { feqn_rhs = defn }}) = hsDataDefnBinders defn -- There can't be repeated symbols because only data instances have binders ------------------- -- | the 'SrcLoc' returned are for the whole declarations, not just the names -hsDataDefnBinders :: IsPass p +hsDataDefnBinders :: (IsPass p, OutputableBndrId p) => HsDataDefn (GhcPass p) - -> ([LocatedA (IdP (GhcPass p))], [LFieldOcc (GhcPass p)]) + -> LConsWithFields p hsDataDefnBinders (HsDataDefn { dd_cons = cons }) = hsConDeclsBinders (toList cons) -- See Note [Binders in family instances] ------------------- -type Seen p = [LFieldOcc (GhcPass p)] -> [LFieldOcc (GhcPass p)] - -- Filters out ones that have already been seen -hsConDeclsBinders :: forall p. IsPass p +{- Note [Collecting record fields in data declarations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When renaming a data declaration that includes record constructors, we are, in +the end, going to to create a mapping from constructor to its field labels, +to store in 'GREInfo' (see 'IAmConLike'). This allows us to know, in the renamer, +which constructor has what fields. + +In order to achieve this, we return the constructor and field information from +hsConDeclsBinders in the following format: + + - [(ConRdrName, [Located Int])], a list of the constructors, each associated + with its record fields, in the form of a list of Int indices into... + - IntMap FieldOcc, an IntMap of record fields. + +(In actual fact, we use [(ConRdrName, Maybe [Located Int])], with Nothing indicating +that the constructor has unlabelled fields: see Note [Local constructor info in the renamer] +in GHC.Types.GREInfo.) + +This allows us to do the following (see GHC.Rename.Names.getLocalNonValBinders.new_tc): + + - create 'Name's for each of the record fields, to get IntMap FieldLabel, + - create 'Name's for each of the constructors, to get [(ConName, [Int])], + - look up the FieldLabels of each constructor, to get [(ConName, [FieldLabel])]. + +NB: This can be a bit tricky to get right in the presence of data types with +duplicate constructors or fields. Storing locations allows us to report an error +for duplicate field declarations, see test cases T9156 T9156_DF. +Other relevant test cases: rnfail015. + +-} + +-- | A mapping from constructors to all of their fields. +-- +-- See Note [Collecting record fields in data declarations]. +data LConsWithFields p = + LConsWithFields + { consWithFieldIndices :: [(LocatedA (IdP (GhcPass p)), Maybe [Located Int])] + , consFields :: IntMap (LFieldOcc (GhcPass p)) + } + +lconsWithFieldsBinders :: LConsWithFields p + -> ([(LocatedA (IdP (GhcPass p)))], [LFieldOcc (GhcPass p)]) +lconsWithFieldsBinders (LConsWithFields cons fields) + = (map fst cons, IntMap.elems fields) + +emptyLConsWithFields :: LConsWithFields p +emptyLConsWithFields = LConsWithFields [] IntMap.empty + +hsConDeclsBinders :: forall p. (IsPass p, OutputableBndrId p) => [LConDecl (GhcPass p)] - -> ([LocatedA (IdP (GhcPass p))], [LFieldOcc (GhcPass p)]) - -- See hsLTyClDeclBinders for what this does - -- The function is boringly complicated because of the records - -- And since we only have equality, we have to be a little careful -hsConDeclsBinders cons - = go id cons + -> LConsWithFields p + -- The function is boringly complicated because of the records + -- And since we only have equality, we have to be a little careful +hsConDeclsBinders cons = go emptyFieldIndices cons where - go :: Seen p -> [LConDecl (GhcPass p)] - -> ([LocatedA (IdP (GhcPass p))], [LFieldOcc (GhcPass p)]) - go _ [] = ([], []) - go remSeen (r:rs) + go :: FieldIndices p -> [LConDecl (GhcPass p)] -> LConsWithFields p + go seen [] = LConsWithFields [] (fields seen) + go seen (r:rs) -- Don't re-mangle the location of field names, because we don't -- have a record of the full location of the field declaration anyway = let loc = getLoc r in case unLoc r of - -- remove only the first occurrence of any seen field in order to - -- avoid circumventing detection of duplicate fields (#9156) ConDeclGADT { con_names = names, con_g_args = args } - -> (toList (L loc . unLoc <$> names) ++ ns, flds ++ fs) + -> LConsWithFields (cons ++ ns) fs where - (remSeen', flds) = get_flds_gadt remSeen args - (ns, fs) = go remSeen' rs + cons = map ( , con_flds ) $ toList (L loc . unLoc <$> names) + (con_flds, seen') = get_flds_gadt seen args + LConsWithFields ns fs = go seen' rs ConDeclH98 { con_name = name, con_args = args } - -> ([L loc (unLoc name)] ++ ns, flds ++ fs) + -> LConsWithFields ([(L loc (unLoc name), con_flds)] ++ ns) fs where - (remSeen', flds) = get_flds_h98 remSeen args - (ns, fs) = go remSeen' rs - - get_flds_h98 :: Seen p -> HsConDeclH98Details (GhcPass p) - -> (Seen p, [LFieldOcc (GhcPass p)]) - get_flds_h98 remSeen (RecCon flds) = get_flds remSeen flds - get_flds_h98 remSeen _ = (remSeen, []) - - get_flds_gadt :: Seen p -> HsConDeclGADTDetails (GhcPass p) - -> (Seen p, [LFieldOcc (GhcPass p)]) - get_flds_gadt remSeen (RecConGADT flds _) = get_flds remSeen flds - get_flds_gadt remSeen _ = (remSeen, []) - - get_flds :: Seen p -> LocatedL [LConDeclField (GhcPass p)] - -> (Seen p, [LFieldOcc (GhcPass p)]) - get_flds remSeen flds = (remSeen', fld_names) - where - fld_names = remSeen (concatMap (cd_fld_names . unLoc) (unLoc flds)) - remSeen' = foldr (.) remSeen - [deleteBy ((==) `on` unLoc . foLabel . unLoc) v - | v <- fld_names] + (con_flds, seen') = get_flds_h98 seen args + LConsWithFields ns fs = go seen' rs + + get_flds_h98 :: FieldIndices p -> HsConDeclH98Details (GhcPass p) + -> (Maybe [Located Int], FieldIndices p) + get_flds_h98 seen (RecCon flds) = first Just $ get_flds seen flds + get_flds_h98 seen (PrefixCon _ []) = (Just [], seen) + get_flds_h98 seen _ = (Nothing, seen) + + get_flds_gadt :: FieldIndices p -> HsConDeclGADTDetails (GhcPass p) + -> (Maybe [Located Int], FieldIndices p) + get_flds_gadt seen (RecConGADT flds _) = first Just $ get_flds seen flds + get_flds_gadt seen (PrefixConGADT []) = (Just [], seen) + get_flds_gadt seen _ = (Nothing, seen) + + get_flds :: FieldIndices p -> LocatedL [LConDeclField (GhcPass p)] + -> ([Located Int], FieldIndices p) + get_flds seen flds = + foldr add_fld ([], seen) fld_names + where + add_fld fld (is, ixs) = + let (i, ixs') = insertField fld ixs + in (i:is, ixs') + fld_names = concatMap (cd_fld_names . unLoc) (unLoc flds) + +-- | A bijection between record fields of a datatype and integers, +-- used to implement Note [Collecting record fields in data declarations]. +data FieldIndices p = + FieldIndices + { fields :: IntMap (LFieldOcc (GhcPass p)) + -- ^ Look up a field from its index. + , fieldIndices :: Map RdrName Int + -- ^ Look up the index of a field label in the previous 'IntMap'. + , newInt :: !Int + -- ^ An integer @i@ such that no integer @i' >= i@ appears in the 'IntMap'. + } + +emptyFieldIndices :: FieldIndices p +emptyFieldIndices = + FieldIndices { fields = IntMap.empty + , fieldIndices = Map.empty + , newInt = 0 } + +insertField :: LFieldOcc (GhcPass p) -> FieldIndices p -> (Located Int, FieldIndices p) +insertField new_fld fi@(FieldIndices flds idxs new_idx) + | Just i <- Map.lookup rdr idxs + = (L loc i, fi) + | otherwise + = (L loc new_idx, + FieldIndices (IntMap.insert new_idx new_fld flds) + (Map.insert rdr new_idx idxs) + (new_idx + 1)) + where + loc = getLocA new_fld + rdr = unLoc . foLabel . unLoc $ new_fld {- Note [SrcSpan for binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~ -When extracting the (Located RdrNme) for a binder, at least for the +When extracting the (Located RdrName) for a binder, at least for the main name (the TyCon of a type declaration etc), we want to give it the @SrcSpan@ of the whole /declaration/, not just the name itself (which is how it appears in the syntax tree). This SrcSpan (for the diff --git a/compiler/GHC/HsToCore/Errors/Types.hs b/compiler/GHC/HsToCore/Errors/Types.hs index 8f6586fb45..40fd6b7aab 100644 --- a/compiler/GHC/HsToCore/Errors/Types.hs +++ b/compiler/GHC/HsToCore/Errors/Types.hs @@ -154,7 +154,7 @@ newtype DsArgNum = DsArgNum Int -- | Why TemplateHaskell rejected the splice. Used in the 'DsNotYetHandledByTH' -- constructor of a 'DsMessage'. data ThRejectionReason - = ThAmbiguousRecordUpdates !(HsRecUpdField GhcRn) + = ThAmbiguousRecordUpdates !(HsRecUpdField GhcRn GhcRn) | ThAbstractClosedTypeFamily !(LFamilyDecl GhcRn) | ThForeignLabel !CLabelString | ThForeignExport !(LForeignDecl GhcRn) diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs index 63c2cee789..6a0bee9089 100644 --- a/compiler/GHC/HsToCore/Expr.hs +++ b/compiler/GHC/HsToCore/Expr.hs @@ -34,6 +34,7 @@ import GHC.Types.SourceText import GHC.Types.Name import GHC.Core.FamInstEnv( topNormaliseType ) import GHC.HsToCore.Quote +import GHC.HsToCore.Ticks (stripTicksTopHsExpr) import GHC.Hs -- NB: The desugarer, which straddles the source and Core worlds, sometimes @@ -66,7 +67,6 @@ import GHC.Utils.Panic import GHC.Utils.Panic.Plain import GHC.Core.PatSyn import Control.Monad -import GHC.HsToCore.Ticks (stripTicksTopHsExpr) {- ************************************************************************ @@ -559,7 +559,7 @@ dsSyntaxExpr NoSyntaxExprTc _ = panic "dsSyntaxExpr" findField :: [LHsRecField GhcTc arg] -> Name -> [arg] findField rbinds sel = [hfbRHS fld | L _ fld <- rbinds - , sel == idName (hsRecFieldId fld) ] + , sel == idName (hsRecFieldId fld) ] {- %-------------------------------------------------------------------- diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs index 8463e9f739..3166370e14 100644 --- a/compiler/GHC/HsToCore/Quote.hs +++ b/compiler/GHC/HsToCore/Quote.hs @@ -3,6 +3,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -98,7 +99,6 @@ import Data.List.NonEmpty ( NonEmpty(..) ) import Data.Function import Control.Monad.Trans.Reader import Control.Monad.Trans.Class -import Data.Foldable ( toList ) import GHC.Types.Name.Reader (RdrName(..)) data MetaWrappers = MetaWrappers { @@ -1608,15 +1608,15 @@ repE (RecordCon { rcon_con = c, rcon_flds = flds }) = do { x <- lookupLOcc c; fs <- repFields flds; repRecCon x fs } -repE (RecordUpd { rupd_expr = e, rupd_flds = Left flds }) +repE (RecordUpd { rupd_expr = e, rupd_flds = RegularRecUpdFields { recUpdFields = flds } }) = do { x <- repLE e; fs <- repUpdFields flds; repRecUpd x fs } -repE (RecordUpd { rupd_flds = Right _ }) +repE e@(RecordUpd { rupd_flds = OverloadedRecUpdFields {} }) = do -- Not possible due to elimination in the renamer. See Note -- [Handling overloaded and rebindable constructs] - panic "The impossible has happened!" + pprPanic "repE: unexpected overloaded record update" $ ppr e repE (ExprWithTySig _ e wc_ty) = addSimpleTyVarBinds FreshNamesOnly (get_scoped_tvs_from_sig sig_ty) $ @@ -1745,10 +1745,10 @@ repFields (HsRecFields { rec_flds = flds }) ; e <- repLE (hfbRHS fld) ; repFieldExp fn e } -repUpdFields :: [LHsRecUpdField GhcRn] -> MetaM (Core [M TH.FieldExp]) +repUpdFields :: [LHsRecUpdField GhcRn GhcRn] -> MetaM (Core [M TH.FieldExp]) repUpdFields = repListM fieldExpTyConName rep_fld where - rep_fld :: LHsRecUpdField GhcRn -> MetaM (Core (M TH.FieldExp)) + rep_fld :: LHsRecUpdField GhcRn GhcRn -> MetaM (Core (M TH.FieldExp)) rep_fld (L l fld) = case unLoc (hfbLHS fld) of Unambiguous sel_name _ -> do { fn <- lookupLOcc (L l sel_name) ; e <- repLE (hfbRHS fld) @@ -2217,20 +2217,24 @@ globalVarLocal unique name globalVarExternal :: Module -> OccName -> DsM (Core TH.Name) globalVarExternal mod name_occ - = do { - - ; MkC mod <- coreStringLit name_mod + = do { MkC mod <- coreStringLit name_mod ; MkC pkg <- coreStringLit name_pkg ; MkC occ <- occNameLit name_occ - ; rep2_nwDsM mk_varg [pkg,mod,occ] } + ; if | isDataOcc name_occ + -> rep2_nwDsM mkNameG_dName [pkg,mod,occ] + | isVarOcc name_occ + -> rep2_nwDsM mkNameG_vName [pkg,mod,occ] + | isTcOcc name_occ + -> rep2_nwDsM mkNameG_tcName [pkg,mod,occ] + | Just con_fs <- fieldOcc_maybe name_occ + -> do { MkC con <- coreStringLit con_fs + ; rep2_nwDsM mkNameG_fldName [pkg,mod,con,occ] } + | otherwise + -> pprPanic "GHC.HsToCore.Quote.globalVar" (ppr name_occ) + } where name_mod = moduleNameFS (moduleName mod) name_pkg = unitFS (moduleUnit mod) - mk_varg | isDataOcc name_occ = mkNameG_dName - | isVarOcc name_occ = mkNameG_vName - | isTcOcc name_occ = mkNameG_tcName - | otherwise = pprPanic "GHC.HsToCore.Quote.globalVar" (ppr name_occ) - lookupType :: Name -- Name of type constructor (e.g. (M TH.Exp)) -> MetaM Type -- The type @@ -2738,16 +2742,19 @@ repGadtDataCons :: NonEmpty (LocatedN Name) -> LHsType GhcRn -> MetaM (Core (M TH.Con)) repGadtDataCons cons details res_ty - = do cons' <- mapM lookupLOcc cons -- See Note [Binders and occurrences] + = do ne_tycon <- lift $ dsLookupTyCon nonEmptyTyConName + name_tycon <- lift $ dsLookupTyCon nameTyConName + let mk_nonEmpty = coreListNonEmpty ne_tycon (mkTyConTy name_tycon) + cons' <- mapM lookupLOcc cons -- See Note [Binders and occurrences] case details of PrefixConGADT ps -> do arg_tys <- repPrefixConArgs ps res_ty' <- repLTy res_ty - rep2 gadtCName [ unC (nonEmptyCoreList' cons'), unC arg_tys, unC res_ty'] + rep2 gadtCName [unC (mk_nonEmpty cons'), unC arg_tys, unC res_ty'] RecConGADT ips _ -> do arg_vtys <- repRecConArgs ips res_ty' <- repLTy res_ty - rep2 recGadtCName [unC (nonEmptyCoreList' cons'), unC arg_vtys, + rep2 recGadtCName [unC (mk_nonEmpty cons'), unC arg_vtys, unC res_ty'] -- TH currently only supports linear constructors. @@ -3053,9 +3060,6 @@ nonEmptyCoreList :: [Core a] -> Core [a] nonEmptyCoreList [] = panic "coreList: empty argument" nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs)) -nonEmptyCoreList' :: NonEmpty (Core a) -> Core [a] -nonEmptyCoreList' xs@(MkC x:|_) = MkC (mkListExpr (exprType x) (toList $ fmap unC xs)) - coreStringLit :: MonadThings m => FastString -> m (Core String) coreStringLit s = do { z <- mkStringExprFS s; return (MkC z) } diff --git a/compiler/GHC/HsToCore/Ticks.hs b/compiler/GHC/HsToCore/Ticks.hs index 3ccf46c4cf..8c0227df80 100644 --- a/compiler/GHC/HsToCore/Ticks.hs +++ b/compiler/GHC/HsToCore/Ticks.hs @@ -550,14 +550,16 @@ addTickHsExpr expr@(RecordCon { rcon_flds = rec_binds }) = do { rec_binds' <- addTickHsRecordBinds rec_binds ; return (expr { rcon_flds = rec_binds' }) } -addTickHsExpr expr@(RecordUpd { rupd_expr = e, rupd_flds = Left flds }) +addTickHsExpr expr@(RecordUpd { rupd_expr = e + , rupd_flds = upd@(RegularRecUpdFields { recUpdFields = flds }) }) = do { e' <- addTickLHsExpr e ; flds' <- mapM addTickHsRecField flds - ; return (expr { rupd_expr = e', rupd_flds = Left flds' }) } -addTickHsExpr expr@(RecordUpd { rupd_expr = e, rupd_flds = Right flds }) + ; return (expr { rupd_expr = e', rupd_flds = upd { recUpdFields = flds' } }) } +addTickHsExpr expr@(RecordUpd { rupd_expr = e + , rupd_flds = upd@(OverloadedRecUpdFields { olRecUpdFields = flds } ) }) = do { e' <- addTickLHsExpr e ; flds' <- mapM addTickHsRecField flds - ; return (expr { rupd_expr = e', rupd_flds = Right flds' }) } + ; return (expr { rupd_expr = e', rupd_flds = upd { olRecUpdFields = flds' } }) } addTickHsExpr (ExprWithTySig x e ty) = liftM3 ExprWithTySig diff --git a/compiler/GHC/Iface/Env.hs b/compiler/GHC/Iface/Env.hs index a67fdfe334..d0a1a38199 100644 --- a/compiler/GHC/Iface/Env.hs +++ b/compiler/GHC/Iface/Env.hs @@ -193,9 +193,12 @@ setNameModule (Just m) n = tcIfaceLclId :: FastString -> IfL Id tcIfaceLclId occ = do { lcl <- getLclEnv - ; case (lookupFsEnv (if_id_env lcl) occ) of + ; case lookupFsEnv (if_id_env lcl) occ of Just ty_var -> return ty_var - Nothing -> failIfM (text "Iface id out of scope: " <+> ppr occ) + Nothing -> failIfM $ + vcat + [ text "Iface id out of scope: " <+> ppr occ + , text "env:" <+> ppr (if_id_env lcl) ] } extendIfaceIdEnv :: [Id] -> IfL a -> IfL a @@ -209,7 +212,7 @@ extendIfaceIdEnv ids tcIfaceTyVar :: FastString -> IfL TyVar tcIfaceTyVar occ = do { lcl <- getLclEnv - ; case (lookupFsEnv (if_tv_env lcl) occ) of + ; case lookupFsEnv (if_tv_env lcl) occ of Just ty_var -> return ty_var Nothing -> failIfM (text "Iface type variable out of scope: " <+> ppr occ) } diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs index 8ede7bcc5f..24a68e63c4 100644 --- a/compiler/GHC/Iface/Ext/Ast.hs +++ b/compiler/GHC/Iface/Ext/Ast.hs @@ -41,6 +41,7 @@ import GHC.Utils.Monad ( concatMapM, MonadIO(liftIO) ) import GHC.Types.Id ( isDataConId_maybe ) import GHC.Types.Name ( Name, nameSrcSpan, nameUnique ) import GHC.Types.Name.Env ( NameEnv, emptyNameEnv, extendNameEnv, lookupNameEnv ) +import GHC.Types.Name.Reader ( RecFieldInfo(..) ) import GHC.Types.SrcLoc import GHC.Core.Type ( Type ) import GHC.Core.Predicate @@ -1182,11 +1183,13 @@ instance HiePass p => ToHie (LocatedA (HsExpr (GhcPass p))) where con_name = case hiePass @p of -- Like ConPat HieRn -> con HieTc -> fmap conLikeName con - RecordUpd {rupd_expr = expr, rupd_flds = Left upds}-> + RecordUpd { rupd_expr = expr + , rupd_flds = RegularRecUpdFields { recUpdFields = upds } }-> [ toHie expr , toHie $ map (RC RecFieldAssign) upds ] - RecordUpd {rupd_expr = expr, rupd_flds = Right _}-> + RecordUpd { rupd_expr = expr + , rupd_flds = OverloadedRecUpdFields {} }-> [ toHie expr ] ExprWithTySig _ expr sig -> @@ -2111,10 +2114,9 @@ instance ToHie (IEContext (LocatedA (IE GhcRn))) where IEThingAll _ n -> [ toHie $ IEC c n ] - IEThingWith flds n _ ns -> + IEThingWith _ n _ ns -> [ toHie $ IEC c n , toHie $ map (IEC c) ns - , toHie $ map (IEC c) flds ] IEModuleContents _ n -> [ toHie $ IEC c n @@ -2135,10 +2137,10 @@ instance ToHie (IEContext (LocatedA (IEWrappedName GhcRn))) where [ toHie $ C (IEThing c) (L l n) ] -instance ToHie (IEContext (Located FieldLabel)) where - toHie (IEC c (L span lbl)) = concatM - [ makeNode lbl span - , toHie $ C (IEThing c) $ L span (flSelector lbl) +instance ToHie (IEContext (Located RecFieldInfo)) where + toHie (IEC c (L span info)) = concatM + [ makeNode info span + , toHie $ C (IEThing c) $ L span (flSelector $ recFieldLabel info) ] instance ToHie (LocatedA (DocDecl GhcRn)) where @@ -2149,4 +2151,5 @@ instance ToHie (LocatedA (DocDecl GhcRn)) where DocGroup _ d -> [ toHie d ] instance ToHie (LHsDoc GhcRn) where - toHie (L span d@(WithHsDocIdentifiers _ ids)) = concatM $ makeNode d span : [toHie $ map (C Use) ids] + toHie (L span d@(WithHsDocIdentifiers _ ids)) = + concatM $ makeNode d span : [toHie $ map (C Use) ids] diff --git a/compiler/GHC/Iface/Load.hs b/compiler/GHC/Iface/Load.hs index 0786505e3a..e794c7c6d2 100644 --- a/compiler/GHC/Iface/Load.hs +++ b/compiler/GHC/Iface/Load.hs @@ -1160,7 +1160,7 @@ pprExport :: IfaceExport -> SDoc pprExport (Avail n) = ppr n pprExport (AvailTC _ []) = Outputable.empty pprExport avail@(AvailTC n _) = - ppr n <> mark <> pp_export (availSubordinateGreNames avail) + ppr n <> mark <> pp_export (availSubordinateNames avail) where mark | availExportsDecl avail = Outputable.empty | otherwise = vbar diff --git a/compiler/GHC/Iface/Make.hs b/compiler/GHC/Iface/Make.hs index c077b28557..3f6ef4b465 100644 --- a/compiler/GHC/Iface/Make.hs +++ b/compiler/GHC/Iface/Make.hs @@ -23,6 +23,7 @@ import GHC.Prelude import GHC.Hs +import GHC.Stg.InferTags.TagSig (StgCgInfos) import GHC.StgToCmm.Types (CmmCgInfos (..)) import GHC.Tc.Utils.TcType @@ -98,7 +99,6 @@ import Data.Function import Data.List ( findIndex, mapAccumL, sortBy ) import Data.Ord import Data.IORef -import GHC.Stg.InferTags.TagSig (StgCgInfos) {- @@ -307,6 +307,7 @@ mkIface_ hsc_env trust_info = setSafeMode safe_mode annotations = map mkIfaceAnnotation anns icomplete_matches = map mkIfaceCompleteMatch complete_matches + !rdrs = maybeGlobalRdrEnv rdr_env ModIface { mi_module = this_mod, @@ -329,7 +330,7 @@ mkIface_ hsc_env mi_fixities = fixities, mi_warns = warns, mi_anns = annotations, - mi_globals = maybeGlobalRdrEnv rdr_env, + mi_globals = rdrs, mi_used_th = used_th, mi_decls = decls, mi_extra_decls = extra_decls, @@ -357,10 +358,13 @@ mkIface_ hsc_env -- Desugar.addExportFlagsAndRules). The mi_globals field is used -- by GHCi to decide whether the module has its full top-level -- scope available. (#5534) - maybeGlobalRdrEnv :: GlobalRdrEnv -> Maybe GlobalRdrEnv + maybeGlobalRdrEnv :: GlobalRdrEnv -> Maybe IfGlobalRdrEnv maybeGlobalRdrEnv rdr_env - | backendWantsGlobalBindings (backend dflags) = Just rdr_env - | otherwise = Nothing + | backendWantsGlobalBindings (backend dflags) + = Just $! forceGlobalRdrEnv rdr_env + -- See Note [Forcing GREInfo] in GHC.Types.GREInfo. + | otherwise + = Nothing ifFamInstTcName = ifFamInstFam @@ -402,8 +406,10 @@ mkIfaceExports exports sort_subs (Avail n) = Avail n sort_subs (AvailTC n []) = AvailTC n [] sort_subs (AvailTC n (m:ms)) - | NormalGreName n==m = AvailTC n (m:sortBy stableGreNameCmp ms) - | otherwise = AvailTC n (sortBy stableGreNameCmp (m:ms)) + | n == m + = AvailTC n (m:sortBy stableNameCmp ms) + | otherwise + = AvailTC n (sortBy stableNameCmp (m:ms)) -- Maintain the AvailTC Invariant {- diff --git a/compiler/GHC/Iface/Recomp.hs b/compiler/GHC/Iface/Recomp.hs index 0f8748e536..ec587318f4 100644 --- a/compiler/GHC/Iface/Recomp.hs +++ b/compiler/GHC/Iface/Recomp.hs @@ -56,7 +56,6 @@ import GHC.Types.Annotations import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.SrcLoc -import GHC.Types.Unique import GHC.Types.Unique.Set import GHC.Types.Fixity.Env import GHC.Unit.External @@ -979,8 +978,8 @@ addFingerprints hsc_env iface0 -- This is computed by finding the free external names of each -- declaration, including IfaceDeclExtras (things that a -- declaration implicitly depends on). - edges :: [ Node Unique IfaceDeclABI ] - edges = [ DigraphNode abi (getUnique (getOccName decl)) out + edges :: [ Node OccName IfaceDeclABI ] + edges = [ DigraphNode abi (getOccName decl) out | decl <- decls , let abi = declABI decl , let out = localOccs $ freeNamesDeclABI abi @@ -988,7 +987,7 @@ addFingerprints hsc_env iface0 name_module n = assertPpr (isExternalName n) (ppr n) (nameModule n) localOccs = - map (getUnique . getParent . getOccName) + map (getParent . getOccName) -- NB: names always use semantic module, so -- filtering must be on the semantic module! -- See Note [Identity versus semantic module] @@ -1013,7 +1012,7 @@ addFingerprints hsc_env iface0 -- Strongly-connected groups of declarations, in dependency order groups :: [SCC IfaceDeclABI] - groups = stronglyConnCompFromEdgedVerticesUniq edges + groups = stronglyConnCompFromEdgedVerticesOrd edges global_hash_fn = mkHashFun hsc_env eps @@ -1205,7 +1204,11 @@ addFingerprints hsc_env iface0 -- This key is safe because mi_extra_decls contains tidied things. getOcc (IfGblTopBndr b) = getOccName b - getOcc (IfLclTopBndr fs _ _ _) = mkVarOccFS fs + getOcc (IfLclTopBndr fs _ _ details) = + case details of + IfRecSelId { ifRecSelFirstCon = first_con } + -> mkRecFieldOccFS (getOccFS first_con) fs + _ -> mkVarOccFS fs binding_key (IfaceNonRec b _) = IfaceNonRec (getOcc b) () binding_key (IfaceRec bs) = IfaceRec (map (\(b, _) -> (getOcc b, ())) bs) diff --git a/compiler/GHC/Iface/Rename.hs b/compiler/GHC/Iface/Rename.hs index 922f8881ff..b372e7a1d9 100644 --- a/compiler/GHC/Iface/Rename.hs +++ b/compiler/GHC/Iface/Rename.hs @@ -231,14 +231,14 @@ rnModule mod = do return (renameHoleModule unit_state hmap mod) rnAvailInfo :: Rename AvailInfo -rnAvailInfo (Avail c) = Avail <$> rnGreName c +rnAvailInfo (Avail c) = Avail <$> rnIfaceGlobal c rnAvailInfo (AvailTC n ns) = do -- Why don't we rnIfaceGlobal the availName itself? It may not -- actually be exported by the module it putatively is from, in -- which case we won't be able to tell what the name actually -- is. But for the availNames they MUST be exported, so they -- will rename fine. - ns' <- mapM rnGreName ns + ns' <- mapM rnIfaceGlobal ns case ns' of [] -> panic "rnAvailInfoEmpty AvailInfo" (rep:rest) -> assertPpr (all ((== childModule rep) . childModule) rest) @@ -246,11 +246,7 @@ rnAvailInfo (AvailTC n ns) = do n' <- setNameModule (Just (childModule rep)) n return (AvailTC n' ns') where - childModule = nameModule . greNameMangledName - -rnGreName :: Rename GreName -rnGreName (NormalGreName n) = NormalGreName <$> rnIfaceGlobal n -rnGreName (FieldGreName fl) = FieldGreName <$> rnFieldLabel fl + childModule = nameModule rnFieldLabel :: Rename FieldLabel rnFieldLabel fl = do @@ -258,8 +254,6 @@ rnFieldLabel fl = do return (fl { flSelector = sel' }) - - -- | The key function. This gets called on every Name embedded -- inside a ModIface. Our job is to take a Name from some -- generalized unit ID p[A=\<A>, B=\<B>], and change @@ -704,9 +698,12 @@ rnIfaceExprs :: Rename [IfaceExpr] rnIfaceExprs = mapM rnIfaceExpr rnIfaceIdDetails :: Rename IfaceIdDetails -rnIfaceIdDetails (IfRecSelId (Left tc) b) = IfRecSelId <$> fmap Left (rnIfaceTyCon tc) <*> pure b -rnIfaceIdDetails (IfRecSelId (Right decl) b) = IfRecSelId <$> fmap Right (rnIfaceDecl decl) <*> pure b -rnIfaceIdDetails details = pure details +rnIfaceIdDetails (IfRecSelId (Left tc) con naughty fl) + = IfRecSelId <$> fmap Left (rnIfaceTyCon tc) <*> rnIfaceGlobal con <*> pure naughty <*> rnFieldLabel fl +rnIfaceIdDetails (IfRecSelId (Right decl) con naughty fl) + = IfRecSelId <$> fmap Right (rnIfaceDecl decl) <*> rnIfaceGlobal con <*> pure naughty <*> rnFieldLabel fl +rnIfaceIdDetails details + = pure details rnIfaceType :: Rename IfaceType rnIfaceType (IfaceFreeTyVar n) = pure (IfaceFreeTyVar n) diff --git a/compiler/GHC/Iface/Syntax.hs b/compiler/GHC/Iface/Syntax.hs index 4ff4ab7eee..71b87cb19c 100644 --- a/compiler/GHC/Iface/Syntax.hs +++ b/compiler/GHC/Iface/Syntax.hs @@ -35,6 +35,7 @@ module GHC.Iface.Syntax ( -- Free Names freeNamesIfDecl, freeNamesIfRule, freeNamesIfFamInst, + freeNamesIfConDecls, -- Pretty printing pprIfaceExpr, @@ -80,8 +81,6 @@ import GHC.Utils.Panic import GHC.Utils.Misc( dropList, filterByList, notNull, unzipWith, seqList, zipWithEqual ) -import Language.Haskell.Syntax.Basic (FieldLabelString(..)) - import Control.Monad import System.IO.Unsafe import Control.DeepSeq @@ -385,7 +384,11 @@ data IfGuidance data IfaceIdDetails = IfVanillaId | IfWorkerLikeId [CbvMark] - | IfRecSelId (Either IfaceTyCon IfaceDecl) Bool + | IfRecSelId + { ifRecSelIdParent :: Either IfaceTyCon IfaceDecl + , ifRecSelFirstCon :: IfaceTopBndr + , ifRecSelIdIsNaughty :: Bool + , ifRecSelIdFieldLabel :: FieldLabel } | IfDFunId -- | Iface type for LambdaFormInfo. Fields not relevant for imported Ids are @@ -1299,7 +1302,7 @@ pprIfaceConDecl ss gadt_style tycon tc_binders parent | otherwise = Nothing where sel = flSelector lbl - occ = mkVarOccFS (field_label $ flLabel lbl) + occ = nameOccName sel mk_user_con_res_ty :: IfaceEqSpec -> SDoc -- See Note [Result type of a data family GADT] @@ -1504,10 +1507,10 @@ instance Outputable IfaceConAlt where instance Outputable IfaceIdDetails where ppr IfVanillaId = Outputable.empty ppr (IfWorkerLikeId dmd) = text "StrWork" <> parens (ppr dmd) - ppr (IfRecSelId tc b) = text "RecSel" <+> ppr tc - <+> if b - then text "<naughty>" - else Outputable.empty + ppr (IfRecSelId tc _c b _fl) = text "RecSel" <+> ppr tc + <+> if b + then text "<naughty>" + else Outputable.empty ppr IfDFunId = text "DFunId" instance Outputable IfaceInfoItem where @@ -1623,9 +1626,13 @@ freeNamesIfAxBranch (IfaceAxBranch { ifaxbTyVars = tyvars freeNamesIfType rhs freeNamesIfIdDetails :: IfaceIdDetails -> NameSet -freeNamesIfIdDetails (IfRecSelId tc _) = - either freeNamesIfTc freeNamesIfDecl tc -freeNamesIfIdDetails _ = emptyNameSet +freeNamesIfIdDetails (IfRecSelId tc first_con _ fl) = + either freeNamesIfTc freeNamesIfDecl tc &&& + unitFV first_con &&& + unitFV (flSelector fl) +freeNamesIfIdDetails IfVanillaId = emptyNameSet +freeNamesIfIdDetails (IfWorkerLikeId {}) = emptyNameSet +freeNamesIfIdDetails IfDFunId = emptyNameSet -- All other changes are handled via the version info on the tycon freeNamesIfFamFlav :: IfaceFamTyConFlav -> NameSet @@ -1657,7 +1664,7 @@ freeNamesDM _ = emptyNameSet freeNamesIfConDecls :: IfaceConDecls -> NameSet freeNamesIfConDecls (IfDataTyCon _ cs) = fnList freeNamesIfConDecl cs freeNamesIfConDecls (IfNewTyCon c) = freeNamesIfConDecl c -freeNamesIfConDecls _ = emptyNameSet +freeNamesIfConDecls _ = emptyNameSet freeNamesIfConDecl :: IfaceConDecl -> NameSet freeNamesIfConDecl (IfCon { ifConExTCvs = ex_tvs, ifConCtxt = ctxt @@ -2264,16 +2271,25 @@ instance Binary IfaceAnnotation where return (IfaceAnnotation a1 a2) instance Binary IfaceIdDetails where - put_ bh IfVanillaId = putByte bh 0 - put_ bh (IfRecSelId a b) = putByte bh 1 >> put_ bh a >> put_ bh b + put_ bh IfVanillaId = putByte bh 0 + put_ bh (IfRecSelId a b c d) = do { putByte bh 1 + ; put_ bh a + ; put_ bh b + ; put_ bh c + ; put_ bh d } put_ bh (IfWorkerLikeId dmds) = putByte bh 2 >> put_ bh dmds - put_ bh IfDFunId = putByte bh 3 + put_ bh IfDFunId = putByte bh 3 get bh = do h <- getByte bh case h of 0 -> return IfVanillaId - 1 -> do { a <- get bh; b <- get bh; return (IfRecSelId a b) } - 2 -> do { dmds <- get bh; return (IfWorkerLikeId dmds) } + 1 -> do { a <- get bh + ; b <- get bh + ; c <- get bh + ; d <- get bh + ; return (IfRecSelId a b c d) } + 2 -> do { dmds <- get bh + ; return (IfWorkerLikeId dmds) } _ -> return IfDFunId instance Binary IfaceInfoItem where @@ -2693,8 +2709,8 @@ instance NFData IfaceIdDetails where rnf = \case IfVanillaId -> () IfWorkerLikeId dmds -> dmds `seqList` () - IfRecSelId (Left tycon) b -> rnf tycon `seq` rnf b - IfRecSelId (Right decl) b -> rnf decl `seq` rnf b + IfRecSelId (Left tycon) b c d -> rnf tycon `seq` rnf b `seq` rnf c `seq` rnf d + IfRecSelId (Right decl) b c d -> rnf decl `seq` rnf b `seq` rnf c `seq` rnf d IfDFunId -> () instance NFData IfaceInfoItem where diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs index 4a4c2a6cee..aaacb86b7f 100644 --- a/compiler/GHC/IfaceToCore.hs +++ b/compiler/GHC/IfaceToCore.hs @@ -10,6 +10,8 @@ Type checking of type signatures in interface files {-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RecursiveDo #-} + {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE RecordWildCards #-} @@ -699,7 +701,7 @@ tc_iface_decl :: Maybe Class -- ^ For associated type/data family declarations tc_iface_decl _ ignore_prags (IfaceId {ifName = name, ifType = iface_type, ifIdDetails = details, ifIdInfo = info}) = do { ty <- tcIfaceType iface_type - ; details <- tcIdDetails ty details + ; details <- tcIdDetails name ty details ; info <- tcIdInfo ignore_prags TopLevel name ty info ; return (AnId (mkGlobalId details name ty info)) } @@ -955,10 +957,15 @@ mk_top_id (IfGblTopBndr gbl_name) return $ mkExportedVanillaId gbl_name (mkTyConApp ioTyCon [unitTy]) | otherwise = tcIfaceExtId gbl_name mk_top_id (IfLclTopBndr raw_name iface_type info details) = do - name <- newIfaceName (mkVarOccFS raw_name) ty <- tcIfaceType iface_type + rec { details' <- tcIdDetails name ty details + ; let occ = case details' of + RecSelId { sel_tycon = parent } + -> let con_fs = getOccFS $ recSelFirstConName parent + in mkRecFieldOccFS con_fs raw_name + _ -> mkVarOccFS raw_name + ; name <- newIfaceName occ } info' <- tcIdInfo False TopLevel name ty info - details' <- tcIdDetails ty details let new_id = mkGlobalId details' name ty info' return new_id @@ -1691,19 +1698,19 @@ tcIfaceDataAlt mult con inst_tys arg_strs rhs ************************************************************************ -} -tcIdDetails :: Type -> IfaceIdDetails -> IfL IdDetails -tcIdDetails _ IfVanillaId = return VanillaId -tcIdDetails _ (IfWorkerLikeId dmds) = return $ WorkerLikeId dmds -tcIdDetails ty IfDFunId +tcIdDetails :: Name -> Type -> IfaceIdDetails -> IfL IdDetails +tcIdDetails _ _ IfVanillaId = return VanillaId +tcIdDetails _ _ (IfWorkerLikeId dmds) = return $ WorkerLikeId dmds +tcIdDetails _ ty IfDFunId = return (DFunId (isNewTyCon (classTyCon cls))) where (_, _, cls, _) = tcSplitDFunTy ty -tcIdDetails _ (IfRecSelId tc naughty) +tcIdDetails nm _ (IfRecSelId tc _first_con naughty fl) = do { tc' <- either (fmap RecSelData . tcIfaceTyCon) (fmap (RecSelPatSyn . tyThingPatSyn) . tcIfaceDecl False) tc - ; return (RecSelId { sel_tycon = tc', sel_naughty = naughty }) } + ; return (RecSelId { sel_tycon = tc', sel_naughty = naughty, sel_fieldLabel = fl { flSelector = nm } }) } where tyThingPatSyn (AConLike (PatSynCon ps)) = ps tyThingPatSyn _ = panic "tcIdDetails: expecting patsyn" diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs index f505e9b59d..0b7053dcbb 100644 --- a/compiler/GHC/Parser/PostProcess.hs +++ b/compiler/GHC/Parser/PostProcess.hs @@ -2523,7 +2523,7 @@ mkRdrRecordUpd overloaded_on exp@(L loc _) fbinds anns = do -- overloaded_on) is in effect because it affects the Left/Right nature -- of the RecordUpd value we calculate. let (fs, ps) = partitionEithers fbinds - fs' :: [LHsRecUpdField GhcPs] + fs' :: [LHsRecUpdField GhcPs GhcPs] fs' = map (fmap mk_rec_upd_field) fs case overloaded_on of False | not $ null ps -> @@ -2534,19 +2534,27 @@ mkRdrRecordUpd overloaded_on exp@(L loc _) fbinds anns = do return RecordUpd { rupd_ext = anns , rupd_expr = exp - , rupd_flds = Left fs' } + , rupd_flds = + RegularRecUpdFields + { xRecUpdFields = noExtField + , recUpdFields = fs' } } + -- This is a RecordDotSyntax update. True -> do let qualifiedFields = [ L l lbl | L _ (HsFieldBind _ (L l lbl) _ _) <- fs' - , isQual . rdrNameAmbiguousFieldOcc $ lbl + , isQual . ambiguousFieldOccRdrName $ lbl ] case qualifiedFields of qf:_ -> addFatalError $ mkPlainErrorMsgEnvelope (getLocA qf) $ - PsErrOverloadedRecordUpdateNoQualifiedFields - _ -> return RecordUpd -- This is a RecordDotSyntax update. - { rupd_ext = anns - , rupd_expr = exp - , rupd_flds = Right (toProjUpdates fbinds) } + PsErrOverloadedRecordUpdateNoQualifiedFields + _ -> return $ + RecordUpd + { rupd_ext = anns + , rupd_expr = exp + , rupd_flds = + OverloadedRecUpdFields + { xOLRecUpdFields = noExtField + , olRecUpdFields = toProjUpdates fbinds } } where toProjUpdates :: [Fbind (HsExpr GhcPs)] -> [LHsRecUpdProj GhcPs] toProjUpdates = map (\case { Right p -> p; Left f -> recFieldToProjUpdate f }) @@ -2578,7 +2586,7 @@ mk_rec_fields fs Nothing = HsRecFields { rec_flds = fs, rec_dotdot = Nothing } mk_rec_fields fs (Just s) = HsRecFields { rec_flds = fs , rec_dotdot = Just (L s (RecFieldsDotDot $ length fs)) } -mk_rec_upd_field :: HsRecField GhcPs (LHsExpr GhcPs) -> HsRecUpdField GhcPs +mk_rec_upd_field :: HsRecField GhcPs (LHsExpr GhcPs) -> HsRecUpdField GhcPs GhcPs mk_rec_upd_field (HsFieldBind noAnn (L loc (FieldOcc _ rdr)) arg pun) = HsFieldBind noAnn (L loc (Unambiguous noExtField rdr)) arg pun diff --git a/compiler/GHC/Rename/Doc.hs b/compiler/GHC/Rename/Doc.hs index b278e02cf3..006bc2689b 100644 --- a/compiler/GHC/Rename/Doc.hs +++ b/compiler/GHC/Rename/Doc.hs @@ -8,7 +8,6 @@ import GHC.Types.Name.Reader import GHC.Types.Name import GHC.Types.SrcLoc import GHC.Tc.Utils.Monad (getGblEnv) -import GHC.Types.Avail import GHC.Rename.Env rnLHsDoc :: LHsDoc GhcPs -> RnM (LHsDoc GhcRn) @@ -37,10 +36,10 @@ rnHsDoc (WithHsDocIdentifiers s ids) = do pure (WithHsDocIdentifiers s (rnHsDocIdentifiers gre ids)) rnHsDocIdentifiers :: GlobalRdrEnv - -> [Located RdrName] - -> [Located Name] -rnHsDocIdentifiers gre ns = concat - [ map (L l . greNamePrintableName . gre_name) (lookupGRE_RdrName c gre) + -> [Located RdrName] + -> [Located Name] +rnHsDocIdentifiers gre_env ns = concat + [ map (L l . greName) (lookupGRE_RdrName (IncludeFields WantNormal) gre_env c) | L l rdr_name <- ns , c <- dataTcOccs rdr_name ] diff --git a/compiler/GHC/Rename/Env.hs b/compiler/GHC/Rename/Env.hs index a4e1ef0a77..9155a86bf0 100644 --- a/compiler/GHC/Rename/Env.hs +++ b/compiler/GHC/Rename/Env.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE TypeApplications #-} {- @@ -17,26 +18,28 @@ module GHC.Rename.Env ( lookupLocatedOccRn, lookupLocatedOccRnConstr, lookupLocatedOccRnRecField, lookupLocatedOccRnNone, - lookupOccRn, lookupOccRn_maybe, + lookupOccRn, lookupOccRn_maybe, lookupSameOccRn_maybe, lookupLocalOccRn_maybe, lookupInfoOccRn, lookupLocalOccThLvl_maybe, lookupLocalOccRn, lookupTypeOccRn, lookupGlobalOccRn, lookupGlobalOccRn_maybe, - AmbiguousResult(..), lookupExprOccRn, lookupRecFieldOcc, - lookupRecFieldOcc_update, + lookupRecUpdFields, + getFieldUpdLbl, + getUpdFieldLbls, ChildLookupResult(..), lookupSubBndrOcc_helper, combineChildLookupResult, -- Called by lookupChildrenExport HsSigCtxt(..), lookupLocalTcNames, lookupSigOccRn, lookupSigOccRnN, - lookupSigCtxtOccRn, lookupSigCtxtOccRnN, + lookupSigCtxtOccRn, lookupInstDeclBndr, lookupFamInstName, lookupConstructorInfo, lookupConstructorFields, + lookupGREInfo, lookupGreAvailRn, @@ -60,7 +63,9 @@ module GHC.Rename.Env ( import GHC.Prelude -import GHC.Iface.Load ( loadInterfaceForName, loadSrcInterface_maybe ) +import Language.Haskell.Syntax.Basic (FieldLabelString(..)) + +import GHC.Iface.Load import GHC.Iface.Env import GHC.Hs import GHC.Types.Name.Reader @@ -71,7 +76,7 @@ import GHC.Parser.PostProcess ( setRdrNameSpace ) import GHC.Builtin.Types import GHC.Types.Name import GHC.Types.Name.Set -import GHC.Types.Name.Env +import GHC.Types.Name.Env ( lookupNameEnv ) import GHC.Types.Avail import GHC.Types.Hint import GHC.Types.Error @@ -82,30 +87,35 @@ import GHC.Core.ConLike import GHC.Core.DataCon import GHC.Core.TyCon import GHC.Builtin.Names( rOOT_MAIN ) -import GHC.Types.Basic ( TopLevelFlag(..), TupleSort(..) ) +import GHC.Types.Basic ( TopLevelFlag(..), TupleSort(..), tupleSortBoxity ) +import GHC.Types.TyThing ( tyThingGREInfo ) import GHC.Types.SrcLoc as SrcLoc import GHC.Utils.Outputable as Outputable -import GHC.Types.Unique.Set ( uniqSetAny ) +import GHC.Types.Unique.FM +import GHC.Types.Unique.Set import GHC.Utils.Misc import GHC.Utils.Panic +import GHC.Utils.Panic.Plain (assert) import GHC.Data.Maybe +import GHC.Driver.Env import GHC.Driver.Session import GHC.Data.FastString -import Control.Monad import GHC.Data.List.SetOps ( minusList ) import qualified GHC.LanguageExtensions as LangExt import GHC.Rename.Unbound import GHC.Rename.Utils -import qualified Data.Semigroup as Semi -import Data.Either ( partitionEithers ) -import Data.List ( find ) -import qualified Data.List.NonEmpty as NE -import Control.Arrow ( first ) -import GHC.Types.FieldLabel import GHC.Data.Bag import GHC.Types.PkgQual -import Language.Haskell.Syntax.Basic (FieldLabelString(..)) -import GHC.Types.ConInfo (ConInfo, conInfoFields, mkConInfo) +import GHC.Types.GREInfo + +import Control.Arrow ( first ) +import Control.Monad +import Data.Either ( partitionEithers ) +import Data.Function ( on ) +import Data.List ( find, partition, groupBy, sortBy ) +import qualified Data.List.NonEmpty as NE +import qualified Data.Semigroup as Semi +import System.IO.Unsafe ( unsafePerformIO ) {- ********************************************************* @@ -276,17 +286,16 @@ lookupTopBndrRn :: WhatLooking -> RdrName -> RnM Name -- A separate function (importsFromLocalDecls) reports duplicate top level -- decls, so here it's safe just to choose an arbitrary one. lookupTopBndrRn which_suggest rdr_name = - lookupExactOrOrig rdr_name id $ + lookupExactOrOrig rdr_name greName $ do { -- Check for operators in type or class declarations -- See Note [Type and class operator definitions] let occ = rdrNameOcc rdr_name ; when (isTcOcc occ && isSymOcc occ) (do { op_ok <- xoptM LangExt.TypeOperators ; unless op_ok (addErr (TcRnIllegalTypeOperatorDecl rdr_name)) }) - ; env <- getGlobalRdrEnv - ; case filter isLocalGRE (lookupGRE_RdrName rdr_name env) of - [gre] -> return (greMangledName gre) + ; case filter isLocalGRE (lookupGRE_RdrName (IncludeFields WantNormal) env rdr_name) of + [gre] -> return (greName gre) _ -> do -- Ambiguous (can't happen) or unbound traceRn "lookupTopBndrRN fail" (ppr rdr_name) unboundName (LF which_suggest WL_LocalTop) rdr_name @@ -307,7 +316,7 @@ lookupLocatedTopBndrRnN = wrapLocMA (lookupTopBndrRn WL_Anything) -- | Lookup an @Exact@ @RdrName@. See Note [Looking up Exact RdrNames]. -- This never adds an error, but it may return one, see -- Note [Errors in lookup functions] -lookupExactOcc_either :: Name -> RnM (Either NotInScopeError Name) +lookupExactOcc_either :: Name -> RnM (Either NotInScopeError GlobalRdrElt) lookupExactOcc_either name | Just thing <- wiredInNameTyThing_maybe name , Just tycon <- case thing of @@ -321,39 +330,57 @@ lookupExactOcc_either name UnboxedTuple -> tyConArity tycon `div` 2 _ -> tyConArity tycon ; checkTupSize tupArity - ; return (Right name) } + ; let gre = (localTyConGRE (TupleFlavour $ tupleSortBoxity tupleSort) name) + { gre_lcl = False } + ; return (Right gre) } | isExternalName name - = return (Right name) + = Right <$> lookupExternalExactGRE name | otherwise + = lookupLocalExactGRE name + +lookupExternalExactGRE :: Name -> RnM GlobalRdrElt +lookupExternalExactGRE name + = do { thing <- + case wiredInNameTyThing_maybe name of + Just thing -> return thing + _ -> tcLookupGlobal name + ; return $ + (localVanillaGRE NoParent name) + { gre_lcl = False, gre_info = tyThingGREInfo thing } } + +lookupLocalExactGRE :: Name -> RnM (Either NotInScopeError GlobalRdrElt) +lookupLocalExactGRE name = do { env <- getGlobalRdrEnv - ; let -- See Note [Splicing Exact names] - main_occ = nameOccName name + ; let main_occ = nameOccName name demoted_occs = case demoteOccName main_occ of Just occ -> [occ] Nothing -> [] gres = [ gre | occ <- main_occ : demoted_occs - , gre <- lookupGlobalRdrEnv env occ - , greMangledName gre == name ] + , gre <- lookupGRE_OccName (IncludeFields WantBoth) env occ + -- We're filtering by an exact 'Name' match, + -- so we should look up as many potential matches as possible. + -- See also test case T11809. + , greName gre == name ] ; case gres of - [gre] -> return (Right (greMangledName gre)) + [gre] -> return (Right gre) [] -> -- See Note [Splicing Exact names] do { lcl_env <- getLocalRdrEnv + ; let gre = localVanillaGRE NoParent name -- LocalRdrEnv only contains Vanilla things ; if name `inLocalRdrEnvScope` lcl_env - then return (Right name) + then return (Right gre) else do { th_topnames_var <- fmap tcg_th_topnames getGblEnv ; th_topnames <- readTcRef th_topnames_var ; if name `elemNameSet` th_topnames - then return (Right name) + then return (Right gre) else return (Left (NoExactName name)) } } - gres -> return (Left (SameName gres)) -- Ugh! See Note [Template Haskell ambiguity] - } + gres -> return (Left (SameName gres)) } -- Ugh! See Note [Template Haskell ambiguity] } ----------------------------------------------- lookupInstDeclBndr :: Name -> SDoc -> RdrName -> RnM Name @@ -400,53 +427,37 @@ lookupFamInstName (Just cls) tc_rdr -- Associated type; c.f GHC.Rename.Bind.rnM lookupFamInstName Nothing tc_rdr -- Family instance; tc_rdr is an *occurrence* = lookupLocatedOccRnConstr tc_rdr -lookupConstructorInfo :: Name -> RnM ConInfo --- Look up the info for a given constructor --- * For constructors from this module, use the record field env, --- which is itself gathered from the (as yet un-typechecked) --- data type decls --- For more details, see Note [Local constructor info in the renamer] --- --- * For constructors from imported modules, use the *type* environment --- since imported modules are already compiled, the info is conveniently --- right there - -lookupConstructorInfo con_name - = do { this_mod <- getModule - ; if nameIsLocalOrFrom this_mod con_name then - do { con_env <- getConEnv - ; let conInfo = lookupNameEnv con_env con_name - ; traceTc "lookupCF" (ppr con_name $$ ppr conInfo $$ ppr con_env) - -- we always info for all the constructors in the current module in GHC.Rename.mk_con_env - -- hence we should be able to look up the constructor in tcg_con_env if it's from the current module - ; return (conInfo `orElse` panic "GHC.Rename.Env.lookupConstructorInfo") } - else - do { con <- tcLookupConLike con_name - ; traceTc "lookupCF 2" (ppr con) - ; pure $ mkConInfo (conLikeArity con) (conLikeFieldLabels con) } } - ----------------------------------------------- lookupConstructorFields :: Name -> RnM [FieldLabel] lookupConstructorFields = fmap conInfoFields . lookupConstructorInfo +-- | Look up the arity and record fields of a constructor. +lookupConstructorInfo :: Name -> RnM ConInfo +lookupConstructorInfo con_name + = do { info <- lookupGREInfo_GRE con_name + ; case info of + IAmConLike con_info -> return con_info + _ -> pprPanic "lookupConstructorInfo: not a ConLike" $ + vcat [ text "name:" <+> ppr con_name ] + } -- In CPS style as `RnM r` is monadic -- Reports an error if the name is an Exact or Orig and it can't find the name -- Otherwise if it is not an Exact or Orig, returns k -lookupExactOrOrig :: RdrName -> (Name -> r) -> RnM r -> RnM r +lookupExactOrOrig :: RdrName -> (GlobalRdrElt -> r) -> RnM r -> RnM r lookupExactOrOrig rdr_name res k = do { men <- lookupExactOrOrig_base rdr_name ; case men of - FoundExactOrOrig n -> return (res n) + FoundExactOrOrig n -> return $ res n ExactOrOrigError e -> do { addErr (mkTcRnNotInScope rdr_name e) - ; return (res (mkUnboundNameRdr rdr_name)) } + ; return $ res (mkUnboundGRERdr rdr_name) } NotExactOrOrig -> k } -- Variant of 'lookupExactOrOrig' that does not report an error -- See Note [Errors in lookup functions] -- Calls k if the name is neither an Exact nor Orig -lookupExactOrOrig_maybe :: RdrName -> (Maybe Name -> r) -> RnM r -> RnM r +lookupExactOrOrig_maybe :: RdrName -> (Maybe GlobalRdrElt -> r) -> RnM r -> RnM r lookupExactOrOrig_maybe rdr_name res k = do { men <- lookupExactOrOrig_base rdr_name ; case men of @@ -454,12 +465,15 @@ lookupExactOrOrig_maybe rdr_name res k ExactOrOrigError _ -> return (res Nothing) NotExactOrOrig -> k } -data ExactOrOrigResult = FoundExactOrOrig Name -- ^ Found an Exact Or Orig Name - | ExactOrOrigError NotInScopeError -- ^ The RdrName was an Exact - -- or Orig, but there was an - -- error looking up the Name - | NotExactOrOrig -- ^ The RdrName is neither an Exact nor - -- Orig +data ExactOrOrigResult + = FoundExactOrOrig GlobalRdrElt + -- ^ Found an Exact Or Orig Name + | ExactOrOrigError NotInScopeError + -- ^ The RdrName was an Exact + -- or Orig, but there was an + -- error looking up the Name + | NotExactOrOrig + -- ^ The RdrName is neither an Exact nor Orig -- Does the actual looking up an Exact or Orig name, see 'ExactOrOrigResult' lookupExactOrOrig_base :: RdrName -> RnM ExactOrOrigResult @@ -467,7 +481,16 @@ lookupExactOrOrig_base rdr_name | Just n <- isExact_maybe rdr_name -- This happens in derived code = cvtEither <$> lookupExactOcc_either n | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name - = FoundExactOrOrig <$> lookupOrig rdr_mod rdr_occ + = do { nm <- lookupOrig rdr_mod rdr_occ + + ; this_mod <- getModule + ; mb_gre <- + if nameIsLocalOrFrom this_mod nm + then lookupLocalExactGRE nm + else Right <$> lookupExternalExactGRE nm + ; return $ case mb_gre of + Left err -> ExactOrOrigError err + Right gre -> FoundExactOrOrig gre } | otherwise = return NotExactOrOrig where cvtEither (Left e) = ExactOrOrigError e @@ -495,10 +518,10 @@ counterparts. ----------------------------------------------- -- | Look up an occurrence of a field in record construction or pattern --- matching (but not update). When the -XDisambiguateRecordFields --- flag is on, take account of the data constructor name to --- disambiguate which field to use. +-- matching (but not update). -- +-- If -XDisambiguateRecordFields is off, then we will pass 'Nothing' for the +-- 'DataCon' 'Name', i.e. we don't use the data constructor for disambiguation. -- See Note [DisambiguateRecordFields] and Note [NoFieldSelectors]. lookupRecFieldOcc :: Maybe Name -- Nothing => just look it up as usual -- Just con => use data con to disambiguate @@ -507,66 +530,48 @@ lookupRecFieldOcc :: Maybe Name -- Nothing => just look it up as usual lookupRecFieldOcc mb_con rdr_name | Just con <- mb_con , isUnboundName con -- Avoid error cascade - = return (mkUnboundNameRdr rdr_name) + = return $ mk_unbound_rec_fld con | Just con <- mb_con - = lookupExactOrOrig rdr_name id $ -- See Note [Record field names and Template Haskell] - do { flds <- lookupConstructorFields con - ; env <- getGlobalRdrEnv - ; let lbl = FieldLabelString $ occNameFS (rdrNameOcc rdr_name) - mb_field = do fl <- find ((== lbl) . flLabel) flds - -- We have the label, now check it is in scope. If - -- there is a qualifier, use pickGREs to check that - -- the qualifier is correct, and return the filtered - -- GRE so we get import usage right (see #17853). - gre <- lookupGRE_FieldLabel env fl - if isQual rdr_name - then do gre' <- listToMaybe (pickGREs rdr_name [gre]) - return (fl, gre') - else return (fl, gre) - ; case mb_field of - Just (fl, gre) -> do { addUsedGRE True gre - ; return (flSelector fl) } - Nothing -> do { addErr (badFieldConErr con lbl) - ; return (mkUnboundNameRdr rdr_name) } } + = do { let lbl = FieldLabelString $ occNameFS (rdrNameOcc rdr_name) + ; res <- lookupExactOrOrig rdr_name ensure_recfld $ -- See Note [Record field names and Template Haskell] + do { flds <- lookupConstructorFields con + ; env <- getGlobalRdrEnv + ; let lbl = FieldLabelString $ occNameFS (rdrNameOcc rdr_name) + mb_gre = do fl <- find ((== lbl) . flLabel) flds + -- We have the label, now check it is in scope. If + -- there is a qualifier, use pickGREs to check that + -- the qualifier is correct, and return the filtered + -- GRE so we get import usage right (see #17853). + gre <- lookupGRE_FieldLabel env fl + if isQual rdr_name + then listToMaybe (pickGREs rdr_name [gre]) + else return gre + ; traceRn "lookupRecFieldOcc" $ + vcat [ text "mb_con:" <+> ppr mb_con + , text "rdr_name:" <+> ppr rdr_name + , text "flds:" <+> ppr flds + , text "mb_gre:" <+> ppr mb_gre ] + ; return mb_gre } + ; case res of + { Nothing -> do { addErr (badFieldConErr con lbl) + ; return $ mk_unbound_rec_fld con } + ; Just gre -> do { addUsedGRE True gre + ; return (flSelector $ fieldGRELabel gre) } } } | otherwise -- Can't use the data constructor to disambiguate - = lookupGlobalOccRn' WantBoth rdr_name + = greName <$> lookupGlobalOccRn' (IncludeFields WantField) rdr_name -- This use of Global is right as we are looking up a selector, -- which can only be defined at the top level. --- | Look up an occurrence of a field in a record update, returning the selector --- name. --- --- Unlike construction and pattern matching with @-XDisambiguateRecordFields@ --- (see 'lookupRecFieldOcc'), there is no data constructor to help disambiguate, --- so this may be ambiguous if the field is in scope multiple times. However we --- ignore non-fields in scope with the same name if @-XDisambiguateRecordFields@ --- is on (see Note [DisambiguateRecordFields for updates]). --- --- Here a field is in scope even if @NoFieldSelectors@ was enabled at its --- definition site (see Note [NoFieldSelectors]). -lookupRecFieldOcc_update - :: DuplicateRecordFields - -> RdrName - -> RnM AmbiguousResult -lookupRecFieldOcc_update dup_fields_ok rdr_name = do - disambig_ok <- xoptM LangExt.DisambiguateRecordFields - let want | disambig_ok = WantField - | otherwise = WantBoth - mr <- lookupGlobalOccRn_overloaded dup_fields_ok want rdr_name - case mr of - Just r -> return r - Nothing -- Try again if we previously looked only for fields, see - -- Note [DisambiguateRecordFields for updates] - | disambig_ok -> do mr' <- lookupGlobalOccRn_overloaded dup_fields_ok WantBoth rdr_name - case mr' of - Just r -> return r - Nothing -> unbound - | otherwise -> unbound where - unbound = UnambiguousGre . NormalGreName - <$> unboundName (LF WL_RecField WL_Global) rdr_name + -- When lookup fails, make an unbound name with the right record field + -- namespace, as that's what we expect to be returned + -- from 'lookupRecFieldOcc'. See T14307. + mk_unbound_rec_fld con = mkUnboundName $ + mkRecFieldOccFS (getOccFS con) (occNameFS occ) + occ = rdrNameOcc rdr_name + ensure_recfld gre = do { guard (isRecFldGRE gre) ; return gre } {- Note [DisambiguateRecordFields] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -622,31 +627,36 @@ data constructor name (as in Note [DisambiguateRecordFields]), provided the For example, consider: - module N where - f = () + module N where + f = () - {-# LANGUAGE DisambiguateRecordFields #-} - module M where - import N (f) - data T = MkT { f :: Int } - t = MkT { f = 1 } -- unambiguous because MkT determines which field we mean - u = t { f = 2 } -- unambiguous because we ignore the non-field 'f' + {-# LANGUAGE DisambiguateRecordFields #-} + module M where + import N (f) + data T = MkT { f :: Int } + t = MkT { f = 1 } -- unambiguous because MkT determines which field we mean + u = t { f = 2 } -- unambiguous because we ignore the non-field 'f' -This works by lookupRecFieldOcc_update using 'WantField :: FieldsOrSelectors' -when looking up the field name, so that 'filterFieldGREs' will later ignore any -non-fields in scope. Of course, if a record update has two fields in scope with -the same name, it is still ambiguous. +We filter out non-fields in lookupFieldGREs by using isRecFldGRE, which allows +us to accept the above program. +Of course, if a record update has two fields in scope with the same name, +it is still ambiguous. -If we do not find anything when looking only for fields, we try again allowing -fields or non-fields. This leads to a better error message if the user -mistakenly tries to use a non-field name in a record update: +We also look up the non-fields with the same textual name - f = () - e x = x { f = () } + 1. to throw an error if the user hasn't enabled DisambiguateRecordFields, + 2. in order to improve the error message when a user mistakenly tries to use + a non-field in a record update: + + f = () + e x = x { f = () } Unlike with constructors or pattern-matching, we do not allow the module -qualifier to be omitted, because we do not have a data constructor from which to -determine it. +qualifier to be omitted from the field names, because we do not have a +data constructor to use to determine the appropriate qualifier. + +This is all done in the function lookupFieldGREs, which is called by +GHC.Rename.Pat.rnHsRecUpdFields, which deals with record updates. Note [Record field names and Template Haskell] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -674,12 +684,15 @@ lookupSubBndrOcc_helper :: Bool -> Bool -> Name -> RdrName lookupSubBndrOcc_helper must_have_parent warn_if_deprec parent rdr_name | isUnboundName parent -- Avoid an error cascade - = return (FoundChild NoParent (NormalGreName (mkUnboundNameRdr rdr_name))) + = return (FoundChild (mkUnboundGRERdr rdr_name)) | otherwise = do gre_env <- getGlobalRdrEnv - let original_gres = lookupGlobalRdrEnv gre_env (rdrNameOcc rdr_name) + let original_gres = lookupGRE_OccName (IncludeFields WantBoth) gre_env (rdrNameOcc rdr_name) + -- WantBoth: we are looking for children, so we want to include fields defined + -- with no field selectors, as we can export those as children. See test NFSExport. + -- Disambiguate the lookup based on the parent information. -- The remaining GREs are things that we *could* export here, note that -- this includes things which have `NoParent`. Those are sorted in @@ -698,11 +711,10 @@ lookupSubBndrOcc_helper must_have_parent warn_if_deprec parent rdr_name AmbiguousOccurrence gres -> mkNameClashErr gres where - -- Convert into FieldLabel if necessary checkFld :: GlobalRdrElt -> RnM ChildLookupResult - checkFld g@GRE{gre_name,gre_par} = do + checkFld g = do addUsedGRE warn_if_deprec g - return $ FoundChild gre_par gre_name + return $ FoundChild g -- Called when we find no matching GREs after disambiguation but -- there are three situations where this happens. @@ -720,21 +732,19 @@ lookupSubBndrOcc_helper must_have_parent warn_if_deprec parent rdr_name dup_fields_ok <- xoptM LangExt.DuplicateRecordFields case original_gres of [] -> return NameNotFound - [g] -> return $ IncorrectParent parent - (gre_name g) + [g] -> return $ IncorrectParent parent g [p | Just p <- [getParent g]] gss@(g:gss'@(_:_)) -> if all isRecFldGRE gss && dup_fields_ok then return $ - IncorrectParent parent - (gre_name g) + IncorrectParent parent g [p | x <- gss, Just p <- [getParent x]] else mkNameClashErr $ g NE.:| gss' mkNameClashErr :: NE.NonEmpty GlobalRdrElt -> RnM ChildLookupResult mkNameClashErr gres = do addNameClashErrRn rdr_name gres - return (FoundChild (gre_par (NE.head gres)) (gre_name (NE.head gres))) + return (FoundChild (NE.head gres)) getParent :: GlobalRdrElt -> Maybe Name getParent (GRE { gre_par = p } ) = @@ -805,11 +815,14 @@ instance Monoid DisambigInfo where -- -- Records the result of looking up a child. data ChildLookupResult - = NameNotFound -- We couldn't find a suitable name - | IncorrectParent Name -- Parent - GreName -- Child we were looking for - [Name] -- List of possible parents - | FoundChild Parent GreName -- We resolved to a child + -- | We couldn't find a suitable name + = NameNotFound + -- | The child has an incorrect parent + | IncorrectParent Name -- ^ parent + GlobalRdrElt -- ^ child we were looking for + [Name] -- ^ list of possible parents + -- | We resolved to a child + | FoundChild GlobalRdrElt -- | Specialised version of msum for RnM ChildLookupResult combineChildLookupResult :: [RnM ChildLookupResult] -> RnM ChildLookupResult @@ -822,9 +835,10 @@ combineChildLookupResult (x:xs) = do instance Outputable ChildLookupResult where ppr NameNotFound = text "NameNotFound" - ppr (FoundChild p n) = text "Found:" <+> ppr p <+> ppr n - ppr (IncorrectParent p n ns) = text "IncorrectParent" - <+> hsep [ppr p, ppr n, ppr ns] + ppr (FoundChild n) = text "Found:" <+> ppr (gre_par n) <+> ppr n + ppr (IncorrectParent p g ns) + = text "IncorrectParent" + <+> hsep [ppr p, ppr $ greName g, ppr ns] lookupSubBndrOcc :: Bool -> Name -- Parent @@ -835,12 +849,12 @@ lookupSubBndrOcc :: Bool -- and pick the one with the right parent name lookupSubBndrOcc warn_if_deprec the_parent doc rdr_name = do res <- - lookupExactOrOrig rdr_name (FoundChild NoParent . NormalGreName) $ + lookupExactOrOrig rdr_name FoundChild $ -- This happens for built-in classes, see mod052 for example lookupSubBndrOcc_helper True warn_if_deprec the_parent rdr_name case res of NameNotFound -> return (Left (UnknownSubordinate doc)) - FoundChild _p child -> return (Right (greNameMangledName child)) + FoundChild child -> return (Right $ greName child) IncorrectParent {} -- See [Mismatched class methods and associated type families] -- in TcInstDecls. @@ -1016,9 +1030,9 @@ lookupLocalOccThLvl_maybe name -- determine what kind of suggestions should be displayed if it is not in scope lookupOccRn' :: WhatLooking -> RdrName -> RnM Name lookupOccRn' which_suggest rdr_name - = do { mb_name <- lookupOccRn_maybe rdr_name - ; case mb_name of - Just name -> return name + = do { mb_gre <- lookupOccRn_maybe rdr_name + ; case mb_gre of + Just gre -> return $ greName gre Nothing -> reportUnboundName' which_suggest rdr_name } -- lookupOccRn looks up an occurrence of a RdrName and displays suggestions if @@ -1055,12 +1069,12 @@ lookupLocalOccRn rdr_name lookupTypeOccRn :: RdrName -> RnM Name -- see Note [Demotion] lookupTypeOccRn rdr_name - | isVarOcc (rdrNameOcc rdr_name) -- See Note [Promoted variables in types] + | (isVarOcc <||> isFieldOcc) (rdrNameOcc rdr_name) -- See Note [Promoted variables in types] = badVarInType rdr_name | otherwise - = do { mb_name <- lookupOccRn_maybe rdr_name - ; case mb_name of - Just name -> return name + = do { mb_gre <- lookupOccRn_maybe rdr_name + ; case mb_gre of + Just gre -> return $ greName gre Nothing -> if occName rdr_name == occName eqTyCon_RDR -- See Note [eqTyCon (~) compatibility fallback] then eqTyConName <$ addDiagnostic TcRnTypeEqualityOutOfScope @@ -1092,7 +1106,7 @@ lookup_demoted rdr_name then do { mb_demoted_name <- lookupOccRn_maybe demoted_rdr ; case mb_demoted_name of Nothing -> unboundNameX looking_for rdr_name star_is_type_hints - Just demoted_name -> return demoted_name } + Just demoted_name -> return $ greName demoted_name } else do { -- We need to check if a data constructor of this name is -- in scope to give good error messages. However, we do -- not want to give an additional error if the data @@ -1120,7 +1134,7 @@ lookup_demoted rdr_name -- ^^^^^^^^^^^ report_qualified_term_in_types :: RdrName -> RdrName -> RnM Name report_qualified_term_in_types rdr_name demoted_rdr_name = - do { mName <- lookupGlobalOccRn_maybe demoted_rdr_name + do { mName <- lookupGlobalOccRn_maybe (IncludeFields WantNormal) demoted_rdr_name ; case mName of (Just _) -> termNameInType looking_for rdr_name demoted_rdr_name [] Nothing -> unboundTermNameInTypes looking_for rdr_name demoted_rdr_name } @@ -1131,7 +1145,7 @@ report_qualified_term_in_types rdr_name demoted_rdr_name = -- lookup_promoted returns the corresponding type-level Name. -- Otherwise, the function returns Nothing. -- See Note [Promotion] below. -lookup_promoted :: RdrName -> RnM (Maybe Name) +lookup_promoted :: RdrName -> RnM (Maybe GlobalRdrElt) lookup_promoted rdr_name | Just promoted_rdr <- promoteRdrName rdr_name = lookupOccRn_maybe promoted_rdr @@ -1216,16 +1230,26 @@ when the user writes the following declaration x = id Int -} -lookupOccRnX_maybe :: (RdrName -> RnM (Maybe r)) -> (Name -> r) -> RdrName +lookupOccRnX_maybe :: (RdrName -> RnM (Maybe r)) -> (GlobalRdrElt -> RnM r) -> RdrName -> RnM (Maybe r) lookupOccRnX_maybe globalLookup wrapper rdr_name = runMaybeT . msum . map MaybeT $ - [ fmap wrapper <$> lookupLocalOccRn_maybe rdr_name + [ do { res <- lookupLocalOccRn_maybe rdr_name + ; case res of + { Nothing -> return Nothing + ; Just nm -> + do { let gre = localVanillaGRE NoParent nm + ; Just <$> wrapper gre } } } , globalLookup rdr_name ] +lookupOccRn_maybe :: RdrName -> RnM (Maybe GlobalRdrElt) +lookupOccRn_maybe = + lookupOccRnX_maybe (lookupGlobalOccRn_maybe $ IncludeFields WantNormal) return + -- Used outside this module only by TH name reification (lookupName, lookupThName_maybe) -lookupOccRn_maybe :: RdrName -> RnM (Maybe Name) -lookupOccRn_maybe = lookupOccRnX_maybe lookupGlobalOccRn_maybe id +lookupSameOccRn_maybe :: RdrName -> RnM (Maybe GlobalRdrElt) +lookupSameOccRn_maybe = + lookupOccRnX_maybe (lookupGlobalOccRn_maybe SameOccName) return -- | Look up a 'RdrName' used as a variable in an expression. -- @@ -1237,28 +1261,21 @@ lookupOccRn_maybe = lookupOccRnX_maybe lookupGlobalOccRn_maybe id -- in scope at the type level, the lookup will succeed (so that the type-checker -- can report a more informative error later). See Note [Promotion]. -- -lookupExprOccRn :: RdrName -> RnM (Maybe GreName) +lookupExprOccRn :: RdrName -> RnM (Maybe GlobalRdrElt) lookupExprOccRn rdr_name - = do { mb_name <- lookupOccRnX_maybe global_lookup NormalGreName rdr_name + = do { mb_name <- lookupOccRnX_maybe + lookupGlobalOccRn_overloaded + return + rdr_name ; case mb_name of - Nothing -> fmap @Maybe NormalGreName <$> lookup_promoted rdr_name + Nothing -> lookup_promoted rdr_name -- See Note [Promotion]. -- We try looking up the name as a -- type constructor or type variable, if -- we failed to look up the name at the term level. p -> return p } - where - global_lookup :: RdrName -> RnM (Maybe GreName) - global_lookup rdr_name = - do { mb_name <- lookupGlobalOccRn_overloaded NoDuplicateRecordFields WantNormal rdr_name - ; case mb_name of - Just (UnambiguousGre name) -> return (Just name) - Just _ -> panic "GHC.Rename.Env.global_lookup: The impossible happened!" - Nothing -> return Nothing - } - -lookupGlobalOccRn_maybe :: RdrName -> RnM (Maybe Name) +lookupGlobalOccRn_maybe :: WhichGREs GREInfo -> RdrName -> RnM (Maybe GlobalRdrElt) -- Looks up a RdrName occurrence in the top-level -- environment, including using lookupQualifiedNameGHCi -- for the GHCi case, but first tries to find an Exact or Orig name. @@ -1267,42 +1284,61 @@ lookupGlobalOccRn_maybe :: RdrName -> RnM (Maybe Name) -- Uses addUsedRdrName to record use and deprecations -- -- Used directly only by getLocalNonValBinders (new_assoc). -lookupGlobalOccRn_maybe rdr_name = - lookupExactOrOrig_maybe rdr_name id (lookupGlobalOccRn_base WantNormal rdr_name) +lookupGlobalOccRn_maybe which_gres rdr_name = + lookupExactOrOrig_maybe rdr_name id $ + lookupGlobalOccRn_base which_gres rdr_name -lookupGlobalOccRn :: RdrName -> RnM Name +lookupGlobalOccRn :: RdrName -> RnM GlobalRdrElt -- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global -- environment. Adds an error message if the RdrName is not in scope. -- You usually want to use "lookupOccRn" which also looks in the local -- environment. -- -- Used by exports_from_avail -lookupGlobalOccRn = lookupGlobalOccRn' WantNormal +lookupGlobalOccRn = lookupGlobalOccRn' (IncludeFields WantNormal) -lookupGlobalOccRn' :: FieldsOrSelectors -> RdrName -> RnM Name -lookupGlobalOccRn' fos rdr_name = +lookupGlobalOccRn' :: WhichGREs GREInfo -> RdrName -> RnM GlobalRdrElt +lookupGlobalOccRn' which_gres rdr_name = lookupExactOrOrig rdr_name id $ do - mn <- lookupGlobalOccRn_base fos rdr_name + mn <- lookupGlobalOccRn_base which_gres rdr_name case mn of Just n -> return n Nothing -> do { traceRn "lookupGlobalOccRn" (ppr rdr_name) - ; unboundName (LF which_suggest WL_Global) rdr_name } - where which_suggest = case fos of - WantNormal -> WL_Anything - WantBoth -> WL_RecField - WantField -> WL_RecField + ; nm <- unboundName (LF which_suggest WL_Global) rdr_name + ; return $ localVanillaGRE NoParent nm } + where which_suggest = case which_gres of + IncludeFields WantBoth -> WL_RecField + IncludeFields WantField -> WL_RecField + _ -> WL_Anything -- Looks up a RdrName occurrence in the GlobalRdrEnv and with -- lookupQualifiedNameGHCi. Does not try to find an Exact or Orig name first. -- lookupQualifiedNameGHCi here is used when we're in GHCi and a name like -- 'Data.Map.elems' is typed, even if you didn't import Data.Map -lookupGlobalOccRn_base :: FieldsOrSelectors -> RdrName -> RnM (Maybe Name) -lookupGlobalOccRn_base fos rdr_name = - runMaybeT . msum . map MaybeT $ - [ fmap greMangledName <$> lookupGreRn_maybe fos rdr_name - , fmap greNameMangledName <$> lookupOneQualifiedNameGHCi fos rdr_name ] +lookupGlobalOccRn_base :: WhichGREs GREInfo -> RdrName -> RnM (Maybe GlobalRdrElt) +lookupGlobalOccRn_base which_gres rdr_name = + runMaybeT . msum . map MaybeT $ + [ lookupGreRn_maybe which_gres rdr_name + , lookupOneQualifiedNameGHCi fos rdr_name ] -- This test is not expensive, -- and only happens for failed lookups + where + fos = case which_gres of + IncludeFields f_or_s -> f_or_s + _ -> WantNormal + +-- | Lookup a 'Name' in the 'GlobalRdrEnv', falling back to looking up +-- in the type environment it if fails. +lookupGREInfo_GRE :: Name -> RnM GREInfo +lookupGREInfo_GRE name + = do { rdr_env <- getGlobalRdrEnv + ; case lookupGRE_Name rdr_env name of + Just ( GRE { gre_info = info } ) + -> return info + _ -> do { hsc_env <- getTopEnv + ; return $ lookupGREInfo hsc_env name } } + -- Just looking in the GlobalRdrEnv is insufficient, as we also + -- need to handle qualified imports in GHCi; see e.g. T9815ghci. lookupInfoOccRn :: RdrName -> RnM [Name] -- lookupInfoOccRn is intended for use in GHCi's ":info" command @@ -1313,142 +1349,265 @@ lookupInfoOccRn :: RdrName -> RnM [Name] -- at least one definition of the RdrName, not complaining about -- multiple definitions. (See #17832) lookupInfoOccRn rdr_name = - lookupExactOrOrig rdr_name (:[]) $ + lookupExactOrOrig rdr_name (\ gre -> [greName gre]) $ do { rdr_env <- getGlobalRdrEnv - ; let ns = map greMangledName (lookupGRE_RdrName' rdr_name rdr_env) - ; qual_ns <- map greNameMangledName <$> lookupQualifiedNameGHCi WantBoth rdr_name - ; return (ns ++ (qual_ns `minusList` ns)) } + ; let ns = map greName $ lookupGRE_RdrName (IncludeFields WantBoth) rdr_env rdr_name + ; qual_ns <- map greName <$> lookupQualifiedNameGHCi WantBoth rdr_name + ; return $ ns ++ (qual_ns `minusList` ns) } --- | Like 'lookupOccRn_maybe', but with a more informative result if --- the 'RdrName' happens to be a record selector: +-- | Look up all record field names, available in the 'GlobalRdrEnv', +-- that a given 'RdrName' might refer to. +-- (Also includes implicit qualified imports in GHCi). -- --- * Nothing -> name not in scope (no error reported) --- * Just (UnambiguousGre x) -> name uniquely refers to x, --- or there is a name clash (reported) --- * Just AmbiguousFields -> name refers to two or more record fields --- (no error reported) +-- Throws an error if no fields are found. -- --- See Note [ Unbound vs Ambiguous Names ]. -lookupGlobalOccRn_overloaded :: DuplicateRecordFields -> FieldsOrSelectors -> RdrName - -> RnM (Maybe AmbiguousResult) -lookupGlobalOccRn_overloaded dup_fields_ok fos rdr_name = - lookupExactOrOrig_maybe rdr_name (fmap (UnambiguousGre . NormalGreName)) $ - do { res <- lookupGreRn_helper fos rdr_name +-- See Note [DisambiguateRecordFields for updates]. +lookupFieldGREs :: GlobalRdrEnv -> LocatedN RdrName -> RnM (NE.NonEmpty FieldGlobalRdrElt) +lookupFieldGREs env (L loc rdr) + = setSrcSpanA loc + $ do { res <- lookupExactOrOrig rdr (\ gre -> maybeToList $ fieldGRE_maybe gre) $ + do { let (env_fld_gres, env_var_gres) = + partition isRecFldGRE $ + lookupGRE_RdrName (IncludeFields WantBoth) env rdr + + -- Handle implicit qualified imports in GHCi. See T10439. + ; ghci_gres <- lookupQualifiedNameGHCi WantBoth rdr + ; let (ghci_fld_gres, ghci_var_gres) = + partition isRecFldGRE $ + ghci_gres + + ; let fld_gres = ghci_fld_gres ++ env_fld_gres + var_gres = ghci_var_gres ++ env_var_gres + + -- Add an error for ambiguity when -XDisambiguateRecordFields is off. + -- + -- See Note [DisambiguateRecordFields for updates]. + ; disamb_ok <- xoptM LangExt.DisambiguateRecordFields + ; if | not disamb_ok + , gre1 : gre2 : others <- fld_gres ++ var_gres + -> addErrTc $ TcRnAmbiguousFieldInUpdate (gre1, gre2, others) + | otherwise + -> return () + ; return fld_gres } + + -- Add an error if lookup failed. ; case res of - GreNotFound -> fmap UnambiguousGre <$> lookupOneQualifiedNameGHCi fos rdr_name - OneNameMatch gre -> return $ Just (UnambiguousGre (gre_name gre)) - MultipleNames gres - | all isRecFldGRE gres - , dup_fields_ok == DuplicateRecordFields -> return $ Just AmbiguousFields - | otherwise -> do - addNameClashErrRn rdr_name gres - return (Just (UnambiguousGre (gre_name (NE.head gres)))) } - - --- | Result of looking up an occurrence that might be an ambiguous field. -data AmbiguousResult - = UnambiguousGre GreName - -- ^ Occurrence picked out a single name, which may or may not belong to a - -- field (or might be unbound, if an error has been reported already, per - -- Note [ Unbound vs Ambiguous Names ]). - | AmbiguousFields - -- ^ Occurrence picked out two or more fields, and no non-fields. For now - -- this is allowed by DuplicateRecordFields in certain circumstances, as the - -- type-checker may be able to disambiguate later. - + gre : gres -> return $ gre NE.:| gres + [] -> do { (imp_errs, hints) <- + unknownNameSuggestions emptyLocalRdrEnv WL_RecField rdr + ; failWithTc $ + TcRnNotInScope NotARecordField rdr imp_errs hints } } -{- -Note [NoFieldSelectors] -~~~~~~~~~~~~~~~~~~~~~~~ -The NoFieldSelectors extension allows record fields to be defined without -bringing the corresponding selector functions into scope. However, such fields -may still be used in contexts such as record construction, pattern matching or -update. This requires us to distinguish contexts in which selectors are required -from those in which any field may be used. For example: - - {-# LANGUAGE NoFieldSelectors #-} - module M (T(foo), foo) where -- T(foo) refers to the field, - -- unadorned foo to the value binding - data T = MkT { foo :: Int } - foo = () +-- | Look up a 'RdrName', which might refer to an overloaded record field. +-- +-- Don't allow any ambiguity: emit a name-clash error if there are multiple +-- matching GREs. +lookupGlobalOccRn_overloaded :: RdrName -> RnM (Maybe GlobalRdrElt) +lookupGlobalOccRn_overloaded rdr_name = + lookupExactOrOrig_maybe rdr_name id $ + do { res <- lookupGreRn_helper (IncludeFields WantNormal) rdr_name + ; case res of + GreNotFound -> lookupOneQualifiedNameGHCi WantNormal rdr_name + OneNameMatch gre -> return $ Just gre + MultipleNames gres@(gre NE.:| _) -> do + addNameClashErrRn rdr_name gres + return (Just gre) } - bar = foo -- refers to the value binding, field ignored +getFieldUpdLbl :: LHsRecUpdField (GhcPass p) q -> LocatedN RdrName +getFieldUpdLbl = ambiguousFieldOccLRdrName . unLoc . hfbLHS . unLoc - module N where - import M (T(..)) - baz = MkT { foo = 3 } -- refers to the field - oops = foo -- an error: the field is in scope but the value binding is not - -Each 'FieldLabel' indicates (in the 'flHasFieldSelector' field) whether the -FieldSelectors extension was enabled in the defining module. This allows them -to be filtered out by 'filterFieldGREs'. - -Even when NoFieldSelectors is in use, we still generate selector functions -internally. For example, the expression - getField @"foo" t -or (with dot-notation) - t.foo -extracts the `foo` field of t::T, and hence needs the selector function -(see Note [HasField instances] in GHC.Tc.Instance.Class). In order to avoid -name clashes with normal bindings reusing the names, selector names for such -fields are mangled just as for DuplicateRecordFields (see Note [FieldLabel] in -GHC.Types.FieldLabel). - - -In many of the name lookup functions in this module we pass a FieldsOrSelectors -value, indicating what we are looking for: - - * WantNormal: fields are in scope only if they have an accompanying selector - function, e.g. we are looking up a variable in an expression - (lookupExprOccRn). - - * WantBoth: any name or field will do, regardless of whether the selector - function is available, e.g. record updates (lookupRecFieldOcc_update) with - NoDisambiguateRecordFields. - - * WantField: any field will do, regardless of whether the selector function is - available, but ignoring any non-field names, e.g. record updates - (lookupRecFieldOcc_update) with DisambiguateRecordFields. - ------------------------------------------------------------------------------------ - Context FieldsOrSelectors ------------------------------------------------------------------------------------ - Record construction/pattern match WantBoth if NoDisambiguateRecordFields - e.g. MkT { foo = 3 } (DisambiguateRecordFields is separate) - - Record update WantBoth if NoDisambiguateRecordFields - e.g. e { foo = 3 } WantField if DisambiguateRecordFields - - :info in GHCi WantBoth - - Variable occurrence in expression WantNormal - Type variable, data constructor - Pretty much everything else ------------------------------------------------------------------------------------ --} +-- | Returns all possible collections of field labels for the given +-- record update. +-- +-- Example: +-- +-- data D = MkD { fld1 :: Int, fld2 :: Bool } +-- data E = MkE1 { fld1 :: Int, fld2 :: Bool, fld3 :: Char } +-- | MkE2 { fld1 :: Int, fld2 :: Bool } +-- data F = MkF1 { fld1 :: Int } | MkF2 { fld2 :: Bool } +-- +-- f r = r { fld1 = a, fld2 = b } +-- +-- This function will return: +-- +-- [ [ D.fld1, D.fld2 ] -- could be a record update at type D +-- , [ E.fld1, E.fld2 ] -- could be a record update at type E +-- ] -- cannot be a record update at type F: no constructor has both +-- -- of the fields fld1 and fld2 +-- +-- If there are no valid parents for the record update, +-- throws a 'TcRnBadRecordUpdate' error. +lookupRecUpdFields :: NE.NonEmpty (LHsRecUpdField GhcPs GhcPs) + -> RnM (NE.NonEmpty (HsRecUpdParent GhcRn)) +lookupRecUpdFields flds +-- See Note [Disambiguating record updates] in GHC.Rename.Pat. + = do { -- Retrieve the possible GlobalRdrElts that each field could refer to. + ; gre_env <- getGlobalRdrEnv + ; fld1_gres NE.:| other_flds_gres <- mapM (lookupFieldGREs gre_env . getFieldUpdLbl) flds + -- Take an intersection: we are only interested in constructors + -- which have all of the fields. + ; let possible_GREs = intersect_by_cons fld1_gres other_flds_gres + + ; traceRn "lookupRecUpdFields" $ + vcat [ text "flds:" <+> ppr (fmap getFieldUpdLbl flds) + , text "possible_GREs:" <+> + ppr (map (fmap greName . rnRecUpdLabels) possible_GREs) ] + + ; case possible_GREs of + + -- There is at least one parent: we can proceed. + -- The typechecker might be able to finish disambiguating. + -- See Note [Type-directed record disambiguation] in GHC.Rename.Pat. + { p1:ps -> return (p1 NE.:| ps) + + -- There are no possible parents for the record update: compute + -- a minimum set of fields which does not belong to any data constructor, + -- to report an informative error to the user. + ; _ -> + let + -- The constructors which have the first field. + fld1_cons :: UniqSet ConLikeName + fld1_cons = unionManyUniqSets + $ NE.toList + $ NE.map (recFieldCons . fieldGREInfo) fld1_gres + -- The field labels of the constructors which have the first field. + fld1_cons_fields :: UniqFM ConLikeName [FieldLabel] + fld1_cons_fields + = fmap (lkp_con_fields gre_env) + $ getUniqSet fld1_cons + in failWithTc $ badFieldsUpd (NE.toList flds) fld1_cons_fields } } --- | When looking up GREs, we may or may not want to include fields that were --- defined in modules with @NoFieldSelectors@ enabled. See Note --- [NoFieldSelectors]. -data FieldsOrSelectors - = WantNormal -- ^ Include normal names, and fields with selectors, but - -- ignore fields without selectors. - | WantBoth -- ^ Include normal names and all fields (regardless of whether - -- they have selectors). - | WantField -- ^ Include only fields, with or without selectors, ignoring - -- any non-fields in scope. - deriving Eq - -filterFieldGREs :: FieldsOrSelectors -> [GlobalRdrElt] -> [GlobalRdrElt] -filterFieldGREs fos = filter (allowGreName fos . gre_name) - -allowGreName :: FieldsOrSelectors -> GreName -> Bool -allowGreName WantBoth _ = True -allowGreName WantNormal (FieldGreName fl) = flHasFieldSelector fl == FieldSelectors -allowGreName WantNormal (NormalGreName _) = True -allowGreName WantField (FieldGreName _) = True -allowGreName WantField (NormalGreName _) = False + where + intersect_by_cons :: NE.NonEmpty FieldGlobalRdrElt + -> [NE.NonEmpty FieldGlobalRdrElt] + -> [HsRecUpdParent GhcRn] + intersect_by_cons this [] = + map + (\ fld -> RnRecUpdParent (fld NE.:| []) (recFieldCons (fieldGREInfo fld))) + (NE.toList this) + intersect_by_cons this (new : rest) = + [ RnRecUpdParent (this_fld NE.<| next_flds) both_cons + | this_fld <- NE.toList this + , let this_cons = recFieldCons $ fieldGREInfo this_fld + , RnRecUpdParent next_flds next_cons <- intersect_by_cons new rest + , let both_cons = next_cons `intersectUniqSets` this_cons + , not $ isEmptyUniqSet both_cons + ] + + lkp_con_fields :: GlobalRdrEnv -> ConLikeName -> [FieldLabel] + lkp_con_fields gre_env con = + [ fl + | let nm = conLikeName_Name con + , gre <- maybeToList $ lookupGRE_Name gre_env nm + , con_info <- maybeToList $ recFieldConLike_maybe gre + , fl <- conInfoFields con_info ] + +{-********************************************************************** +* * + Record field errors +* * +**********************************************************************-} + +getUpdFieldLbls :: forall p q. UnXRec (GhcPass p) + => [LHsRecUpdField (GhcPass p) q] -> [RdrName] +getUpdFieldLbls + = map $ ambiguousFieldOccRdrName + . unXRec @(GhcPass p) + . hfbLHS + . unXRec @(GhcPass p) + +-- | Create an error message when there is no single 'ConLike' which +-- has all of the required fields for a record update. +-- +-- This boils down the problem to a smaller set of fields, to avoid +-- the error message containing a lot of uninformative field names that +-- aren't really relevant to the problem. +-- +-- NB: this error message should only be triggered when all the field names +-- are in scope (i.e. each individual field name does belong to some +-- constructor in scope). +badFieldsUpd + :: (OutputableBndrId p) + => [LHsRecUpdField (GhcPass p) q] + -- ^ Field names that don't belong to a single datacon + -> UniqFM ConLikeName [FieldLabel] + -- ^ The list of field labels for each constructor. + -- (These are the constructors in which the first field occurs.) + -> TcRnMessage +badFieldsUpd rbinds fld1_cons_fields + = TcRnBadRecordUpdate + (getUpdFieldLbls rbinds) + (NoConstructorHasAllFields conflictingFields) + -- See Note [Finding the conflicting fields] + where + -- A (preferably small) set of fields such that no constructor contains + -- all of them. See Note [Finding the conflicting fields] + conflictingFields = case nonMembers of + -- nonMember belongs to a different type. + (nonMember, _) : _ -> [aMember, nonMember] + [] -> let + -- All of rbinds belong to one type. In this case, repeatedly add + -- a field to the set until no constructor contains the set. + + -- Each field, together with a list indicating which constructors + -- have all the fields so far. + growingSets :: [(FieldLabelString, [Bool])] + growingSets = scanl1 combine membership + combine (_, setMem) (field, fldMem) + = (field, zipWith (&&) setMem fldMem) + in + -- Fields that don't change the membership status of the set + -- are redundant and can be dropped. + map (fst . head) $ groupBy ((==) `on` snd) growingSets + + aMember = assert (not (null members) ) fst (head members) + (members, nonMembers) = partition (or . snd) membership + + -- For each field, which constructors contain the field? + membership :: [(FieldLabelString, [Bool])] + membership + = sortMembership $ + map + ( (\fld -> (fld, map (fld `elementOfUniqSet`) fieldLabelSets)) + . FieldLabelString . occNameFS . rdrNameOcc . unLoc . getFieldUpdLbl ) + rbinds + + fieldLabelSets :: [UniqSet FieldLabelString] + fieldLabelSets = map (mkUniqSet . map flLabel) $ nonDetEltsUFM fld1_cons_fields + + -- Sort in order of increasing number of True, so that a smaller + -- conflicting set can be found. + sortMembership = + map snd . + sortBy (compare `on` fst) . + map (\ item@(_, membershipRow) -> (countTrue membershipRow, item)) + + countTrue = count id +{- +Note [Finding the conflicting fields] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + data A = A {a0, a1 :: Int} + | B {b0, b1 :: Int} +and we see a record update + x { a0 = 3, a1 = 2, b0 = 4, b1 = 5 } +Then we'd like to find the smallest subset of fields that no +constructor has all of. Here, say, {a0,b0}, or {a0,b1}, etc. +We don't really want to report that no constructor has all of +{a0,a1,b0,b1}, because when there are hundreds of fields it's +hard to see what was really wrong. + +We may need more than two fields, though; eg + data T = A { x,y :: Int, v::Int } + | B { y,z :: Int, v::Int } + | C { z,x :: Int, v::Int } +with update + r { x=e1, y=e2, z=e3 }, we + +Finding the smallest subset is hard, so the code here makes +a decent stab, no more. See #7989. +-} -------------------------------------------------- -- Lookup in the Global RdrEnv of the module @@ -1458,15 +1617,15 @@ data GreLookupResult = GreNotFound | OneNameMatch GlobalRdrElt | MultipleNames (NE.NonEmpty GlobalRdrElt) -lookupGreRn_maybe :: FieldsOrSelectors -> RdrName -> RnM (Maybe GlobalRdrElt) +lookupGreRn_maybe :: WhichGREs GREInfo -> RdrName -> RnM (Maybe GlobalRdrElt) -- Look up the RdrName in the GlobalRdrEnv -- Exactly one binding: records it as "used", return (Just gre) -- No bindings: return Nothing -- Many bindings: report "ambiguous", return an arbitrary (Just gre) -- Uses addUsedRdrName to record use and deprecations -lookupGreRn_maybe fos rdr_name +lookupGreRn_maybe which_gres rdr_name = do - res <- lookupGreRn_helper fos rdr_name + res <- lookupGreRn_helper which_gres rdr_name case res of OneNameMatch gre -> return $ Just gre MultipleNames gres -> do @@ -1501,43 +1660,38 @@ is enabled then we defer the selection until the typechecker. -} - - -- Internal Function -lookupGreRn_helper :: FieldsOrSelectors -> RdrName -> RnM GreLookupResult -lookupGreRn_helper fos rdr_name +lookupGreRn_helper :: WhichGREs GREInfo -> RdrName -> RnM GreLookupResult +lookupGreRn_helper which_gres rdr_name = do { env <- getGlobalRdrEnv - ; case filterFieldGREs fos (lookupGRE_RdrName' rdr_name env) of + ; case lookupGRE_RdrName which_gres env rdr_name of [] -> return GreNotFound [gre] -> do { addUsedGRE True gre ; return (OneNameMatch gre) } -- Don't record usage for ambiguous names -- until we know which is meant - (gre:gres) -> return (MultipleNames (gre NE.:| gres)) } + (gre:others) -> return (MultipleNames (gre NE.:| others)) } -lookupGreAvailRn :: RdrName -> RnM (Name, AvailInfo) +lookupGreAvailRn :: RdrName -> RnM (Maybe GlobalRdrElt) -- Used in export lists -- If not found or ambiguous, add error message, and fake with UnboundName -- Uses addUsedRdrName to record use and deprecations lookupGreAvailRn rdr_name = do - mb_gre <- lookupGreRn_helper WantNormal rdr_name + mb_gre <- lookupGreRn_helper (IncludeFields WantNormal) rdr_name case mb_gre of GreNotFound -> do traceRn "lookupGreAvailRn" (ppr rdr_name) - name <- unboundName (LF WL_Anything WL_Global) rdr_name - return (name, avail name) + _ <- unboundName (LF WL_Anything WL_Global) rdr_name + return Nothing MultipleNames gres -> do addNameClashErrRn rdr_name gres - let unbound_name = mkUnboundNameRdr rdr_name - return (unbound_name, avail unbound_name) - -- Returning an unbound name here prevents an error - -- cascade + return Nothing + -- Prevent error cascade OneNameMatch gre -> - return (greMangledName gre, availFromGRE gre) - + return $ Just gre {- ********************************************************* @@ -1570,7 +1724,7 @@ addUsedDataCons rdr_env tycon | dc <- tyConDataCons tycon , Just gre <- [lookupGRE_Name rdr_env (dataConName dc)] ] -addUsedGRE :: Bool -> GlobalRdrElt -> RnM () +addUsedGRE :: Bool -> GlobalRdrElt-> RnM () -- Called for both local and imported things -- Add usage *and* warn if deprecated addUsedGRE warn_if_deprec gre @@ -1614,7 +1768,7 @@ warnIfDeprecated gre@(GRE { gre_imp = iss }) = return () where occ = greOccName gre - name = greMangledName gre + name = greName gre definedMod = moduleName $ assertPpr (isExternalName name) (ppr name) (nameModule name) doc = text "The name" <+> quotes (ppr occ) <+> text "is mentioned explicitly" @@ -1687,33 +1841,23 @@ ambiguity error. -} - -- | Like 'lookupQualifiedNameGHCi' but returning at most one name, reporting an -- ambiguity error if there are more than one. -lookupOneQualifiedNameGHCi :: FieldsOrSelectors -> RdrName -> RnM (Maybe GreName) +lookupOneQualifiedNameGHCi :: FieldsOrSelectors -> RdrName -> RnM (Maybe GlobalRdrElt) lookupOneQualifiedNameGHCi fos rdr_name = do - gnames <- lookupQualifiedNameGHCi fos rdr_name - case gnames of - [] -> return Nothing - [gname] -> return (Just gname) - (gname:gnames') -> do addNameClashErrRn rdr_name (toGRE gname NE.:| map toGRE gnames') - return (Just (NormalGreName (mkUnboundNameRdr rdr_name))) - where - -- Fake a GRE so we can report a sensible name clash error if - -- -fimplicit-import-qualified is used with a module that exports the same - -- field name multiple times (see - -- Note [DuplicateRecordFields and -fimplicit-import-qualified]). - toGRE gname = GRE { gre_name = gname, gre_par = NoParent, gre_lcl = False, gre_imp = unitBag is } - is = ImpSpec { is_decl = ImpDeclSpec { is_mod = mod, is_as = mod, is_qual = True, is_dloc = noSrcSpan } - , is_item = ImpAll } - -- If -fimplicit-import-qualified succeeded, the name must be qualified. - (mod, _) = fromMaybe (pprPanic "lookupOneQualifiedNameGHCi" (ppr rdr_name)) (isQual_maybe rdr_name) - + all_gres <- lookupQualifiedNameGHCi fos rdr_name + case all_gres of + [] -> return Nothing + [gre] -> return $ Just $ gre + (gre:gres) -> + do addNameClashErrRn rdr_name (gre NE.:| gres) + return (Just (mkUnboundGRE $ greOccName gre)) + -- (Use mkUnboundGRE to get the correct namespace) -- | Look up *all* the names to which the 'RdrName' may refer in GHCi (using -- @-fimplicit-import-qualified@). This will normally be zero or one, but may -- be more in the presence of @DuplicateRecordFields@. -lookupQualifiedNameGHCi :: FieldsOrSelectors -> RdrName -> RnM [GreName] +lookupQualifiedNameGHCi :: HasDebugCallStack => FieldsOrSelectors -> RdrName -> RnM [GlobalRdrElt] lookupQualifiedNameGHCi fos rdr_name = -- We want to behave as we would for a source file import here, -- and respect hiddenness of modules/packages, hence loadSrcInterface. @@ -1724,20 +1868,28 @@ lookupQualifiedNameGHCi fos rdr_name where go_for_it dflags is_ghci | Just (mod,occ) <- isQual_maybe rdr_name + , let ns = occNameSpace occ , is_ghci , gopt Opt_ImplicitImportQualified dflags -- Enables this GHCi behaviour , not (safeDirectImpsReq dflags) -- See Note [Safe Haskell and GHCi] = do { res <- loadSrcInterface_maybe doc mod NotBoot NoPkgQual ; case res of Succeeded iface - -> return [ gname - | avail <- mi_exports iface - , gname <- availGreNames avail - , occName gname == occ - -- Include a field if it has a selector or we are looking for all fields; - -- see Note [NoFieldSelectors]. - , allowGreName fos gname - ] + -> do { hsc_env <- getTopEnv + ; let gres = + [ gre + | avail <- mi_exports iface + , gname <- availNames avail + , let lk_occ = occName gname + lk_ns = occNameSpace lk_occ + , occNameFS occ == occNameFS lk_occ + , ns == lk_ns || (ns == varName && isFieldNameSpace lk_ns) + , let gre = lookupGRE_PTE mod hsc_env gname + , allowGRE fos gre + -- Include a field if it has a selector or we are looking for all fields; + -- see Note [NoFieldSelectors]. + ] + ; return gres } _ -> -- Either we couldn't load the interface, or -- we could but we didn't find the name in it @@ -1750,6 +1902,47 @@ lookupQualifiedNameGHCi fos rdr_name doc = text "Need to find" <+> ppr rdr_name + -- Lookup a Name for an implicit qualified import in GHCi + -- in the given PackageTypeEnv. + lookupGRE_PTE :: ModuleName -> HscEnv -> Name -> GlobalRdrElt + lookupGRE_PTE mod hsc_env nm = + -- Fake a GRE so we can report a sensible name clash error if + -- -fimplicit-import-qualified is used with a module that exports the same + -- field name multiple times (see + -- Note [DuplicateRecordFields and -fimplicit-import-qualified]). + GRE { gre_name = nm + , gre_par = NoParent + , gre_lcl = False + , gre_imp = unitBag is + , gre_info = info } + where + info = lookupGREInfo hsc_env nm + spec = ImpDeclSpec { is_mod = mod, is_as = mod, is_qual = True, is_dloc = noSrcSpan } + is = ImpSpec { is_decl = spec, is_item = ImpAll } + +-- | Look up the 'GREInfo' associated with the given 'Name' +-- by looking up in the type environment. +lookupGREInfo :: HasDebugCallStack => HscEnv -> Name -> GREInfo +lookupGREInfo hsc_env nm + | Just ty_thing <- wiredInNameTyThing_maybe nm + = tyThingGREInfo ty_thing + | otherwise + -- Create a thunk which, when forced, loads the interface + -- and looks up the TyThing in the type environment. + -- + -- See Note [Retrieving the GREInfo from interfaces] in GHC.Types.GREInfo. + = let lookup_res = unsafePerformIO $ do + let mod = nameModule nm + _ <- initIfaceLoad hsc_env $ + loadInterface (text "lookupGREInfo" <+> parens (ppr nm)) + mod ImportBySystem + lookupType hsc_env nm + in + case lookup_res of + Nothing -> pprPanic "lookupGREInfo" $ + vcat [ text "lookup failed:" <+> ppr nm ] + Just ty_thing -> tyThingGREInfo ty_thing + {- Note [Looking up signature names] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1822,27 +2015,14 @@ lookupSigOccRn ctxt sig = lookupSigCtxtOccRn ctxt (hsSigDoc sig) lookupSigOccRnN :: HsSigCtxt -> Sig GhcPs -> LocatedN RdrName -> RnM (LocatedN Name) -lookupSigOccRnN ctxt sig = lookupSigCtxtOccRnN ctxt (hsSigDoc sig) - - --- | Lookup a name in relation to the names in a 'HsSigCtxt' -lookupSigCtxtOccRnN :: HsSigCtxt - -> SDoc -- ^ description of thing we're looking up, - -- like "type family" - -> LocatedN RdrName -> RnM (LocatedN Name) -lookupSigCtxtOccRnN ctxt what - = wrapLocMA $ \ rdr_name -> - do { mb_name <- lookupBindGroupOcc ctxt what rdr_name - ; case mb_name of - Left err -> do { addErr (mkTcRnNotInScope rdr_name err) - ; return (mkUnboundNameRdr rdr_name) } - Right name -> return name } +lookupSigOccRnN ctxt sig = lookupSigCtxtOccRn ctxt (hsSigDoc sig) -- | Lookup a name in relation to the names in a 'HsSigCtxt' lookupSigCtxtOccRn :: HsSigCtxt -> SDoc -- ^ description of thing we're looking up, -- like "type family" - -> LocatedA RdrName -> RnM (LocatedA Name) + -> GenLocated (SrcSpanAnn' ann) RdrName + -> RnM (GenLocated (SrcSpanAnn' ann) Name) lookupSigCtxtOccRn ctxt what = wrapLocMA $ \ rdr_name -> do { mb_name <- lookupBindGroupOcc ctxt what rdr_name @@ -1860,8 +2040,9 @@ lookupBindGroupOcc :: HsSigCtxt -- See Note [Looking up signature names] lookupBindGroupOcc ctxt what rdr_name | Just n <- isExact_maybe rdr_name - = lookupExactOcc_either n -- allow for the possibility of missing Exacts; - -- see Note [dataTcOccs and Exact Names] + = fmap greName <$> lookupExactOcc_either n + -- allow for the possibility of missing Exacts; + -- see Note [dataTcOccs and Exact Names] -- Maybe we should check the side conditions -- but it's a pain, and Exact things only show -- up when you know what you are doing @@ -1889,21 +2070,21 @@ lookupBindGroupOcc ctxt what rdr_name lookup_top keep_me = do { env <- getGlobalRdrEnv ; dflags <- getDynFlags - ; let all_gres = lookupGlobalRdrEnv env (rdrNameOcc rdr_name) + ; let all_gres = lookupGRE_OccName (IncludeFields WantNormal) env (rdrNameOcc rdr_name) names_in_scope = -- If rdr_name lacks a binding, only -- recommend alternatives from related -- namespaces. See #17593. filter (\n -> nameSpacesRelated dflags WL_Anything (rdrNameSpace rdr_name) (nameNameSpace n)) - $ map greMangledName + $ map greName $ filter isLocalGRE $ globalRdrEnvElts env candidates_msg = candidates names_in_scope - ; case filter (keep_me . greMangledName) all_gres of + ; case filter (keep_me . greName) all_gres of [] | null all_gres -> bale_out_with candidates_msg | otherwise -> bale_out_with local_msg - (gre:_) -> return (Right (greMangledName gre)) } + (gre:_) -> return (Right (greName gre)) } lookup_group bound_names -- Look in the local envt (not top level) = do { mname <- lookupLocalOccRn_maybe rdr_name diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs index 47e6217f56..b68ff6a492 100644 --- a/compiler/GHC/Rename/Expr.hs +++ b/compiler/GHC/Rename/Expr.hs @@ -54,6 +54,7 @@ import GHC.Rename.HsType import GHC.Rename.Pat import GHC.Driver.Session import GHC.Builtin.Names +import GHC.Builtin.Types ( nilDataConName ) import GHC.Types.FieldLabel import GHC.Types.Fixity @@ -63,22 +64,22 @@ import GHC.Types.Name.Set import GHC.Types.Name.Reader import GHC.Types.Unique.Set import GHC.Types.SourceText +import GHC.Types.SrcLoc import GHC.Utils.Misc import GHC.Data.List.SetOps ( removeDupsOn ) +import GHC.Data.Maybe import GHC.Utils.Error import GHC.Utils.Panic import GHC.Utils.Panic.Plain import GHC.Utils.Outputable as Outputable -import GHC.Types.SrcLoc -import Control.Monad -import GHC.Builtin.Types ( nilDataConName ) + import qualified GHC.LanguageExtensions as LangExt import Language.Haskell.Syntax.Basic (FieldLabelString(..)) +import Control.Monad import Data.List (unzip4, minimumBy) import Data.List.NonEmpty ( NonEmpty(..), nonEmpty ) -import Data.Maybe (isJust, isNothing) import Control.Arrow (first) import Data.Ord import Data.Array @@ -254,28 +255,31 @@ rnUnboundVar v = do rnExpr (HsVar _ (L l v)) = do { dflags <- getDynFlags - ; mb_name <- lookupExprOccRn v - - ; case mb_name of { + ; mb_gre <- lookupExprOccRn v + ; case mb_gre of { Nothing -> rnUnboundVar v ; - Just (NormalGreName name) - | name == nilDataConName -- Treat [] as an ExplicitList, so that - -- OverloadedLists works correctly - -- Note [Empty lists] in GHC.Hs.Expr - , xopt LangExt.OverloadedLists dflags - -> rnExpr (ExplicitList noAnn []) - - | otherwise - -> finishHsVar (L (na2la l) name) ; - Just (FieldGreName fl) - -> do { let sel_name = flSelector fl - ; this_mod <- getModule - ; when (nameIsLocalOrFrom this_mod sel_name) $ - checkThLocalName sel_name - ; return ( HsRecSel noExtField (FieldOcc sel_name (L l v) ), unitFV sel_name) - } - } - } + Just gre -> + do { if | Just fl <- recFieldLabel <$> recFieldInfo_maybe gre + -- Since GHC 9.4, such occurrences of record fields must be + -- unambiguous. For ambiguous occurrences, we arbitrarily pick one + -- matching GRE and add a name clash error + -- (see lookupGlobalOccRn_overloaded, called by lookupExprOccRn). + -> do { let sel_name = flSelector fl + ; this_mod <- getModule + ; when (nameIsLocalOrFrom this_mod sel_name) $ + checkThLocalName sel_name + ; return (HsRecSel noExtField (FieldOcc sel_name (L l v) ), unitFV sel_name) + } + | greName gre == nilDataConName + -- Treat [] as an ExplicitList, so that + -- OverloadedLists works correctly + -- Note [Empty lists] in GHC.Hs.Expr + , xopt LangExt.OverloadedLists dflags + -> rnExpr (ExplicitList noAnn []) + + | otherwise + -> finishHsVar (L (na2la l) $ greName gre) + }}} rnExpr (HsIPVar x v) = return (HsIPVar x v, emptyFVs) @@ -477,29 +481,40 @@ rnExpr (RecordCon { rcon_con = con_id rn_field (L l fld) = do { (arg', fvs) <- rnLExpr (hfbRHS fld) ; return (L l (fld { hfbRHS = arg' }), fvs) } -rnExpr (RecordUpd { rupd_expr = expr, rupd_flds = rbinds }) - = case rbinds of - Left flds -> -- 'OverloadedRecordUpdate' is not in effect. Regular record update. - do { ; (e, fv_e) <- rnLExpr expr - ; (rs, fv_rs) <- rnHsRecUpdFields flds - ; return ( RecordUpd noExtField e (Left rs), fv_e `plusFV` fv_rs ) - } - Right flds -> -- 'OverloadedRecordUpdate' is in effect. Record dot update desugaring. - do { ; unlessXOptM LangExt.RebindableSyntax $ - addErr TcRnNoRebindableSyntaxRecordDot - ; let punnedFields = [fld | (L _ fld) <- flds, hfbPun fld] - ; punsEnabled <-xoptM LangExt.NamedFieldPuns - ; unless (null punnedFields || punsEnabled) $ - addErr TcRnNoFieldPunsRecordDot - ; (getField, fv_getField) <- lookupSyntaxName getFieldName - ; (setField, fv_setField) <- lookupSyntaxName setFieldName - ; (e, fv_e) <- rnLExpr expr - ; (us, fv_us) <- rnHsUpdProjs flds - ; return ( mkExpandedExpr - (RecordUpd noExtField e (Right us)) - (mkRecordDotUpd getField setField e us) - , plusFVs [fv_getField, fv_setField, fv_e, fv_us] ) - } +rnExpr (RecordUpd { rupd_expr = L l expr, rupd_flds = rbinds }) + = setSrcSpanA l $ + case rbinds of + + -- 'OverloadedRecordUpdate' is not in effect. Regular record update. + RegularRecUpdFields { recUpdFields = flds } -> + do { (e, fv_e) <- rnExpr expr + ; (parents, flds, fv_flds) <- rnHsRecUpdFields flds + ; let upd_flds = + RegularRecUpdFields + { xRecUpdFields = parents + , recUpdFields = flds } + ; return ( RecordUpd noExtField (L l e) upd_flds + , fv_e `plusFV` fv_flds ) } + + -- 'OverloadedRecordUpdate' is in effect. Record dot update desugaring. + OverloadedRecUpdFields { olRecUpdFields = flds } -> + do { unlessXOptM LangExt.RebindableSyntax $ + addErr TcRnNoRebindableSyntaxRecordDot + ; let punnedFields = [fld | (L _ fld) <- flds, hfbPun fld] + ; punsEnabled <- xoptM LangExt.NamedFieldPuns + ; unless (null punnedFields || punsEnabled) $ + addErr TcRnNoFieldPunsRecordDot + ; (getField, fv_getField) <- lookupSyntaxName getFieldName + ; (setField, fv_setField) <- lookupSyntaxName setFieldName + ; (e, fv_e) <- rnExpr expr + ; (us, fv_us) <- rnHsUpdProjs flds + ; let upd_flds = OverloadedRecUpdFields + { xOLRecUpdFields = noExtField + , olRecUpdFields = us } + ; return ( mkExpandedExpr + (RecordUpd noExtField (L l e) upd_flds) + (mkRecordDotUpd getField setField (L l e) us) + , plusFVs [fv_getField, fv_setField, fv_e, fv_us] ) } rnExpr (HsRecSel x _) = dataConCantHappen x @@ -2775,4 +2790,4 @@ rnHsUpdProjs us = do hfbAnn = noAnn , hfbLHS = fmap rnFieldLabelStrings fs , hfbRHS = arg - , hfbPun = pun}), fv ) } + , hfbPun = pun }), fv ) } diff --git a/compiler/GHC/Rename/Fixity.hs b/compiler/GHC/Rename/Fixity.hs index 5c8fe36fcb..a4da8672af 100644 --- a/compiler/GHC/Rename/Fixity.hs +++ b/compiler/GHC/Rename/Fixity.hs @@ -24,7 +24,6 @@ import GHC.Unit.Module.ModIface import GHC.Types.Fixity.Env import GHC.Types.Name import GHC.Types.Name.Env -import GHC.Types.Name.Reader import GHC.Types.Fixity import GHC.Types.SourceText import GHC.Types.SrcLoc @@ -107,10 +106,7 @@ lookupFixity is a bit strange. -} lookupFixityRn :: Name -> RnM Fixity -lookupFixityRn name = lookupFixityRn' name (nameOccName name) - -lookupFixityRn' :: Name -> OccName -> RnM Fixity -lookupFixityRn' name = fmap snd . lookupFixityRn_help' name +lookupFixityRn = fmap snd . lookupFixityRn_help -- | 'lookupFixityRn_help' returns @(True, fixity)@ if it finds a 'Fixity' -- in a local environment or from an interface file. Otherwise, it returns @@ -118,13 +114,7 @@ lookupFixityRn' name = fmap snd . lookupFixityRn_help' name -- user-supplied fixity declarations). lookupFixityRn_help :: Name -> RnM (Bool, Fixity) -lookupFixityRn_help name = - lookupFixityRn_help' name (nameOccName name) - -lookupFixityRn_help' :: Name - -> OccName - -> RnM (Bool, Fixity) -lookupFixityRn_help' name occ +lookupFixityRn_help name | isUnboundName name = return (False, Fixity NoSourceText minPrecedence InfixL) -- Minimise errors from unbound names; eg @@ -144,6 +134,7 @@ lookupFixityRn_help' name occ then return (False, defaultFixity) else lookup_imported } } } where + occ = nameOccName name lookup_imported -- For imported names, we have to get their fixities by doing a -- loadInterfaceForName, and consulting the Ifaces that comes back @@ -180,10 +171,5 @@ lookupFixityRn_help' name occ lookupTyFixityRn :: LocatedN Name -> RnM Fixity lookupTyFixityRn = lookupFixityRn . unLoc --- | Look up the fixity of an occurrence of a record field selector. --- We use 'lookupFixityRn'' so that we can specify the 'OccName' as --- the field label, which might be different to the 'OccName' of the --- selector 'Name' if @DuplicateRecordFields@ is in use (#1173). lookupFieldFixityRn :: FieldOcc GhcRn -> RnM Fixity -lookupFieldFixityRn (FieldOcc n lrdr) - = lookupFixityRn' n (rdrNameOcc (unLoc lrdr)) +lookupFieldFixityRn (FieldOcc n _) = lookupFixityRn n diff --git a/compiler/GHC/Rename/HsType.hs b/compiler/GHC/Rename/HsType.hs index f9720a53e1..d67a60efd0 100644 --- a/compiler/GHC/Rename/HsType.hs +++ b/compiler/GHC/Rename/HsType.hs @@ -631,11 +631,17 @@ rnHsTyKi env ty@(HsRecTy _ flds) ; return (HsRecTy noExtField flds', fvs) } where get_fields (ConDeclCtx names) - = concatMapM (lookupConstructorFields . unLoc) names - get_fields _ - = do { addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $ - (hang (text "Record syntax is illegal here:") 2 (ppr ty)) - ; return [] } + = do res <- concatMapM (lookupConstructorFields . unLoc) names + if equalLength res names + -- Lookup can fail when the record syntax is incorrect, e.g. + -- data D = D Int { fld :: Bool }. See T7943. + then return res + else err + get_fields _ = err + + err = + do { addErr $ TcRnIllegalRecordSyntax (Left ty) + ; return [] } rnHsTyKi env (HsFunTy u mult ty1 ty2) = do { (ty1', fvs1) <- rnLHsTyKi env ty1 @@ -1159,7 +1165,7 @@ warn_term_var_capture lVar = do case demoteRdrNameTv $ unLoc lVar of Nothing -> return () Just demoted_name -> do - let global_vars = lookupGRE_RdrName demoted_name gbl_env + let global_vars = lookupGRE_RdrName SameOccName gbl_env demoted_name let mlocal_var = lookupLocalRdrEnv local_env demoted_name case mlocal_var of Just name -> warnCapturedTerm lVar (Right name) @@ -1284,10 +1290,12 @@ rnField fl_env env (L l (ConDeclField _ names ty haddock_doc)) lookupField :: FastStringEnv FieldLabel -> FieldOcc GhcPs -> FieldOcc GhcRn lookupField fl_env (FieldOcc _ (L lr rdr)) = - FieldOcc (flSelector fl) (L lr rdr) + FieldOcc sel (L lr $ mkRdrUnqual $ occName sel) where lbl = occNameFS $ rdrNameOcc rdr - fl = expectJust "lookupField" $ lookupFsEnv fl_env lbl + sel = flSelector + $ expectJust "lookupField" + $ lookupFsEnv fl_env lbl {- ************************************************************************ @@ -1585,8 +1593,7 @@ checkSectionPrec direction section op arg (sectionPrecErr (get_op op, op_fix) (arg_op, arg_fix) section) --- | Look up the fixity for an operator name. Be careful to use --- 'lookupFieldFixityRn' for record fields (see #13132). +-- | Look up the fixity for an operator name. lookupFixityOp :: OpName -> RnM Fixity lookupFixityOp (NormalOp n) = lookupFixityRn n lookupFixityOp NegateOp = lookupFixityRn negateName diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs index 7b2b418d87..1602b2b92d 100644 --- a/compiler/GHC/Rename/Module.hs +++ b/compiler/GHC/Rename/Module.hs @@ -52,7 +52,6 @@ import GHC.Builtin.Names( applicativeClassName, pureAName, thenAName import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.Name.Env -import GHC.Types.Avail import GHC.Utils.Outputable import GHC.Data.Bag import GHC.Types.Basic ( TypeOrKind(..) ) @@ -77,7 +76,7 @@ import Data.List ( mapAccumL ) import Data.List.NonEmpty ( NonEmpty(..), head ) import Data.Maybe ( isNothing, fromMaybe, mapMaybe ) import qualified Data.Set as Set ( difference, fromList, toList, null ) -import GHC.Types.ConInfo (ConInfo, mkConInfo, conInfoFields) +import GHC.Types.GREInfo (ConInfo, mkConInfo, conInfoFields) {- | @rnSourceDecl@ "renames" declarations. It simultaneously performs dependency analysis and precedence parsing. @@ -154,7 +153,7 @@ rnSrcDecls group@(HsGroup { hs_valds = val_decls, -- Excludes pattern-synonym binders -- They are already in scope traceRn "rnSrcDecls" (ppr id_bndrs) ; - tc_envs <- extendGlobalRdrEnvRn (map avail id_bndrs) local_fix_env ; + tc_envs <- extendGlobalRdrEnvRn (map (localVanillaGRE NoParent) id_bndrs) local_fix_env ; restoreEnvs tc_envs $ do { -- Now everything is in scope, as the remaining renaming assumes. @@ -188,6 +187,8 @@ rnSrcDecls group@(HsGroup { hs_valds = val_decls, -- Rename fixity declarations and error if we try to -- fix something from another module (duplicates were checked in (A)) let { all_bndrs = tc_bndrs `unionNameSet` val_bndr_set } ; + traceRn "rnSrcDecls fixity" $ + vcat [ text "all_bndrs:" <+> ppr all_bndrs ] ; rn_fix_decls <- mapM (mapM (rnSrcFixityDecl (TopSigCtxt all_bndrs))) fix_decls ; @@ -1489,12 +1490,17 @@ rnTyClDecls tycl_ds = do { -- Rename the type/class, instance, and role declarations ; tycls_w_fvs <- mapM (wrapLocFstMA rnTyClDecl) (tyClGroupTyClDecls tycl_ds) ; let tc_names = mkNameSet (map (tcdName . unLoc . fst) tycls_w_fvs) + ; traceRn "rnTyClDecls" $ + vcat [ text "tyClGroupTyClDecls:" <+> ppr tycls_w_fvs + , text "tc_names:" <+> ppr tc_names ] ; kisigs_w_fvs <- rnStandaloneKindSignatures tc_names (tyClGroupKindSigs tycl_ds) ; instds_w_fvs <- mapM (wrapLocFstMA rnSrcInstDecl) (tyClGroupInstDecls tycl_ds) ; role_annots <- rnRoleAnnots tc_names (tyClGroupRoleDecls tycl_ds) -- Do SCC analysis on the type/class decls ; rdr_env <- getGlobalRdrEnv + ; traceRn "rnTyClDecls SCC analysis" $ + vcat [ text "rdr_env:" <+> ppr rdr_env ] ; let tycl_sccs = depAnalTyClDecls rdr_env kisig_fv_env tycls_w_fvs role_annot_env = mkRoleAnnotEnv role_annots (kisig_env, kisig_fv_env) = mkKindSig_fv_env kisigs_w_fvs @@ -1586,7 +1592,7 @@ rnStandaloneKindSignature rnStandaloneKindSignature tc_names (StandaloneKindSig _ v ki) = do { standalone_ki_sig_ok <- xoptM LangExt.StandaloneKindSignatures ; unless standalone_ki_sig_ok $ addErr TcRnUnexpectedStandaloneKindSig - ; new_v <- lookupSigCtxtOccRnN (TopSigCtxt tc_names) (text "standalone kind signature") v + ; new_v <- lookupSigCtxtOccRn (TopSigCtxt tc_names) (text "standalone kind signature") v ; let doc = StandaloneKindSigCtx (ppr v) ; (new_ki, fvs) <- rnHsSigType doc KindLevel ki ; return (StandaloneKindSig noExtField new_v new_ki, fvs) @@ -1654,9 +1660,9 @@ rnRoleAnnots tc_names role_annots rn_role_annot1 (RoleAnnotDecl _ tycon roles) = do { -- the name is an *occurrence*, but look it up only in the -- decls defined in this group (see #10263) - tycon' <- lookupSigCtxtOccRnN (RoleAnnotCtxt tc_names) - (text "role annotation") - tycon + tycon' <- lookupSigCtxtOccRn (RoleAnnotCtxt tc_names) + (text "role annotation") + tycon ; return $ RoleAnnotDecl noExtField tycon' roles } dupRoleAnnotErr :: NonEmpty (LRoleAnnotDecl GhcPs) -> RnM () @@ -2563,44 +2569,40 @@ extendPatSynEnv :: DuplicateRecordFields -> FieldSelectors -> HsValBinds GhcPs - -> ([Name] -> TcRnIf TcGblEnv TcLclEnv a) -> TcM a extendPatSynEnv dup_fields_ok has_sel val_decls local_fix_env thing = do { names_with_fls <- new_ps val_decls - ; let pat_syn_bndrs = concat [ name : map flSelector (conInfoFields fields) - | (name, fields) <- names_with_fls ] - ; let avails = map avail (map fst names_with_fls) - ++ map availField (concatMap (conInfoFields . snd) names_with_fls) - ; (gbl_env, lcl_env) <- extendGlobalRdrEnvRn avails local_fix_env - - ; let field_env' = extendNameEnvList (tcg_con_env gbl_env) names_with_fls - final_gbl_env = gbl_env { tcg_con_env = field_env' } - ; restoreEnvs (final_gbl_env, lcl_env) (thing pat_syn_bndrs) } + ; let pat_syn_bndrs = concat [ conLikeName_Name name : map flSelector flds + | (name, con_info) <- names_with_fls + , let flds = conInfoFields con_info ] + ; let gres = map (localConLikeGRE NoParent) names_with_fls + ++ localFieldGREs NoParent names_with_fls + -- Recall Note [Parents] in GHC.Types.Name.Reader: + -- + -- pattern synonym constructors and their record fields have no parent + -- in the module in which they are defined. + ; (gbl_env, lcl_env) <- extendGlobalRdrEnvRn gres local_fix_env + ; restoreEnvs (gbl_env, lcl_env) (thing pat_syn_bndrs) } where - new_ps :: HsValBinds GhcPs -> TcM [(Name, ConInfo)] + + new_ps :: HsValBinds GhcPs -> TcM [(ConLikeName, ConInfo)] new_ps (ValBinds _ binds _) = foldrM new_ps' [] binds new_ps _ = panic "new_ps" new_ps' :: LHsBindLR GhcPs GhcPs - -> [(Name, ConInfo)] - -> TcM [(Name, ConInfo)] + -> [(ConLikeName, ConInfo)] + -> TcM [(ConLikeName, ConInfo)] new_ps' bind names | (L bind_loc (PatSynBind _ (PSB { psb_id = L _ n , psb_args = RecCon as }))) <- bind = do bnd_name <- newTopSrcBinder (L (l2l bind_loc) n) let field_occs = map ((\ f -> L (noAnnSrcSpan $ getLocA (foLabel f)) f) . recordPatSynField) as - flds <- mapM (newRecordSelector dup_fields_ok has_sel [bnd_name]) field_occs - let conInfo = - mkConInfo - (conDetailsArity length (RecCon as)) - flds - return ((bnd_name, conInfo): names) - | L bind_loc (PatSynBind _ (PSB { psb_id = L _ n - , psb_args})) <- bind + flds <- mapM (newRecordFieldLabel dup_fields_ok has_sel [bnd_name]) field_occs + let con_info = mkConInfo (conDetailsArity length (RecCon as)) flds + return ((PatSynName bnd_name, con_info) : names) + | L bind_loc (PatSynBind _ (PSB { psb_id = L _ n, psb_args = as })) <- bind = do bnd_name <- newTopSrcBinder (L (la2na bind_loc) n) - let conInfo = - mkConInfo - (conDetailsArity length psb_args) - [] - return ((bnd_name, conInfo): names) + let con_info = mkConInfo (conDetailsArity length as) [] + return ((PatSynName bnd_name, con_info) : names) | otherwise = return names diff --git a/compiler/GHC/Rename/Names.hs b/compiler/GHC/Rename/Names.hs index 25b1c6e8af..f5309eb174 100644 --- a/compiler/GHC/Rename/Names.hs +++ b/compiler/GHC/Rename/Names.hs @@ -8,11 +8,14 @@ Extracting imported and top-level names in scope {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE LambdaCase #-} +{-# OPTIONS_GHC -ddump-to-file -ddump-simpl #-} + module GHC.Rename.Names ( - rnImports, getLocalNonValBinders, newRecordSelector, + rnImports, getLocalNonValBinders, newRecordFieldLabel, extendGlobalRdrEnvRn, gresFromAvails, calculateAvails, @@ -24,7 +27,8 @@ module GHC.Rename.Names ( getMinimalImports, printMinimalImports, renamePkgQual, renameRawPkgQual, - ImportDeclUsage + classifyGREs, + ImportDeclUsage, ) where import GHC.Prelude hiding ( head, init, last, tail ) @@ -35,7 +39,7 @@ import GHC.Driver.Ppr import GHC.Rename.Env import GHC.Rename.Fixity -import GHC.Rename.Utils ( warnUnusedTopBinds, mkFieldEnv ) +import GHC.Rename.Utils ( warnUnusedTopBinds ) import GHC.Tc.Errors.Types import GHC.Tc.Utils.Env @@ -64,13 +68,13 @@ import GHC.Types.Avail import GHC.Types.FieldLabel import GHC.Types.SourceFile import GHC.Types.SrcLoc as SrcLoc -import GHC.Types.Basic ( Arity, TopLevelFlag(..) ) +import GHC.Types.Basic ( TopLevelFlag(..) ) import GHC.Types.SourceText import GHC.Types.Id import GHC.Types.HpcInfo import GHC.Types.Error import GHC.Types.PkgQual -import GHC.Types.ConInfo (ConInfo, mkConInfo) +import GHC.Types.GREInfo (ConInfo(..)) import GHC.Unit import GHC.Unit.Module.Warnings @@ -79,28 +83,27 @@ import GHC.Unit.Module.Imported import GHC.Unit.Module.Deps import GHC.Unit.Env -import GHC.Data.Maybe +import GHC.Data.Bag import GHC.Data.FastString import GHC.Data.FastString.Env - -import Language.Haskell.Syntax.Basic (FieldLabelString(..)) +import GHC.Data.Maybe +import GHC.Data.List.SetOps ( removeDups ) import Control.Monad -import Data.Either ( partitionEithers ) +import Data.Foldable ( for_, toList ) +import Data.IntMap ( IntMap ) +import qualified Data.IntMap as IntMap import Data.Map ( Map ) import qualified Data.Map as Map import Data.Ord ( comparing ) -import Data.List ( partition, (\\), find, sortBy ) +import Data.List ( partition, find, sortBy ) import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NE import Data.Function ( on ) import qualified Data.Set as S -import Data.Foldable ( toList ) -import Data.Void ( Void ) import System.FilePath ((</>)) - import System.IO -import GHC.Data.Bag + {- ************************************************************************ @@ -398,11 +401,11 @@ rnImportDecl this_mod is_dloc = locA loc, is_as = qual_mod_name } -- filter the imports according to the import declaration - (new_imp_details, gres) <- filterImports iface imp_spec imp_details + (new_imp_details, gres) <- filterImports hsc_env iface imp_spec imp_details -- for certain error messages, we’d like to know what could be imported -- here, if everything were imported - potential_gres <- mkGlobalRdrEnv . snd <$> filterImports iface imp_spec Nothing + potential_gres <- mkGlobalRdrEnv . snd <$> filterImports hsc_env iface imp_spec Nothing let gbl_env = mkGlobalRdrEnv gres @@ -682,7 +685,7 @@ top level binders specially in two ways fields of Brack, hence the error thunks in thRnBrack. -} -extendGlobalRdrEnvRn :: [AvailInfo] +extendGlobalRdrEnvRn :: [GlobalRdrElt] -> MiniFixityEnv -> RnM (TcGblEnv, TcLclEnv) -- Updates both the GlobalRdrEnv and the FixityEnv @@ -690,7 +693,7 @@ extendGlobalRdrEnvRn :: [AvailInfo] -- delete some bindings from it; -- see Note [Top-level Names in Template Haskell decl quotes] -extendGlobalRdrEnvRn avails new_fixities +extendGlobalRdrEnvRn new_gres new_fixities = checkNoErrs $ -- See Note [Fail fast on duplicate definitions] do { (gbl_env, lcl_env) <- getEnvs ; stage <- getStage @@ -706,7 +709,7 @@ extendGlobalRdrEnvRn avails new_fixities -- See Note [GlobalRdrEnv shadowing] inBracket = isBrackStage stage - lcl_env_TH = lcl_env { tcl_rdr = minusLocalRdrEnv (tcl_rdr lcl_env) new_occs } + lcl_env_TH = lcl_env { tcl_rdr = minusLocalRdrEnv (tcl_rdr lcl_env) new_gres_env } -- See Note [GlobalRdrEnv shadowing] lcl_env2 | inBracket = lcl_env_TH @@ -714,12 +717,11 @@ extendGlobalRdrEnvRn avails new_fixities -- Deal with shadowing: see Note [GlobalRdrEnv shadowing] want_shadowing = isGHCi || inBracket - rdr_env1 | want_shadowing = shadowNames rdr_env new_occs + rdr_env1 | want_shadowing = shadowNames rdr_env new_gres_env | otherwise = rdr_env lcl_env3 = lcl_env2 { tcl_th_bndrs = extendNameEnvList th_bndrs - [ ( greNameMangledName n - , (TopLevel, th_lvl) ) + [ ( n, (TopLevel, th_lvl) ) | n <- new_names ] } ; rdr_env2 <- foldlM add_gre rdr_env1 new_gres @@ -730,8 +732,8 @@ extendGlobalRdrEnvRn avails new_fixities ; traceRn "extendGlobalRdrEnvRn 2" (pprGlobalRdrEnv True rdr_env2) ; return (gbl_env', lcl_env3) } where - new_names = concatMap availGreNames avails - new_occs = occSetToEnv (mkOccSet (map occName new_names)) + new_names = map greName new_gres + new_gres_env = mkGlobalRdrEnv new_gres -- If there is a fixity decl for the gre, add it to the fixity env extend_fix_env fix_env gre @@ -740,12 +742,9 @@ extendGlobalRdrEnvRn avails new_fixities | otherwise = fix_env where - name = greMangledName gre + name = greName gre occ = greOccName gre - new_gres :: [GlobalRdrElt] -- New LocalDef GREs, derived from avails - new_gres = concatMap localGREsFromAvail avails - add_gre :: GlobalRdrEnv -> GlobalRdrElt -> RnM GlobalRdrEnv -- Extend the GlobalRdrEnv with a LocalDef GRE -- If there is already a LocalDef GRE with the same OccName, @@ -759,15 +758,9 @@ extendGlobalRdrEnvRn avails new_fixities = return (extendGlobalRdrEnv env gre) where -- See Note [Reporting duplicate local declarations] - dups = filter isDupGRE (lookupGlobalRdrEnv env (greOccName gre)) - isDupGRE gre' = isLocalGRE gre' && not (isAllowedDup gre') - isAllowedDup gre' = - case (isRecFldGRE gre, isRecFldGRE gre') of - (True, True) -> gre_name gre /= gre_name gre' - && isDuplicateRecFldGRE gre' - (True, False) -> isNoFieldSelectorGRE gre - (False, True) -> isNoFieldSelectorGRE gre' - (False, False) -> False + dups = filter isBadDupGRE + $ lookupGRE_OccName (AllNameSpaces WantBoth) env (greOccName gre) + isBadDupGRE old_gre = isLocalGRE old_gre && greClashesWith gre old_gre {- Note [Fail fast on duplicate definitions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -789,7 +782,7 @@ is checked in extendGlobalRdrEnvRn: when adding a new locally-defined GRE to the GlobalRdrEnv we report an error if there are already duplicates in the environment. This establishes INVARIANT 1 (see comments on GlobalRdrEnv in GHC.Types.Name.Reader), which says that for a given OccName, all the -GlobalRdrElts to which it maps must have distinct 'gre_name's. +GlobalRdrElts to which it maps must have distinct 'greName's. For example, the following will be rejected: @@ -797,75 +790,27 @@ For example, the following will be rejected: g x = x f x = x -- Duplicate! -Two GREs with the same OccName are OK iff: -------------------------------------------------------------------- - Existing GRE | Newly-defined GRE - | NormalGre FieldGre -------------------------------------------------------------------- - Imported | Always Always - | - Local NormalGre | Never NoFieldSelectors - | - Local FieldGre | NoFieldSelectors DuplicateRecordFields - | and not in same record -------------------------------------------------------------------- - -In this table "NoFieldSelectors" means "NoFieldSelectors was enabled at the -definition site of the fields; ditto "DuplicateRecordFields". These facts are -recorded in the 'FieldLabel' (but where both GREs are local, both will -necessarily have the same extensions enabled). - -More precisely: - -* The programmer is allowed to make a new local definition that clashes with an - imported one (although attempting to refer to either may lead to ambiguity - errors at use sites). For example, the following definition is allowed: - - import M (f) - f x = x - - Thus isDupGRE reports errors only if the existing GRE is a LocalDef. - -* When DuplicateRecordFields is enabled, the same field label may be defined in - multiple records. For example, this is allowed: +Users are allowed to introduce new GREs with the same OccName as an imported GRE, +as disambiguation is possible through the module system, e.g.: - {-# LANGUAGE DuplicateRecordFields #-} - data S1 = MkS1 { f :: Int } - data S2 = MkS2 { f :: Int } - - Even though both fields have the same OccName, this does not violate INVARIANT - 1 of the GlobalRdrEnv, because the fields have distinct selector names, which - form part of the gre_name (see Note [GreNames] in GHC.Types.Name.Reader). - -* However, we must be careful to reject the following (#9156): - - {-# LANGUAGE DuplicateRecordFields #-} - data T = MkT { f :: Int, f :: Int } -- Duplicate! - - In this case, both 'gre_name's are the same (because the fields belong to the - same type), and adding them both to the environment would be a violation of - INVARIANT 1. Thus isAllowedDup checks both GREs have distinct 'gre_name's - if they are both record fields. - -* With DuplicateRecordFields, we reject attempts to define a field and a - non-field with the same OccName (#17965): - - {-# LANGUAGE DuplicateRecordFields #-} + module M where + import N (f) f x = x - data T = MkT { f :: Int} + g x = M.f x + N.f x - In principle this could be supported, but the current "specification" of - DuplicateRecordFields does not allow it. Thus isAllowedDup checks for - DuplicateRecordFields only if *both* GREs being compared are record fields. +If both GREs are local, the general rule is that two GREs clash if they have +the same OccName, i.e. they share a textual name and live in the same namespace. +However, there are additional clashes due to record fields: -* However, with NoFieldSelectors, it is possible by design to define a field and - a non-field with the same OccName: + - a new variable clashes with previously defined record fields + which define field selectors, - {-# LANGUAGE NoFieldSelectors #-} - f x = x - data T = MkT { f :: Int} + - a new record field shadows: + + - previously defined variables, if it defines a field selector, + - previously defined record fields, unless it is a duplicate record field. - Thus isAllowedDup checks for NoFieldSelectors if either the existing or the - new GRE are record fields. See Note [NoFieldSelectors] in GHC.Rename.Env. +This logic is implemented in the function 'GHC.Types.Name.Reader.greClashesWith'. See also Note [Skipping ambiguity errors at use sites of local declarations] in GHC.Rename.Utils. @@ -900,19 +845,19 @@ getLocalNonValBinders fixity_env ; let inst_decls = tycl_decls >>= group_instds ; dup_fields_ok <- xopt_DuplicateRecordFields <$> getDynFlags ; has_sel <- xopt_FieldSelectors <$> getDynFlags - ; (tc_avails, tc_fldss) - <- fmap unzip $ mapM (new_tc dup_fields_ok has_sel) - (tyClGroupTyClDecls tycl_decls) - ; traceRn "getLocalNonValBinders 1" (ppr tc_avails) - ; envs <- extendGlobalRdrEnvRn tc_avails fixity_env + ; tc_gres + <- concatMapM + (new_tc dup_fields_ok has_sel) + (tyClGroupTyClDecls tycl_decls) + ; traceRn "getLocalNonValBinders 1" (ppr tc_gres) + ; envs <- extendGlobalRdrEnvRn tc_gres fixity_env ; restoreEnvs envs $ do { -- Bring these things into scope first -- See Note [Looking up family names in family instances] -- Process all family instances -- to bring new data constructors into scope - ; (nti_availss, nti_fldss) <- mapAndUnzipM (new_assoc dup_fields_ok has_sel) - inst_decls + ; nti_gress <- mapM (new_assoc dup_fields_ok has_sel) inst_decls -- Finish off with value binders: -- foreign decls and pattern synonyms for an ordinary module @@ -927,24 +872,13 @@ getLocalNonValBinders fixity_env | L decl_loc (TypeSig _ ns _) <- val_sigs, n <- ns] _ -> panic "Non-ValBinds in hs-boot group" | otherwise = for_hs_bndrs - ; val_avails <- mapM new_simple val_bndrs + ; val_gres <- mapM new_simple val_bndrs - ; let avails = concat nti_availss ++ val_avails - new_bndrs = availsToNameSetWithSelectors avails `unionNameSet` - availsToNameSetWithSelectors tc_avails - flds = concat nti_fldss ++ concat tc_fldss + ; let avails = concat nti_gress ++ val_gres + new_bndrs = gresToNameSet avails `unionNameSet` + gresToNameSet tc_gres ; traceRn "getLocalNonValBinders 2" (ppr avails) - ; (tcg_env, tcl_env) <- extendGlobalRdrEnvRn avails fixity_env - - -- Force the field access so that tcg_env is not retained. The - -- selector thunk optimisation doesn't kick-in, see #20139 - ; let !old_field_env = tcg_con_env tcg_env - -- Extend tcg_con_env with new fields (this used to be the - -- work of extendRecordFieldEnv) - field_env = extendNameEnvList old_field_env flds - envs = (tcg_env { tcg_con_env = field_env }, tcl_env) - - ; traceRn "getLocalNonValBinders 3" (vcat [ppr flds, ppr field_env]) + ; envs <- extendGlobalRdrEnvRn avails fixity_env ; return (envs, new_bndrs) } } where for_hs_bndrs :: [LocatedN RdrName] @@ -952,101 +886,61 @@ getLocalNonValBinders fixity_env -- the SrcSpan attached to the input should be the span of the -- declaration, not just the name - new_simple :: LocatedN RdrName -> RnM AvailInfo - new_simple rdr_name = do{ nm <- newTopSrcBinder rdr_name - ; return (avail nm) } + new_simple :: LocatedN RdrName -> RnM GlobalRdrElt + new_simple rdr_name = do { nm <- newTopSrcBinder rdr_name + ; return (localVanillaGRE NoParent nm) } new_tc :: DuplicateRecordFields -> FieldSelectors -> LTyClDecl GhcPs - -> RnM (AvailInfo, [(Name, ConInfo)]) + -> RnM [GlobalRdrElt] new_tc dup_fields_ok has_sel tc_decl -- NOT for type/data instances - = do { let (bndrs, flds) = hsLTyClDeclBinders tc_decl - ; names@(main_name : sub_names) <- mapM (newTopSrcBinder . l2n) bndrs - ; flds' <- mapM (newRecordSelector dup_fields_ok has_sel sub_names) flds - ; let fld_env = case unLoc tc_decl of - DataDecl { tcdDataDefn = d } -> mk_con_env d names flds' - _ -> [] - ; return (availTC main_name names flds', fld_env) } - - - -- Calculate the mapping from constructor names to arity and fields, which - -- will go in tcg_con_env. It's convenient to do this here where + = do { let TyDeclBinders (main_bndr, tc_flav) at_bndrs sig_bndrs + (LConsWithFields cons_with_flds flds) = hsLTyClDeclBinders tc_decl + ; tycon_name <- newTopSrcBinder $ l2n main_bndr + ; at_names <- mapM (newTopSrcBinder . l2n . fst) at_bndrs + ; sig_names <- mapM (newTopSrcBinder . l2n) sig_bndrs + ; con_names_with_flds <- mapM (\(con,flds) -> (,flds) <$> newTopSrcBinder (l2n con)) cons_with_flds + ; flds' <- mapM (newRecordFieldLabel dup_fields_ok has_sel $ map fst con_names_with_flds) flds + ; mapM_ (add_dup_fld_errs flds') con_names_with_flds + ; let tc_gre = localTyConGRE (fmap (const tycon_name) tc_flav) tycon_name + fld_env = mk_fld_env con_names_with_flds flds' + at_gres = zipWith (\ (_, at_flav) at_nm -> localTyConGRE (fmap (const tycon_name) at_flav) at_nm) + at_bndrs at_names + sig_gres = map (localVanillaGRE (ParentIs tycon_name)) sig_names + con_gres = map (localConLikeGRE (ParentIs tycon_name)) fld_env + fld_gres = localFieldGREs (ParentIs tycon_name) fld_env + sub_gres = at_gres ++ sig_gres ++ con_gres ++ fld_gres + ; traceRn "getLocalNonValBinders new_tc" $ + vcat [ text "tycon:" <+> ppr tycon_name + , text "tc_gre:" <+> ppr tc_gre + , text "sub_gres:" <+> ppr sub_gres ] + ; return $ tc_gre : sub_gres } + + -- Calculate the record field information, which feeds into the GlobalRdrElts + -- for DataCons and their fields. It's convenient to do this here where -- we are working with a single datatype definition. - -- For more details, see Note [Local constructor info in the renamer] - mk_con_env :: HsDataDefn GhcPs -> [Name] -> [FieldLabel] - -> [(Name, ConInfo)] - mk_con_env d names flds = concatMap find_con_flds (dd_cons d) - where - find_con_flds :: GenLocated l (ConDecl GhcPs) -> [(Name, ConInfo)] - find_con_flds (L _ (ConDeclH98 { con_name = L _ rdr - , con_args = con_det })) - = [( find_con_name rdr - , con_det_con_info con_det - )] - find_con_flds (L _ (ConDeclGADT { con_names = rdrs - , con_g_args = con_gadt_det })) - = [ ( find_con_name rdr - , gadt_det_con_info con_gadt_det - ) - | L _ rdr <- toList rdrs ] - - find_con_name rdr - = expectJust "getLocalNonValBinders/find_con_name" $ - find (\ n -> nameOccName n == rdrNameOcc rdr) names - - con_det_con_info - :: HsConDetails Void (HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))) (GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcPs)]) - -> ConInfo - con_det_con_info con_det = - let - (arity, fields) = - case con_det of - PrefixCon _ args -> - (length args, []) - RecCon cdflds -> - ((find_con_decl_field_arity . unLoc) cdflds, concatMap find_con_decl_flds $ unLoc cdflds) - InfixCon _ _ -> - (2, []) - in - mkConInfo - arity - fields - - gadt_det_con_info :: HsConDeclGADTDetails GhcPs -> ConInfo - gadt_det_con_info con_gadt_det = - let - (arity, fields) = - case con_gadt_det of - PrefixConGADT args -> - (length args, []) - RecConGADT (L _ args) _ -> - (find_con_decl_field_arity args, concatMap find_con_decl_flds args) - in - mkConInfo - arity - fields - - find_con_decl_flds :: GenLocated l (ConDeclField GhcPs) -> [FieldLabel] - find_con_decl_flds (L _ x) - = map find_con_decl_fld (cd_fld_names x) - - find_con_decl_fld (L _ (FieldOcc _ (L _ rdr))) - = expectJust "getLocalNonValBinders/find_con_decl_fld" $ - find (\ fl -> flLabel fl == lbl) flds - where lbl = FieldLabelString $ occNameFS (rdrNameOcc rdr) - - find_con_decl_field_arity :: [GenLocated SrcSpanAnnA (ConDeclField GhcPs)] -> Arity - find_con_decl_field_arity = length . concatMap (cd_fld_names . unLoc) + -- + -- The information we needed was all set up for us: + -- see Note [Collecting record fields in data declarations] in GHC.Hs.Utils. + mk_fld_env :: [(Name, Maybe [Located Int])] -> IntMap FieldLabel + -> [(ConLikeName, ConInfo)] + mk_fld_env names flds = + [ (DataConName con, con_info) + | (con, mb_fl_indxs) <- names + , let con_info = case fmap (map ((flds IntMap.!) . unLoc)) mb_fl_indxs of + Nothing -> ConHasPositionalArgs + Just [] -> ConIsNullary + Just (fld:flds) -> ConHasRecordFields $ fld NE.:| flds ] new_assoc :: DuplicateRecordFields -> FieldSelectors -> LInstDecl GhcPs - -> RnM ([AvailInfo], [(Name, ConInfo)]) - new_assoc _ _ (L _ (TyFamInstD {})) = return ([], []) + -> RnM [GlobalRdrElt] + new_assoc _ _ (L _ (TyFamInstD {})) = return [] -- type instances don't bind new names new_assoc dup_fields_ok has_sel (L _ (DataFamInstD _ d)) - = do { (avail, arityAndFlds) <- new_di dup_fields_ok has_sel Nothing d - ; return ([avail], arityAndFlds) } - new_assoc dup_fields_ok has_sel (L _ (ClsInstD _ (ClsInstDecl { cid_poly_ty = inst_ty - , cid_datafam_insts = adts }))) + = new_di dup_fields_ok has_sel Nothing d + new_assoc dup_fields_ok has_sel + (L _ (ClsInstD _ (ClsInstDecl { cid_poly_ty = inst_ty + , cid_datafam_insts = adts }))) = do -- First, attempt to grab the name of the class from the instance. -- This step could fail if the instance is not headed by a class, -- such as in the following examples: @@ -1056,57 +950,87 @@ getLocalNonValBinders fixity_env -- (2) The class is headed by a type variable, such as in -- `instance c` (#16385) -- - -- If looking up the class name fails, then mb_cls_nm will + -- If looking up the class name fails, then mb_cls_gre will -- be Nothing. - mb_cls_nm <- runMaybeT $ do + mb_cls_gre <- runMaybeT $ do -- See (1) above L loc cls_rdr <- MaybeT $ pure $ getLHsInstDeclClass_maybe inst_ty -- See (2) above - MaybeT $ setSrcSpan (locA loc) $ lookupGlobalOccRn_maybe cls_rdr + MaybeT $ setSrcSpan (locA loc) $ lookupGlobalOccRn_maybe SameOccName cls_rdr -- Assuming the previous step succeeded, process any associated data -- family instances. If the previous step failed, bail out. - case mb_cls_nm of - Nothing -> pure ([], []) - Just cls_nm -> do - (avails, fldss) - <- mapAndUnzipM (new_loc_di dup_fields_ok has_sel (Just cls_nm)) adts - pure (avails, concat fldss) - - new_di :: DuplicateRecordFields -> FieldSelectors -> Maybe Name -> DataFamInstDecl GhcPs - -> RnM (AvailInfo, [(Name, ConInfo)]) + case mb_cls_gre of + Nothing + -> pure [] + Just cls_gre + -> let cls_nm = greName cls_gre + in concatMapM (new_di dup_fields_ok has_sel (Just cls_nm) . unLoc) adts + + new_di :: DuplicateRecordFields -> FieldSelectors + -> Maybe Name -- class name + -> DataFamInstDecl GhcPs + -> RnM [GlobalRdrElt] new_di dup_fields_ok has_sel mb_cls dfid@(DataFamInstDecl { dfid_eqn = ti_decl }) - = do { main_name <- lookupFamInstName mb_cls (feqn_tycon ti_decl) - ; let (bndrs, flds) = hsDataFamInstBinders dfid - ; sub_names <- mapM (newTopSrcBinder .l2n) bndrs - ; flds' <- mapM (newRecordSelector dup_fields_ok has_sel sub_names) flds - ; let avail = availTC (unLoc main_name) sub_names flds' - -- main_name is not bound here! - fld_env = mk_con_env (feqn_rhs ti_decl) sub_names flds' - ; return (avail, fld_env) } - - new_loc_di :: DuplicateRecordFields -> FieldSelectors -> Maybe Name -> LDataFamInstDecl GhcPs - -> RnM (AvailInfo, [(Name, ConInfo)]) - new_loc_di dup_fields_ok has_sel mb_cls (L _ d) = new_di dup_fields_ok has_sel mb_cls d - -newRecordSelector :: DuplicateRecordFields -> FieldSelectors -> [Name] -> LFieldOcc GhcPs -> RnM FieldLabel -newRecordSelector _ _ [] _ = error "newRecordSelector: datatype has no constructors!" -newRecordSelector dup_fields_ok has_sel (dc:_) (L loc (FieldOcc _ (L _ fld))) + = do { main_name <- unLoc <$> lookupFamInstName mb_cls (feqn_tycon ti_decl) + ; let LConsWithFields cons_with_flds flds = hsDataFamInstBinders dfid + ; sub_names <- mapM (\(con,flds) -> (,flds) <$> newTopSrcBinder (l2n con)) cons_with_flds + ; flds' <- mapM (newRecordFieldLabel dup_fields_ok has_sel $ map fst sub_names) flds + ; mapM_ (add_dup_fld_errs flds') sub_names + ; let fld_env = mk_fld_env sub_names flds' + con_gres = map (localConLikeGRE (ParentIs main_name)) fld_env + field_gres = localFieldGREs (ParentIs main_name) fld_env + -- NB: the data family name is not bound here, + -- so we don't return a GlobalRdrElt for it here! + ; return $ con_gres ++ field_gres } + + -- Add errors if a constructor has a duplicate record field. + add_dup_fld_errs :: IntMap FieldLabel + -> (Name, Maybe [Located Int]) + -> IOEnv (Env TcGblEnv TcLclEnv) () + add_dup_fld_errs all_flds (con, mb_con_flds) + | Just con_flds <- mb_con_flds + , let (_, dups) = removeDups (comparing unLoc) con_flds + = for_ dups $ \ dup_flds -> + -- Report the error at the location of the second occurrence + -- of the duplicate field. + let loc = + case dup_flds of + _ :| ( L loc _ : _) -> loc + L loc _ :| _ -> loc + dup_rdrs = fmap (nameRdrName . flSelector . (all_flds IntMap.!) . unLoc) dup_flds + in addErrAt loc $ TcRnDuplicateFieldName (RecordFieldDecl con) dup_rdrs + | otherwise + = return () + +newRecordFieldLabel :: DuplicateRecordFields -> FieldSelectors -> [Name] -> LFieldOcc GhcPs -> RnM FieldLabel +newRecordFieldLabel _ _ [] _ = error "newRecordFieldLabel: datatype has no constructors!" +newRecordFieldLabel dup_fields_ok has_sel (dc:_) (L loc (FieldOcc _ (L _ fld))) = do { selName <- newTopSrcBinder $ L (l2l loc) $ field - ; return $ FieldLabel { flLabel = fieldLabelString - , flHasDuplicateRecordFields = dup_fields_ok + ; return $ FieldLabel { flHasDuplicateRecordFields = dup_fields_ok , flHasFieldSelector = has_sel , flSelector = selName } } where - fieldLabelString = FieldLabelString $ occNameFS $ rdrNameOcc fld - selOccName = fieldSelectorOccName fieldLabelString (nameOccName dc) dup_fields_ok has_sel - field | isExact fld = fld - -- use an Exact RdrName as is to preserve the bindings - -- of an already renamer-resolved field and its use - -- sites. This is needed to correctly support record - -- selectors in Template Haskell. See Note [Binders in - -- Template Haskell] in "GHC.ThToHs" and Note [Looking up - -- Exact RdrNames] in "GHC.Rename.Env". - | otherwise = mkRdrUnqual selOccName + fld_occ = rdrNameOcc fld + dc_fs = (occNameFS $ nameOccName dc) + field + -- Use an Exact RdrName as-is, to preserve the bindings + -- of an already renamer-resolved field and its use + -- sites. This is needed to correctly support record + -- selectors in Template Haskell. See Note [Binders in + -- Template Haskell] in "GHC.ThToHs" and Note [Looking up + -- Exact RdrNames] in "GHC.Rename.Env". + | isExact fld + = assertPpr (fieldOcc_maybe fld_occ == Just dc_fs) + (vcat [ text "newRecordFieldLabel: incorrect namespace for exact Name" <+> quotes (ppr fld) + , text "expected namespace:" <+> pprNameSpace (fieldName dc_fs) + , text " actual namespace:" <+> pprNameSpace (occNameSpace fld_occ) ]) + fld + + -- Field names produced by the parser are namespaced with VarName. + -- Here we namespace them according to the first constructor. + -- See Note [Record field namespacing] in GHC.Types.Name.Occurrence. + | otherwise + = mkRdrUnqual $ varToRecFieldOcc dc_fs fld_occ {- Note [Looking up family names in family instances] @@ -1138,37 +1062,52 @@ available, and filters it through the import spec (if any). Note [Dealing with imports] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For import M( ies ), we take the mi_exports of M, and make - imp_occ_env :: OccEnv (NameEnv (GreName, AvailInfo, Maybe Name)) -One entry for each OccName that M exports, mapping each corresponding Name to -its GreName, the AvailInfo exported from M that exports that Name, and -optionally a Name for an associated type's parent class. (Typically there will -be a single Name in the NameEnv, but see Note [Importing DuplicateRecordFields] -for why we may need more than one.) - -The situation is made more complicated by associated types. E.g. - module M where - class C a where { data T a } - instance C Int where { data T Int = T1 | T2 } - instance C Bool where { data T Int = T3 } -Then M's export_avails are (recall the AvailTC invariant from Avails.hs) +For import M( ies ), we take each AvailInfo from the mi_exports of M, and make + + imp_occ_env :: OccEnv (NameEnv ImpOccItem) + +This map contains one entry for each OccName that M exports, mapping each OccName +to the following information: + + 1. the GlobalRdrElt corresponding to the OccName, + 2. whether this GlobalRdrElt was the parent in the AvailInfo we found + the OccName in. + 3. the GlobalRdrElts that were bundled together in the AvailInfo we found + this OccName in (not including the parent), + +We need (2) and (3) during the construction of the OccEnv because of associated +types and bundled pattern synonyms, respectively. +(3) is explained in Note [Importing PatternSynonyms]. + +To explain (2), consider for example: + + module M where + class C a where { data T a } + instance C Int where { data T Int = T1 | T2 } + instance C Bool where { data T Int = T3 } + +Here, M's exports avails are (recalling the AvailTC invariant from GHC.Types.Avail) + C(C,T), T(T,T1,T2,T3) + Notice that T appears *twice*, once as a child and once as a parent. From -this list we construct a raw list including - T -> (T, T( T1, T2, T3 ), Nothing) - T -> (T, C( C, T ), Nothing) -and we combine these (in function 'combine' in 'imp_occ_env' in -'filterImports') to get - T -> (T, T(T,T1,T2,T3), Just C) - -So the overall imp_occ_env is - C -> (C, C(C,T), Nothing) - T -> (T, T(T,T1,T2,T3), Just C) - T1 -> (T1, T(T,T1,T2,T3), Nothing) -- similarly T2,T3 - -If we say - import M( T(T1,T2) ) -then we get *two* Avails: C(T), T(T1,T2) +these two exports, respectively, during construction of the imp_occ_env, we begin +by associating the following two elements with the key T: + + T -> ImpOccItem { imp_item = T, imp_bundled = [C,T] , imp_is_parent = False } + T -> ImpOccItem { imp_item = T, imp_bundled = [T1,T2,T3], imp_is_parent = True } + +We combine these (in function 'combine' in 'mkImportOccEnv') by simply discarding +the first item, to get: + + T -> IE_ITem { imp_item = T, imp_bundled = [T1,T2,T3], imp_is_parent = True } + +So the overall imp_occ_env is: + + C -> ImpOccItem { imp_item = C, imp_bundled = [T ], imp_is_parent = True } + T -> ImpOccItem { imp_item = T , imp_bundled = [T1,T2,T3], imp_is_parent = True } + T1 -> ImpOccItem { imp_item = T1, imp_bundled = [T1,T2,T3], imp_is_parent = False } + -- similarly for T2, T3 Note that the imp_occ_env will have entries for data constructors too, although we never look up data constructors. @@ -1187,12 +1126,16 @@ A simplified example, based on #11959: data T = MkT pattern P = MkT -Here we have T(P) and P in export_avails, and construct both - P -> (P, P, Nothing) - P -> (P, T(P), Nothing) -which are 'combine'd to leave - P -> (P, T(P), Nothing) -i.e. we simply discard the non-bundled Avail. +Here we have T(P) and P in export_avails, and respectively construct both + + P -> ImpOccItem { imp_item = P, imp_bundled = [P], imp_is_parent = False } + P -> ImpOccItem { imp_item = P, imp_bundled = [] , imp_is_parent = False } + +We combine these by dropping the one with no siblings, leaving us with: + + P -> ImpOccItem { imp_item = P, imp_bundled = [P], imp_is_parent = False } + +That is, we simply discard the non-bundled Avail. Note [Importing DuplicateRecordFields] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1202,124 +1145,117 @@ Suppose we have: {-# LANGUAGE DuplicateRecordFields #-} module M (S(foo), T(foo)) where data S = MkS { foo :: Int } - data T = mkT { foo :: Int } + data T = MkT { foo :: Int } module N where import M (foo) -- this is allowed (A) import M (S(foo)) -- this is allowed (B) -Here M exports the OccName 'foo' twice, so we get an imp_occ_env where 'foo' -maps to a NameEnv containing an entry for each of the two mangled field selector -names (see Note [FieldLabel] in GHC.Types.FieldLabel). - - foo -> [ $sel:foo:MkS -> (foo, S(foo), Nothing) - , $sel:foo:MKT -> (foo, T(foo), Nothing) - ] - -Then when we look up 'foo' in lookup_names for case (A) we get both entries and -hence two Avails. Whereas in case (B) we reach the lookup_ie -case for IEThingWith, which looks up 'S' and then finds the unique 'foo' amongst -its children. +Here M exports 'foo' at two different OccNames, with different namespaces for +the two construtors MkS and MkT. Then, when we look up 'foo' in lookup_names +for case (A), we have a variable foo but must look in all the record field +namespaces to find the two fields (and hence two different Avails). +Whereas in case (B) we reach the lookup_ie case for IEThingWith, +which looks up 'S' and then finds the unique 'foo' amongst its children. See T16745 for a test of this. - -} +-- | All the 'GlobalRdrElt's associated with an 'AvailInfo'. +gresFromAvail :: HasDebugCallStack + => HscEnv -> Maybe ImportSpec -> AvailInfo -> [GlobalRdrElt] +gresFromAvail hsc_env prov avail = + [ mk_gre nm info + | nm <- availNames avail + , let info = lookupGREInfo hsc_env nm ] + where + + mk_gre n info + = case prov of + -- Nothing => bound locally + -- Just is => imported from 'is' + Nothing -> GRE { gre_name = n, gre_par = mkParent n avail + , gre_lcl = True, gre_imp = emptyBag + , gre_info = info } + Just is -> GRE { gre_name = n, gre_par = mkParent n avail + , gre_lcl = False, gre_imp = unitBag is + , gre_info = info } + +-- | All the 'GlobalRdrElt's associated with a collection of 'AvailInfo's. +gresFromAvails :: HscEnv -> Maybe ImportSpec -> [AvailInfo] -> [GlobalRdrElt] +gresFromAvails hsc_env prov = concatMap (gresFromAvail hsc_env prov) + filterImports - :: ModIface - -> ImpDeclSpec -- The span for the entire import decl - -> Maybe (ImportListInterpretation, LocatedL [LIE GhcPs]) -- Import spec; True => hiding + :: HasDebugCallStack + => HscEnv + -> ModIface + -> ImpDeclSpec + -- ^ Import spec + -> Maybe (ImportListInterpretation, LocatedL [LIE GhcPs]) + -- ^ Whether this is a "hiding" import list -> RnM (Maybe (ImportListInterpretation, LocatedL [LIE GhcRn]), -- Import spec w/ Names [GlobalRdrElt]) -- Same again, but in GRE form -filterImports iface decl_spec Nothing - = return (Nothing, gresFromAvails (Just imp_spec) (mi_exports iface)) +filterImports hsc_env iface decl_spec Nothing + = return (Nothing, gresFromAvails hsc_env (Just imp_spec) all_avails) where + all_avails = mi_exports iface imp_spec = ImpSpec { is_decl = decl_spec, is_item = ImpAll } - -filterImports iface decl_spec (Just (want_hiding, L l import_items)) +filterImports hsc_env iface decl_spec (Just (want_hiding, L l import_items)) = do -- check for errors, convert RdrNames to Names items1 <- mapM lookup_lie import_items - let items2 :: [(LIE GhcRn, AvailInfo)] + let items2 :: [(LIE GhcRn, [GlobalRdrElt])] items2 = concat items1 - -- NB the AvailInfo may have duplicates, and several items + -- NB we may have duplicates, and several items -- for the same parent; e.g N(x) and N(y) - names = availsToNameSetWithSelectors (map snd items2) - keep n = not (n `elemNameSet` names) - pruned_avails = filterAvails keep all_avails - hiding_spec = ImpSpec { is_decl = decl_spec, is_item = ImpAll } - - gres | want_hiding == EverythingBut = gresFromAvails (Just hiding_spec) pruned_avails - | otherwise = concatMap (gresFromIE decl_spec) items2 + gres = case want_hiding of + Exactly -> + concatMap (gresFromIE decl_spec) items2 + EverythingBut -> + let hidden_names = mkNameSet $ concatMap (map greName . snd) items2 + keep n = not (n `elemNameSet` hidden_names) + all_gres = gresFromAvails hsc_env (Just hiding_spec) all_avails + in filter (keep . greName) all_gres return (Just (want_hiding, L l (map fst items2)), gres) where all_avails = mi_exports iface - - -- See Note [Dealing with imports] - imp_occ_env :: OccEnv (NameEnv (GreName, -- the name or field - AvailInfo, -- the export item providing it - Maybe Name)) -- the parent of associated types - imp_occ_env = mkOccEnv_C (plusNameEnv_C combine) - [ (occName c, mkNameEnv [(greNameMangledName c, (c, a, Nothing))]) - | a <- all_avails - , c <- availGreNames a] - -- See Note [Dealing with imports] - -- 'combine' may be called for associated data 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) - -- NB: the AvailTC can have fields as well as data constructors (#12127) - combine :: (GreName, AvailInfo, Maybe Name) - -> (GreName, AvailInfo, Maybe Name) - -> (GreName, AvailInfo, Maybe Name) - combine (NormalGreName name1, a1@(AvailTC p1 _), mb1) - (NormalGreName name2, a2@(AvailTC p2 _), mb2) - = assertPpr (name1 == name2 && isNothing mb1 && isNothing mb2) - (ppr name1 <+> ppr name2 <+> ppr mb1 <+> ppr mb2) $ - if p1 == name1 then (NormalGreName name1, a1, Just p2) - else (NormalGreName name1, a2, Just p1) - -- 'combine' may also be called for pattern synonyms which appear both - -- unassociated and associated (see Note [Importing PatternSynonyms]). - combine (c1, a1, mb1) (c2, a2, mb2) - = assertPpr (c1 == c2 && isNothing mb1 && isNothing mb2 - && (isAvailTC a1 || isAvailTC a2)) - (ppr c1 <+> ppr c2 <+> ppr a1 <+> ppr a2 <+> ppr mb1 <+> ppr mb2) $ - if isAvailTC a1 then (c1, a1, Nothing) - else (c1, a2, Nothing) - - isAvailTC AvailTC{} = True - isAvailTC _ = False + hiding_spec = ImpSpec { is_decl = decl_spec, is_item = ImpAll } + imp_occ_env = mkImportOccEnv hsc_env decl_spec all_avails -- Look up a RdrName used in an import, failing if it is ambiguous -- (e.g. because it refers to multiple record fields) - lookup_name :: IE GhcPs -> RdrName -> IELookupM (Name, AvailInfo, Maybe Name) + lookup_name :: IE GhcPs -> RdrName -> IELookupM ImpOccItem lookup_name ie rdr = do xs <- lookup_names ie rdr case xs of [cax] -> return cax - _ -> failLookupWith (AmbiguousImport rdr (map sndOf3 xs)) + _ -> failLookupWith (AmbiguousImport rdr (map imp_item xs)) -- Look up a RdrName used in an import, returning multiple values if there -- are several fields with the same name exposed by the module - lookup_names :: IE GhcPs -> RdrName -> IELookupM [(Name, AvailInfo, Maybe Name)] + lookup_names :: IE GhcPs -> RdrName -> IELookupM [ImpOccItem] lookup_names ie rdr - | isQual rdr = failLookupWith (QualImportError rdr) - | Just succ <- mb_success = return $ map (\ (c,a,x) -> (greNameMangledName c, a, x)) (nonDetNameEnvElts succ) - | otherwise = failLookupWith (BadImport ie) + | isQual rdr + = failLookupWith (QualImportError rdr) + | null lookups + = failLookupWith (BadImport ie) + | otherwise + = return $ concatMap nonDetNameEnvElts lookups where - mb_success = lookupOccEnv imp_occ_env (rdrNameOcc rdr) + lookups = lookupOccEnv_WithFields imp_occ_env (rdrNameOcc rdr) - lookup_lie :: LIE GhcPs -> TcRn [(LIE GhcRn, AvailInfo)] + lookup_lie :: LIE GhcPs -> TcRn [(LIE GhcRn, [GlobalRdrElt])] lookup_lie (L loc ieRdr) = do (stuff, warns) <- setSrcSpanA loc $ liftM (fromMaybe ([],[])) $ run_lookup (lookup_ie ieRdr) mapM_ emit_warning warns - return [ (L loc ie, avail) | (ie,avail) <- stuff ] + return [ (L loc ie, gres) | (ie,gres) <- stuff ] where - -- Warn when importing T(..) if T was exported abstractly + -- Warn when importing T(..) and no children are brought in scope emit_warning (DodgyImport n) = whenWOptM Opt_WarnDodgyImports $ addTcRnDiagnostic (TcRnDodgyImports n) emit_warning MissingImportList = whenWOptM Opt_WarnMissingImportList $ @@ -1345,51 +1281,45 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items)) AmbiguousImport rdr xs -> ambiguousImportItemErr rdr xs -- For each import item, we convert its RdrNames to Names, - -- and at the same time construct an AvailInfo corresponding + -- and at the same time compute all the GlobalRdrElt corresponding -- to what is actually imported by this item. -- Returns Nothing on error. - -- We return a list here, because in the case of an import - -- item like C, if we are hiding, then C refers to *both* a - -- type/class and a data constructor. Moreover, when we import - -- data constructors of an associated family, we need separate - -- AvailInfos for the data constructors and the family (as they have - -- different parents). See Note [Dealing with imports] + -- + -- Returns a list because, with DuplicateRecordFields, a naked + -- import/export of a record field can correspond to multiple + -- different GlobalRdrElts. See Note [Importing DuplicateRecordFields]. lookup_ie :: IE GhcPs - -> IELookupM ([(IE GhcRn, AvailInfo)], [IELookupWarning]) + -> IELookupM ([(IE GhcRn, [GlobalRdrElt])], [IELookupWarning]) lookup_ie ie = handle_bad_import $ case ie of IEVar _ (L l n) -> do -- See Note [Importing DuplicateRecordFields] xs <- lookup_names ie (ieWrappedName n) - return ([(IEVar noExtField (L l (replaceWrappedName n name)), - trimAvail avail name) - | (name, avail, _) <- xs ], []) + return ( [ (IEVar noExtField (L l (replaceWrappedName n name)), [gre]) + | ImpOccItem { imp_item = gre } <- xs + , let name = greName gre ] + , [] ) IEThingAll _ (L l tc) -> do - (name, avail, mb_parent) <- lookup_name ie $ ieWrappedName tc - let warns = case avail of - Avail {} -- e.g. f(..) - -> [DodgyImport $ ieWrappedName tc] + ImpOccItem gre child_gres _ <- lookup_name ie $ ieWrappedName tc + let name = greName gre + warns - AvailTC _ subs - | null (drop 1 subs) -- e.g. T(..) where T is a synonym - -> [DodgyImport $ ieWrappedName tc] + | null child_gres + -- e.g. f(..) or T(..) where T is a type synonym + = [DodgyImport gre] - | not (is_qual decl_spec) -- e.g. import M( T(..) ) - -> [MissingImportList] + -- e.g. import M( T(..) ) + | not (is_qual decl_spec) + = [MissingImportList] - | otherwise - -> [] + | otherwise + = [] renamed_ie = IEThingAll noAnn (L l (replaceWrappedName tc name)) - sub_avails = case avail of - Avail {} -> [] - AvailTC name2 subs -> [(renamed_ie, AvailTC name2 (subs \\ [NormalGreName name]))] - case mb_parent of - Nothing -> return ([(renamed_ie, avail)], warns) - -- non-associated ty/cls - Just parent -> return ((renamed_ie, AvailTC parent [NormalGreName name]) : sub_avails, warns) - -- associated type + + return ([(renamed_ie, gre:child_gres)], warns) + IEThingAbs _ (L l tc') | want_hiding == EverythingBut -- hiding ( C ) @@ -1401,19 +1331,18 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items)) in case catIELookupM [ tc_name, dc_name ] of [] -> failLookupWith (BadImport ie) - names -> return ([mkIEThingAbs tc' l name | name <- names], []) + names -> return ([mkIEThingAbs tc' l (imp_item name) | name <- names], []) | otherwise - -> do nameAvail <- lookup_name ie (ieWrappedName tc') - return ([mkIEThingAbs tc' l nameAvail] - , []) + -> do ImpOccItem { imp_item = gre } <- lookup_name ie (ieWrappedName tc') + return ([mkIEThingAbs tc' l gre], []) IEThingWith xt ltc@(L l rdr_tc) wc rdr_ns -> do - (name, avail, mb_parent) + ImpOccItem { imp_item = gre, imp_bundled = subnames } <- lookup_name (IEThingAbs noAnn ltc) (ieWrappedName rdr_tc) + let name = greName gre -- Look up the children in the sub-names of the parent -- See Note [Importing DuplicateRecordFields] - let subnames = availSubordinateGreNames avail case lookupChildren subnames rdr_ns of Failed rdrs -> failLookupWith (BadImport (IEThingWith xt ltc wc rdrs)) @@ -1422,36 +1351,22 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items)) -- to report as failing, namely T( b, d ). -- c.f. #15412 - Succeeded (childnames, childflds) -> - case mb_parent of - -- non-associated ty/cls - Nothing - -> return ([(IEThingWith childflds (L l name') wc childnames', - availTC name (name:map unLoc childnames) (map unLoc childflds))], - []) - where name' = replaceWrappedName rdr_tc name - childnames' = map to_ie_post_rn childnames - -- childnames' = postrn_ies childnames - -- associated ty - Just parent - -> return ([(IEThingWith childflds (L l name') wc childnames', - availTC name (map unLoc childnames) (map unLoc childflds)), - (IEThingWith childflds (L l name') wc childnames', - availTC parent [name] [])], - []) - where name' = replaceWrappedName rdr_tc name - childnames' = map to_ie_post_rn childnames + Succeeded childnames -> + return ([ (IEThingWith xt (L l name') wc childnames' + ,gre : map unLoc childnames)] + , []) + + where name' = replaceWrappedName rdr_tc name + childnames' = map (to_ie_post_rn . fmap greName) childnames _other -> failLookupWith IllegalImport - -- could be IEModuleContents, IEGroup, IEDoc, IEDocNamed - -- all errors. + -- could be IEModuleContents, IEGroup, IEDoc, IEDocNamed... + -- all of those constitute errors. where - mkIEThingAbs tc l (n, av, Nothing ) - = (IEThingAbs noAnn (L l (replaceWrappedName tc n)), trimAvail av n) - mkIEThingAbs tc l (n, _, Just parent) - = (IEThingAbs noAnn (L l (replaceWrappedName tc n)) - , availTC parent [n] []) + mkIEThingAbs tc l gre + = (IEThingAbs noAnn (L l (replaceWrappedName tc n)), [gre]) + where n = greName gre handle_bad_import m = catchIELookup m $ \err -> case err of BadImport ie | want_hiding == EverythingBut -> return ([], [BadImportW ie]) @@ -1462,14 +1377,13 @@ type IELookupM = MaybeErr IELookupError data IELookupWarning = BadImportW (IE GhcPs) | MissingImportList - | DodgyImport RdrName - -- NB. use the RdrName for reporting a "dodgy" import + | DodgyImport GlobalRdrElt data IELookupError = QualImportError RdrName | BadImport (IE GhcPs) | IllegalImport - | AmbiguousImport RdrName [AvailInfo] -- e.g. a duplicated field name as a top-level import + | AmbiguousImport RdrName [GlobalRdrElt] -- e.g. a duplicated field name as a top-level import failLookupWith :: IELookupError -> IELookupM a failLookupWith err = Failed err @@ -1482,6 +1396,76 @@ catchIELookup m h = case m of catIELookupM :: [IELookupM a] -> [a] catIELookupM ms = [ a | Succeeded a <- ms ] +-- | Information associated to an 'AvailInfo' used in constructing +-- an 'OccEnv' corresponding to imports. +-- +-- See Note [Dealing with imports]. +data ImpOccItem + = ImpOccItem + { imp_item :: GlobalRdrElt + -- ^ The import item + , imp_bundled :: [GlobalRdrElt] + -- ^ Items bundled in the Avail this import item came from, + -- not including the import item itself if it is a parent. + , imp_is_parent :: Bool + -- ^ Is the import item a parent? See Note [Dealing with imports]. + } + +-- | Make an 'OccEnv' of all the imports. +-- +-- Complicated by the fact that associated data types and pattern synonyms +-- can appear twice. See Note [Dealing with imports]. +mkImportOccEnv :: HscEnv -> ImpDeclSpec -> [IfaceExport] -> OccEnv (NameEnv ImpOccItem) +mkImportOccEnv hsc_env decl_spec all_avails = + mkOccEnv_C (plusNameEnv_C combine) + [ (occ, mkNameEnv [(nm, ImpOccItem g bundled is_parent)]) + | avail <- all_avails + , let gs = gresFromAvail hsc_env (Just hiding_spec) avail + , g <- gs + , let nm = greName g + occ = greOccName g + (is_parent, bundled) = case avail of + AvailTC c _ + -> if c == nm -- (Recall the AvailTC invariant) + then ( True, case gs of { g0 : gs' | greName g0 == nm -> gs'; _ -> gs } ) + else ( False, gs ) + _ -> ( False, [] ) + ] + where + + hiding_spec = ImpSpec { is_decl = decl_spec, is_item = ImpAll } + + -- See Note [Dealing with imports] + -- 'combine' may be called for associated data 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) + -- NB: the AvailTC can have fields as well as data constructors (#12127) + combine :: ImpOccItem -> ImpOccItem -> ImpOccItem + combine item1@(ImpOccItem { imp_item = gre1, imp_is_parent = is_parent1 }) + item2@(ImpOccItem { imp_item = gre2, imp_is_parent = is_parent2 }) + | is_parent1 || is_parent2 + , not (isRecFldGRE gre1 || isRecFldGRE gre2) -- NB: does not force GREInfo. + , let name1 = greName gre1 + name2 = greName gre2 + = assertPpr (name1 == name2) + (ppr name1 <+> ppr name2) $ + if is_parent1 + then item1 + else item2 + -- Discard C(C,T) in favour of T(T, T1, T2, T3). + + -- 'combine' may also be called for pattern synonyms which appear both + -- unassociated and associated (see Note [Importing PatternSynonyms]). + combine item1@(ImpOccItem { imp_item = c1, imp_bundled = kids1 }) + item2@(ImpOccItem { imp_item = c2, imp_bundled = kids2 }) + = assertPpr (greName c1 == greName c2 + && (not (null kids1 && null kids2))) + (ppr c1 <+> ppr c2 <+> ppr kids1 <+> ppr kids2) $ + if null kids1 + then item2 + else item1 + -- Discard standalone pattern P in favour of T(P). + {- ************************************************************************ * * @@ -1490,20 +1474,22 @@ catIELookupM ms = [ a | Succeeded a <- ms ] ************************************************************************ -} --- | Given an import\/export spec, construct the appropriate 'GlobalRdrElt's. -gresFromIE :: ImpDeclSpec -> (LIE GhcRn, AvailInfo) -> [GlobalRdrElt] -gresFromIE decl_spec (L loc ie, avail) - = gresFromAvail prov_fn avail +-- | Given an import\/export spec, appropriately set the @gre_imp@ field +-- for the 'GlobalRdrElt's. +gresFromIE :: ImpDeclSpec -> (LIE GhcRn, [GlobalRdrElt]) -> [GlobalRdrElt] +gresFromIE decl_spec (L loc ie, gres) + = map set_gre_imp gres where is_explicit = case ie of IEThingAll _ name -> \n -> n == lieWrappedName name _ -> \_ -> True prov_fn name - = Just (ImpSpec { is_decl = decl_spec, is_item = item_spec }) + = ImpSpec { is_decl = decl_spec, is_item = item_spec } where item_spec = ImpSome { is_explicit = is_explicit name , is_iloc = locA loc } - + set_gre_imp gre@( GRE { gre_name = nm } ) + = gre { gre_imp = unitBag $ prov_fn nm } {- Note [Children for duplicate record fields] @@ -1531,9 +1517,10 @@ mkChildEnv gres = foldr add emptyNameEnv gres findChildren :: NameEnv [a] -> Name -> [a] findChildren env n = lookupNameEnv env n `orElse` [] -lookupChildren :: [GreName] -> [LIEWrappedName GhcPs] +lookupChildren :: [GlobalRdrElt] + -> [LIEWrappedName GhcPs] -> MaybeErr [LIEWrappedName GhcPs] -- The ones for which the lookup failed - ([LocatedA Name], [Located FieldLabel]) + [LocatedA GlobalRdrElt] -- (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 @@ -1543,7 +1530,7 @@ lookupChildren :: [GreName] -> [LIEWrappedName GhcPs] -- (Really the rdr_items should be FastStrings in the first place.) lookupChildren all_kids rdr_items | null fails - = Succeeded (fmap concat (partitionEithers oks)) + = Succeeded (concat oks) -- This 'fmap concat' trickily applies concat to the /second/ component -- of the pair, whose type is ([LocatedA Name], [[Located FieldLabel]]) | otherwise @@ -1552,20 +1539,23 @@ lookupChildren all_kids rdr_items mb_xs = map doOne rdr_items fails = [ bad_rdr | Failed bad_rdr <- mb_xs ] oks = [ ok | Succeeded ok <- mb_xs ] - oks :: [Either (LocatedA Name) [Located FieldLabel]] + oks :: [[LocatedA GlobalRdrElt]] doOne item@(L l r) = case (lookupFsEnv kid_env . occNameFS . rdrNameOcc . ieWrappedName) r of - Just [NormalGreName n] -> Succeeded (Left (L l n)) - Just rs | Just fs <- traverse greNameFieldLabel rs -> Succeeded (Right (map (L (locA l)) fs)) - _ -> Failed item + Just [g] + | not $ isRecFldGRE g + -> Succeeded [L l g] + Just gs + | all isRecFldGRE gs + -> Succeeded $ map (L l) gs + _ -> Failed item -- See Note [Children for duplicate record fields] kid_env = extendFsEnvList_C (++) emptyFsEnv [(occNameFS (occName x), [x]) | x <- all_kids] - ------------------------------- {- @@ -1600,11 +1590,11 @@ reportUnusedNames gbl_env hsc_src gre_is_used :: NameSet -> GlobalRdrElt -> Bool gre_is_used used_names gre0 = name `elemNameSet` used_names - || any (\ gre -> greMangledName gre `elemNameSet` used_names) (findChildren kids_env name) + || any (\ gre -> greName 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) where - name = greMangledName gre0 + name = greName gre0 -- Filter out the ones that are -- (a) defined in this module, and @@ -1621,7 +1611,8 @@ reportUnusedNames gbl_env hsc_src in filter is_unused_local defined_but_not_used is_unused_local :: GlobalRdrElt -> Bool - is_unused_local gre = isLocalGRE gre && isExternalName (greMangledName gre) + is_unused_local gre = isLocalGRE gre + && isExternalName (greName gre) {- ********************************************************************* * * @@ -1756,7 +1747,6 @@ warnUnusedImportDecls gbl_env hsc_src -- 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 uses @@ -1766,7 +1756,7 @@ warnUnusedImportDecls gbl_env hsc_src , text "Import usage" <+> ppr usage]) ; whenWOptM Opt_WarnUnusedImports $ - mapM_ (warnUnusedImport Opt_WarnUnusedImports fld_env) usage + mapM_ (warnUnusedImport Opt_WarnUnusedImports rdr_env) usage ; whenGOptM Opt_D_dump_minimal_imports $ printMinimalImports hsc_src usage } @@ -1789,7 +1779,7 @@ findImportUsage imports used_gres -- srcSpanEnd: see Note [The ImportMap] `orElse` [] - used_names = mkNameSet (map greMangledName used_gres) + used_names = mkNameSet (map greName used_gres) used_parents = mkNameSet (mapMaybe greParent_maybe used_gres) unused_imps -- Not trivial; see eg #7454 @@ -1802,10 +1792,10 @@ findImportUsage imports used_gres add_unused (IEVar _ n) acc = add_unused_name (lieWrappedName n) acc add_unused (IEThingAbs _ n) acc = add_unused_name (lieWrappedName n) acc add_unused (IEThingAll _ n) acc = add_unused_all (lieWrappedName n) acc - add_unused (IEThingWith fs p wc ns) acc = + add_unused (IEThingWith _ p wc ns) acc = add_wc_all (add_unused_with pn xs acc) where pn = lieWrappedName p - xs = map lieWrappedName ns ++ map (flSelector . unLoc) fs + xs = map lieWrappedName ns add_wc_all = case wc of NoIEWildcard -> id IEWildcard _ -> add_unused_all pn @@ -1868,9 +1858,9 @@ mkImportMap gres best_imp_spec = bestImport (bagToList imp_specs) add _ gres = gre : gres -warnUnusedImport :: WarningFlag -> NameEnv (FieldLabelString, Parent) +warnUnusedImport :: WarningFlag -> GlobalRdrEnv -> ImportDeclUsage -> RnM () -warnUnusedImport flag fld_env (L loc decl, used, unused) +warnUnusedImport flag rdr_env (L loc decl, used, unused) -- Do not warn for 'import M()' | Just (Exactly, L _ []) <- ideclImportList decl @@ -1923,10 +1913,15 @@ warnUnusedImport flag fld_env (L loc decl, used, unused) -- In warning message, pretty-print identifiers unqualified unconditionally -- to improve the consistent for ambiguous/unambiguous identifiers. -- See trac#14881. - ppr_possible_field n = case lookupNameEnv fld_env n of - Just (fld, ParentIs p) -> pprNameUnqualified p <> parens (ppr fld) - Just (fld, NoParent) -> ppr fld - Nothing -> pprNameUnqualified n + ppr_possible_field n = + case lookupGRE_Name rdr_env n of + Just (GRE { gre_par = par, gre_info = IAmRecField info }) -> + let fld_occ :: OccName + fld_occ = nameOccName $ flSelector $ recFieldLabel info + in case par of + ParentIs p -> pprNameUnqualified p <> parens (ppr fld_occ) + NoParent -> ppr fld_occ + _ -> pprNameUnqualified n -- Print unused names in a deterministic (lexicographic) order sort_unused :: SDoc @@ -1957,9 +1952,11 @@ decls, and simply trim their import lists. NB that -} getMinimalImports :: [ImportDeclUsage] -> RnM [LImportDecl GhcRn] -getMinimalImports = fmap combine . mapM mk_minimal +getMinimalImports ie_decls + = do { rdr_env <- getGlobalRdrEnv + ; fmap combine $ mapM (mk_minimal rdr_env) ie_decls } where - mk_minimal (L l decl, used_gres, unused) + mk_minimal rdr_env (L l decl, used_gres, unused) | null unused , Just (Exactly, _) <- ideclImportList decl = return (L l decl) @@ -1969,42 +1966,51 @@ getMinimalImports = fmap combine . mapM mk_minimal , ideclPkgQual = pkg_qual } = decl ; iface <- loadSrcInterface doc mod_name is_boot pkg_qual ; let used_avails = gresToAvailInfo used_gres - lies = map (L l) (concatMap (to_ie iface) used_avails) + ; lies <- map (L l) <$> concatMapM (to_ie rdr_env iface) used_avails ; return (L l (decl { ideclImportList = Just (Exactly, L (l2l l) lies) })) } where doc = text "Compute minimal imports for" <+> ppr decl - to_ie :: ModIface -> AvailInfo -> [IE GhcRn] + to_ie :: GlobalRdrEnv -> ModIface -> AvailInfo -> RnM [IE GhcRn] -- The main trick here is that if we're importing all the constructors -- we want to say "T(..)", but if we're importing only a subset we want -- to say "T(A,B,C)". So we have to find out what the module exports. - to_ie _ (Avail c) -- Note [Overloaded field import] - = [IEVar noExtField (to_ie_post_rn $ noLocA (greNamePrintableName c))] - to_ie _ avail@(AvailTC n [_]) -- Exporting the main decl and nothing else - | availExportsDecl avail = [IEThingAbs noAnn (to_ie_post_rn $ noLocA n)] - to_ie iface (AvailTC n cs) - = case [xs | avail@(AvailTC x xs) <- mi_exports iface - , x == n - , availExportsDecl avail -- Note [Partial export] - ] of - [xs] | all_used xs -> - [IEThingAll noAnn (to_ie_post_rn $ noLocA n)] - | otherwise -> - [IEThingWith (map noLoc fs) (to_ie_post_rn $ noLocA n) NoIEWildcard - (map (to_ie_post_rn . noLocA) (filter (/= n) ns))] - -- Note [Overloaded field import] - _other | all_non_overloaded fs - -> map (IEVar noExtField . to_ie_post_rn_var . noLocA) $ ns - ++ map flSelector fs - | otherwise -> - [IEThingWith (map noLoc fs) (to_ie_post_rn $ noLocA n) NoIEWildcard - (map (to_ie_post_rn . noLocA) (filter (/= n) ns))] + to_ie rdr_env _ (Avail c) -- Note [Overloaded field import] + = do { let + gre = expectJust "getMinimalImports Avail" $ lookupGRE_Name rdr_env c + ; return $ [IEVar noExtField (to_ie_post_rn $ noLocA $ greName gre)] } + to_ie _ _ avail@(AvailTC n [_]) -- Exporting the main decl and nothing else + | availExportsDecl avail + = return [IEThingAbs noAnn (to_ie_post_rn $ noLocA n)] + to_ie rdr_env iface (AvailTC n cs) = + case [ xs | avail@(AvailTC x xs) <- mi_exports iface + , x == n + , availExportsDecl avail -- Note [Partial export] + ] of + [xs] + | all_used xs + -> return [IEThingAll noAnn (to_ie_post_rn $ noLocA n)] + | otherwise + -> do { let ns_gres = map (expectJust "getMinimalImports AvailTC" . lookupGRE_Name rdr_env) cs + ns = map greName ns_gres + ; return [IEThingWith noAnn (to_ie_post_rn $ noLocA n) NoIEWildcard + (map (to_ie_post_rn . noLocA) (filter (/= n) ns))] } + -- Note [Overloaded field import] + _other + -> do { let infos = map (expectJust "getMinimalImports AvailTC" . lookupGRE_Name rdr_env) cs + (ns_gres,fs_gres) = classifyGREs infos + ns = map greName (ns_gres ++ fs_gres) + fs = map fieldGREInfo fs_gres + ; return $ + if all_non_overloaded fs + then map (IEVar noExtField . to_ie_post_rn_var . noLocA) ns + else [IEThingWith noAnn (to_ie_post_rn $ noLocA n) NoIEWildcard + (map (to_ie_post_rn . noLocA) (filter (/= n) ns))] } where - (ns, fs) = partitionGreNames cs all_used avail_cs = all (`elem` cs) avail_cs - all_non_overloaded = all (not . flIsOverloaded) + all_non_overloaded = all (not . flIsOverloaded . recFieldLabel) combine :: [LImportDecl GhcRn] -> [LImportDecl GhcRn] combine = map merge . NE.groupAllWith getKey @@ -2023,6 +2029,8 @@ getMinimalImports = fmap combine . mapM mk_minimal merge decls@((L l decl) :| _) = L l (decl { ideclImportList = Just (Exactly, L (noAnnSrcSpan (locA l)) lies) }) where lies = concatMap (unLoc . snd) $ mapMaybe (ideclImportList . unLoc) $ NE.toList decls +classifyGREs :: [GlobalRdrElt] -> ([GlobalRdrElt], [FieldGlobalRdrElt]) +classifyGREs = partition (not . isRecFldGRE) printMinimalImports :: HscSource -> [ImportDeclUsage] -> RnM () -- See Note [Printing minimal imports] @@ -2130,13 +2138,10 @@ qualImportItemErr rdr = hang (text "Illegal qualified name in import item:") 2 (ppr rdr) -ambiguousImportItemErr :: RdrName -> [AvailInfo] -> SDoc -ambiguousImportItemErr rdr avails +ambiguousImportItemErr :: RdrName -> [GlobalRdrElt] -> SDoc +ambiguousImportItemErr rdr gres = hang (text "Ambiguous name" <+> quotes (ppr rdr) <+> text "in import item. It could refer to:") - 2 (vcat (map ppr_avail avails)) - where - ppr_avail (AvailTC parent _) = ppr parent <> parens (ppr rdr) - ppr_avail (Avail name) = ppr name + 2 (vcat (map (ppr . greOccName) gres)) pprImpDeclSpec :: ModIface -> ImpDeclSpec -> SDoc pprImpDeclSpec iface decl_spec = @@ -2181,10 +2186,10 @@ badImportItemErr iface decl_spec ie avails where checkIfDataCon (AvailTC _ ns) = case find (\n -> importedFS == occNameFS (occName n)) ns of - Just n -> isDataConName (greNameMangledName n) + Just n -> isDataConName n Nothing -> False checkIfDataCon _ = False - availOccName = occName . availGreName + availOccName = occName . availName importedFS = occNameFS . rdrNameOcc $ ieName ie illegalImportItemErr :: SDoc @@ -2204,9 +2209,7 @@ addDupDeclErr gres@(gre :| _) where sorted_names = NE.sortBy (SrcLoc.leftmost_smallest `on` nameSrcSpan) - (fmap greMangledName gres) - - + (fmap greName gres) missingImportListWarn :: ModuleName -> SDoc missingImportListWarn mod diff --git a/compiler/GHC/Rename/Pat.hs b/compiler/GHC/Rename/Pat.hs index ccfb77fbde..0b01f2cbcb 100644 --- a/compiler/GHC/Rename/Pat.hs +++ b/compiler/GHC/Rename/Pat.hs @@ -56,33 +56,35 @@ import GHC.Rename.Utils ( newLocalBndrRn, bindLocalNames , wrapGenSpan, genHsApps, genLHsVar, genHsIntegralLit, warnForallIdentifier ) import GHC.Rename.HsType import GHC.Builtin.Names -import GHC.Types.Avail ( greNameMangledName ) + import GHC.Types.Error import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.Name.Reader +import GHC.Types.Unique.Set + import GHC.Types.Basic import GHC.Types.SourceText import GHC.Utils.Misc +import GHC.Data.FastString ( uniqCompareFS ) import GHC.Data.List.SetOps( removeDups ) import GHC.Utils.Outputable import GHC.Utils.Panic.Plain import GHC.Types.SrcLoc import GHC.Types.Literal ( inCharRange ) +import GHC.Types.GREInfo ( ConInfo(..), conInfoFields ) import GHC.Builtin.Types ( nilDataCon ) import GHC.Core.DataCon -import GHC.Driver.Session ( getDynFlags, xopt_DuplicateRecordFields ) import qualified GHC.LanguageExtensions as LangExt import Control.Monad ( when, ap, guard, unless ) import Data.Foldable +import Data.Function ( on ) import Data.Functor.Identity ( Identity (..) ) import qualified Data.List.NonEmpty as NE import Data.Maybe import Data.Ratio -import GHC.Types.FieldLabel (DuplicateRecordFields(..)) -import Language.Haskell.Syntax.Basic (FieldLabelString(..)) -import GHC.Types.ConInfo (ConInfo(..), conInfoFields) + {- ********************************************************* @@ -778,23 +780,24 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }) -> RnM (LHsRecField GhcRn (LocatedA arg)) rn_fld pun_ok parent (L l (HsFieldBind - { hfbLHS = - (L loc (FieldOcc _ (L ll lbl))) + { hfbLHS = L loc (FieldOcc _ (L ll lbl)) , hfbRHS = arg - , hfbPun = pun })) + , hfbPun = pun })) = do { sel <- setSrcSpanA loc $ lookupRecFieldOcc parent lbl + ; let arg_rdr = mkRdrUnqual $ recFieldToVarOcc $ occName sel + -- Discard any module qualifier (#11662) ; arg' <- if pun - then do { checkErr pun_ok (TcRnIllegalFieldPunning (L (locA loc) lbl)) - -- Discard any module qualifier (#11662) - ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl) - ; return (L (l2l loc) (mk_arg (locA loc) arg_rdr)) } + then do { checkErr pun_ok $ + TcRnIllegalFieldPunning (L (locA loc) arg_rdr) + ; return $ L (l2l loc) $ + mk_arg (locA loc) arg_rdr } else return arg - ; return (L l (HsFieldBind - { hfbAnn = noAnn - , hfbLHS = (L loc (FieldOcc sel (L ll lbl))) - , hfbRHS = arg' - , hfbPun = pun })) } - + ; return $ L l $ + HsFieldBind + { hfbAnn = noAnn + , hfbLHS = L loc (FieldOcc sel (L ll arg_rdr)) + , hfbRHS = arg' + , hfbPun = pun } } rn_dotdot :: Maybe (Located RecFieldsDotDot) -- See Note [DotDot fields] in GHC.Hs.Pat -> Maybe Name -- The constructor (Nothing for an @@ -821,16 +824,16 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }) -- f x = R { .. } -- Should expand to R {x=x}, not R{x=x,y=y} arg_in_scope lbl = mkRdrUnqual lbl `elemLocalRdrEnv` lcl_env - (dot_dot_fields, dot_dot_gres) - = unzip [ (fl, gre) - | fl <- conInfoFields conInfo - , let lbl = mkVarOccFS (field_label $ flLabel fl) - , not (lbl `elemOccSet` present_flds) - , Just gre <- [lookupGRE_FieldLabel rdr_env fl] - -- Check selector is in scope - , case ctxt of - HsRecFieldCon {} -> arg_in_scope lbl - _other -> True ] + (dot_dot_fields, dot_dot_gres) = + unzip [ (fl, gre) + | fl <- conInfoFields conInfo + , let lbl = recFieldToVarOcc $ occName $ flSelector fl + , not (lbl `elemOccSet` present_flds) + , Just gre <- [lookupGRE_FieldLabel rdr_env fl] + -- Check selector is in scope + , case ctxt of + HsRecFieldCon {} -> arg_in_scope lbl + _other -> True ] ; addUsedGREs dot_dot_gres ; let locn = noAnnSrcSpan loc @@ -839,10 +842,12 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }) , hfbLHS = L (noAnnSrcSpan loc) (FieldOcc sel (L (noAnnSrcSpan loc) arg_rdr)) , hfbRHS = L locn (mk_arg loc arg_rdr) - , hfbPun = False }) + , hfbPun = False }) | fl <- dot_dot_fields , let sel = flSelector fl - , let arg_rdr = mkVarUnqual (field_label $ flLabel fl) ] } + arg_rdr = mkRdrUnqual + $ recFieldToVarOcc + $ nameOccName sel ] } rn_dotdot _dotdot _mb_con _flds = return [] @@ -854,67 +859,102 @@ 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 (getFieldLbls flds) - - --- NB: Consider this: --- module Foo where { data R = R { fld :: Int } } --- module Odd where { import Foo; fld x = x { fld = 3 } } --- Arguably this should work, because the reference to 'fld' is --- unambiguous because there is only one field id 'fld' in scope. --- But currently it's rejected. + (_, dup_flds) = removeDups (uniqCompareFS `on` (occNameFS . rdrNameOcc)) (getFieldLbls flds) + -- See the same duplicate handling logic in rnHsRecUpdFields below for further context. +-- | Rename a regular (non-overloaded) record field update, +-- disambiguating the fields if necessary. rnHsRecUpdFields - :: [LHsRecUpdField GhcPs] - -> RnM ([LHsRecUpdField GhcRn], FreeVars) + :: [LHsRecUpdField GhcPs GhcPs] + -> RnM (XLHsRecUpdLabels GhcRn, [LHsRecUpdField GhcRn GhcRn], FreeVars) rnHsRecUpdFields flds - = do { pun_ok <- xoptM LangExt.NamedFieldPuns - ; dup_fields_ok <- xopt_DuplicateRecordFields <$> getDynFlags - ; (flds1, fvss) <- mapAndUnzipM (rn_fld pun_ok dup_fields_ok) flds - ; mapM_ (addErr . dupFieldErr HsRecFieldUpd) dup_flds + = do { pun_ok <- xoptM LangExt.NamedFieldPuns - -- Check for an empty record update e {} + -- Check for an empty record update: e {} -- NB: don't complain about e { .. }, because rn_dotdot has done that already - ; when (null flds) $ addErr TcRnEmptyRecordUpdate - - ; return (flds1, plusFVs fvss) } - where - rn_fld :: Bool -> DuplicateRecordFields -> LHsRecUpdField GhcPs - -> RnM (LHsRecUpdField GhcRn, FreeVars) - rn_fld pun_ok dup_fields_ok (L l (HsFieldBind { hfbLHS = L loc f - , hfbRHS = arg - , hfbPun = pun })) - = do { let lbl = rdrNameAmbiguousFieldOcc f - ; mb_sel <- setSrcSpanA loc $ - -- Defer renaming of overloaded fields to the typechecker - -- See Note [Disambiguating record fields] in GHC.Tc.Gen.Head - lookupRecFieldOcc_update dup_fields_ok lbl - ; arg' <- if pun - then do { checkErr pun_ok (TcRnIllegalFieldPunning (L (locA loc) lbl)) - -- Discard any module qualifier (#11662) - ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl) - ; return (L (l2l loc) (HsVar noExtField - (L (l2l loc) arg_rdr))) } - else return arg - ; (arg'', fvs) <- rnLExpr arg' - - ; let (lbl', fvs') = case mb_sel of - UnambiguousGre gname -> let sel_name = greNameMangledName gname - in (Unambiguous sel_name (L (l2l loc) lbl), fvs `addOneFV` sel_name) - AmbiguousFields -> (Ambiguous noExtField (L (l2l loc) lbl), fvs) - - ; return (L l (HsFieldBind { hfbAnn = noAnn - , hfbLHS = L loc lbl' - , hfbRHS = arg'' - , hfbPun = pun }), fvs') } - - dup_flds :: [NE.NonEmpty 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) - - + ; case flds of + { [] -> failWithTc TcRnEmptyRecordUpdate + ; fld:other_flds -> + do { let dup_lbls :: [NE.NonEmpty RdrName] + (_, dup_lbls) = removeDups (uniqCompareFS `on` (occNameFS . rdrNameOcc)) + (fmap (unLoc . getFieldUpdLbl) flds) + -- NB: we compare using the underlying field label FastString, + -- in order to catch duplicates involving qualified names, + -- as in the record update `r { fld = x, Mod.fld = y }`. + -- See #21959. + -- Note that this test doesn't correctly handle exact Names, but those + -- aren't handled properly by the rest of the compiler anyway. See #22122. + ; mapM_ (addErr . dupFieldErr HsRecFieldUpd) dup_lbls + + -- See Note [Disambiguating record updates] + ; possible_parents <- lookupRecUpdFields (fld NE.:| other_flds) + ; let mb_unambig_lbls :: Maybe [FieldLabel] + fvs :: FreeVars + (mb_unambig_lbls, fvs) = + case possible_parents of + RnRecUpdParent { rnRecUpdLabels = gres } NE.:| [] + | let lbls = map fieldGRELabel $ NE.toList gres + -> ( Just lbls, mkFVs $ map flSelector lbls) + _ -> ( Nothing + , plusFVs $ map (plusFVs . map pat_syn_free_vars . NE.toList . rnRecUpdLabels) + $ NE.toList possible_parents + -- See Note [Using PatSyn FreeVars] + ) + + -- Rename each field. + ; (upd_flds, fvs') <- rn_flds pun_ok mb_unambig_lbls flds + ; let all_fvs = fvs `plusFV` fvs' + ; return (possible_parents, upd_flds, all_fvs) } } } + + where + + -- For an ambiguous record update involving pattern synonym record fields, + -- we must add all the possibly-relevant field selector names to ensure that + -- we typecheck the record update **after** we typecheck the pattern synonym + -- definition. See Note [Using PatSyn FreeVars]. + pat_syn_free_vars :: FieldGlobalRdrElt -> FreeVars + pat_syn_free_vars (GRE { gre_info = info }) + | IAmRecField fld_info <- info + , RecFieldInfo { recFieldLabel = fl, recFieldCons = cons } <- fld_info + , uniqSetAny is_PS cons + = unitFV (flSelector fl) + pat_syn_free_vars _ + = emptyFVs + + is_PS :: ConLikeName -> Bool + is_PS (PatSynName {}) = True + is_PS (DataConName {}) = False + + rn_flds :: Bool -> Maybe [FieldLabel] + -> [LHsRecUpdField GhcPs GhcPs] + -> RnM ([LHsRecUpdField GhcRn GhcRn], FreeVars) + rn_flds _ _ [] = return ([], emptyFVs) + rn_flds pun_ok mb_unambig_lbls + ((L l (HsFieldBind { hfbLHS = L loc f + , hfbRHS = arg + , hfbPun = pun })):flds) + = do { let lbl = ambiguousFieldOccRdrName f + ; (arg' :: LHsExpr GhcPs) <- if pun + then do { setSrcSpanA loc $ + checkErr pun_ok (TcRnIllegalFieldPunning (L (locA loc) lbl)) + -- Discard any module qualifier (#11662) + ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl) + ; return (L (l2l loc) (HsVar noExtField (L (l2l loc) arg_rdr))) } + else return arg + ; (arg'', fvs) <- rnLExpr arg' + ; let lbl' :: AmbiguousFieldOcc GhcRn + lbl' = case mb_unambig_lbls of + { Just (fl:_) -> + let sel_name = flSelector fl + in Unambiguous sel_name (L (l2l loc) lbl) + ; _ -> Ambiguous noExtField (L (l2l loc) lbl) } + fld' :: LHsRecUpdField GhcRn GhcRn + fld' = L l (HsFieldBind { hfbAnn = noAnn + , hfbLHS = L loc lbl' + , hfbRHS = arg'' + , hfbPun = pun }) + ; (flds', fvs') <- rn_flds pun_ok (tail <$> mb_unambig_lbls) flds + ; return (fld' : flds', fvs `plusFV` fvs') } getFieldIds :: [LHsRecField GhcRn arg] -> [Name] getFieldIds flds = map (hsRecFieldSel . unLoc) flds @@ -923,9 +963,6 @@ getFieldLbls :: forall p arg . UnXRec p => [LHsRecField p arg] -> [RdrName] getFieldLbls flds = map (unXRec @p . foLabel . unXRec @p . hfbLHS . unXRec @p) flds -getFieldUpdLbls :: [LHsRecUpdField GhcPs] -> [RdrName] -getFieldUpdLbls flds = map (rdrNameAmbiguousFieldOcc . unLoc . hfbLHS . unLoc) flds - needFlagDotDot :: HsRecFieldContext -> TcRnMessage needFlagDotDot = TcRnIllegalWildcardsInRecord . toRecordFieldPart @@ -937,7 +974,59 @@ toRecordFieldPart (HsRecFieldCon n) = RecordFieldConstructor n toRecordFieldPart (HsRecFieldPat n) = RecordFieldPattern n toRecordFieldPart (HsRecFieldUpd {}) = RecordFieldUpdate -{- +{- Note [Disambiguating record updates] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When the -XDuplicateRecordFields extension is used, to rename and typecheck +a non-overloaded record update, we might need to disambiguate the field labels. + +Consider the following definitions: + + {-# LANGUAGE DuplicateRecordFields #-} + + data R = MkR1 { fld1 :: Int, fld2 :: Char } + | MKR2 { fld1 :: Int, fld2 :: Char, fld3 :: Bool } + data S = MkS1 { fld1 :: Int } | MkS2 { fld2 :: Char } + +In a record update, the `lookupRecUpdFields` function tries to determine +the parent datatype by computing the parents (TyCon/PatSyn) which have +at least one constructor (DataCon/PatSyn) with all of the fields. + +For example, in the (non-overloaded) record update + + r { fld1 = 3, fld2 = 'x' } + +only the TyCon R contains at least one DataCon which has both of the fields +being updated: in this case, MkR1 and MkR2 have both of the updated fields. +The TyCon S also has both fields fld1 and fld2, but no single constructor +has both of those fields, so S is not a valid parent for this record update. + +Note that this check is namespace-aware, so that a record update such as + + import qualified M ( R (fld1, fld2) ) + f r = r { M.fld1 = 3 } + +is unambiguous, as only R contains the field fld1 in the M namespace. +(See however #22122 for issues relating to the usage of exact Names in +record fields.) + +See also Note [Type-directed record disambiguation] in GHC.Tc.Gen.Expr. + +Note [Using PatSyn FreeVars] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we are disambiguating a non-overloaded record update, as per +Note [Disambiguating record updates], and have determined that this +record update might involve pattern synonym record fields, it is important +to declare usage of all these pattern synonyms record fields in the returned +FreeVars of rnHsRecUpdFields. This ensures that the typechecker sees +that the typechecking of the record update depends on the typechecking +of the pattern synonym, and typechecks the pattern synonyms first. +Not doing so caused #21898. + +Note that this can be removed once GHC proposal #366 is implemented, +as we will be able to fully disambiguate the record update in the renamer, +and can immediately declare the correct used FreeVars instead of having +to over-estimate in case of ambiguity. + ************************************************************************ * * \subsubsection{Literals} diff --git a/compiler/GHC/Rename/Splice.hs b/compiler/GHC/Rename/Splice.hs index ff52727716..d8566ec747 100644 --- a/compiler/GHC/Rename/Splice.hs +++ b/compiler/GHC/Rename/Splice.hs @@ -474,8 +474,9 @@ rnTypedSplice expr ; traceRn "rnTypedSplice: typed expression splice" empty ; lcl_rdr <- getLocalRdrEnv ; gbl_rdr <- getGlobalRdrEnv - ; let gbl_names = mkNameSet [greMangledName gre | gre <- globalRdrEnvElts gbl_rdr - , isLocalGRE gre] + ; let gbl_names = mkNameSet [ greName gre + | gre <- globalRdrEnvElts gbl_rdr + , isLocalGRE gre] lcl_names = mkNameSet (localRdrEnvElts lcl_rdr) fvs2 = lcl_names `plusFV` gbl_names diff --git a/compiler/GHC/Rename/Unbound.hs b/compiler/GHC/Rename/Unbound.hs index c8e77b9e87..ee9f2c82b8 100644 --- a/compiler/GHC/Rename/Unbound.hs +++ b/compiler/GHC/Rename/Unbound.hs @@ -9,6 +9,8 @@ unbound variables. module GHC.Rename.Unbound ( mkUnboundName , mkUnboundNameRdr + , mkUnboundGRE + , mkUnboundGRERdr , isUnboundName , reportUnboundName , reportUnboundName' @@ -102,6 +104,12 @@ data IsTermInTypes = UnknownTermInTypes RdrName | TermInTypes RdrName | NoTermIn mkUnboundNameRdr :: RdrName -> Name mkUnboundNameRdr rdr = mkUnboundName (rdrNameOcc rdr) +mkUnboundGRE :: OccName -> GlobalRdrElt +mkUnboundGRE occ = localVanillaGRE NoParent $ mkUnboundName occ + +mkUnboundGRERdr :: RdrName -> GlobalRdrElt +mkUnboundGRERdr rdr = localVanillaGRE NoParent $ mkUnboundNameRdr rdr + reportUnboundName' :: WhatLooking -> RdrName -> RnM Name reportUnboundName' what_look rdr = unboundName (LF what_look WL_Anywhere) rdr @@ -165,11 +173,17 @@ notInScopeErr where_look rdr_name = NotInScope -- | Called from the typechecker ("GHC.Tc.Errors") when we find an unbound variable -unknownNameSuggestions :: WhatLooking -> DynFlags - -> HomePackageTable -> Module - -> GlobalRdrEnv -> LocalRdrEnv -> ImportAvails - -> RdrName -> ([ImportError], [GhcHint]) -unknownNameSuggestions what_look = unknownNameSuggestions_ (LF what_look WL_Anywhere) +unknownNameSuggestions :: LocalRdrEnv -> WhatLooking -> RdrName -> RnM ([ImportError], [GhcHint]) +unknownNameSuggestions lcl_env what_look tried_rdr_name = + do { dflags <- getDynFlags + ; hpt <- getHpt + ; rdr_env <- getGlobalRdrEnv + ; imp_info <- getImports + ; curr_mod <- getModule + ; return $ + unknownNameSuggestions_ + (LF what_look WL_Anywhere) + dflags hpt curr_mod rdr_env lcl_env imp_info tried_rdr_name } unknownNameSuggestions_ :: LookingFor -> DynFlags -> HomePackageTable -> Module @@ -197,8 +211,8 @@ fieldSelectorSuggestions global_env tried_rdr_name | null gres = [] | otherwise = [RemindFieldSelectorSuppressed tried_rdr_name parents] where - gres = filter isNoFieldSelectorGRE $ - lookupGRE_RdrName' tried_rdr_name global_env + gres = filter isNoFieldSelectorGRE + $ lookupGRE_RdrName (IncludeFields WantField) global_env tried_rdr_name parents = [ parent | ParentIs parent <- map gre_par gres ] similarNameSuggestions :: LookingFor -> DynFlags @@ -341,7 +355,7 @@ importSuggestions looking_for global_env hpt currMod imports rdr_name helpful_imports = filter helpful interesting_imports where helpful (_,imv) = any (isGreOk looking_for) $ - lookupGlobalRdrEnv (imv_all_exports imv) occ_name + lookupGRE_OccName (AllNameSpaces WantNormal) (imv_all_exports imv) occ_name -- Which of these do that because of an explicit hiding list resp. an -- explicit import list @@ -359,9 +373,9 @@ importSuggestions looking_for global_env hpt currMod imports rdr_name hpt_uniques = map fst (udfmToList hpt) is_last_loaded_mod modnam uniqs = lastMaybe uniqs == Just (getUnique modnam) glob_mods = nub [ mod - | gre <- globalRdrEnvElts global_env - , (mod, _) <- qualsInScope gre - ] + | gre <- globalRdrEnvElts global_env + , (mod, _) <- qualsInScope gre + ] extensionSuggestions :: RdrName -> [GhcHint] extensionSuggestions rdrName @@ -403,12 +417,15 @@ nameSpacesRelated :: DynFlags -- ^ to find out whether -XDataKinds is enabled -> NameSpace -- ^ Name space of a name that might have been meant -> Bool nameSpacesRelated dflags what_looking ns ns' - = ns' `elem` ns : [ other_ns - | (orig_ns, others) <- other_namespaces - , ns == orig_ns - , (other_ns, wls) <- others - , what_looking `elem` WL_Anything : wls - ] + | ns == ns' + = True + | otherwise + = or [ other_ns ns' + | (orig_ns, others) <- other_namespaces + , orig_ns ns + , (other_ns, wls) <- others + , what_looking `elem` WL_Anything : wls + ] where -- explanation: -- [(orig_ns, [(other_ns, what_looking_possibilities)])] @@ -416,19 +433,21 @@ nameSpacesRelated dflags what_looking ns ns' -- and what_looking is either WL_Anything or is one of -- what_looking_possibilities other_namespaces = - [ (varName , [(dataName, [WL_Constructor])]) - , (dataName , [(varName , [WL_RecField])]) - , (tvName , (tcClsName, [WL_Constructor]) : promoted_datacons) - , (tcClsName, (tvName , []) : promoted_datacons) + [ (isVarNameSpace , [(isFieldNameSpace , [WL_RecField]) + ,(isDataConNameSpace, [WL_Constructor])]) + , (isDataConNameSpace , [(isVarNameSpace , [WL_RecField])]) + , (isTvNameSpace , (isTcClsNameSpace , [WL_Constructor]) + : promoted_datacons) + , (isTcClsNameSpace , (isTvNameSpace , []) + : promoted_datacons) ] -- If -XDataKinds is enabled, the data constructor name space is also -- related to the type-level name spaces data_kinds = xopt LangExt.DataKinds dflags - promoted_datacons = [(dataName, [WL_Constructor]) | data_kinds] + promoted_datacons = [(isDataConNameSpace, [WL_Constructor]) | data_kinds] -{- -Note [Related name spaces] -~~~~~~~~~~~~~~~~~~~~~~~~~ +{- Note [Related name spaces] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Name spaces are related if there is a chance to mean the one when one writes the other, i.e. variables <-> data constructors and type variables <-> type constructors. diff --git a/compiler/GHC/Rename/Utils.hs b/compiler/GHC/Rename/Utils.hs index 91f79af520..4992ebf309 100644 --- a/compiler/GHC/Rename/Utils.hs +++ b/compiler/GHC/Rename/Utils.hs @@ -17,7 +17,6 @@ module GHC.Rename.Utils ( warnUnusedTopBinds, warnUnusedLocalBinds, warnForallIdentifier, checkUnusedRecordWildcard, - mkFieldEnv, badQualBndrErr, typeAppErr, badFieldConErr, wrapGenSpan, genHsVar, genLHsVar, genHsApp, genHsApps, genAppType, genHsIntegralLit, genHsTyLit, genSimpleConPat, @@ -28,7 +27,7 @@ module GHC.Rename.Utils ( bindLocalNames, bindLocalNamesFV, - addNameClashErrRn, + addNameClashErrRn, mkNameClashErr, checkInferredVars, noNestedForallsContextsErr, addNoNestedForallsContextsErr @@ -171,7 +170,7 @@ checkShadowedOccs (global_env,local_env) get_loc_occ ns where (loc,occ) = get_loc_occ n mb_local = lookupLocalRdrOcc local_env occ - gres = lookupGRE_RdrName (mkRdrUnqual occ) global_env + gres = lookupGRE_RdrName (AllNameSpaces WantBoth) global_env (mkRdrUnqual occ) -- Make an Unqualified RdrName and look that up, so that -- we don't find any GREs that are in scope qualified-only @@ -450,13 +449,13 @@ warnUnusedGREs gres = mapM_ warnUnusedGRE gres -- NB the Names must not be the names of record fields! warnUnused :: WarningFlag -> [Name] -> RnM () warnUnused flag names = - mapM_ (warnUnused1 flag . NormalGreName) names + mapM_ (\ nm -> warnUnused1 flag nm (nameOccName nm)) names -warnUnused1 :: WarningFlag -> GreName -> RnM () -warnUnused1 flag child - = when (reportable child) $ +warnUnused1 :: WarningFlag -> Name -> OccName -> RnM () +warnUnused1 flag child child_occ + = when (reportable child child_occ) $ addUnusedWarning flag - (occName child) (greNameSrcSpan child) + child_occ (nameSrcSpan child) (text $ "Defined but not used" ++ opt_str) where opt_str = case flag of @@ -465,35 +464,28 @@ warnUnused1 flag child warnUnusedGRE :: GlobalRdrElt -> RnM () warnUnusedGRE gre@(GRE { gre_lcl = lcl, gre_imp = is }) - | lcl = warnUnused1 Opt_WarnUnusedTopBinds (gre_name gre) - | otherwise = when (reportable (gre_name gre)) (mapM_ warn is) + | lcl = warnUnused1 Opt_WarnUnusedTopBinds nm occ + | otherwise = when (reportable nm occ) (mapM_ warn is) where occ = greOccName gre + nm = greName gre warn spec = addUnusedWarning Opt_WarnUnusedTopBinds occ span msg where span = importSpecLoc spec pp_mod = quotes (ppr (importSpecModule spec)) msg = text "Imported from" <+> pp_mod <+> text "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, Parent) -mkFieldEnv rdr_env = mkNameEnv [ (greMangledName gre, (flLabel fl, gre_par gre)) - | gres <- nonDetOccEnvElts rdr_env - , gre <- gres - , Just fl <- [greFieldLabel gre] - ] - -- | Should we report the fact that this 'Name' is unused? The -- 'OccName' may differ from 'nameOccName' due to -- DuplicateRecordFields. -reportable :: GreName -> Bool -reportable child - | NormalGreName name <- child - , isWiredInName name = False -- Don't report unused wired-in names - -- Otherwise we get a zillion warnings - -- from Data.Tuple - | otherwise = not (startsWithUnderscore (occName child)) +reportable :: Name -> OccName -> Bool +reportable child child_occ + | isWiredInName child + = False -- Don't report unused wired-in names + -- Otherwise we get a zillion warnings + -- from Data.Tuple + | otherwise + = not (startsWithUnderscore child_occ) addUnusedWarning :: WarningFlag -> OccName -> SrcSpan -> SDoc -> RnM () addUnusedWarning flag occ span msg = do @@ -555,7 +547,23 @@ addNameClashErrRn rdr_name gres -- already, and we don't want an error cascade. = return () | otherwise - = addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $ + = addErr $ mkNameClashErr rdr_name gres + where + -- If all the GREs are defined locally, can we skip reporting an ambiguity + -- error at use sites, because it will have been reported already? See + -- Note [Skipping ambiguity errors at use sites of local declarations] + can_skip = num_non_flds >= 2 + || (num_flds >= 2 && not (isDuplicateRecFldGRE (head flds))) + || (num_non_flds >= 1 && num_flds >= 1 + && not (isNoFieldSelectorGRE (head flds))) + (flds, non_flds) = NE.partition isRecFldGRE gres + num_flds = length flds + num_non_flds = length non_flds + +mkNameClashErr :: Outputable a + => a -> NE.NonEmpty GlobalRdrElt -> TcRnMessage +mkNameClashErr rdr_name gres = + mkTcRnUnknownMessage $ mkPlainError noHints $ (vcat [ text "Ambiguous occurrence" <+> quotes (ppr rdr_name) , text "It could refer to" , nest 3 (vcat (msg1 : msgs)) ]) @@ -563,7 +571,7 @@ addNameClashErrRn rdr_name gres np1 NE.:| nps = gres msg1 = text "either" <+> ppr_gre np1 msgs = [text " or" <+> ppr_gre np | np <- nps] - ppr_gre gre = sep [ pp_greMangledName gre <> comma + ppr_gre gre = sep [ pp_gre_name gre <> comma , pprNameProvenance gre] -- When printing the name, take care to qualify it in the same @@ -574,36 +582,27 @@ addNameClashErrRn rdr_name gres -- imported from ‘Prelude’ at T15487.hs:1:8-13 -- or ... -- See #15487 - pp_greMangledName gre@(GRE { gre_name = child, gre_par = par - , gre_lcl = lcl, gre_imp = iss }) = - case child of - FieldGreName fl -> text "the field" <+> quotes (ppr fl) <+> parent_info - NormalGreName name -> quotes (pp_qual name <> dot <> ppr (nameOccName name)) + pp_gre_name gre + | isRecFldGRE gre + = text "the field" <+> quotes (ppr occ) <+> parent_info + | otherwise + = quotes (pp_qual <> dot <> ppr occ) where - parent_info = case par of + occ = greOccName gre + parent_info = case gre_par gre of NoParent -> empty ParentIs { par_is = par_name } -> text "of record" <+> quotes (ppr par_name) - pp_qual name - | lcl - = ppr (nameModule name) - | Just imp <- headMaybe iss -- This 'imp' is the one that - -- pprNameProvenance chooses - , ImpDeclSpec { is_as = mod } <- is_decl imp - = ppr mod - | otherwise - = pprPanic "addNameClassErrRn" (ppr gre $$ ppr iss) - -- Invariant: either 'lcl' is True or 'iss' is non-empty - - -- If all the GREs are defined locally, can we skip reporting an ambiguity - -- error at use sites, because it will have been reported already? See - -- Note [Skipping ambiguity errors at use sites of local declarations] - can_skip = num_non_flds >= 2 - || (num_flds >= 2 && not (isDuplicateRecFldGRE (head flds))) - || (num_non_flds >= 1 && num_flds >= 1 - && not (isNoFieldSelectorGRE (head flds))) - (flds, non_flds) = NE.partition isRecFldGRE gres - num_flds = length flds - num_non_flds = length non_flds + pp_qual + | gre_lcl gre + = ppr (nameModule $ greName gre) + | Just imp <- headMaybe $ gre_imp gre + -- This 'imp' is the one that + -- pprNameProvenance chooses + , ImpDeclSpec { is_as = mod } <- is_decl imp + = ppr mod + | otherwise + = pprPanic "addNameClassErrRn" (ppr gre) + -- Invariant: either 'lcl' is True or 'iss' is non-empty dupNamesErr :: Outputable n => (n -> SrcSpan) -> NE.NonEmpty n -> RnM () diff --git a/compiler/GHC/Runtime/Context.hs b/compiler/GHC/Runtime/Context.hs index 388ae69aea..929b2ca6e9 100644 --- a/compiler/GHC/Runtime/Context.hs +++ b/compiler/GHC/Runtime/Context.hs @@ -8,6 +8,7 @@ module GHC.Runtime.Context , substInteractiveContext , replaceImportEnv , icReaderEnv + , icExtendGblRdrEnv , icInteractiveModule , icInScopeTTs , icNamePprCtx @@ -30,7 +31,6 @@ import GHC.Core.FamInstEnv import GHC.Core.InstEnv import GHC.Core.Type -import GHC.Types.Avail import GHC.Types.Fixity.Env import GHC.Types.Id.Info ( IdDetails(..) ) import GHC.Types.Name @@ -94,7 +94,7 @@ The details are a bit tricky though: call to initTc in initTcInteractive, which in turn get the module from it 'icInteractiveModule' field of the interactive context. - The 'homeUnitId' field stays as 'main' (or whatever -this-unit-id says. + The 'homeUnitId' field stays as 'main' (or whatever -this-unit-id says). * The main trickiness is that the type environment (tcg_type_env) and fixity envt (tcg_fix_env), now contain entities from all the @@ -185,9 +185,12 @@ It's exactly the same for type-family instances. See #7102 Note [icReaderEnv recalculation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The GlobalRdrEnv describing what’s in scope at the prompts consists -of all the imported things, followed by all the things defined on the prompt, with -shadowing. Defining new things on the prompt is easy: we shadow as needed and then extend the environment. But changing the set of imports, which can happen later as well, -is tricky: we need to re-apply the shadowing from all the things defined at the prompt! +of all the imported things, followed by all the things defined on the prompt, +with shadowing. Defining new things on the prompt is easy: we shadow as needed, +and then extend the environment. + +But changing the set of imports, which can happen later as well, is tricky +we need to re-apply the shadowing from all the things defined at the prompt! For example: @@ -196,22 +199,21 @@ For example: ghci> empty -- Still gets the 'empty' defined at the prompt True - -It would be correct ot re-construct the env from scratch based on +It would be correct to re-construct the env from scratch based on `ic_tythings`, but that'd be quite expensive if there are many entries in `ic_tythings` that shadow each other. -Therefore we keep around a that `GlobalRdrEnv` in `igre_prompt_env` that -contians _just_ the things defined at the prompt, and use that in -`replaceImportEnv` to rebuild the full env. Conveniently, `shadowNames` takes -such an `OccEnv` to denote the set of names to shadow. +Therefore we keep around a `GlobalRdrEnv` in `igre_prompt_env` that contains +_just_ the things defined at the prompt, and use that in `replaceImportEnv` to +rebuild the full env. Conveniently, `shadowNames` takes such an `OccEnv` +to denote the set of names to shadow. INVARIANT: Every `OccName` in `igre_prompt_env` is present unqualified as well -(else it would not be right to use pass `igre_prompt_env` to `shadowNames`.) +(else it would not be right to pass `igre_prompt_env` to `shadowNames`.) + +The definition of the IcGlobalRdrEnv type should conceptually be in this module, +and made abstract, but it’s used in `Resume`, so it lives in GHC.Runtime.Eval.Type. -The definition of the IcGlobalRdrEnv type should conceptually be in this module, and -made abstract, but it’s used in `Resume`, so it lives in GHC.Runtime.Eval.Type. -- -} -- | Interactive context, recording information about the state of the @@ -343,12 +345,11 @@ icInScopeTTs ictxt = filter in_scope_unqualified (ic_tythings ictxt) where in_scope_unqualified thing = or [ unQualOK gre - | avail <- tyThingAvailInfo thing - , name <- availNames avail + | gre <- tyThingLocalGREs thing + , let name = greName gre , Just gre <- [lookupGRE_Name (icReaderEnv ictxt) name] ] - -- | Get the NamePprCtx function based on the flags and this InteractiveContext icNamePprCtx :: UnitEnv -> InteractiveContext -> NamePprCtx icNamePprCtx unit_env ictxt = mkNamePprCtx ptc unit_env (icReaderEnv ictxt) @@ -412,8 +413,8 @@ replaceImportEnv igre import_env = igre { igre_env = new_env } import_env_shadowed = import_env `shadowNames` igre_prompt_env igre new_env = import_env_shadowed `plusGlobalRdrEnv` igre_prompt_env igre --- | Add TyThings to the GlobalRdrEnv, earlier ones in the list shadowing --- later ones, and shadowing existing entries in the GlobalRdrEnv. +-- | Add 'TyThings' to the 'GlobalRdrEnv', earlier ones in the list shadowing +-- later ones, and shadowing existing entries in the 'GlobalRdrEnv'. icExtendGblRdrEnv :: GlobalRdrEnv -> [TyThing] -> GlobalRdrEnv icExtendGblRdrEnv env tythings = foldr add env tythings -- Foldr makes things in the front of @@ -424,12 +425,10 @@ icExtendGblRdrEnv env tythings | is_sub_bndr thing = env | otherwise - = foldl' extendGlobalRdrEnv env1 (concatMap localGREsFromAvail avail) + = foldl' extendGlobalRdrEnv env1 new_gres where - new_gres = concatMap availGreNames avail - new_occs = occSetToEnv (mkOccSet (map occName new_gres)) - env1 = shadowNames env new_occs - avail = tyThingAvailInfo thing + new_gres = tyThingLocalGREs thing + env1 = shadowNames env $ mkGlobalRdrEnv new_gres -- Ugh! The new_tythings may include record selectors, since they -- are not implicit-ids, and must appear in the TypeEnv. But they diff --git a/compiler/GHC/Runtime/Eval.hs b/compiler/GHC/Runtime/Eval.hs index b6cf935b7e..88dbe46626 100644 --- a/compiler/GHC/Runtime/Eval.hs +++ b/compiler/GHC/Runtime/Eval.hs @@ -66,12 +66,13 @@ import GHC.Linker.Loader as Loader import GHC.Hs -import GHC.Core.Predicate -import GHC.Core.InstEnv +import GHC.Core.Class (classTyCon) import GHC.Core.FamInstEnv ( FamInst, orphNamesOfFamInst ) +import GHC.Core.InstEnv +import GHC.Core.Predicate +import GHC.Core.TyCo.Ppr import GHC.Core.TyCon import GHC.Core.Type hiding( typeKind ) -import GHC.Core.TyCo.Ppr import qualified GHC.Core.Type as Type import GHC.Iface.Env ( newInteractiveBinder ) @@ -85,12 +86,13 @@ import GHC.Data.Maybe import GHC.Data.FastString import GHC.Data.Bag -import GHC.Utils.Monad -import GHC.Utils.Panic import GHC.Utils.Error -import GHC.Utils.Outputable -import GHC.Utils.Misc +import GHC.Utils.Exception import GHC.Utils.Logger +import GHC.Utils.Misc +import GHC.Utils.Monad +import GHC.Utils.Outputable +import GHC.Utils.Panic import GHC.Types.RepType import GHC.Types.Fixity.Env @@ -114,29 +116,27 @@ import GHC.Unit.Module.ModIface import GHC.Unit.Module.ModSummary import GHC.Unit.Home.ModInfo -import System.Directory -import Data.Dynamic -import Data.Either -import Data.IntMap (IntMap) -import qualified Data.IntMap as IntMap -import Data.List (find,intercalate) -import Data.List.NonEmpty (NonEmpty) -import Control.Monad -import Control.Monad.Catch as MC -import Data.Array -import GHC.Utils.Exception -import Unsafe.Coerce ( unsafeCoerce ) - import GHC.Tc.Module ( runTcInteractive, tcRnType, loadUnqualIfaces ) import GHC.Tc.Utils.Zonk ( ZonkFlexi (SkolemiseFlexi) ) -import GHC.Tc.Utils.Env (tcGetInstEnvs) +import GHC.Tc.Utils.Env (tcGetInstEnvs, lookupGlobal) import GHC.Tc.Utils.Instantiate (instDFunType) import GHC.Tc.Solver (simplifyWantedsTcM) import GHC.Tc.Utils.Monad -import GHC.Core.Class (classTyCon) import GHC.Unit.Env import GHC.IfaceToCore +import Control.Monad +import Control.Monad.Catch as MC +import Data.Array +import Data.Dynamic +import Data.Either +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap +import Data.List (find,intercalate) +import Data.List.NonEmpty (NonEmpty) +import System.Directory +import Unsafe.Coerce ( unsafeCoerce ) + -- ----------------------------------------------------------------------------- -- running a statement interactively @@ -819,8 +819,14 @@ findGlobalRdrEnv hsc_env imports = do { idecls_env <- hscRnImportDecls hsc_env idecls -- This call also loads any orphan modules ; return $ case partitionEithers (map mkEnv imods) of - ([], imods_env) -> Right (foldr plusGlobalRdrEnv idecls_env imods_env) - (err : _, _) -> Left err } + (err : _, _) -> Left err + ([], imods_env0) -> + -- Need to rehydrate the 'GlobalRdrEnv' to recover the 'GREInfo's. + -- This is done in order to avoid space leaks. + -- See Note [Forcing GREInfo] in GHC.Types.GREInfo. + let imods_env = map (hydrateGlobalRdrEnv get_GRE_info) imods_env0 + in Right (foldr plusGlobalRdrEnv idecls_env imods_env) + } where idecls :: [LImportDecl GhcPs] idecls = [noLocA d | IIDecl d <- imports] @@ -832,7 +838,9 @@ findGlobalRdrEnv hsc_env imports Left err -> Left (mod, err) Right env -> Right env -mkTopLevEnv :: HomePackageTable -> ModuleName -> Either String GlobalRdrEnv + get_GRE_info nm = tyThingGREInfo <$> lookupGlobal hsc_env nm + +mkTopLevEnv :: HomePackageTable -> ModuleName -> Either String IfGlobalRdrEnv mkTopLevEnv hpt modl = case lookupHpt hpt modl of Nothing -> Left "not a home module" @@ -840,6 +848,9 @@ mkTopLevEnv hpt modl case mi_globals (hm_iface details) of Nothing -> Left "not interpreted" Just env -> Right env + -- It's OK to be lazy here; we force the GlobalRdrEnv before storing it + -- in ModInfo; see GHCi.UI.Info. + -- See Note [Forcing GREInfo] in GHC.Types.GREInfo. -- | Get the interactive evaluation context, consisting of a pair of the -- set of modules from which we take the full top-level scope, and the set @@ -895,7 +906,7 @@ getInfo allInfo name -- | Returns all names in scope in the current interactive context getNamesInScope :: GhcMonad m => m [Name] getNamesInScope = withSession $ \hsc_env -> - return (map greMangledName (globalRdrEnvElts (icReaderEnv (hsc_IC hsc_env)))) + return $ map greName $ globalRdrEnvElts (icReaderEnv (hsc_IC hsc_env)) -- | Returns all 'RdrName's in scope in the current interactive -- context, excluding any that are internally-generated. diff --git a/compiler/GHC/Runtime/Loader.hs b/compiler/GHC/Runtime/Loader.hs index b59071d5f6..ebfa7875e5 100644 --- a/compiler/GHC/Runtime/Loader.hs +++ b/compiler/GHC/Runtime/Loader.hs @@ -33,9 +33,10 @@ import GHC.Linker.Loader ( loadModule, loadName ) import GHC.Runtime.Interpreter ( wormhole ) import GHC.Runtime.Interpreter.Types +import GHC.Rename.Names ( gresFromAvails ) + import GHC.Tc.Utils.Monad ( initTcInteractive, initIfaceTcRn ) import GHC.Iface.Load ( loadPluginInterface, cannotFindModule ) -import GHC.Rename.Names ( gresFromAvails ) import GHC.Builtin.Names ( pluginTyConName, frontendPluginTyConName ) import GHC.Driver.Env @@ -49,10 +50,7 @@ import GHC.Types.Name ( Name, nameModule_maybe ) import GHC.Types.Id ( idType ) import GHC.Types.TyThing import GHC.Types.Name.Occurrence ( OccName, mkVarOccFS ) -import GHC.Types.Name.Reader ( RdrName, ImportSpec(..), ImpDeclSpec(..) - , ImpItemSpec(..), mkGlobalRdrEnv, lookupGRE_RdrName - , greMangledName, mkRdrQual ) - +import GHC.Types.Name.Reader import GHC.Unit.Finder ( findPluginModule, FindResult(..) ) import GHC.Driver.Config.Finder ( initFinderOpts ) import GHC.Unit.Module ( Module, ModuleName ) @@ -61,6 +59,7 @@ import GHC.Unit.Env import GHC.Utils.Panic import GHC.Utils.Logger +import GHC.Utils.Misc ( HasDebugCallStack ) import GHC.Utils.Error import GHC.Utils.Outputable import GHC.Utils.Exception @@ -298,7 +297,8 @@ lessUnsafeCoerce logger context what = do -- being compiled. This was introduced by 57d6798. -- -- Need the module as well to record information in the interface file -lookupRdrNameInModuleForPlugins :: HscEnv -> ModuleName -> RdrName +lookupRdrNameInModuleForPlugins :: HasDebugCallStack + => HscEnv -> ModuleName -> RdrName -> IO (Maybe (Name, ModIface)) lookupRdrNameInModuleForPlugins hsc_env mod_name rdr_name = do let dflags = hsc_dflags hsc_env @@ -321,9 +321,10 @@ lookupRdrNameInModuleForPlugins hsc_env mod_name rdr_name = do let decl_spec = ImpDeclSpec { is_mod = mod_name, is_as = mod_name , is_qual = False, is_dloc = noSrcSpan } imp_spec = ImpSpec decl_spec ImpAll - env = mkGlobalRdrEnv (gresFromAvails (Just imp_spec) (mi_exports iface)) - case lookupGRE_RdrName rdr_name env of - [gre] -> return (Just (greMangledName gre, iface)) + env = mkGlobalRdrEnv + $ gresFromAvails hsc_env (Just imp_spec) (mi_exports iface) + case lookupGRE_RdrName (IncludeFields WantNormal) env rdr_name of + [gre] -> return (Just (greName gre, iface)) [] -> return Nothing _ -> panic "lookupRdrNameInModule" diff --git a/compiler/GHC/StgToJS/Ids.hs b/compiler/GHC/StgToJS/Ids.hs index 5d28b511f6..9817b326a3 100644 --- a/compiler/GHC/StgToJS/Ids.hs +++ b/compiler/GHC/StgToJS/Ids.hs @@ -111,7 +111,7 @@ makeIdentForId i num id_type current_module = TxtI ident = current_module !ident = mkFastStringByteString $ mconcat - [ mkJsSymbolBS exported mod (occNameFS (nameOccName name)) + [ mkJsSymbolBS exported mod (occNameMangledFS (nameOccName name)) ------------- -- suffixes diff --git a/compiler/GHC/Tc/Errors.hs b/compiler/GHC/Tc/Errors.hs index 3816f31ddd..8d5ac3a227 100644 --- a/compiler/GHC/Tc/Errors.hs +++ b/compiler/GHC/Tc/Errors.hs @@ -1,4 +1,5 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ParallelListComp #-} @@ -40,8 +41,7 @@ import GHC.Tc.Utils.Instantiate import {-# SOURCE #-} GHC.Tc.Errors.Hole ( findValidHoleFits, getHoleFitDispConfig, pprHoleFit ) import GHC.Types.Name -import GHC.Types.Name.Reader ( lookupGRE_Name, GlobalRdrEnv, mkRdrUnqual - , emptyLocalRdrEnv, lookupGlobalRdrEnv , lookupLocalRdrOcc ) +import GHC.Types.Name.Reader import GHC.Types.Id import GHC.Types.Var import GHC.Types.Var.Set @@ -81,7 +81,7 @@ import Data.Function ( on ) import Data.List ( partition, sort, sortBy ) import Data.List.NonEmpty ( NonEmpty(..), nonEmpty ) import qualified Data.List.NonEmpty as NE -import Data.Ord ( comparing ) +import Data.Ord ( comparing ) import qualified Data.Semigroup as S {- @@ -1303,15 +1303,9 @@ See also 'reportUnsolved'. mkHoleError :: NameEnv Type -> [ErrorItem] -> SolverReportErrCtxt -> Hole -> TcM (MsgEnvelope TcRnMessage) mkHoleError _ _tidy_simples ctxt hole@(Hole { hole_occ = occ, hole_loc = ct_loc }) | isOutOfScopeHole hole - = do { dflags <- getDynFlags - ; rdr_env <- getGlobalRdrEnv - ; imp_info <- getImports - ; curr_mod <- getModule - ; hpt <- getHpt - ; let (imp_errs, hints) - = unknownNameSuggestions WL_Anything - dflags hpt curr_mod rdr_env - (tcl_rdr lcl_env) imp_info occ + = do { (imp_errs, hints) + <- unknownNameSuggestions (tcl_rdr lcl_env) WL_Anything occ + ; let err = SolverReportWithCtxt ctxt (ReportHoleError hole $ OutOfScopeHole imp_errs) report = SolverReport err [] hints @@ -2212,15 +2206,10 @@ mk_dict_err ctxt (item, (matches, unifiers, unsafe_overlapped)) = case (NE.nonEm ; lcl_env <- getLocalRdrEnv ; if occ_name_in_scope glb_env lcl_env name then return ([], noHints) - else do { dflags <- getDynFlags - ; imp_info <- getImports - ; curr_mod <- getModule - ; hpt <- getHpt - ; return (unknownNameSuggestions WL_RecField dflags hpt curr_mod - glb_env emptyLocalRdrEnv imp_info (mkRdrUnqual name)) } } + else unknownNameSuggestions emptyLocalRdrEnv WL_RecField (mkRdrUnqual name) } occ_name_in_scope glb_env lcl_env occ_name = not $ - null (lookupGlobalRdrEnv glb_env occ_name) && + null (lookupGRE_OccName (IncludeFields WantNormal) glb_env occ_name) && isNothing (lookupLocalRdrOcc lcl_env occ_name) record_field = case orig of diff --git a/compiler/GHC/Tc/Errors/Hole.hs b/compiler/GHC/Tc/Errors/Hole.hs index d4ee8abef2..76929e8c11 100644 --- a/compiler/GHC/Tc/Errors/Hole.hs +++ b/compiler/GHC/Tc/Errors/Hole.hs @@ -42,8 +42,7 @@ import GHC.Tc.Utils.TcType import GHC.Core.Type import GHC.Core.DataCon import GHC.Types.Name -import GHC.Types.Name.Reader ( pprNameProvenance , GlobalRdrElt (..) - , globalRdrEnvElts, greMangledName, grePrintableName ) +import GHC.Types.Name.Reader import GHC.Builtin.Names ( gHC_ERR ) import GHC.Types.Id import GHC.Types.Var.Set @@ -527,7 +526,7 @@ pprHoleFit (HFDC sWrp sWrpVars sTy sProv sMs) (HoleFit {..}) = holeDisp = if sMs then holeVs else sep $ replicate (length hfMatches) $ text "_" occDisp = case hfCand of - GreHFCand gre -> pprPrefixOcc (grePrintableName gre) + GreHFCand gre -> pprPrefixOcc (greName gre) NameHFCand name -> pprPrefixOcc name IdHFCand id_ -> pprPrefixOcc id_ tyDisp = ppWhen sTy $ dcolon <+> ppr hfType @@ -832,9 +831,9 @@ tcFilterHoleFits limit typed_hole ht@(hole_ty, _) candidates = _ -> Nothing } where name = case hfc of #if __GLASGOW_HASKELL__ < 901 - IdHFCand id -> idName id + IdHFCand id -> idName id #endif - GreHFCand gre -> greMangledName gre + GreHFCand gre -> greName gre NameHFCand name -> name discard_it = go subs seen maxleft ty elts keep_it eid eid_ty wrp ms = go (fit:subs) (extendVarSet seen eid) diff --git a/compiler/GHC/Tc/Errors/Hole/FitTypes.hs b/compiler/GHC/Tc/Errors/Hole/FitTypes.hs index 72cb54bec2..71dae5b672 100644 --- a/compiler/GHC/Tc/Errors/Hole/FitTypes.hs +++ b/compiler/GHC/Tc/Errors/Hole/FitTypes.hs @@ -48,7 +48,7 @@ data HoleFitCandidate = IdHFCand Id -- An id, like locals. instance Eq HoleFitCandidate where IdHFCand i1 == IdHFCand i2 = i1 == i2 NameHFCand n1 == NameHFCand n2 = n1 == n2 - GreHFCand gre1 == GreHFCand gre2 = gre_name gre1 == gre_name gre2 + GreHFCand gre1 == GreHFCand gre2 = greName gre1 == greName gre2 _ == _ = False instance Outputable HoleFitCandidate where @@ -63,11 +63,11 @@ instance NamedThing HoleFitCandidate where getName hfc = case hfc of IdHFCand cid -> idName cid NameHFCand cname -> cname - GreHFCand cgre -> greMangledName cgre + GreHFCand cgre -> greName cgre getOccName hfc = case hfc of IdHFCand cid -> occName cid NameHFCand cname -> occName cname - GreHFCand cgre -> occName (greMangledName cgre) + GreHFCand cgre -> occName $ greName cgre instance HasOccName HoleFitCandidate where occName = getOccName diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs index 8b4896c5cc..4f1d88aaa5 100644 --- a/compiler/GHC/Tc/Errors/Ppr.hs +++ b/compiler/GHC/Tc/Errors/Ppr.hs @@ -58,15 +58,15 @@ import GHC.Tc.Types.Rank (Rank(..)) import GHC.Tc.Utils.TcType import GHC.Types.Error -import GHC.Types.FieldLabel (flIsOverloaded) import GHC.Types.Hint (UntickedPromotedThing(..), pprUntickedConstructor, isBareSymbol) import GHC.Types.Hint.Ppr () -- Outputable GhcHint import GHC.Types.Basic import GHC.Types.Error.Codes ( constructorCode ) import GHC.Types.Id +import GHC.Types.Id.Info ( RecSelParent(..) ) import GHC.Types.Name -import GHC.Types.Name.Reader ( GreName(..), pprNameProvenance - , RdrName, rdrNameOcc, greMangledName, grePrintableName ) +import GHC.Types.Name.Reader +import GHC.Types.Name.Env import GHC.Types.Name.Set import GHC.Types.SrcLoc import GHC.Types.TyThing @@ -99,7 +99,6 @@ import Data.List ( groupBy, sortBy, tails , partition, unfoldr ) import Data.Ord ( comparing ) import Data.Bifunctor -import GHC.Types.Name.Env import qualified Language.Haskell.TH as TH import {-# SOURCE #-} GHC.Tc.Types (pprTcTyThingCategory) @@ -150,10 +149,10 @@ instance Diagnostic TcRnMessage where ) : [errInfoContext, errInfoSupplementary] TcRnUnusedPatternBinds bind -> mkDecorated [hang (text "This pattern-binding binds no variables:") 2 (ppr bind)] - TcRnDodgyImports name - -> mkDecorated [dodgy_msg (text "import") name (dodgy_msg_insert name :: IE GhcPs)] - TcRnDodgyExports name - -> mkDecorated [dodgy_msg (text "export") name (dodgy_msg_insert name :: IE GhcRn)] + TcRnDodgyImports gre + -> mkDecorated [dodgy_msg (text "import") gre (dodgy_msg_insert gre)] + TcRnDodgyExports gre + -> mkDecorated [dodgy_msg (text "export") gre (dodgy_msg_insert gre)] TcRnMissingImportList ie -> mkDecorated [ text "The import item" <+> quotes (ppr ie) <+> text "does not have an explicit import list" @@ -250,9 +249,9 @@ instance Diagnostic TcRnMessage where , nest 2 (text "e.g., deriving instance _ => Eq (Foo a)") ] TcRnDuplicateFieldName fld_part dups -> mkSimpleDecorated $ - hsep [text "duplicate field name", - quotes (ppr (NE.head dups)), - text "in record", pprRecordFieldPart fld_part] + hsep [ text "Duplicate field name" + , quotes (ppr (rdrNameOcc $ NE.head dups)) + , text "in record", pprRecordFieldPart fld_part ] TcRnIllegalViewPattern pat -> mkSimpleDecorated $ vcat [text "Illegal view pattern: " <+> ppr pat] TcRnCharLiteralOutOfRange c @@ -535,9 +534,9 @@ instance Diagnostic TcRnMessage where $ formatExportItemError (ppr export_item) "attempts to export constructors or class methods that are not visible here" - TcRnDuplicateExport child ie1 ie2 + TcRnDuplicateExport gre ie1 ie2 -> mkSimpleDecorated $ - hsep [ quotes (ppr child) + hsep [ quotes (ppr $ greName gre) , text "is exported by", quotes (ppr ie1) , text "and", quotes (ppr ie2) ] TcRnExportedParentChildMismatch parent_name ty_thing child parent_names @@ -557,33 +556,60 @@ instance Diagnostic TcRnMessage where | isRecordSelector i = "record selector" pp_category i = tyThingCategory i what_is = pp_category ty_thing - thing = ppr child + thing = ppr $ greOccName child parents = map ppr parent_names - TcRnConflictingExports occ child1 gre1 ie1 child2 gre2 ie2 + TcRnConflictingExports occ child_gre1 ie1 child_gre2 ie2 -> mkSimpleDecorated $ vcat [ text "Conflicting exports for" <+> quotes (ppr occ) <> colon - , ppr_export child1 gre1 ie1 - , ppr_export child2 gre2 ie2 + , ppr_export child_gre1 ie1 + , ppr_export child_gre2 ie2 ] where - ppr_export child gre ie = nest 3 (hang (quotes (ppr ie) <+> text "exports" <+> - quotes (ppr_name child)) - 2 (pprNameProvenance gre)) - - -- DuplicateRecordFields means that nameOccName might be a - -- mangled $sel-prefixed thing, in which case show the correct OccName - -- alone (but otherwise show the Name so it will have a module - -- qualifier) - ppr_name (FieldGreName fl) | flIsOverloaded fl = ppr fl - | otherwise = ppr (flSelector fl) - ppr_name (NormalGreName name) = ppr name - TcRnAmbiguousField rupd parent_type - -> mkSimpleDecorated $ - vcat [ text "The record update" <+> ppr rupd - <+> text "with type" <+> ppr parent_type - <+> text "is ambiguous." - , text "This will not be supported by -XDuplicateRecordFields in future releases of GHC." + ppr_export gre ie = + nest 3 $ + hang (quotes (ppr ie) <+> text "exports" <+> quotes (ppr $ greName gre)) + 2 (pprNameProvenance gre) + TcRnDuplicateFieldExport (gre, ie1) gres_ies -> + mkSimpleDecorated $ + vcat ( hsep [ text "Duplicate record field" + , quotes (ppr $ greOccName gre) + , text "in export list" <> colon ] + : map ppr_export ((gre,ie1) : NE.toList gres_ies) + ) + where + ppr_export (gre,ie) = + nest 3 $ + hang (sep [ quotes (ppr ie) <+> text "exports the field" <+> quotes (ppr $ greName gre) + , text "belonging to the constructor" <> plural fld_cons <+> pprQuotedList fld_cons ]) + 2 (pprNameProvenance gre) + where + fld_cons :: [ConLikeName] + fld_cons = nonDetEltsUniqSet $ recFieldCons $ fieldGREInfo gre + TcRnAmbiguousFieldInUpdate (gre1, gre2, gres) + -> mkSimpleDecorated $ + vcat [ text "Ambiguous record field" <+> fld <> dot + , hang (text "It could refer to any of the following:") + 2 $ vcat (map pprSugg (gre1 : gre2 : gres)) + ] + where + fld = quotes $ ppr (occNameFS $ greOccName gre1) + pprSugg gre = vcat [ bullet <+> pprGRE gre <> comma + , nest 2 (pprNameProvenance gre) ] + pprGRE gre = case gre_info gre of + IAmRecField {} + -> let parent = par_is $ gre_par gre + in text "record field" <+> fld <+> text "of" <+> quotes (ppr parent) + _ -> text "variable" <+> fld + TcRnAmbiguousRecordUpdate _rupd tc + -> mkSimpleDecorated $ + vcat [ text "Ambiguous record update with parent" <+> what <> dot + , hsep [ text "This type-directed disambiguation mechanism" + , text "will not be supported by -XDuplicateRecordFields in future releases of GHC." ] + , text "Consider disambiguating using module qualification instead." ] + where + what :: SDoc + what = text "type constructor" <+> quotes (ppr $ RecSelData tc) TcRnMissingFields con fields -> mkSimpleDecorated $ vcat [header, nest 2 rest] where @@ -597,21 +623,6 @@ instance Diagnostic TcRnMessage where hang (text "Record update for insufficiently polymorphic field" <> plural prs <> colon) 2 (vcat [ ppr f <+> dcolon <+> ppr ty | (f,ty) <- prs ]) - TcRnNoConstructorHasAllFields conflictingFields - -> mkSimpleDecorated $ - hang (text "No constructor has all these fields:") - 2 (pprQuotedList conflictingFields) - TcRnMixedSelectors data_name data_sels pat_name pat_syn_sels - -> mkSimpleDecorated $ - text "Cannot use a mixture of pattern synonym and record selectors" $$ - text "Record selectors defined by" - <+> quotes (ppr data_name) - <> colon - <+> pprWithCommas ppr data_sels $$ - text "Pattern synonym selectors defined by" - <+> quotes (ppr pat_name) - <> colon - <+> pprWithCommas ppr pat_syn_sels TcRnMissingStrictFields con fields -> mkSimpleDecorated $ vcat [header, nest 2 rest] where @@ -622,14 +633,51 @@ instance Diagnostic TcRnMessage where header = text "Constructor" <+> quotes (ppr con) <+> text "does not have the required strict field(s)" <> if null fields then empty else colon - TcRnNoPossibleParentForFields rbinds - -> mkSimpleDecorated $ - hang (text "No type has all these fields:") - 2 (pprQuotedList fields) - where fields = map (hfbLHS . unLoc) rbinds - TcRnBadOverloadedRecordUpdate _rbinds - -> mkSimpleDecorated $ - text "Record update is ambiguous, and requires a type signature" + TcRnBadRecordUpdate upd_flds reason + -> case reason of + NoConstructorHasAllFields { conflictingFields = conflicts } + | [fld] <- conflicts + -> mkSimpleDecorated $ + vcat [ header + , text "No constructor in scope has the field" <+> quotes (ppr fld) ] + | otherwise + -> + mkSimpleDecorated $ + vcat [ header + , hang (text "No constructor in scope has all of the following fields:") + 2 (pprQuotedList conflicts) ] + where + header :: SDoc + header = text "Invalid record update." + MultiplePossibleParents (par1, par2, pars) -> + mkSimpleDecorated $ + vcat [ hang (text "Ambiguous record update with field" <> plural upd_flds) + 2 ppr_flds + , hang (thisOrThese upd_flds <+> text "field" <> plural upd_flds <+> what_parent) + 2 (quotedListWithAnd (map ppr (par1:par2:pars))) ] + where + ppr_flds, what_parent, which :: SDoc + ppr_flds = quotedListWithAnd $ map ppr upd_flds + what_parent = case par1 of + RecSelData {} -> text "appear" <> singular upd_flds + <+> text "in" <+> which <+> text "datatypes" + RecSelPatSyn {} -> isOrAre upd_flds <+> text "associated with" + <+> which <+> text "pattern synonyms" + which = case pars of + [] -> text "both" + _ -> text "all of the" + InvalidTyConParent tc pars -> + mkSimpleDecorated $ + vcat [ hang (text "No data constructor of" <+> what $$ text "has all of the fields:") + 2 (pprQuotedList upd_flds) + , pat_syn_msg ] + where + what = text "type constructor" <+> quotes (ppr (RecSelData tc)) + pat_syn_msg + | any (\case { RecSelPatSyn {} -> True; _ -> False}) pars + = text "NB: type-directed disambiguation is not supported for pattern synonym record fields." + | otherwise + = empty TcRnStaticFormNotClosed name reason -> mkSimpleDecorated $ quotes (ppr name) @@ -861,9 +909,6 @@ instance Diagnostic TcRnMessage where TcRnExpectedValueId thing -> mkSimpleDecorated $ ppr thing <+> text "used where a value identifier was expected" - TcRnNotARecordSelector field - -> mkSimpleDecorated $ - hsep [quotes (ppr field), text "is not a record selector"] TcRnRecSelectorEscapedTyVar lbl -> mkSimpleDecorated $ text "Cannot use record selector" <+> quotes (ppr lbl) <+> @@ -887,9 +932,9 @@ instance Diagnostic TcRnMessage where HsSrcBang _ _ _ -> "strictness" in text "Unexpected" <+> text err <+> text "annotation:" <+> ppr ty $$ text err <+> text "annotation cannot appear nested inside a type" - TcRnIllegalRecordSyntax ty + TcRnIllegalRecordSyntax either_ty_ty -> mkSimpleDecorated $ - text "Record syntax is illegal here:" <+> ppr ty + text "Record syntax is illegal here:" <+> either ppr ppr either_ty_ty TcRnUnexpectedTypeSplice ty -> mkSimpleDecorated $ text "Unexpected type splice:" <+> ppr ty @@ -1281,7 +1326,7 @@ instance Diagnostic TcRnMessage where text "This is not forward-compatible with a planned GHC extension, RequiredTypeArguments." where var_names = case shadowed_term_names of - Left gbl_names -> vcat (map (\name -> quotes (ppr $ grePrintableName name) <+> pprNameProvenance name) gbl_names) + Left gbl_names -> vcat (map (\name -> quotes (ppr $ greName name) <+> pprNameProvenance name) gbl_names) Right lcl_name -> quotes (ppr lcl_name) <+> text "defined at" <+> ppr (nameSrcLoc lcl_name) TcRnBindingOfExistingName name -> mkSimpleDecorated $ @@ -1681,21 +1726,19 @@ instance Diagnostic TcRnMessage where -> ErrorWithoutFlag TcRnConflictingExports{} -> ErrorWithoutFlag - TcRnAmbiguousField{} + TcRnDuplicateFieldExport {} + -> ErrorWithoutFlag + TcRnAmbiguousFieldInUpdate {} + -> ErrorWithoutFlag + TcRnAmbiguousRecordUpdate{} -> WarningWithFlag Opt_WarnAmbiguousFields TcRnMissingFields{} -> WarningWithFlag Opt_WarnMissingFields TcRnFieldUpdateInvalidType{} -> ErrorWithoutFlag - TcRnNoConstructorHasAllFields{} - -> ErrorWithoutFlag - TcRnMixedSelectors{} - -> ErrorWithoutFlag TcRnMissingStrictFields{} -> ErrorWithoutFlag - TcRnNoPossibleParentForFields{} - -> ErrorWithoutFlag - TcRnBadOverloadedRecordUpdate{} + TcRnBadRecordUpdate{} -> ErrorWithoutFlag TcRnStaticFormNotClosed{} -> ErrorWithoutFlag @@ -1788,8 +1831,6 @@ instance Diagnostic TcRnMessage where -> ErrorWithoutFlag TcRnExpectedValueId{} -> ErrorWithoutFlag - TcRnNotARecordSelector{} - -> ErrorWithoutFlag TcRnRecSelectorEscapedTyVar{} -> ErrorWithoutFlag TcRnPatSynNotBidirectional{} @@ -2195,21 +2236,19 @@ instance Diagnostic TcRnMessage where -> noHints TcRnConflictingExports{} -> noHints - TcRnAmbiguousField{} + TcRnDuplicateFieldExport {} + -> [suggestExtension LangExt.DuplicateRecordFields] + TcRnAmbiguousFieldInUpdate {} + -> [suggestExtension LangExt.DisambiguateRecordFields] + TcRnAmbiguousRecordUpdate{} -> noHints TcRnMissingFields{} -> noHints TcRnFieldUpdateInvalidType{} -> noHints - TcRnNoConstructorHasAllFields{} - -> noHints - TcRnMixedSelectors{} - -> noHints TcRnMissingStrictFields{} -> noHints - TcRnNoPossibleParentForFields{} - -> noHints - TcRnBadOverloadedRecordUpdate{} + TcRnBadRecordUpdate{} -> noHints TcRnStaticFormNotClosed{} -> noHints @@ -2285,8 +2324,6 @@ instance Diagnostic TcRnMessage where -> noHints TcRnExpectedValueId{} -> noHints - TcRnNotARecordSelector{} - -> noHints TcRnRecSelectorEscapedTyVar{} -> [SuggestPatternMatchingSyntax] TcRnPatSynNotBidirectional{} @@ -2623,19 +2660,27 @@ messageWithInfoDiagnosticMessage unit_state ErrInfo{..} show_ctxt important = in (mapDecoratedSDoc (pprWithUnitState unit_state) important) `unionDecoratedSDoc` mkDecorated err_info' -dodgy_msg :: (Outputable a, Outputable b) => SDoc -> a -> b -> SDoc +dodgy_msg :: Outputable ie => SDoc -> GlobalRdrElt -> ie -> SDoc dodgy_msg kind tc ie - = sep [ text "The" <+> kind <+> text "item" - <+> quotes (ppr ie) - <+> text "suggests that", - quotes (ppr tc) <+> text "has (in-scope) constructors or class methods,", - text "but it has none" ] - -dodgy_msg_insert :: forall p . (Anno (IdP (GhcPass p)) ~ SrcSpanAnnN) => IdP (GhcPass p) -> IE (GhcPass p) -dodgy_msg_insert tc = IEThingAll noAnn ii + = vcat [ text "The" <+> kind <+> text "item" <+> quotes (ppr ie) <+> text "suggests that" + , quotes (ppr $ greName tc) <+> text "has" <+> sep rest ] + where + rest :: [SDoc] + rest = + case gre_info tc of + IAmTyCon ClassFlavour + -> [ text "(in-scope) class methods or associated types" <> comma + , text "but it has none" ] + IAmTyCon _ + -> [ text "(in-scope) constructors or record fields" <> comma + , text "but it has none" ] + _ -> [ text "children" <> comma + , text "but it is not a type constructor or a class" ] + +dodgy_msg_insert :: GlobalRdrElt -> IE GhcRn +dodgy_msg_insert tc_gre = IEThingAll noAnn ii where - ii :: LIEWrappedName (GhcPass p) - ii = noLocA (IEName noExtField $ noLocA tc) + ii = noLocA (IEName noExtField $ noLocA $ greName tc_gre) pprTypeDoesNotHaveFixedRuntimeRep :: Type -> FixedRuntimeRepProvenance -> SDoc pprTypeDoesNotHaveFixedRuntimeRep ty prov = @@ -2656,6 +2701,7 @@ pprField (f,ty) = ppr f <+> dcolon <+> ppr ty pprRecordFieldPart :: RecordFieldPart -> SDoc pprRecordFieldPart = \case + RecordFieldDecl {} -> text "declaration" RecordFieldConstructor{} -> text "construction" RecordFieldPattern{} -> text "pattern" RecordFieldUpdate -> text "update" @@ -3951,6 +3997,9 @@ pprScopeError rdr_name scope_err = NotInScope {} -> hang (text "Not in scope:") 2 (what <+> quotes (ppr rdr_name)) + NotARecordField {} -> + hang (text "Not in scope:") + 2 (text "record field" <+> quotes (ppr rdr_name)) NoExactName name -> text "The Name" <+> quotes (ppr name) <+> text "is not in scope." SameName gres -> @@ -3958,7 +4007,8 @@ pprScopeError rdr_name scope_err = $ hang (text "Same Name in multiple name-spaces:") 2 (vcat (map pp_one sorted_names)) where - sorted_names = sortBy (leftmost_smallest `on` nameSrcSpan) (map greMangledName gres) + sorted_names = sortBy (leftmost_smallest `on` nameSrcSpan) + $ map greName gres pp_one name = hang (pprNameSpace (occNameSpace (getOccName name)) <+> quotes (ppr name) <> comma) @@ -3983,6 +4033,7 @@ scopeErrorHints :: NotInScopeError -> [GhcHint] scopeErrorHints scope_err = case scope_err of NotInScope -> noHints + NotARecordField -> noHints NoExactName {} -> [SuggestDumpSlices] SameName {} -> [SuggestDumpSlices] MissingBinding _ hints -> hints @@ -4553,10 +4604,6 @@ pprConversionFailReason = \case text "Implicit parameters mixed with other bindings" InvalidCCallImpent from -> text (show from) <+> text "is not a valid ccall impent" - RecGadtNoCons -> - text "RecGadtC must have at least one constructor name" - GadtNoCons -> - text "GadtC must have at least one constructor name" InvalidTypeInstanceHeader tys -> text "Invalid type instance header:" <+> text (show tys) diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs index 6b8d570c05..c2f19613d4 100644 --- a/compiler/GHC/Tc/Errors/Types.hs +++ b/compiler/GHC/Tc/Errors/Types.hs @@ -15,6 +15,7 @@ module GHC.Tc.Errors.Types ( , ShadowedNameProvenance(..) , RecordFieldPart(..) , IllegalNewtypeReason(..) + , BadRecordUpdateReason(..) , InjectivityErrReason(..) , HasKinds(..) , hasKinds @@ -114,6 +115,7 @@ import GHC.Types.Avail (AvailInfo) import GHC.Types.Error import GHC.Types.Hint (UntickedPromotedThing(..)) import GHC.Types.ForeignCall (CLabelString) +import GHC.Types.Id.Info ( RecSelParent(..) ) import GHC.Types.Name (Name, OccName, getSrcLoc, getSrcSpan) import qualified GHC.Types.Name.Occurrence as OccName import GHC.Types.Name.Reader @@ -132,7 +134,7 @@ import GHC.Core.FamInstEnv (FamInst) import GHC.Core.InstEnv (LookupInstanceErrReason, ClsInst) import GHC.Core.PatSyn (PatSyn) import GHC.Core.Predicate (EqRel, predTypeEqRel) -import GHC.Core.TyCon (TyCon, TyConFlavour) +import GHC.Core.TyCon (TyCon) import GHC.Core.Type (Kind, Type, ThetaType, PredType) import GHC.Driver.Backend (Backend) import GHC.Unit.State (UnitState) @@ -327,15 +329,15 @@ data TcRnMessage where -} TcRnUnusedPatternBinds :: HsBind GhcRn -> TcRnMessage {-| TcRnDodgyImports is a warning (controlled with -Wdodgy-imports) that occurs when - a datatype 'T' is imported with all constructors, i.e. 'T(..)', but has been exported - abstractly, i.e. 'T'. + an import of the form 'T(..)' or 'f(..)' does not actually import anything beside + 'T'/'f' itself. Test cases: rename/should_compile/T7167 -} - TcRnDodgyImports :: RdrName -> TcRnMessage - {-| TcRnDodgyExports is a warning (controlled by -Wdodgy-exports) that occurs when a datatype - 'T' is exported with all constructors, i.e. 'T(..)', but is it just a type synonym or a - type/data family. + TcRnDodgyImports :: GlobalRdrElt -> TcRnMessage + {-| TcRnDodgyExports is a warning (controlled by -Wdodgy-exports) that occurs when + an export of the form 'T(..)' for a type constructor 'T' does not actually export anything + beside 'T' itself. Example: module Foo ( @@ -350,7 +352,7 @@ data TcRnMessage where Test cases: warnings/should_compile/DodgyExports01 -} - TcRnDodgyExports :: Name -> TcRnMessage + TcRnDodgyExports :: GlobalRdrElt -> TcRnMessage {-| TcRnMissingImportList is a warning (controlled by -Wmissing-import-lists) that occurs when an import declaration does not explicitly list all the names brought into scope. @@ -577,13 +579,15 @@ data TcRnMessage where -> !BadAnonWildcardContext -> TcRnMessage - {-| TcRnDuplicateFieldName is an error that occurs whenever - there are duplicate field names in a record. + there are duplicate field names in a single record. - Examples(s): None. + Examples(s): - Test cases: None. + data R = MkR { x :: Int, x :: Bool } + f r = r { x = 3, x = 4 } + + Test cases: T21959. -} TcRnDuplicateFieldName :: !RecordFieldPart -> NE.NonEmpty RdrName -> TcRnMessage @@ -1040,7 +1044,7 @@ data TcRnMessage where Test cases: polykinds/T13267 -} - TcRnIllegalClassInst :: !TyConFlavour -> TcRnMessage + TcRnIllegalClassInst :: !(TyConFlavour TyCon) -> TcRnMessage {-| TcRnOversaturatedVisibleKindArg is an error that occurs whenever an illegal oversaturated visible kind argument is specified. @@ -1342,7 +1346,7 @@ data TcRnMessage where overloadedrecflds/should_fail/DuplicateExports patsyn/should_compile/T11959 -} - TcRnDuplicateExport :: GreName -> IE GhcPs -> IE GhcPs -> TcRnMessage + TcRnDuplicateExport :: GlobalRdrElt -> IE GhcPs -> IE GhcPs -> TcRnMessage {-| TcRnExportedParentChildMismatch is an error that occurs when an export is bundled with a parent that it does not belong to @@ -1358,7 +1362,10 @@ data TcRnMessage where module/mod3 overloadedrecflds/should_fail/NoParent -} - TcRnExportedParentChildMismatch :: Name -> TyThing -> GreName -> [Name] -> TcRnMessage + TcRnExportedParentChildMismatch :: Name -- ^ parent + -> TyThing + -> GlobalRdrElt -- ^ child + -> [Name] -> TcRnMessage {-| TcRnConflictingExports is an error that occurs when different identifiers that have the same name are being exported by a module. @@ -1385,29 +1392,50 @@ data TcRnMessage where typecheck/should_fail/tcfail026 -} TcRnConflictingExports - :: OccName -- ^ Occurrence name shared by both exports - -> GreName -- ^ Name of first export - -> GlobalRdrElt -- ^ Provenance for definition site of first export - -> IE GhcPs -- ^ Export decl of first export - -> GreName -- ^ Name of second export - -> GlobalRdrElt -- ^ Provenance for definition site of second export - -> IE GhcPs -- ^ Export decl of second export + :: OccName -- ^ Occurrence name shared by both exports + -> GlobalRdrElt -- ^ First export + -> IE GhcPs -- ^ Export decl of first export + -> GlobalRdrElt -- ^ Second export + -> IE GhcPs -- ^ Export decl of second export + -> TcRnMessage + + {-| TcRnDuplicateFieldExport is an error that occurs when a module exports + multiple record fields with the same name, without enabling + DuplicateRecordFields. + + Example: + + module M1 where + data D1 = MkD1 { foo :: Int } + module M2 where + data D2 = MkD2 { foo :: Int } + module M ( D1(..), D2(..) ) where + import module M1 + import module M2 + + Test case: overloadedrecflds/should_fail/overloadedrecfldsfail10 + -} + TcRnDuplicateFieldExport + :: (GlobalRdrElt, IE GhcPs) + -> NE.NonEmpty (GlobalRdrElt, IE GhcPs) -> TcRnMessage - {-| TcRnAmbiguousField is a warning controlled by -Wambiguous-fields occurring - when a record update's type cannot be precisely determined. This will not - be supported by -XDuplicateRecordFields in future releases. + {-| TcRnAmbiguousRecordUpdate is a warning, controlled by -Wambiguous-fields, + which occurs when a user relies on the type-directed disambiguation + mechanism to disambiguate a record update. This will not be supported by + -XDuplicateRecordFields in future releases. Example(s): - data Person = MkPerson { personId :: Int, name :: String } - data Address = MkAddress { personId :: Int, address :: String } - bad1 x = x { personId = 4 } :: Person -- ambiguous - bad2 (x :: Person) = x { personId = 4 } -- ambiguous - good x = (x :: Person) { personId = 4 } -- not ambiguous + + data Person = MkPerson { personId :: Int, name :: String } + data Address = MkAddress { personId :: Int, address :: String } + bad1 x = x { personId = 4 } :: Person -- ambiguous + bad2 (x :: Person) = x { personId = 4 } -- ambiguous + good x = (x :: Person) { personId = 4 } -- not ambiguous Test cases: overloadedrecflds/should_fail/overloadedrecfldsfail06 -} - TcRnAmbiguousField + TcRnAmbiguousRecordUpdate :: HsExpr GhcRn -- ^ Field update -> TyCon -- ^ Record type -> TcRnMessage @@ -1442,38 +1470,6 @@ data TcRnMessage where -} TcRnFieldUpdateInvalidType :: [(FieldLabelString,TcType)] -> TcRnMessage - {-| TcRnNoConstructorHasAllFields is an error that occurs when a record update - has fields that no single constructor encompasses. - - Example(s): - data Foo = A { x :: Bool } - | B { y :: Int } - foo = (A False) { x = True, y = 5 } - - Test cases: overloadedrecflds/should_fail/overloadedrecfldsfail08 - patsyn/should_fail/mixed-pat-syn-record-sels - typecheck/should_fail/T7989 - -} - TcRnNoConstructorHasAllFields :: [FieldLabelString] -> TcRnMessage - - {- TcRnMixedSelectors is an error for when a mixture of pattern synonym and - record selectors are used in the same record update block. - - Example(s): - data Rec = Rec { foo :: Int, bar :: String } - pattern Pat { f1, f2 } = Rec { foo = f1, bar = f2 } - illegal :: Rec -> Rec - illegal r = r { f1 = 1, bar = "two" } - - Test cases: patsyn/should_fail/records-mixing-fields - -} - TcRnMixedSelectors - :: Name -- ^ Record - -> [Id] -- ^ Record selectors - -> Name -- ^ Pattern synonym - -> [Id] -- ^ Pattern selectors - -> TcRnMessage - {- TcRnMissingStrictFields is an error occurring when a record field marked as strict is omitted when constructing said record. @@ -1487,30 +1483,54 @@ data TcRnMessage where -} TcRnMissingStrictFields :: ConLike -> [(FieldLabelString, TcType)] -> TcRnMessage - {- TcRnNoPossibleParentForFields is an error thrown when the fields used in a - record update block do not all belong to any one type. + {-| TcRnAmbiguousFieldInUpdate is an error that occurs when a field in a + record update clashes with another field or top-level function of the + same name, and the user hasn't enabled -XDisambiguateRecordFields. - Example(s): - data R1 = R1 { x :: Int, y :: Int } - data R2 = R2 { y :: Int, z :: Int } - update r = r { x = 1, y = 2, z = 3 } + Example: + + {-# LANGUAGE NoFieldSelectors #-} + {-# LANGUAGE NoDisambiguateRecordFields #-} + module M where + + data A = MkA { fld :: Int } + + fld :: Bool + fld = False + + f r = r { fld = 3 } - Test cases: overloadedrecflds/should_fail/overloadedrecfldsfail01 - overloadedrecflds/should_fail/overloadedrecfldsfail14 -} - TcRnNoPossibleParentForFields :: [LHsRecUpdField GhcRn] -> TcRnMessage + TcRnAmbiguousFieldInUpdate :: (GlobalRdrElt, GlobalRdrElt, [GlobalRdrElt]) + -> TcRnMessage + + {-| TcRnBadRecordUpdate is an error when a regular (non-overloaded) + record update cannot be pinned down to any one parent. - {- TcRnBadOverloadedRecordUpdate is an error for a record update that cannot - be pinned down to any one constructor and thus must be given a type signature. + The problem with the record update is stored in the 'BadRecordUpdateReason' + field. Example(s): - data R1 = R1 { x :: Int } - data R2 = R2 { x :: Int } - update r = r { x = 1 } -- needs a type signature + + data R1 = R1 { x :: Int } + data R2 = R2 { x :: Int } + update r = r { x = 1 } + -- ambiguous + + data R1 = R1 { x :: Int, y :: Int } + data R2 = R2 { y :: Int, z :: Int } + update r = r { x = 1, y = 2, z = 3 } + -- no parent has all the fields Test cases: overloadedrecflds/should_fail/overloadedrecfldsfail01 + overloadedrecflds/should_fail/overloadedrecfldsfail01 + overloadedrecflds/should_fail/overloadedrecfldsfail14 -} - TcRnBadOverloadedRecordUpdate :: [LHsRecUpdField GhcRn] -> TcRnMessage + TcRnBadRecordUpdate :: [RdrName] + -- ^ the fields of the record update + -> BadRecordUpdateReason + -- ^ the reason this record update was rejected + -> TcRnMessage {- TcRnStaticFormNotClosed is an error pertaining to terms that are marked static using the -XStaticPointers extension but which are not closed terms. @@ -1932,19 +1952,6 @@ data TcRnMessage where -} TcRnExpectedValueId :: !TcTyThing -> TcRnMessage - {- TcRnNotARecordSelector is an error for when something that is not a record - selector is used in a record pattern. - - Example(s): - data Rec = MkRec { field :: Int } - r = Mkrec 1 - r' = r { notAField = 2 } - - Test cases: rename/should_fail/rnfail054 - typecheck/should_fail/tcfail114 - -} - TcRnNotARecordSelector :: !Name -> TcRnMessage - {- TcRnRecSelectorEscapedTyVar is an error indicating that a record field selector containing an existential type variable is used as a function rather than in a pattern match. @@ -2011,7 +2018,7 @@ data TcRnMessage where Test cases: rename/should_fail/T7943 rename/should_fail/T9077 -} - TcRnIllegalRecordSyntax :: !(HsType GhcRn) -> TcRnMessage + TcRnIllegalRecordSyntax :: Either (HsType GhcPs) (HsType GhcRn) -> TcRnMessage {- TcRnUnexpectedTypeSplice is an error for a typed template haskell splice appearing unexpectedly. @@ -2568,8 +2575,6 @@ data TcRnMessage where th/T16895c th/T16895d th/T16895e - th/T17379a - th/T17379b th/T18740d th/T2597b th/T2674 @@ -3401,8 +3406,6 @@ data ConversionFailReason | CasesExprWithoutAlts | ImplicitParamsWithOtherBinds | InvalidCCallImpent !String -- ^ Source - | RecGadtNoCons - | GadtNoCons | InvalidTypeInstanceHeader !TH.Type | InvalidTyFamInstLHS !TH.Type | InvalidImplicitParamBinding @@ -3438,10 +3441,30 @@ data ArgOrResult -- | Which parts of a record field are affected by a particular error or warning. data RecordFieldPart - = RecordFieldConstructor !Name + = RecordFieldDecl !Name + | RecordFieldConstructor !Name | RecordFieldPattern !Name | RecordFieldUpdate +-- | Why did we reject a record update? +data BadRecordUpdateReason + -- | No constructor has all of the required fields. + = NoConstructorHasAllFields + { conflictingFields :: [FieldLabelString] } + + -- | There are several possible parents which have all of the required fields, + -- and we weren't able to disambiguate in any way. + | MultiplePossibleParents + (RecSelParent, RecSelParent, [RecSelParent]) + -- ^ The possible parents (at least 2) + + -- | We used type-directed disambiguation, but this resulted in + -- an invalid parent (the type-directed parent is not among the + -- parents we computed from the field labels alone). + | InvalidTyConParent TyCon (NE.NonEmpty RecSelParent) + + deriving Generic + -- | Where a shadowed name comes from data ShadowedNameProvenance = ShadowedNameProvenanceLocal !SrcLoc @@ -4289,6 +4312,11 @@ data NotInScopeError -- | A run-of-the-mill @"not in scope"@ error. = NotInScope + -- | Something used in record syntax, but it isn't a record field. + | NotARecordField + -- TODO: this could be folded into NotInScope were there + -- a separate namespace for record fields. + -- | An exact 'Name' was not in scope. -- -- This usually indicates a problem with a Template Haskell splice. diff --git a/compiler/GHC/Tc/Gen/Export.hs b/compiler/GHC/Tc/Gen/Export.hs index dbe9fd828c..eed125e8b0 100644 --- a/compiler/GHC/Tc/Gen/Export.hs +++ b/compiler/GHC/Tc/Gen/Export.hs @@ -3,17 +3,18 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} -module GHC.Tc.Gen.Export (rnExports, exports_from_avail) where +module GHC.Tc.Gen.Export (rnExports, exports_from_avail, classifyGREs) where import GHC.Prelude import GHC.Hs -import GHC.Types.FieldLabel import GHC.Builtin.Names import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Env + ( TyThing(AConLike, AnId), tcLookupGlobal, tcLookupTyCon ) import GHC.Tc.Utils.TcType +import GHC.Rename.Doc import GHC.Rename.Names import GHC.Rename.Env import GHC.Rename.Unbound ( reportUnboundName ) @@ -28,6 +29,9 @@ import GHC.Core.PatSyn import GHC.Data.Maybe import GHC.Data.FastString (fsLit) import GHC.Driver.Env +import GHC.Driver.Session +import GHC.Parser.PostProcess ( setRdrNameSpace ) +import qualified GHC.LanguageExtensions as LangExt import GHC.Types.Unique.Set import GHC.Types.SrcLoc as SrcLoc @@ -40,11 +44,10 @@ import GHC.Types.Id import GHC.Types.Id.Info import GHC.Types.Name.Reader -import Control.Monad -import GHC.Driver.Session -import GHC.Parser.PostProcess ( setRdrNameSpace ) -import Data.Either ( partitionEithers ) -import GHC.Rename.Doc +import Control.Arrow ( first ) +import Control.Monad ( when ) +import qualified Data.List.NonEmpty as NE +import Data.Traversable ( for ) {- ************************************************************************ @@ -147,7 +150,7 @@ accumExports f = fmap (catMaybes . snd) . mapAccumLM f' emptyExportAccum Just (Just (acc', y)) -> (acc', Just y) _ -> (acc, Nothing) -type ExportOccMap = OccEnv (GreName, IE GhcPs) +type ExportOccMap = OccEnv (Name, IE GhcPs) -- Tracks what a particular exported OccName -- in an export list refers to, and which item -- it came from. It's illegal to export two distinct things @@ -206,7 +209,7 @@ rnExports explicit_mod exports else checkNoErrs do_it -- Final processing - ; let final_ns = availsToNameSetWithSelectors final_avails + ; let final_ns = availsToNameSet final_avails ; traceRn "rnExports: Exports:" (ppr final_avails) @@ -249,8 +252,10 @@ exports_from_avail Nothing rdr_env _imports _this_mod -- only data families can locally define subordinate things (`ns` here) -- without locally defining (and instead importing) the parent (`n`) fix_faminst avail@(AvailTC n ns) - | availExportsDecl avail = avail - | otherwise = AvailTC n (NormalGreName n:ns) + | availExportsDecl avail + = avail + | otherwise + = AvailTC n (n:ns) fix_faminst avail = avail @@ -270,8 +275,11 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod -- See Note [Avails of associated data families] expand_tyty_gre :: GlobalRdrElt -> [GlobalRdrElt] expand_tyty_gre (gre@GRE { gre_par = ParentIs p }) - | isTyConName p, isTyConName (greMangledName gre) = [gre, gre{ gre_par = NoParent }] - expand_tyty_gre gre = [gre] + | isTyConName p + , isTyConName (greName gre) + = [gre, gre{ gre_par = NoParent }] + expand_tyty_gre gre + = [gre] imported_modules = [ imv_name imv | xs <- moduleEnvElts $ imp_mods imports @@ -281,120 +289,133 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod -> RnM (Maybe (ExportAccum, (LIE GhcRn, Avails))) exports_from_item (ExportAccum occs earlier_mods) (L loc ie@(IEModuleContents _ lmod@(L _ mod))) - | mod `elementOfUniqSet` earlier_mods -- Duplicate export of M - = do { addDiagnostic (TcRnDupeModuleExport mod) ; - return Nothing } - - | otherwise - = do { let { exportValid = (mod `elem` imported_modules) - || (moduleName this_mod == mod) - ; gre_prs = pickGREsModExp mod (globalRdrEnvElts rdr_env) - ; new_exports = [ availFromGRE gre' - | (gre, _) <- gre_prs - , gre' <- expand_tyty_gre gre ] - ; all_gres = foldr (\(gre1,gre2) gres -> gre1 : gre2 : gres) [] gre_prs - ; mods = addOneToUniqSet earlier_mods mod - } - - ; checkErr exportValid (TcRnExportedModNotImported mod) - ; warnIf (exportValid && null gre_prs) (TcRnNullExportedModule mod) - - ; traceRn "efa" (ppr mod $$ ppr all_gres) - ; addUsedGREs all_gres - - ; occs' <- check_occs ie occs new_exports - -- This check_occs not only finds conflicts - -- between this item and others, but also - -- internally within this item. That is, if - -- 'M.x' is in scope in several ways, we'll have - -- several members of mod_avails with the same - -- OccName. - ; traceRn "export_mod" - (vcat [ ppr mod - , ppr new_exports ]) - - ; return (Just ( ExportAccum occs' mods - , ( L loc (IEModuleContents noExtField lmod) - , new_exports))) } + | mod `elementOfUniqSet` earlier_mods -- Duplicate export of M + = do { addDiagnostic (TcRnDupeModuleExport mod) + ; return Nothing} + + | otherwise + = do { let { exportValid = (mod `elem` imported_modules) + || (moduleName this_mod == mod) + ; gre_prs = pickGREsModExp mod (globalRdrEnvElts rdr_env) + ; new_gres = [ gre' + | (gre, _) <- gre_prs + , gre' <- expand_tyty_gre gre ] + ; new_exports = map availFromGRE new_gres + ; all_gres = foldr (\(gre1,gre2) gres -> gre1 : gre2 : gres) [] gre_prs + ; mods = addOneToUniqSet earlier_mods mod + } + + ; checkErr exportValid (TcRnExportedModNotImported mod) + ; warnIf (exportValid && null gre_prs) (TcRnNullExportedModule mod) + + ; traceRn "efa" (ppr mod $$ ppr all_gres) + ; addUsedGREs all_gres + + ; occs' <- check_occs occs ie new_gres + -- This check_occs not only finds conflicts + -- between this item and others, but also + -- internally within this item. That is, if + -- 'M.x' is in scope in several ways, we'll have + -- several members of mod_avails with the same + -- OccName. + ; traceRn "export_mod" + (vcat [ ppr mod + , ppr new_exports ]) + ; return $ Just $ + ( ExportAccum occs' mods + , ( L loc (IEModuleContents noExtField lmod) + , new_exports) ) } exports_from_item acc@(ExportAccum occs mods) (L loc ie) = do m_new_ie <- lookup_doc_ie ie case m_new_ie of - Just new_ie -> return (Just (acc, (L loc new_ie, []))) + Just new_ie -> return $ Just (acc, (L loc new_ie, [])) Nothing -> do - (new_ie, avail) <- lookup_ie ie - if isUnboundName (ieName new_ie) - then return Nothing -- Avoid error cascade - else do - - occs' <- check_occs ie occs [avail] - - return (Just ( ExportAccum occs' mods - , (L loc new_ie, [avail]))) + let finish (occs', new_ie, avail) = (ExportAccum occs' mods, (L loc new_ie, [avail])) + fmap finish <$> lookup_ie occs ie ------------- - lookup_ie :: IE GhcPs -> RnM (IE GhcRn, AvailInfo) - lookup_ie (IEVar _ (L l rdr)) - = do (name, avail) <- lookupGreAvailRn $ ieWrappedName rdr - return (IEVar noExtField (L l (replaceWrappedName rdr name)), avail) - - lookup_ie (IEThingAbs _ (L l rdr)) - = do (name, avail) <- lookupGreAvailRn $ ieWrappedName rdr - return (IEThingAbs noAnn (L l (replaceWrappedName rdr name)) - , avail) - - lookup_ie ie@(IEThingAll _ n') + lookup_ie :: ExportOccMap -> IE GhcPs -> RnM (Maybe (ExportOccMap, IE GhcRn, AvailInfo)) + lookup_ie occs ie@(IEVar ann (L l rdr)) + = do mb_gre <- lookupGreAvailRn $ ieWrappedName rdr + for mb_gre $ \ gre -> do + let avail = availFromGRE gre + name = greName gre + occs' <- check_occs occs ie [gre] + return (occs', IEVar ann (L l (replaceWrappedName rdr name)), avail) + + lookup_ie occs ie@(IEThingAbs ann (L l rdr)) + = do mb_gre <- lookupGreAvailRn $ ieWrappedName rdr + for mb_gre $ \ gre -> do + let avail = availFromGRE gre + name = greName gre + occs' <- check_occs occs ie [gre] + return ( occs' + , IEThingAbs ann (L l (replaceWrappedName rdr name)) + , avail) + + lookup_ie occs ie@(IEThingAll ann n') = do - (n, avail, flds) <- lookup_ie_all ie n' + (n, kids) <- lookup_ie_all ie n' let name = unLoc n - return (IEThingAll noAnn (replaceLWrappedName n' (unLoc n)) - , availTC name (name:avail) flds) - - - lookup_ie ie@(IEThingWith _ l wc sub_rdrs) + avails = map greName kids + occs' <- check_occs occs ie kids + return $ Just + ( occs' + , IEThingAll ann (replaceLWrappedName n' (unLoc n)) + , AvailTC name (name:avails)) + + lookup_ie occs ie@(IEThingWith ann l wc sub_rdrs) = do - (lname, subs, avails, flds) + (lname, subs, with_gres) <- addExportErrCtxt ie $ lookup_ie_with l sub_rdrs - (_, all_avail, all_flds) <- + + (_, wc_gres) <- case wc of - NoIEWildcard -> return (lname, [], []) + NoIEWildcard -> return (lname, []) IEWildcard _ -> lookup_ie_all ie l + let name = unLoc lname - let flds' = flds ++ (map noLoc all_flds) - return (IEThingWith flds' (replaceLWrappedName l name) wc subs, - availTC name (name : avails ++ all_avail) - (map unLoc flds ++ all_flds)) + all_names = name : map greName (with_gres ++ wc_gres) + gres = localVanillaGRE NoParent name + -- localVanillaGRE might not be correct here, + -- but these GREs are only passed to check_occs + -- which only needs the correct Name for the GREs... + : with_gres ++ wc_gres + occs' <- check_occs occs ie gres + return $ Just $ + ( occs' + , IEThingWith ann (replaceLWrappedName l name) wc subs + , AvailTC name all_names) - lookup_ie _ = panic "lookup_ie" -- Other cases covered earlier + lookup_ie _ _ = panic "lookup_ie" -- Other cases covered earlier lookup_ie_with :: LIEWrappedName GhcPs -> [LIEWrappedName GhcPs] - -> RnM (Located Name, [LIEWrappedName GhcRn], [Name], - [Located FieldLabel]) - lookup_ie_with (L l rdr) sub_rdrs - = do name <- lookupGlobalOccRn $ ieWrappedName rdr - (non_flds, flds) <- lookupChildrenExport name sub_rdrs - if isUnboundName name - then return (L (locA l) name, [], [name], []) - else return (L (locA l) name, non_flds - , map (ieWrappedName . unLoc) non_flds - , flds) + -> RnM (Located Name, [LIEWrappedName GhcRn], [GlobalRdrElt]) + lookup_ie_with (L l rdr) sub_rdrs = + do { gre <- lookupGlobalOccRn $ ieWrappedName rdr + ; let name = greName gre + ; kids <- lookupChildrenExport name sub_rdrs + ; if isUnboundName name + then return (L (locA l) name, [], [gre]) + else return (L (locA l) name, map fst kids, map snd kids) } lookup_ie_all :: IE GhcPs -> LIEWrappedName GhcPs - -> RnM (Located Name, [Name], [FieldLabel]) + -> RnM (Located Name, [GlobalRdrElt]) lookup_ie_all ie (L l rdr) = - do name <- lookupGlobalOccRn $ ieWrappedName rdr - let gres = findChildren kids_env name - (non_flds, flds) = classifyGREs gres - addUsedKids (ieWrappedName rdr) gres - when (null gres) $ - if isTyConName name - then addTcRnDiagnostic (TcRnDodgyExports name) - else -- This occurs when you export T(..), but - -- only import T abstractly, or T is a synonym. - addErr (TcRnExportHiddenComponents ie) - return (L (locA l) name, non_flds, flds) + do { gre <- lookupGlobalOccRn $ ieWrappedName rdr + ; let name = greName gre + gres = findChildren kids_env name + ; addUsedKids (ieWrappedName rdr) gres + ; when (null gres) $ + if isTyConName name + then addTcRnDiagnostic (TcRnDodgyExports gre) + else -- This occurs when you export T(..), but + -- only import T abstractly, or T is a synonym. + addErr (TcRnExportHiddenComponents ie) + ; return (L (locA l) name, gres) } ------------- lookup_doc_ie :: IE GhcPs -> RnM (Maybe (IE GhcRn)) @@ -413,9 +434,6 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod addUsedKids :: RdrName -> [GlobalRdrElt] -> RnM () addUsedKids parent_rdr kid_gres = addUsedGREs (pickGREs parent_rdr kid_gres) -classifyGREs :: [GlobalRdrElt] -> ([Name], [FieldLabel]) -classifyGREs = partitionGreNames . map gre_name - -- Renaming and typechecking of exports happens after everything else has -- been typechecked. @@ -477,11 +495,8 @@ If the module has NO main function: lookupChildrenExport :: Name -> [LIEWrappedName GhcPs] - -> RnM ([LIEWrappedName GhcRn], [Located FieldLabel]) -lookupChildrenExport spec_parent rdr_items = - do - xs <- mapAndReportM doOne rdr_items - return $ partitionEithers xs + -> RnM ([(LIEWrappedName GhcRn, GlobalRdrElt)]) +lookupChildrenExport spec_parent rdr_items = mapAndReportM doOne rdr_items where -- Pick out the possible namespaces in order of priority -- This is a consequence of how the parser parses all @@ -489,11 +504,13 @@ lookupChildrenExport spec_parent rdr_items = choosePossibleNamespaces :: NameSpace -> [NameSpace] choosePossibleNamespaces ns | ns == varName = [varName, tcName] + -- NB: for varName, we will also end up looking in the + -- record field namespaces. | ns == tcName = [dataName, tcName] | otherwise = [ns] -- Process an individual child doOne :: LIEWrappedName GhcPs - -> RnM (Either (LIEWrappedName GhcRn) (Located FieldLabel)) + -> RnM (LIEWrappedName GhcRn, GlobalRdrElt) doOne n = do let bareName = (ieWrappedName . unLoc) n @@ -507,18 +524,20 @@ lookupChildrenExport spec_parent rdr_items = -- messages let unboundName :: RdrName unboundName = if rdrNameSpace bareName == varName - then bareName - else setRdrNameSpace bareName dataName + then bareName + else setRdrNameSpace bareName dataName case name of - NameNotFound -> do { ub <- reportUnboundName unboundName - ; let l = getLoc n - ; return (Left (L l (IEName noExtField (L (la2na l) ub))))} - FoundChild par child -> do { checkPatSynParent spec_parent par child - ; return $ case child of - FieldGreName fl -> Right (L (getLocA n) fl) - NormalGreName name -> Left (replaceLWrappedName n name) - } + NameNotFound -> + do { ub <- reportUnboundName unboundName + ; let l = getLoc n + gre = localVanillaGRE NoParent ub + ; return (L l (IEName noExtField (L (la2na l) ub)), gre)} + FoundChild child@(GRE { gre_par = par }) -> + do { checkPatSynParent spec_parent par child + ; let child_nm = greName child + ; return (replaceLWrappedName n child_nm, child) + } IncorrectParent p c gs -> failWithDcErr p c gs @@ -582,30 +601,32 @@ lookupChildrenExport spec_parent rdr_items = checkPatSynParent :: Name -- ^ Alleged parent type constructor -- User wrote T( P, Q ) -> Parent -- The parent of P we discovered - -> GreName -- ^ Either a - -- a) Pattern Synonym Constructor - -- b) A pattern synonym selector + -> GlobalRdrElt + -- ^ Either a + -- a) Pattern Synonym Constructor + -- b) A pattern synonym selector -> TcM () -- Fails if wrong parent checkPatSynParent _ (ParentIs {}) _ = return () -checkPatSynParent parent NoParent gname +checkPatSynParent parent NoParent gre | isUnboundName parent -- Avoid an error cascade = return () | otherwise - = do { parent_ty_con <- tcLookupTyCon parent - ; mpat_syn_thing <- tcLookupGlobal (greNameMangledName gname) + = do { parent_ty_con <- tcLookupTyCon parent + ; let nm = greName gre + ; mpat_syn_thing <- tcLookupGlobal nm -- 1. Check that the Id was actually from a thing associated with patsyns ; case mpat_syn_thing of AnId i | isId i , RecSelId { sel_tycon = RecSelPatSyn p } <- idDetails i - -> handle_pat_syn (selErr gname) parent_ty_con p + -> handle_pat_syn (selErr nm) parent_ty_con p AConLike (PatSynCon p) -> handle_pat_syn (psErr p) parent_ty_con p - _ -> failWithDcErr parent gname [] } + _ -> failWithDcErr parent gre [] } where psErr = exportErrCtxt "pattern synonym" selErr = exportErrCtxt "pattern synonym record selector" @@ -641,73 +662,65 @@ checkPatSynParent parent NoParent gname {-===========================================================================-} -check_occs :: IE GhcPs -> ExportOccMap -> [AvailInfo] - -> RnM ExportOccMap -check_occs ie occs avails - -- 'avails' are the entities specified by 'ie' - = foldlM check occs children + +-- | Check that the each of the given 'GlobalRdrElt's does not appear multiple +-- times in the 'ExportOccMap', as per Note [Exporting duplicate declarations]. +check_occs :: ExportOccMap -> IE GhcPs -> [GlobalRdrElt] -> RnM ExportOccMap +check_occs occs ie gres + -- 'gres' are the entities specified by 'ie' + = do { drf <- xoptM LangExt.DuplicateRecordFields + ; foldlM (check drf) occs gres } where - children = concatMap availGreNames avails -- Check for distinct children exported with the same OccName (an error) or -- for duplicate exports of the same child (a warning). - check :: ExportOccMap -> GreName -> RnM ExportOccMap - check occs child - = case try_insert occs child of - Right occs' -> return occs' + -- + -- See Note [Exporting duplicate declarations]. + check :: Bool -> ExportOccMap -> GlobalRdrElt -> RnM ExportOccMap + check drf_enabled occs gre + = case try_insert occs gre of + Right occs' + -- If DuplicateRecordFields is not enabled, also make sure + -- that we are not exporting two fields with the same occNameFS + -- under different namespaces. + -- + -- See Note [Exporting duplicate record fields]. + | drf_enabled || not (isFieldOcc child_occ) + -> return occs' + | otherwise + -> do { let flds = filter (\(_,ie') -> not $ dupFieldExport_ok ie ie') + $ lookupFieldsOccEnv occs (occNameFS child_occ) + ; case flds of { [] -> return occs'; clash1:clashes -> + do { addDuplicateFieldExportErr (gre,ie) (clash1 NE.:| clashes) + ; return occs } } } Left (child', ie') - | greNameMangledName child == greNameMangledName child' -- Duplicate export - -- But we don't want to warn if the same thing is exported - -- by two different module exports. See ticket #4478. - -> do { warnIf (not (dupExport_ok child ie ie')) (TcRnDuplicateExport child ie ie') + | child == child' -- Duplicate export of a single Name: a warning. + -> do { warnIf (not (dupExport_ok child ie ie')) (TcRnDuplicateExport gre ie ie') ; return occs } - | otherwise -- Same occ name but different names: an error - -> do { global_env <- getGlobalRdrEnv ; - addErr (exportClashErr global_env child' child ie' ie) ; - return occs } + | otherwise -- Same OccName but different Name: an error. + -> do { global_env <- getGlobalRdrEnv + ; addErr (exportClashErr global_env child' child ie' ie) + ; return occs } + where + child = greName gre + child_occ = occName child -- Try to insert a child into the map, returning Left if there is something - -- already exported with the same OccName - try_insert :: ExportOccMap -> GreName -> Either (GreName, IE GhcPs) ExportOccMap + -- already exported with the same OccName. + try_insert :: ExportOccMap -> GlobalRdrElt -> Either (Name, IE GhcPs) ExportOccMap try_insert occs child - = case lookupOccEnv occs name_occ of - Nothing -> Right (extendOccEnv occs name_occ (child, ie)) + = case lookupOccEnv occs occ of + Nothing -> Right (extendOccEnv occs occ (greName child, ie)) Just x -> Left x where - -- For fields, we check for export clashes using the (OccName of the) - -- selector Name - name_occ = nameOccName (greNameMangledName child) - + occ = greOccName child -dupExport_ok :: GreName -> IE GhcPs -> IE GhcPs -> Bool --- The GreName is exported by both IEs. Is that ok? --- "No" iff the name is mentioned explicitly in both IEs --- or one of the IEs mentions the name *alone* --- "Yes" otherwise --- --- Examples of "no": module M( f, f ) --- module M( fmap, Functor(..) ) --- module M( module Data.List, head ) --- --- Example of "yes" --- module M( module A, module B ) where --- import A( f ) --- import B( f ) +-- | Is it OK for the given name to be exported by both export items? -- --- Example of "yes" (#2436) --- module M( C(..), T(..) ) where --- class C a where { data T a } --- instance C Int where { data T Int = TInt } --- --- Example of "yes" (#2436) --- module Foo ( T ) where --- data family T a --- module Bar ( T(..), module Foo ) where --- import Foo --- data instance T Int = TInt - +-- See Note [Exporting duplicate declarations]. +dupExport_ok :: Name -> IE GhcPs -> IE GhcPs -> Bool dupExport_ok child ie1 ie2 = not ( single ie1 || single ie2 || (explicit_in ie1 && explicit_in ie2) ) @@ -719,8 +732,7 @@ dupExport_ok child ie1 ie2 single IEVar {} = True single IEThingAbs {} = True - single _ = False - + single _ = False exportErrCtxt :: Outputable o => String -> o -> SDoc exportErrCtxt herald exp = @@ -734,18 +746,18 @@ addExportErrCtxt ie = addErrCtxt exportCtxt exportCtxt = text "In the export:" <+> ppr ie -failWithDcErr :: Name -> GreName -> [Name] -> TcM a +failWithDcErr :: Name -> GlobalRdrElt -> [Name] -> TcM a failWithDcErr parent child parents = do - ty_thing <- tcLookupGlobal (greNameMangledName child) + ty_thing <- tcLookupGlobal (greName child) failWithTc $ TcRnExportedParentChildMismatch parent ty_thing child parents exportClashErr :: GlobalRdrEnv - -> GreName -> GreName + -> Name -> Name -> IE GhcPs -> IE GhcPs -> TcRnMessage exportClashErr global_env child1 child2 ie1 ie2 - = TcRnConflictingExports occ child1' gre1' ie1' child2' gre2' ie2' + = TcRnConflictingExports occ gre1' ie1' gre2' ie2' where occ = occName child1 -- get_gre finds a GRE for the Name, so that we can show its provenance @@ -753,9 +765,127 @@ exportClashErr global_env child1 child2 ie1 ie2 gre2 = get_gre child2 get_gre child = fromMaybe (pprPanic "exportClashErr" (ppr child)) - (lookupGRE_GreName global_env child) - (child1', gre1', ie1', child2', gre2', ie2') = + (lookupGRE_Name global_env child) + (gre1', ie1', gre2', ie2') = case SrcLoc.leftmost_smallest (greSrcSpan gre1) (greSrcSpan gre2) of - LT -> (child1, gre1, ie1, child2, gre2, ie2) - GT -> (child2, gre2, ie2, child1, gre1, ie1) + LT -> (gre1, ie1, gre2, ie2) + GT -> (gre2, ie2, gre1, ie1) EQ -> panic "exportClashErr: clashing exports have identical location" + +addDuplicateFieldExportErr :: (GlobalRdrElt, IE GhcPs) + -> NE.NonEmpty (Name, IE GhcPs) + -> RnM () +addDuplicateFieldExportErr gre others + = do { rdr_env <- getGlobalRdrEnv + ; let lkup = expectJust "addDuplicateFieldExportErr" . lookupGRE_Name rdr_env + other_gres = fmap (first lkup) others + ; addErr (TcRnDuplicateFieldExport gre other_gres) } + +-- | Is it OK to export two clashing duplicate record fields coming from the +-- given export items, with @-XDisambiguateRecordFields@ disabled? +-- +-- See Note [Exporting duplicate record fields]. +dupFieldExport_ok :: IE GhcPs -> IE GhcPs -> Bool +dupFieldExport_ok ie1 ie2 + | IEModuleContents {} <- ie1 + , ie2 == ie1 + = True + | otherwise + = False + +{- Note [Exporting duplicate declarations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We want to check that two different export items don't have both attempt to export +the same thing. What do we mean precisely? There are three main situations to consider: + + 1. We export two distinct Names with identical OccNames. This is an error. + 2. We export the same Name in two different export items. This is usually + a warning, but see below. + 3. We export a duplicate record field, and DuplicateRecordFields is not enabled. + See Note [Exporting duplicate record fields]. + +Concerning (2), we sometimes want to allow a duplicate export of a given Name, +as #4478 points out. The logic, as implemented in dupExport_ok, is that we +do not allow a given Name to be exported by two IEs iff either: + + - the Name is mentioned explicitly in both IEs, or + - one of the IEs mentions the name *alone*. + +Examples: + + NOT OK: module M( f, f ) + + f is mentioned explicitly in both + + NOT OK: module M( fmap, Functor(..) ) + NOT OK: module M( module Data.Functor, fmap ) + + One of the import items mentions fmap alone, which is also + exported by the other export item. + + OK: + module M( module A, module B ) where + import A( f ) + import B( f ) + + OK: (#2436) + module M( C(..), T(..) ) where + class C a where { data T a } + instance C Int where { data T Int = TInt } + + OK: (#2436) + module Foo ( T ) where + data family T a + module Bar ( T(..), module Foo ) where + import Foo + data instance T Int = TInt + +Note [Exporting duplicate record fields] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Record fields belonging to different datatypes belong to different namespaces, +as explained in Note [Record field namespacing] in GHC.Types.Name.Occurrence. +However, when the DuplicateRecordFields extension is NOT enabled, we want to +prevent users from exporting record fields that share the same underlying occNameFS. + +To enforce this, in check_occs, when inserting a new record field into the ExportOccMap +and DuplicateRecordFields is not enabled, we also look up any clashing record fields, +and report an error. + +Note however that the clash check has an extra wrinkle, similar to dupExport_ok, +as we want to allow the following: + + {-# LANGUAGE DuplicateRecordFields #-} + module M1 where + data D1 = MkD1 { foo :: Int } + data D2 = MkD2 { foo :: Bool } + + --------------------------------------------- + + module M2 ( module M1 ) where + import M1 + +That is, we should be allowed to re-export the whole module M1, without reporting +any nameclashes, even though M1 exports duplicate record fields and we have not +enabled -XDuplicateRecordFields in M2. This logic is implemented in +dupFieldExport_ok. See test case NoDRFModuleExport. + +Note that this logic only applies to whole-module imports, as we don't want +to allow the following: + + module N0 where + data family D a + module N1 where + import N0 + data instance D Int = MkDInt { foo :: Int } + module N2 where + import N0 + data instance D Bool = MkDBool { foo :: Int } + + module N (D(..)) where + import N1 + import N2 + +Here, the single export item D(..) of N exports both record fields, +`$fld:MkDInt:foo` and `$fld:MkDBool:foo`, so we have to reject the program. +See test overloadedrecfldsfail10. +-} diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs index 8ab5ad3d0d..8a7ce396bf 100644 --- a/compiler/GHC/Tc/Gen/Expr.hs +++ b/compiler/GHC/Tc/Gen/Expr.hs @@ -27,7 +27,10 @@ module GHC.Tc.Gen.Expr import GHC.Prelude -import {-# SOURCE #-} GHC.Tc.Gen.Splice( tcTypedSplice, tcTypedBracket, tcUntypedBracket ) +import Language.Haskell.Syntax.Basic (FieldLabelString(..)) + +import {-# SOURCE #-} GHC.Tc.Gen.Splice + ( tcTypedSplice, tcTypedBracket, tcUntypedBracket ) import GHC.Hs import GHC.Hs.Syn.Type @@ -38,7 +41,9 @@ import GHC.Tc.Utils.Unify import GHC.Types.Basic import GHC.Types.Error import GHC.Types.FieldLabel -import GHC.Types.Unique.Map ( UniqMap, listToUniqMap, lookupUniqMap ) +import GHC.Types.Unique.FM +import GHC.Types.Unique.Map +import GHC.Types.Unique.Set import GHC.Core.Multiplicity import GHC.Core.UsageEnv import GHC.Tc.Errors.Types @@ -50,7 +55,7 @@ import GHC.Tc.Gen.Bind ( tcLocalBinds ) import GHC.Tc.Instance.Family ( tcGetFamInstEnvs ) import GHC.Core.FamInstEnv ( FamInstEnvs ) import GHC.Rename.Expr ( mkExpandedExpr ) -import GHC.Rename.Env ( addUsedGRE ) +import GHC.Rename.Env ( addUsedGRE, getUpdFieldLbls ) import GHC.Tc.Utils.Env import GHC.Tc.Gen.Arrow import GHC.Tc.Gen.Match @@ -62,11 +67,11 @@ import GHC.Types.Id import GHC.Types.Id.Info import GHC.Core.ConLike import GHC.Core.DataCon -import GHC.Core.PatSyn import GHC.Types.Name import GHC.Types.Name.Env import GHC.Types.Name.Set import GHC.Types.Name.Reader +import GHC.Core.Class(classTyCon) import GHC.Core.TyCon import GHC.Core.Type import GHC.Core.Coercion( mkSymCo ) @@ -77,23 +82,16 @@ import GHC.Builtin.Uniques ( mkBuiltinUnique ) import GHC.Driver.Session import GHC.Types.SrcLoc import GHC.Utils.Misc +import GHC.Data.Bag ( unitBag ) import GHC.Data.List.SetOps import GHC.Data.Maybe import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic import GHC.Utils.Panic.Plain -import Control.Monad -import GHC.Core.Class(classTyCon) -import GHC.Types.Unique.Set ( UniqSet, mkUniqSet, elementOfUniqSet, nonDetEltsUniqSet ) - -import Language.Haskell.Syntax.Basic (FieldLabelString(..)) -import Data.Function -import Data.List (partition, sortBy, intersect) +import Control.Monad import qualified Data.List.NonEmpty as NE -import GHC.Data.Bag ( unitBag ) - {- ************************************************************************ * * @@ -515,10 +513,17 @@ tcExpr expr@(RecordCon { rcon_con = L loc con_name -- in the renamer. See Note [Overview of record dot syntax] in -- GHC.Hs.Expr. This is why we match on 'rupd_flds = Left rbnds' here -- and panic otherwise. -tcExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = Left rbnds }) res_ty +tcExpr expr@(RecordUpd { rupd_expr = record_expr + , rupd_flds = + RegularRecUpdFields + { xRecUpdFields = possible_parents + , recUpdFields = rbnds } + }) + res_ty = assert (notNull rbnds) $ do { -- Desugar the record update. See Note [Record Updates]. - ; (ds_expr, ds_res_ty, err_ctxt) <- desugarRecordUpd record_expr rbnds res_ty + ; (ds_expr, ds_res_ty, err_ctxt) + <- desugarRecordUpd record_expr possible_parents rbnds res_ty -- Typecheck the desugared expression. ; expr' <- addErrCtxt err_ctxt $ @@ -534,7 +539,8 @@ tcExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = Left rbnds }) res_ -- Test case: T10808. } -tcExpr (RecordUpd {}) _ = panic "tcExpr: unexpected overloaded-dot RecordUpd" +tcExpr e@(RecordUpd { rupd_flds = OverloadedRecUpdFields {}}) _ + = pprPanic "tcExpr: unexpected overloaded-dot RecordUpd" $ ppr e {- ************************************************************************ @@ -888,141 +894,8 @@ in the other order, the extra signature in f2 is reqd. * * ********************************************************************* -} -{- -Note [Type of a record update] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The main complication with RecordUpd is that we need to explicitly -handle the *non-updated* fields. Consider: - - data T a b c = MkT1 { fa :: a, fb :: (b,c) } - | MkT2 { fa :: a, fb :: (b,c), fc :: c -> c } - | MkT3 { fd :: a } - - upd :: T a b c -> (b',c) -> T a b' c - upd t x = t { fb = x} - -The result type should be (T a b' c) -not (T a b c), because 'b' *is not* mentioned in a non-updated field -not (T a b' c'), because 'c' *is* mentioned in a non-updated field -NB that it's not good enough to look at just one constructor; we must -look at them all; cf #3219 - -After all, upd should be equivalent to: - upd t x = case t of - MkT1 p q -> MkT1 p x - MkT2 a b -> MkT2 p b - MkT3 d -> error ... - -So we need to give a completely fresh type to the result record, -and then constrain it by the fields that are *not* updated ("p" above). -We call these the "fixed" type variables, and compute them in getFixedTyVars. - -Note that because MkT3 doesn't contain all the fields being updated, -its RHS is simply an error, so it doesn't impose any type constraints. -Hence the use of 'relevant_cont'. - -Note [Implicit type sharing] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We also take into account any "implicit" non-update fields. For example - data T a b where { MkT { f::a } :: T a a; ... } -So the "real" type of MkT is: forall ab. (a~b) => a -> T a b - -Then consider - upd t x = t { f=x } -We infer the type - upd :: T a b -> a -> T a b - upd (t::T a b) (x::a) - = case t of { MkT (co:a~b) (_:a) -> MkT co x } -We can't give it the more general type - upd :: T a b -> c -> T c b - -Note [Criteria for update] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -We want to allow update for existentials etc, provided the updated -field isn't part of the existential. For example, this should be ok. - data T a where { MkT { f1::a, f2::b->b } :: T a } - f :: T a -> b -> T b - f t b = t { f1=b } - -The criterion we use is this: - - The types of the updated fields - mention only the universally-quantified type variables - of the data constructor - -NB: this is not (quite) the same as being a "naughty" record selector -(See Note [Naughty record selectors]) in GHC.Tc.TyCl), at least -in the case of GADTs. Consider - data T a where { MkT :: { f :: a } :: T [a] } -Then f is not "naughty" because it has a well-typed record selector. -But we don't allow updates for 'f'. (One could consider trying to -allow this, but it makes my head hurt. Badly. And no one has asked -for it.) - -In principle one could go further, and allow - g :: T a -> T a - g t = t { f2 = \x -> x } -because the expression is polymorphic...but that seems a bridge too far. - -Note [Data family example] -~~~~~~~~~~~~~~~~~~~~~~~~~~ - data instance T (a,b) = MkT { x::a, y::b } - ---> - data :TP a b = MkT { a::a, y::b } - coTP a b :: T (a,b) ~ :TP a b - -Suppose r :: T (t1,t2), e :: t3 -Then r { x=e } :: T (t3,t1) - ---> - case r |> co1 of - MkT x y -> MkT e y |> co2 - where co1 :: T (t1,t2) ~ :TP t1 t2 - co2 :: :TP t3 t2 ~ T (t3,t2) -The wrapping with co2 is done by the constructor wrapper for MkT - -Outgoing invariants -~~~~~~~~~~~~~~~~~~~ -In the outgoing (HsRecordUpd scrut binds cons in_inst_tys out_inst_tys): - - * cons are the data constructors to be updated - - * in_inst_tys, out_inst_tys have same length, and instantiate the - *representation* tycon of the data cons. In Note [Data - family example], in_inst_tys = [t1,t2], out_inst_tys = [t3,t2] - -Note [Mixed Record Field Updates] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider the following pattern synonym. - - data MyRec = MyRec { foo :: Int, qux :: String } - - pattern HisRec{f1, f2} = MyRec{foo = f1, qux=f2} - -This allows updates such as the following - - updater :: MyRec -> MyRec - updater a = a {f1 = 1 } - -It would also make sense to allow the following update (which we reject). - - updater a = a {f1 = 1, qux = "two" } ==? MyRec 1 "two" - -This leads to confusing behaviour when the selectors in fact refer the same -field. - - updater a = a {f1 = 1, foo = 2} ==? ??? - -For this reason, we reject a mixture of pattern synonym and normal record -selectors in the same update block. Although of course we still allow the -following. - - updater a = (a {f1 = 1}) {foo = 2} - - > updater (MyRec 0 "str") - MyRec 2 "str" - -Note [Record Updates] -~~~~~~~~~~~~~~~~~~~~~ +{- Note [Record Updates] +~~~~~~~~~~~~~~~~~~~~~~~~ To typecheck a record update, we desugar it first. Suppose we have data T p q = T1 { x :: Int, y :: Bool, z :: Char } | T2 { v :: Char } @@ -1041,74 +914,114 @@ T2, T3 and T5 should not occur, so we omit them from the match. The critical part of desugaring is to identify T and then T1/T4. Wrinkle [Disambiguating fields] -As outlined above, to typecheck a record update via desugaring, we first need -to identify the parent record `TyCon` (`T` above). This can be tricky when several -record types share the same field (with `-XDuplicateRecordFields`). -Currently, we use the inferred type of the record to help disambiguate the record -fields. For example, in + As explained in Note [Disambiguating record updates] in GHC.Rename.Pat, + to typecheck a record update we first need to disambiguate the field labels, + in order to find a parent which has at least one constructor with all of the fields + being updated. - ( mempty :: T a b ) { x = 3 } + As mentioned in Note [Type-directed record disambiguation], we sometimes use + type-directed disambiguation, although this mechanism is deprecated and + scheduled for removal via the implementation of GHC proposal #366 + https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0366-no-ambiguous-field-access.rst. -the type signature on `mempty` allows us to disambiguate the record `TyCon` to `T`, -when there might be other datatypes with field `x :: Int`. -This complexity is scheduled for removal via the implementation of GHC proposal #366 -https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0366-no-ambiguous-field-access.rst -However, for the time being, we still need to disambiguate record fields using the -inferred types. This means that, when typechecking a record update via desugaring, -we need to do the following: +All in all, this means that when typechecking a record update via desugaring, +we take the following steps: - D1. Perform a first typechecking pass on the record expression (`e` in the example above), + (0) Perform a first typechecking pass on the record expression (`e` in the example above), to infer the type of the record being updated. - D2. Desugar the record update as described above, using an HsExpansion. - D3. Typecheck the desugared code. - -In (D1), we call inferRho to infer the type of the record being updated. This returns the + (1) Disambiguate the record fields (potentially using the type obtained in (0)). + (2) Desugar the record update as described above, using an HsExpansion. + (a) Create a let-binding to share the record update right-hand sides. + (b) Desugar the record update to a case expression updating all the + relevant constructors (those that have all of the fields being updated). + (3) Typecheck the desugared code. + +In (0), we call inferRho to infer the type of the record being updated. This returns the inferred type of the record, together with a typechecked expression (of type HsExpr GhcTc) and a collection of residual constraints. We have no need for the latter two, because we will typecheck again in (D3). So, for the time being (and until GHC proposal #366 is implemented), we simply drop them. Wrinkle [Using IdSig] -As noted above, we want to let-bind the updated fields to avoid code duplication: - let { x' = e1; y' = e2 } in - case e of - T1 _ _ z -> T1 x' y' z - T4 p _ _ -> T4 p y' x' + As noted above, we want to let-bind the updated fields to avoid code duplication: + + let { x' = e1; y' = e2 } in + case e of + T1 _ _ z -> T1 x' y' z + T4 p _ _ -> T4 p y' x' + + However, doing so in a naive way would cause difficulties for type inference. + For example: + + data R b = MkR { f :: (forall a. a -> a) -> (Int,b), c :: Int } + foo r = r { f = \ k -> (k 3, k 'x') } + + If we desugar to: + + ds_foo r = + let f' = \ k -> (k 3, k 'x') + in case r of + MkR _ b -> MkR f' b + + then we are unable to infer an appropriately polymorphic type for f', because we + never infer higher-rank types. To circumvent this problem, we proceed as follows: -However, doing so in a naive way would cause difficulties for type inference. -For example: + 1. Obtain general field types by instantiating any of the constructors + that contain all the necessary fields. (Note that the field type must be + identical across different constructors of a given data constructor). + 2. Let-bind an 'IdSig' with this type. This amounts to giving the let-bound + 'Id's a partial type signature. - data R b = MkR { f :: (forall a. a -> a) -> (Int,b), c :: Int } - foo r = r { f = \ k -> (k 3, k 'x') } + In the above example, it's as if we wrote: -If we desugar to: + ds_foo r = + let f' :: (forall a. a -> a) -> (Int, _b) + f' = \ k -> (k 3, k 'x') + in case r of + MkR _ b -> MkR f' b - ds_foo r = - let f' = \ k -> (k 3, k 'x') - in case r of - MkR _ b -> MkR f' b + This allows us to compute the right type for f', and thus accept this record update. -then we are unable to infer an appropriately polymorphic type for f', because we -never infer higher-rank types. To circumvent this problem, we proceed as follows: +Note [Type-directed record disambiguation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +GHC currently supports an additional type-directed disambiguation +mechanism, which is deprecated and scheduled for removal as part of +GHC proposal #366 https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0366-no-ambiguous-field-access.rst. - 1. Obtain general field types by instantiating any of the constructors - that contain all the necessary fields. (Note that the field type must be - identical across different constructors of a given data constructor). - 2. Let-bind an 'IdSig' with this type. This amounts to giving the let-bound - 'Id's a partial type signature. +To perform this disambiguation, when there are multiple possible parents for +a record update, the renamer defers to the typechecker. +See GHC.Tc.Gen.Expr.disambiguateRecordBinds, and in particular the auxiliary +function identifyParentLabels, which picks a parent for the record update +using the following additional mechanisms: -In the above example, it's as if we wrote: + (a) Use the type being pushed in, if it is already a TyConApp. The + following are valid updates at type `R`: - ds_foo r = - let f' :: (forall a. a -> a) -> (Int, _b) - f' = \ k -> (k 3, k 'x') - in case r of - MkR _ b -> MkR f' b + g :: R -> R + g x = x { fld1 = 3 } -This allows us to compute the right type for f', and thus accept this record update. + g' x = x { fld1 = 3 } :: R + + (b) Use the type signature of the record expression, if it exists and + is a TyConApp. Thus this is valid update at type `R`: + + h x = (x :: R) { fld1 = 3 } + +Note that this type-directed disambiguation mechanism isn't very robust, +as it doesn't properly integrate with the rest of the typechecker. +For example, the following updates will all be rejected as ambiguous: + + let r :: R + r = blah + in r { foo = 3 } + + \r. (r { foo = 3 }, r :: R) + +Record updates which require constraint-solving should instead use the +-XOverloadedRecordUpdate extension, as described in Note [Overview of record dot syntax]. Note [Unifying result types in tcRecordUpd] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1165,7 +1078,10 @@ Wrinkle [GADT result type in tcRecordUpd] -- result type of this desugared record update. desugarRecordUpd :: LHsExpr GhcRn -- ^ @record_expr@: expression to which the record update is applied - -> [LHsRecUpdField GhcRn] + -> NE.NonEmpty (HsRecUpdParent GhcRn) + -- ^ Possible parent 'TyCon'/'PatSyn's for the record update, + -- with the associated constructors and field labels + -> [LHsRecUpdField GhcRn GhcRn] -- ^ the record update fields -> ExpRhoType -- ^ the expected result type of the record update @@ -1177,8 +1093,9 @@ desugarRecordUpd :: LHsExpr GhcRn -- error context to push when typechecking -- the desugared code ) -desugarRecordUpd record_expr rbnds res_ty - = do { -- STEP -2: typecheck the record_expr, the record to be updated +desugarRecordUpd record_expr possible_parents rbnds res_ty + = do { -- STEP 0: typecheck the record_expr, the record to be updated. + -- -- Until GHC proposal #366 is implemented, we still use the type of -- the record to disambiguate its fields, so we must infer the record -- type here before we can desugar. See Wrinkle [Disambiguating fields] @@ -1209,73 +1126,36 @@ desugarRecordUpd record_expr rbnds res_ty -- -- This should definitely *not* typecheck. - -- STEP -1 See Note [Disambiguating record fields] in GHC.Tc.Gen.Head - -- After this we know that rbinds is unambiguous - ; rbinds <- disambiguateRecordBinds record_expr record_rho rbnds res_ty + -- STEP 1: disambiguate the record update by computing a single parent + -- which has a constructor with all of the fields being updated. + -- + -- See Note [Disambiguating record updates] in GHC.Rename.Pat. + ; (cons, rbinds) + <- disambiguateRecordBinds record_expr record_rho possible_parents rbnds res_ty ; let upd_flds = map (unLoc . hfbLHS . unLoc) rbinds - upd_fld_occs = map (FieldLabelString . occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc) upd_flds sel_ids = map selectorAmbiguousFieldOcc upd_flds upd_fld_names = map idName sel_ids + relevant_cons = nonDetEltsUniqSet cons + relevant_con = head relevant_cons - -- STEP 0 - -- Check that the field names are really field names - -- and they are all field names for proper records or - -- all field names for pattern synonyms. - ; let bad_guys = [ setSrcSpan loc $ addErrTc (notSelector fld_name) - | fld <- rbinds, - -- Excludes class ops - let L loc sel_id = hsRecUpdFieldId (unLoc fld), - not (isRecordSelector sel_id), - let fld_name = idName sel_id ] - ; unless (null bad_guys) (sequence bad_guys >> failM) - -- See Note [Mixed Record Field Updates] - ; let (data_sels, pat_syn_sels) = - partition isDataConRecordSelector sel_ids - ; massert (all isPatSynRecordSelector pat_syn_sels) - ; checkTc ( null data_sels || null pat_syn_sels ) - ( mixedSelectors data_sels pat_syn_sels ) - - -- STEP 1 - -- Figure out the tycon and data cons from the first field name - ; let -- It's OK to use the non-tc splitters here (for a selector) - sel_id : _ = sel_ids - con_likes :: [ConLike] - con_likes = case idDetails sel_id of - RecSelId (RecSelData tc) _ - -> map RealDataCon (tyConDataCons tc) - RecSelId (RecSelPatSyn ps) _ - -> [PatSynCon ps] - _ -> panic "tcRecordUpd" - -- NB: for a data type family, the tycon is the instance tycon - relevant_cons = conLikesWithFields con_likes upd_fld_occs - -- A constructor is only relevant to this process if - -- it contains *all* the fields that are being updated - -- Other ones will cause a runtime error if they occur - - -- STEP 2 - -- Check that at least one constructor has all the named fields - -- i.e. has an empty set of bad fields returned by badFields - ; case relevant_cons of - { [] -> failWithTc (badFieldsUpd rbinds con_likes) - ; relevant_con : _ -> - - -- STEP 3 - -- Create new variables for the fields we are updating, - -- so that we can share them across constructors. + -- STEP 2: desugar the record update. + -- + -- (a) Create new variables for the fields we are updating, + -- so that we can share them across constructors. -- - -- Example: + -- Example: -- - -- e { x=e1, y=e2 } + -- e { x=e1, y=e2 } -- - -- We want to let-bind variables to `e1` and `e2`: + -- We want to let-bind variables to `e1` and `e2`: -- - -- let x' :: Int - -- x' = e1 - -- y' :: Bool - -- y' = e2 - -- in ... + -- let x' :: Int + -- x' = e1 + -- y' :: Bool + -- y' = e2 + -- in ... - do { -- Instantiate the type variables of any relevant constuctor + -- Instantiate the type variables of any relevant constuctor -- with metavariables to obtain a type for each 'Id'. -- This will allow us to have 'Id's with polymorphic types -- by using 'IdSig'. See Wrinkle [Using IdSig] in Note [Record Updates]. @@ -1318,6 +1198,10 @@ desugarRecordUpd record_expr rbnds res_ty (conLikeFieldLabels relevant_con) arg_tys + ; traceTc "tcRecordUpd" $ + vcat [ text "upd_fld_names:" <+> ppr upd_fld_names + , text "relevant_cons:" <+> ppr relevant_cons ] + ; upd_ids <- zipWithM mk_upd_id upd_fld_names rbinds ; let updEnv :: UniqMap Name (Id, LHsExpr GhcRn) updEnv = listToUniqMap $ upd_ids @@ -1360,12 +1244,11 @@ desugarRecordUpd record_expr rbnds res_ty Just (upd_id, _) -> (genWildPat, genLHsVar (idName upd_id)) -- Field is not being updated: LHS = variable pattern, RHS = that same variable. _ -> let fld_nm = mkInternalName (mkBuiltinUnique i) - (mkVarOccFS (field_label $ flLabel fld_lbl)) + (nameOccName $ flSelector $ fld_lbl) generatedSrcSpan in (genVarPat fld_nm, genLHsVar fld_nm) - -- STEP 4 - -- Desugar to HsCase, as per note [Record Updates] + -- STEP 2 (b): desugar to HsCase, as per note [Record Updates] ; let ds_expr :: HsExpr GhcRn ds_expr = HsLet noExtField noHsTok let_binds noHsTok (L gen case_expr) @@ -1407,7 +1290,7 @@ desugarRecordUpd record_expr rbnds res_ty else [ text "existential variable" <> plural ex_tvs <+> pprQuotedList ex_tvs ] err_ctxt = make_lines_msg err_lines - ; return (ds_expr, ds_res_ty, err_ctxt) } } } + ; return (ds_expr, ds_res_ty, err_ctxt) } -- | Pretty-print a collection of lines, adding commas at the end of each line, -- and adding "and" to the start of the last line. @@ -1421,118 +1304,144 @@ make_lines_msg (l:ls) = l <> comma $$ make_lines_msg ls * * Record bindings * * -********************************************************************* -} +**********************************************************************-} --- Disambiguate the fields in a record update. --- See Note [Disambiguating record fields] in GHC.Tc.Gen.Head +-- | Disambiguate the fields in a record update. +-- +-- Most of the disambiguation has been done by the renamer; this function +-- performs a final type-directed disambiguation pass, as explained in +-- Note [Type-directed record disambiguation]. disambiguateRecordBinds :: LHsExpr GhcRn -> TcRhoType - -> [LHsRecUpdField GhcRn] -> ExpRhoType - -> TcM [LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)] -disambiguateRecordBinds record_expr record_rho rbnds res_ty - -- Are all the fields unambiguous? - = case mapM isUnambiguous rbnds of - -- If so, just skip to looking up the Ids - -- Always the case if DuplicateRecordFields is off - Just rbnds' -> mapM lookupSelector rbnds' - Nothing -> -- If not, try to identify a single parent - do { fam_inst_envs <- tcGetFamInstEnvs - -- Look up the possible parents for each field - ; rbnds_with_parents <- getUpdFieldsParents - ; let possible_parents = map (map fst . snd) rbnds_with_parents - -- Identify a single parent - ; p <- identifyParent fam_inst_envs possible_parents - -- Pick the right selector with that parent for each field - ; checkNoErrs $ mapM (pickParent p) rbnds_with_parents } + -> NE.NonEmpty (HsRecUpdParent GhcRn) + -> [LHsRecUpdField GhcRn GhcRn] -> ExpRhoType + -> TcM (UniqSet ConLike, [LHsRecUpdField GhcTc GhcRn]) +disambiguateRecordBinds record_expr record_rho possible_parents rbnds res_ty + = do { fam_inst_envs <- tcGetFamInstEnvs + -- Identify a single parent, using type-directed disambiguation + -- if necessary. (Note that type-directed disambiguation of + -- record field updates is is scheduled for removal, as per + -- Note [Type-directed record disambiguation].) + ; TcRecUpdParent + { tcRecUpdLabels = lbls + , tcRecUpdCons = cons } + <- identifyParentLabels fam_inst_envs possible_parents + -- Pick the right selector with that parent for each field + ; rbnds' <- zipWithM lookupField (NE.toList lbls) rbnds + ; return (cons, rbnds') } where - -- Extract the selector name of a field update if it is unambiguous - isUnambiguous :: LHsRecUpdField GhcRn -> Maybe (LHsRecUpdField GhcRn,Name) - isUnambiguous x = case unLoc (hfbLHS (unLoc x)) of - Unambiguous sel_name _ -> Just (x, sel_name) - Ambiguous{} -> Nothing - - -- Look up the possible parents and selector GREs for each field - getUpdFieldsParents :: TcM [(LHsRecUpdField GhcRn - , [(RecSelParent, GlobalRdrElt)])] - getUpdFieldsParents - = fmap (zip rbnds) $ mapM - (lookupParents False . unLoc . hsRecUpdFieldRdr . unLoc) - rbnds - - -- Given a the lists of possible parents for each field, - -- identify a single parent - identifyParent :: FamInstEnvs -> [[RecSelParent]] -> TcM RecSelParent - identifyParent fam_inst_envs possible_parents - = case foldr1 intersect possible_parents of - -- No parents for all fields: record update is ill-typed - [] -> failWithTc (TcRnNoPossibleParentForFields rbnds) - - -- Exactly one datatype with all the fields: use that - [p] -> return p - - -- Multiple possible parents: try harder to disambiguate + + -- Try to identify a single parent, using type-directed disambiguation. + -- + -- Any non-type-directed disambiguation will have been done already. + -- See GHC.Rename.Env.lookupRecUpdFields. + identifyParentLabels :: FamInstEnvs + -> NE.NonEmpty (HsRecUpdParent GhcRn) + -> TcM (HsRecUpdParent GhcTc) + identifyParentLabels fam_inst_envs possible_parents + = case possible_parents of + + -- Exactly one possible parent for the record update! + p NE.:| [] -> lookup_parent_flds p + + -- Multiple possible parents: try harder to disambiguate. -- Can we get a parent TyCon from the pushed-in type? - _:_ | Just p <- tyConOfET fam_inst_envs res_ty -> - do { reportAmbiguousField p - ; return (RecSelData p) } + -- + -- See (a) in Note [Type-directed record disambiguation] in GHC.Rename.Pat. + _ NE.:| _ : _ + | Just tc <- tyConOfET fam_inst_envs res_ty + -> do { reportAmbiguousUpdate possible_parents tc + ; try_disambiguated_tycon tc possible_parents } -- Does the expression being updated have a type signature? - -- If so, try to extract a parent TyCon from it - | Just {} <- obviousSig (unLoc record_expr) - , Just tc <- tyConOf fam_inst_envs record_rho - -> do { reportAmbiguousField tc - ; return (RecSelData tc) } + -- If so, try to extract a parent TyCon from it. + -- + -- See (b) inNote [Type-directed record disambiguation] in GHC.Rename.Pat. + | Just {} <- obviousSig (unLoc record_expr) + , Just tc <- tyConOf fam_inst_envs record_rho + -> do { reportAmbiguousUpdate possible_parents tc + ; try_disambiguated_tycon tc possible_parents } -- Nothing else we can try... - _ -> failWithTc (TcRnBadOverloadedRecordUpdate rbnds) - - -- Make a field unambiguous by choosing the given parent. - -- Emits an error if the field cannot have that parent, - -- e.g. if the user writes - -- r { x = e } :: T - -- where T does not have field x. - pickParent :: RecSelParent - -> (LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)]) - -> TcM (LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)) - pickParent p (upd, xs) - = case lookup p xs of - -- Phew! The parent is valid for this field. - -- Previously ambiguous fields must be marked as - -- used now that we know which one is meant, but - -- unambiguous ones shouldn't be recorded again - -- (giving duplicate deprecation warnings). - Just gre -> do { unless (null (tail xs)) $ do - let L loc _ = hfbLHS (unLoc upd) - setSrcSpanA loc $ addUsedGRE True gre - ; lookupSelector (upd, greMangledName gre) } - -- The field doesn't belong to this parent, so report - -- an error but keep going through all the fields - Nothing -> do { addErrTc (fieldNotInType p - (unLoc (hsRecUpdFieldRdr (unLoc upd)))) - ; lookupSelector (upd, greMangledName (snd (head xs))) } - - -- Given a (field update, selector name) pair, look up the - -- selector to give a field update with an unambiguous Id - lookupSelector :: (LHsRecUpdField GhcRn, Name) - -> TcM (LHsFieldBind GhcRn (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)) - lookupSelector (L l upd, n) - = do { i <- tcLookupId n + p1 NE.:| p2 : ps + -> do { p1 <- tcLookupRecSelParent p1 + ; p2 <- tcLookupRecSelParent p2 + ; ps <- mapM tcLookupRecSelParent ps + ; failWithTc $ TcRnBadRecordUpdate (getUpdFieldLbls rbnds) + $ MultiplePossibleParents (p1, p2, ps) } + + -- Try to use the 'TyCon' we learned from type-directed disambiguation. + -- This might not work, if it doesn't match up with any of the parents we had + -- computed on the basis of the field labels. + -- (See test cases overloadedrecfields01 and T21946.) + try_disambiguated_tycon :: TyCon + -> NE.NonEmpty (HsRecUpdParent GhcRn) + -> TcM (HsRecUpdParent GhcTc) + try_disambiguated_tycon tc pars + = do { pars <- mapMaybeM (fmap (guard_parent tc) . lookup_parent_flds) (NE.toList pars) + ; case pars of + [par] -> return par + [] -> do { pars <- mapM tcLookupRecSelParent possible_parents + ; failWithTc $ TcRnBadRecordUpdate (getUpdFieldLbls rbnds) + $ InvalidTyConParent tc pars } + _ -> pprPanic "try_disambiguated_tycon: more than 1 valid parent" + (ppr $ map tcRecUpdParent pars) } + + guard_parent :: TyCon -> HsRecUpdParent GhcTc -> Maybe (HsRecUpdParent GhcTc) + guard_parent disamb_tc cand_parent@(TcRecUpdParent { tcRecUpdParent = cand_tc }) + = do { guard (RecSelData disamb_tc == cand_tc) + ; return cand_parent } + + lookup_parent_flds :: HsRecUpdParent GhcRn + -> TcM (HsRecUpdParent GhcTc) + lookup_parent_flds par@(RnRecUpdParent { rnRecUpdLabels = lbls, rnRecUpdCons = cons }) + = do { let cons' :: NonDetUniqFM ConLike ConLikeName + cons' = NonDetUniqFM $ unsafeCastUFMKey $ getUniqSet cons + ; cons <- traverse (tcLookupConLike . conLikeName_Name) cons' + ; tc <- tcLookupRecSelParent par + ; return $ + TcRecUpdParent + { tcRecUpdParent = tc + , tcRecUpdLabels = lbls + , tcRecUpdCons = unsafeUFMToUniqSet $ getNonDet cons } } + + lookupField :: FieldGlobalRdrElt + -> LHsRecUpdField GhcRn GhcRn + -> TcM (LHsRecUpdField GhcTc GhcRn) + lookupField fl (L l upd) + = do { let L loc af = hfbLHS upd + rdr = ambiguousFieldOccRdrName af + mb_gre = pickGREs rdr [fl] + -- NB: this GRE can be 'Nothing' when in GHCi. + -- See test T10439. + + -- Mark the record fields as used, now that we have disambiguated. + -- There is no risk of duplicate deprecation warnings, as we have + -- not marked the GREs as used previously. + ; setSrcSpanA loc $ mapM_ (addUsedGRE True) mb_gre + ; sel <- tcLookupId $ flSelector $ fieldGRELabel fl ; let L loc af = hfbLHS upd - lbl = rdrNameAmbiguousFieldOcc af + lbl = ambiguousFieldOccRdrName af ; return $ L l HsFieldBind { hfbAnn = hfbAnn upd - , hfbLHS - = L (l2l loc) (Unambiguous i (L (l2l loc) lbl)) + , hfbLHS = L (l2l loc) $ Unambiguous sel (L (l2l loc) lbl) , hfbRHS = hfbRHS upd , hfbPun = hfbPun upd - } - } - - -- See Note [Deprecating ambiguous fields] in GHC.Tc.Gen.Head - reportAmbiguousField :: TyCon -> TcM () - reportAmbiguousField parent_type = - setSrcSpan loc $ addDiagnostic $ TcRnAmbiguousField rupd parent_type + } } + + -- The type-directed disambiguation mechanism is scheduled for removal, + -- as per Note [Type-directed record disambiguation]. + -- So we emit a warning whenever the user relies on it. + reportAmbiguousUpdate :: NE.NonEmpty (HsRecUpdParent GhcRn) + -> TyCon -> TcM () + reportAmbiguousUpdate parents parent_type = + setSrcSpan loc $ addDiagnostic $ TcRnAmbiguousRecordUpdate rupd parent_type where - rupd = RecordUpd { rupd_expr = record_expr, rupd_flds = Left rbnds, rupd_ext = noExtField } + rupd = RecordUpd { rupd_expr = record_expr + , rupd_flds = + RegularRecUpdFields + { xRecUpdFields = parents + , recUpdFields = rbnds } + , rupd_ext = noExtField } loc = getLocA (head rbnds) {- @@ -1574,14 +1483,15 @@ tcRecordBinds con_like arg_tys (HsRecFields rbinds dd) = do { mb <- tcRecordField con_like flds_w_tys f rhs ; case mb of Nothing -> return Nothing - -- Just (f', rhs') -> return (Just (L l (fld { hfbLHS = f' - -- , hfbRHS = rhs' }))) } Just (f', rhs') -> return (Just (L l (HsFieldBind { hfbAnn = hfbAnn fld , hfbLHS = f' , hfbRHS = rhs' , hfbPun = hfbPun fld}))) } +fieldCtxt :: FieldLabelString -> SDoc +fieldCtxt field_name + = text "In the" <+> quotes (ppr field_name) <+> text "field of a record" tcRecordField :: ConLike -> Assoc Name Type -> LFieldOcc GhcRn -> LHsExpr GhcRn @@ -1663,103 +1573,6 @@ checkMissingFields con_like rbinds arg_tys {- ************************************************************************ * * -\subsection{Errors and contexts} -* * -************************************************************************ - -Boring and alphabetical: --} - -fieldCtxt :: FieldLabelString -> SDoc -fieldCtxt field_name - = text "In the" <+> quotes (ppr field_name) <+> text "field of a record" - -badFieldsUpd - :: [LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)] - -- Field names that don't belong to a single datacon - -> [ConLike] -- Data cons of the type which the first field name belongs to - -> TcRnMessage -badFieldsUpd rbinds data_cons - = TcRnNoConstructorHasAllFields conflictingFields - -- See Note [Finding the conflicting fields] - where - -- A (preferably small) set of fields such that no constructor contains - -- all of them. See Note [Finding the conflicting fields] - conflictingFields = case nonMembers of - -- nonMember belongs to a different type. - (nonMember, _) : _ -> [aMember, nonMember] - [] -> let - -- All of rbinds belong to one type. In this case, repeatedly add - -- a field to the set until no constructor contains the set. - - -- Each field, together with a list indicating which constructors - -- have all the fields so far. - growingSets :: [(FieldLabelString, [Bool])] - growingSets = scanl1 combine membership - combine (_, setMem) (field, fldMem) - = (field, zipWith (&&) setMem fldMem) - in - -- Fields that don't change the membership status of the set - -- are redundant and can be dropped. - map (fst . NE.head) $ NE.groupWith snd growingSets - - aMember = assert (not (null members) ) fst (head members) - (members, nonMembers) = partition (or . snd) membership - - -- For each field, which constructors contain the field? - membership :: [(FieldLabelString, [Bool])] - membership = sortMembership $ - map (\fld -> (fld, map (fld `elementOfUniqSet`) fieldLabelSets)) $ - map (FieldLabelString . occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc . unLoc . hfbLHS . unLoc) rbinds - - fieldLabelSets :: [UniqSet FieldLabelString] - fieldLabelSets = map (mkUniqSet . map flLabel . conLikeFieldLabels) data_cons - - -- Sort in order of increasing number of True, so that a smaller - -- conflicting set can be found. - sortMembership = - map snd . - sortBy (compare `on` fst) . - map (\ item@(_, membershipRow) -> (countTrue membershipRow, item)) - - countTrue = count id - -{- -Note [Finding the conflicting fields] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - data A = A {a0, a1 :: Int} - | B {b0, b1 :: Int} -and we see a record update - x { a0 = 3, a1 = 2, b0 = 4, b1 = 5 } -Then we'd like to find the smallest subset of fields that no -constructor has all of. Here, say, {a0,b0}, or {a0,b1}, etc. -We don't really want to report that no constructor has all of -{a0,a1,b0,b1}, because when there are hundreds of fields it's -hard to see what was really wrong. - -We may need more than two fields, though; eg - data T = A { x,y :: Int, v::Int } - | B { y,z :: Int, v::Int } - | C { z,x :: Int, v::Int } -with update - r { x=e1, y=e2, z=e3 }, we - -Finding the smallest subset is hard, so the code here makes -a decent stab, no more. See #7989. --} - -mixedSelectors :: [Id] -> [Id] -> TcRnMessage -mixedSelectors data_sels@(dc_rep_id:_) pat_syn_sels@(ps_rep_id:_) - = TcRnMixedSelectors (tyConName rep_dc) data_sels (patSynName rep_ps) pat_syn_sels - where - RecSelPatSyn rep_ps = recordSelectorTyCon ps_rep_id - RecSelData rep_dc = recordSelectorTyCon dc_rep_id -mixedSelectors _ _ = panic "GHC.Tc.Gen.Expr: mixedSelectors emptylists" - -{- -************************************************************************ -* * \subsection{Static Pointers} * * ************************************************************************ diff --git a/compiler/GHC/Tc/Gen/Head.hs b/compiler/GHC/Tc/Gen/Head.hs index 5154d7c98a..d5721ff5e1 100644 --- a/compiler/GHC/Tc/Gen/Head.hs +++ b/compiler/GHC/Tc/Gen/Head.hs @@ -26,8 +26,8 @@ module GHC.Tc.Gen.Head , tcInferAppHead, tcInferAppHead_maybe , tcInferId, tcCheckId , obviousSig - , tyConOf, tyConOfET, lookupParents, fieldNotInType - , notSelector, nonBidirectionalErr + , tyConOf, tyConOfET, fieldNotInType + , nonBidirectionalErr , addHeadCtxt, addExprCtxt, addFunResCtxt ) where @@ -47,7 +47,8 @@ import GHC.Tc.Utils.Unify import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic ) import GHC.Tc.Utils.Instantiate import GHC.Tc.Instance.Family ( tcLookupDataFamInst ) -import GHC.Unit.Module ( getModule ) +import GHC.Core.FamInstEnv ( FamInstEnvs ) +import GHC.Core.UsageEnv ( unitUE ) import GHC.Tc.Errors.Types import GHC.Tc.Solver ( InferMode(..), simplifyInfer ) import GHC.Tc.Utils.Env @@ -57,8 +58,6 @@ import GHC.Tc.Utils.TcType as TcType import GHC.Tc.Types.Evidence import GHC.Hs.Syn.Type -import GHC.Core.FamInstEnv ( FamInstEnvs ) -import GHC.Core.UsageEnv ( unitUE ) import GHC.Core.PatSyn( PatSyn ) import GHC.Core.ConLike( ConLike(..) ) import GHC.Core.DataCon @@ -860,35 +859,11 @@ tyConOf fam_inst_envs ty0 tyConOfET :: FamInstEnvs -> ExpRhoType -> Maybe TyCon tyConOfET fam_inst_envs ty0 = tyConOf fam_inst_envs =<< checkingExpType_maybe ty0 - --- For an ambiguous record field, find all the candidate record --- selectors (as GlobalRdrElts) and their parents. -lookupParents :: Bool -> RdrName -> RnM [(RecSelParent, GlobalRdrElt)] -lookupParents is_selector rdr - = do { env <- getGlobalRdrEnv - -- Filter by isRecFldGRE because otherwise a non-selector variable with - -- an overlapping name can get through when NoFieldSelectors is enabled. - -- See Note [NoFieldSelectors] in GHC.Rename.Env. - ; let all_gres = lookupGRE_RdrName' rdr env - ; let gres | is_selector = filter isFieldSelectorGRE all_gres - | otherwise = filter isRecFldGRE all_gres - ; mapM lookupParent gres } - where - lookupParent :: GlobalRdrElt -> RnM (RecSelParent, GlobalRdrElt) - lookupParent gre = do { id <- tcLookupId (greMangledName gre) - ; case recordSelectorTyCon_maybe id of - Just rstc -> return (rstc, gre) - Nothing -> failWithTc (notSelector (greMangledName gre)) } - - fieldNotInType :: RecSelParent -> RdrName -> TcRnMessage fieldNotInType p rdr = mkTcRnNotInScope rdr $ UnknownSubordinate (text "field of type" <+> quotes (ppr p)) -notSelector :: Name -> TcRnMessage -notSelector = TcRnNotARecordSelector - {- ********************************************************************* * * @@ -1108,14 +1083,8 @@ tc_infer_id id_name get_suggestions ns = do let occ = mkOccNameFS ns (occNameFS (occName id_name)) - dflags <- getDynFlags - rdr_env <- getGlobalRdrEnv lcl_env <- getLocalRdrEnv - imp_info <- getImports - curr_mod <- getModule - hpt <- getHpt - return $ unknownNameSuggestions WL_Anything dflags hpt curr_mod rdr_env - lcl_env imp_info (mkRdrUnqual occ) + unknownNameSuggestions lcl_env WL_Anything (mkRdrUnqual occ) return_id id = return (HsVar noExtField (noLocA id), idType id) diff --git a/compiler/GHC/Tc/Gen/HsType.hs b/compiler/GHC/Tc/Gen/HsType.hs index 0a0ec7230a..9e8375b47d 100644 --- a/compiler/GHC/Tc/Gen/HsType.hs +++ b/compiler/GHC/Tc/Gen/HsType.hs @@ -1144,7 +1144,7 @@ tc_hs_type _ ty@(HsBangTy _ bang _) _ tc_hs_type _ ty@(HsRecTy {}) _ -- Record types (which only show up temporarily in constructor -- signatures) should have been removed by now - = failWithTc $ TcRnIllegalRecordSyntax ty + = failWithTc $ TcRnIllegalRecordSyntax (Right ty) -- HsSpliced is an annotation produced by 'GHC.Rename.Splice.rnSpliceType'. -- Here we get rid of it and add the finalizers to the global environment @@ -2315,11 +2315,11 @@ instance Outputable SAKS_or_CUSK where -- See Note [kcCheckDeclHeader vs kcInferDeclHeader] kcDeclHeader :: InitialKindStrategy - -> Name -- ^ of the thing being checked - -> TyConFlavour -- ^ What sort of 'TyCon' is being checked - -> LHsQTyVars GhcRn -- ^ Binders in the header - -> TcM ContextKind -- ^ The result kind - -> TcM TcTyCon -- ^ A suitably-kinded TcTyCon + -> Name -- ^ of the thing being checked + -> TyConFlavour TyCon -- ^ What sort of 'TyCon' is being checked + -> LHsQTyVars GhcRn -- ^ Binders in the header + -> TcM ContextKind -- ^ The result kind + -> TcM TcTyCon -- ^ A suitably-kinded TcTyCon kcDeclHeader (InitialKindCheck msig) = kcCheckDeclHeader msig kcDeclHeader InitialKindInfer = kcInferDeclHeader @@ -2342,20 +2342,20 @@ of a type constructor. ------------------------------ kcCheckDeclHeader :: SAKS_or_CUSK - -> Name -- ^ of the thing being checked - -> TyConFlavour -- ^ What sort of 'TyCon' is being checked - -> LHsQTyVars GhcRn -- ^ Binders in the header - -> TcM ContextKind -- ^ The result kind. AnyKind == no result signature - -> TcM PolyTcTyCon -- ^ A suitably-kinded generalized TcTyCon + -> Name -- ^ of the thing being checked + -> TyConFlavour TyCon -- ^ What sort of 'TyCon' is being checked + -> LHsQTyVars GhcRn -- ^ Binders in the header + -> TcM ContextKind -- ^ The result kind. AnyKind == no result signature + -> TcM PolyTcTyCon -- ^ A suitably-kinded generalized TcTyCon kcCheckDeclHeader (SAKS sig) = kcCheckDeclHeader_sig sig kcCheckDeclHeader CUSK = kcCheckDeclHeader_cusk kcCheckDeclHeader_cusk - :: Name -- ^ of the thing being checked - -> TyConFlavour -- ^ What sort of 'TyCon' is being checked - -> LHsQTyVars GhcRn -- ^ Binders in the header - -> TcM ContextKind -- ^ The result kind - -> TcM PolyTcTyCon -- ^ A suitably-kinded generalized TcTyCon + :: Name -- ^ of the thing being checked + -> TyConFlavour TyCon -- ^ What sort of 'TyCon' is being checked + -> LHsQTyVars GhcRn -- ^ Binders in the header + -> TcM ContextKind -- ^ The result kind + -> TcM PolyTcTyCon -- ^ A suitably-kinded generalized TcTyCon kcCheckDeclHeader_cusk name flav (HsQTvs { hsq_ext = kv_ns , hsq_explicit = hs_tvs }) kc_res_ki @@ -2441,11 +2441,11 @@ kcCheckDeclHeader_cusk name flav -- -- This function does not do telescope checking. kcInferDeclHeader - :: Name -- ^ of the thing being checked - -> TyConFlavour -- ^ What sort of 'TyCon' is being checked + :: Name -- ^ of the thing being checked + -> TyConFlavour TyCon -- ^ What sort of 'TyCon' is being checked -> LHsQTyVars GhcRn - -> TcM ContextKind -- ^ The result kind - -> TcM MonoTcTyCon -- ^ A suitably-kinded non-generalized TcTyCon + -> TcM ContextKind -- ^ The result kind + -> TcM MonoTcTyCon -- ^ A suitably-kinded non-generalized TcTyCon kcInferDeclHeader name flav (HsQTvs { hsq_ext = kv_ns , hsq_explicit = hs_tvs }) kc_res_ki @@ -2494,12 +2494,12 @@ kcInferDeclHeader name flav -- | Kind-check a declaration header against a standalone kind signature. -- See Note [kcCheckDeclHeader_sig] kcCheckDeclHeader_sig - :: Kind -- ^ Standalone kind signature, fully zonked! (zonkTcTypeToType) - -> Name -- ^ of the thing being checked - -> TyConFlavour -- ^ What sort of 'TyCon' is being checked - -> LHsQTyVars GhcRn -- ^ Binders in the header - -> TcM ContextKind -- ^ The result kind. AnyKind == no result signature - -> TcM PolyTcTyCon -- ^ A suitably-kinded, fully generalised TcTyCon + :: Kind -- ^ Standalone kind signature, fully zonked! (zonkTcTypeToType) + -> Name -- ^ of the thing being checked + -> TyConFlavour TyCon -- ^ What sort of 'TyCon' is being checked + -> LHsQTyVars GhcRn -- ^ Binders in the header + -> TcM ContextKind -- ^ The result kind. AnyKind == no result signature + -> TcM PolyTcTyCon -- ^ A suitably-kinded, fully generalised TcTyCon -- Postcondition to (kcCheckDeclHeader_sig sig_kind n f hs_tvs kc_res_ki): -- kind(returned PolyTcTyCon) = sig_kind -- @@ -3660,7 +3660,7 @@ Hence using zonked_kinds when forming tvs'. -} ----------------------------------- -etaExpandAlgTyCon :: TyConFlavour -> SkolemInfo +etaExpandAlgTyCon :: TyConFlavour tc -> SkolemInfo -> [TcTyConBinder] -> Kind -> TcM ([TcTyConBinder], Kind) etaExpandAlgTyCon flav skol_info tcbs res_kind @@ -3673,7 +3673,7 @@ etaExpandAlgTyCon flav skol_info tcbs res_kind in_scope = mkInScopeSetList tyvars avoid_occs = map getOccName tyvars -needsEtaExpansion :: TyConFlavour -> Bool +needsEtaExpansion :: TyConFlavour tc -> Bool needsEtaExpansion NewtypeFlavour = True needsEtaExpansion DataTypeFlavour = True needsEtaExpansion ClassFlavour = True @@ -4337,7 +4337,7 @@ funAppCtxt fun arg arg_no 2 (quotes (ppr arg)) -- | Add a "In the data declaration for T" or some such. -addTyConFlavCtxt :: Name -> TyConFlavour -> TcM a -> TcM a +addTyConFlavCtxt :: Name -> TyConFlavour tc -> TcM a -> TcM a addTyConFlavCtxt name flav = addErrCtxt $ hsep [ text "In the", ppr flav , text "declaration for", quotes (ppr name) ] diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs index 943c8dcbd2..f3d7c3c381 100644 --- a/compiler/GHC/Tc/Gen/Splice.hs +++ b/compiler/GHC/Tc/Gen/Splice.hs @@ -92,7 +92,6 @@ import GHC.Core.PatSyn import GHC.Core.ConLike import GHC.Core.DataCon as DataCon -import GHC.Types.FieldLabel import GHC.Types.SrcLoc import GHC.Types.Name.Env import GHC.Types.Name.Set @@ -131,7 +130,6 @@ import GHC.Data.FastString import GHC.Data.Maybe( MaybeErr(..) ) import qualified GHC.Data.EnumSet as EnumSet -import Language.Haskell.Syntax.Basic (FieldLabelString(..)) import qualified Language.Haskell.TH as TH -- THSyntax gives access to internal functions and data types import qualified Language.Haskell.TH.Syntax as TH @@ -145,7 +143,7 @@ import Unsafe.Coerce ( unsafeCoerce ) import Control.Monad import Data.Binary import Data.Binary.Get -import Data.List ( find ) +import qualified Data.List.NonEmpty as NE ( singleton ) import Data.Maybe import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as LB @@ -1938,8 +1936,8 @@ lookupName :: Bool -- True <=> type namespace -- False <=> value namespace -> String -> TcM (Maybe TH.Name) lookupName is_type_name s - = do { mb_nm <- lookupOccRn_maybe rdr_name - ; return (fmap reifyName mb_nm) } + = do { mb_gre <- lookupSameOccRn_maybe rdr_name + ; return (fmap (reifyName . greName) mb_gre) } where th_name = TH.mkName s -- Parses M.x into a base of 'x' and a module of 'M' @@ -1975,9 +1973,10 @@ getThing th_name -- ToDo: this tcLookup could fail, which would give a -- rather unhelpful error message where - ppr_ns (TH.Name _ (TH.NameG TH.DataName _pkg _mod)) = text "data" - ppr_ns (TH.Name _ (TH.NameG TH.TcClsName _pkg _mod)) = text "tc" - ppr_ns (TH.Name _ (TH.NameG TH.VarName _pkg _mod)) = text "var" + ppr_ns (TH.Name _ (TH.NameG TH.DataName _pkg _mod)) = text "data" + ppr_ns (TH.Name _ (TH.NameG TH.TcClsName _pkg _mod)) = text "tc" + ppr_ns (TH.Name _ (TH.NameG TH.VarName _pkg _mod)) = text "var" + ppr_ns (TH.Name _ (TH.NameG (TH.FldName {}) _pkg _mod)) = text "fld" ppr_ns _ = panic "reify/ppr_ns" reify :: TH.Name -> TcM TH.Info @@ -1996,10 +1995,17 @@ lookupThName th_name = do lookupThName_maybe :: TH.Name -> TcM (Maybe Name) lookupThName_maybe th_name - = do { names <- mapMaybeM lookupOccRn_maybe (thRdrNameGuesses th_name) + = do { let guesses = thRdrNameGuesses th_name + ; case guesses of + { [for_sure] -> get_name $ lookupSameOccRn_maybe for_sure + ; _ -> + do { names <- mapMaybeM (get_name . lookupOccRn_maybe) guesses -- Pick the first that works -- E.g. reify (mkName "A") will pick the class A in preference to the data constructor A - ; return (listToMaybe names) } + ; return (listToMaybe names) } } } + where + get_name :: TcM (Maybe GlobalRdrElt) -> TcM (Maybe Name) + get_name = fmap (fmap greName) tcLookupTh :: Name -> TcM TcTyThing -- This is a specialised version of GHC.Tc.Utils.Env.tcLookup; specialised mainly in that @@ -2058,9 +2064,7 @@ reifyThing (AGlobal (AnId id)) ; let v = reifyName id ; case idDetails id of ClassOpId cls _ -> return (TH.ClassOpI v ty (reifyName cls)) - RecSelId{sel_tycon=RecSelData tc} - -> return (TH.VarI (reifySelector id tc) ty Nothing) - _ -> return (TH.VarI v ty Nothing) + _ -> return (TH.VarI v ty Nothing) } reifyThing (AGlobal (ATyCon tc)) = reifyTyCon tc @@ -2231,8 +2235,8 @@ reifyDataCon isGadtDataCon tys dc dcdBangs r_arg_tys) | not (null fields) -> do { res_ty <- reifyType g_res_ty - ; return $ TH.RecGadtC [name] - (zip3 (map (reifyName . flSelector) fields) + ; return $ TH.RecGadtC (NE.singleton name) + (zip3 (map reifyFieldLabel fields) dcdBangs r_arg_tys) res_ty } -- We need to check not isGadtDataCon here because GADT -- constructors can be declared infix. @@ -2244,7 +2248,8 @@ reifyDataCon isGadtDataCon tys dc ; return $ TH.InfixC (s1,r_a1) name (s2,r_a2) } | isGadtDataCon -> do { res_ty <- reifyType g_res_ty - ; return $ TH.GadtC [name] (dcdBangs `zip` r_arg_tys) res_ty } + ; return $ TH.GadtC (NE.singleton name) + (dcdBangs `zip` r_arg_tys) res_ty } | otherwise -> return $ TH.NormalC name (dcdBangs `zip` r_arg_tys) @@ -2734,26 +2739,12 @@ reifyName thing mk_varg | OccName.isDataOcc occ = TH.mkNameG_d | OccName.isVarOcc occ = TH.mkNameG_v | OccName.isTcOcc occ = TH.mkNameG_tc + | Just con_fs <- OccName.fieldOcc_maybe occ + = \ pkg mod occ -> TH.mkNameG_fld pkg mod (unpackFS con_fs) occ | otherwise = pprPanic "reifyName" (ppr name) --- See Note [Reifying field labels] reifyFieldLabel :: FieldLabel -> TH.Name -reifyFieldLabel fl - | flIsOverloaded fl - = TH.Name (TH.mkOccName occ_str) (TH.NameQ (TH.mkModName mod_str)) - | otherwise = TH.mkNameG_v pkg_str mod_str occ_str - where - name = flSelector fl - mod = assert (isExternalName name) $ nameModule name - pkg_str = unitString (moduleUnit mod) - mod_str = moduleNameString (moduleName mod) - occ_str = unpackFS (field_label $ flLabel fl) - -reifySelector :: Id -> TyCon -> TH.Name -reifySelector id tc - = case find ((idName id ==) . flSelector) (tyConFieldLabels tc) of - Just fl -> reifyFieldLabel fl - Nothing -> pprPanic "reifySelector: missing field" (ppr id $$ ppr tc) +reifyFieldLabel fl = reifyName $ flSelector fl ------------------------------ reifyFixity :: Name -> TcM (Maybe TH.Fixity) @@ -2857,34 +2848,6 @@ noTH s d = failWithTc $ TcRnCannotRepresentType s d ppr_th :: TH.Ppr a => a -> SDoc ppr_th x = text (TH.pprint x) -{- -Note [Reifying field labels] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When reifying a datatype declared with DuplicateRecordFields enabled, we want -the reified names of the fields to be labels rather than selector functions. -That is, we want (reify ''T) and (reify 'foo) to produce - - data T = MkT { foo :: Int } - foo :: T -> Int - -rather than - - data T = MkT { $sel:foo:MkT :: Int } - $sel:foo:MkT :: T -> Int - -because otherwise TH code that uses the field names as strings will silently do -the wrong thing. Thus we use the field label (e.g. foo) as the OccName, rather -than the selector (e.g. $sel:foo:MkT). Since the Orig name M.foo isn't in the -environment, NameG can't be used to represent such fields. Instead, -reifyFieldLabel uses NameQ. - -However, this means that extracting the field name from the output of reify, and -trying to reify it again, may fail with an ambiguity error if there are multiple -such fields defined in the module (see the test case -overloadedrecflds/should_fail/T11103.hs). The "proper" fix requires changes to -the TH AST to make it able to represent duplicate record fields. --} - tcGetInterp :: TcM Interp tcGetInterp = do hsc_env <- getTopEnv diff --git a/compiler/GHC/Tc/Instance/Class.hs b/compiler/GHC/Tc/Instance/Class.hs index 71dd30638b..00811459c4 100644 --- a/compiler/GHC/Tc/Instance/Class.hs +++ b/compiler/GHC/Tc/Instance/Class.hs @@ -30,7 +30,7 @@ import GHC.Builtin.Types.Prim import GHC.Builtin.Names import GHC.Types.FieldLabel -import GHC.Types.Name.Reader( lookupGRE_FieldLabel, greMangledName ) +import GHC.Types.Name.Reader import GHC.Types.SafeHaskell import GHC.Types.Name ( Name ) import GHC.Types.Var.Env ( VarEnv ) @@ -949,7 +949,7 @@ matchHasField dflags short_cut clas tys ; if not (isNaughtyRecordSelector sel_id) && isTauTy sel_ty then do { -- See Note [Unused name reporting and HasField] addUsedGRE True gre - ; keepAlive (greMangledName gre) + ; keepAlive (greName gre) ; return OneInst { cir_new_theta = theta , cir_mk_ev = mk_ev , cir_coherence = IsCoherent diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs index f877e006b8..c4b0e80504 100644 --- a/compiler/GHC/Tc/Module.hs +++ b/compiler/GHC/Tc/Module.hs @@ -96,6 +96,7 @@ import GHC.Rename.Names import GHC.Rename.Env import GHC.Rename.Module import GHC.Rename.Doc +import GHC.Rename.Utils ( mkNameClashErr ) import GHC.Iface.Syntax ( ShowSub(..), showToHeader ) import GHC.Iface.Type ( ShowForAllFlag(..) ) @@ -110,7 +111,7 @@ import GHC.Builtin.Utils import GHC.Hs import GHC.Hs.Dump -import GHC.Core.PatSyn ( pprPatSynType ) +import GHC.Core.PatSyn import GHC.Core.Predicate ( classMethodTy ) import GHC.Core.InstEnv import GHC.Core.TyCon @@ -157,7 +158,6 @@ import GHC.Types.SrcLoc import GHC.Types.SourceFile import GHC.Types.TyThing.Ppr ( pprTyThingInContext ) import GHC.Types.PkgQual -import GHC.Types.ConInfo (mkConInfo) import qualified GHC.LanguageExtensions as LangExt import GHC.Unit.External @@ -177,15 +177,18 @@ import GHC.Data.List.SetOps import GHC.Data.Bag import qualified GHC.Data.BooleanFormula as BF +import Control.DeepSeq +import Control.Monad +import Data.Data ( Data ) import Data.Functor.Classes ( liftEq ) import Data.List ( sortBy, sort ) import Data.List.NonEmpty ( NonEmpty (..) ) import qualified Data.List.NonEmpty as NE import Data.Ord -import Data.Data ( Data ) import qualified Data.Set as S -import Control.DeepSeq -import Control.Monad +import Data.Traversable ( for ) + + {- ************************************************************************ @@ -343,7 +346,7 @@ tcRnModuleTcRnM hsc_env mod_sum -- boot_dfuns, which may be mentioned in imported -- unfoldings. ; -- Report unused names - -- Do this /after/ typeinference, so that when reporting + -- Do this /after/ type inference, so that when reporting -- a function with no type signature we can give the -- inferred type ; reportUnusedNames tcg_env hsc_src @@ -786,17 +789,21 @@ checkHiBootIface tcg_env boot_info , tcg_type_env = local_type_env , tcg_exports = local_exports } <- tcg_env = do { -- This code is tricky, see Note [DFun knot-tying] - ; dfun_prs <- checkHiBootIface' local_insts local_type_env - local_exports boot_details + ; imp_prs <- checkHiBootIface' local_insts local_type_env + local_exports boot_details - -- Now add the boot-dfun bindings $fxblah = $fblah + -- Now add the impedance-matching boot bindings: + -- + -- - dfun bindings $fxblah = $fblah + -- - record bindings fld{var} = fld{rec field of ..} + -- -- to (a) the type envt, and (b) the top-level bindings - ; let boot_dfuns = map fst dfun_prs - type_env' = extendTypeEnvWithIds local_type_env boot_dfuns - dfun_binds = listToBag [ mkVarBind boot_dfun (nlHsVar dfun) - | (boot_dfun, dfun) <- dfun_prs ] + ; let boot_impedance_bds = map fst imp_prs + type_env' = extendTypeEnvWithIds local_type_env boot_impedance_bds + impedance_binds = listToBag [ mkVarBind boot_id (nlHsVar id) + | (boot_id, id) <- imp_prs ] tcg_env_w_binds - = tcg_env { tcg_binds = binds `unionBags` dfun_binds } + = tcg_env { tcg_binds = binds `unionBags` impedance_binds } ; type_env' `seq` -- Why the seq? Without, we will put a TypeEnv thunk in @@ -828,6 +835,62 @@ In fact, the names will always differ because we always pick names prefixed with "$fx" for boot dfuns, and "$f" for real dfuns (so that this impedance matching is always possible). +Note [Record field impedance matching] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When a hs-boot file defines a function whose implementation in the hs file +is a record selector, we have to do something similar to Note [DFun impedance matching]. + +Example: + + -- M.hs-boot + module M where + data A + fld :: A -> () + + -- M.hs + module M where + data A = MkA { fld :: () } + +Recall from Note [Record field namespacing] in GHC.Types.Name.Occurrence that +record fields have their own namespaces. This means that M.hs exports the Id +fld{record selector of MkA} :: A -> (), while M.hs-boot exports the Id +fld{variable} :: A -> (). + +To remedy this, we add an impedance-matching binding in M.hs: + + fld{variable} :: A -> () + fld{variable} = fld{record selector of MkA} + +Note that we imperatively need to add a binding for fld{variable} in M.hs, as we +might have an exact Name reference to it (e.g. in a module that imports M.hs-boot). +Not doing so would cause Core Lint errors, at the very least. + +These bindings are returned by the check_export in checkHiBootIface', and +added to the DFun impedance-matching bindings. + +[Wrinkle: exports] + + We MUST NOT add fld{variable} to the export list of M.hs, as this + would mean that M.hs exports both a record field and variable with the same + occNameFS, which would cause ambiguity errors at use-sites. + It's OK to only export the field name even though the boot-file exported + the variable: name resolution will take care of that. + +Another situation is that we are re-exporting, e.g. (with M as above): + + -- N.hs-boot + module N ( module M ) where + import {-# SOURCE #-} M + + -- N.hs + module N ( module M where ) + import M + +In this case, N.hs-boot re-exports the variable fld, and N re-exports the +record field fld, but not the variable fld. We don't need to do anything in +this situation; in particular, don't re-export the variable name from N.hs, +as per [Wrinkle: exports] above. + Note [DFun knot-tying] ~~~~~~~~~~~~~~~~~~~~~~ The 'SelfBootInfo' that is fed into 'checkHiBootIface' comes from @@ -860,10 +923,12 @@ checkHiBootIface' , md_fam_insts = boot_fam_insts , md_exports = boot_exports }) = do { traceTc "checkHiBootIface" $ vcat - [ ppr boot_type_env, ppr boot_exports] + [ ppr boot_type_env, ppr boot_exports ] + + ; gre_env <- getGlobalRdrEnv -- Check the exports of the boot module, one by one - ; mapM_ check_export boot_exports + ; fld_prs <- mapMaybeM (check_export gre_env) boot_exports -- Check for no family instances ; unless (null boot_fam_insts) $ @@ -875,11 +940,11 @@ checkHiBootIface' -- Check instance declarations -- and generate an impedance-matching binding - ; mb_dfun_prs <- mapM check_cls_inst boot_dfuns + ; dfun_prs <- mapMaybeM check_cls_inst boot_dfuns ; failIfErrsM - ; return (catMaybes mb_dfun_prs) } + ; return (fld_prs ++ dfun_prs) } where boot_dfun_names = map idName boot_dfuns @@ -888,46 +953,96 @@ checkHiBootIface' -- We don't want to look at md_insts! -- Why not? See Note [DFun knot-tying] - check_export boot_avail -- boot_avail is exported by the boot iface - | name `elem` boot_dfun_names = return () + check_export gre_env boot_avail -- boot_avail is exported by the boot iface + | name `elem` boot_dfun_names + = return Nothing -- Check that the actual module exports the same thing | missing_name:_ <- missing_names - = addErrAt (nameSrcSpan missing_name) - (missingBootThing True missing_name "exported by") + = -- Lookup might have failed because the hs-boot file defines a variable + -- that is implemented in the hs file as a record selector, which + -- lives in a different namespace. + -- + -- See Note [Record field impedance matching]. + let missing_occ = nameOccName missing_name + mb_ok :: GlobalRdrElt -> Maybe (GlobalRdrElt, Maybe Id) + mb_ok gre + -- Ensure that this GRE refers to an Id that is exported. + | isNothing $ lookupNameEnv local_export_env (greName gre) + = Nothing + -- We locally define the field: create an impedance-matching + -- binding for the variable. + | Just (AnId id) <- lookupTypeEnv local_type_env (greName gre) + = Just (gre, Just id) + -- We are re-exporting the field but not the variable: not a problem, + -- as per [Wrinkle: exports] in Note [Record field impedance matching]. + | otherwise + = Just (gre, Nothing) + matching_flds + | isVarOcc missing_occ -- (This only applies to variables.) + = lookupGRE_OccName (IncludeFields WantField) gre_env missing_occ + | otherwise + = [] + + in case mapMaybe mb_ok $ matching_flds of + + -- At least 2 matches: report an ambiguity error. + (gre1,_):(gre2,_):gres_ids -> do + addErrAt (nameSrcSpan missing_name) $ + mkNameClashErr missing_name (gre1 NE.:| gre2 : map fst gres_ids) + return Nothing + + -- Single match: resolve the issue. + [(_,mb_fld_id)] -> + -- See Note [Record field impedance matching]. + for mb_fld_id $ \ fld_id -> do + let local_boot_var = + Id.mkExportedVanillaId missing_name (idType fld_id) + return (local_boot_var, fld_id) + + -- Otherwise: report that the hs file does not export something + -- that the hs-boot file exports. + [] -> do + addErrAt (nameSrcSpan missing_name) + (missingBootThing True missing_name "exported by") + return Nothing -- If the boot module does not *define* the thing, we are done -- (it simply re-exports it, and names match, so nothing further to do) - | isNothing mb_boot_thing = return () + | isNothing mb_boot_thing + = return Nothing -- Check that the actual module also defines the thing, and -- then compare the definitions | Just real_thing <- lookupTypeEnv local_type_env name, Just boot_thing <- mb_boot_thing - = checkBootDeclM True boot_thing real_thing + = do checkBootDeclM True boot_thing real_thing + return Nothing | otherwise - = addErrTc (missingBootThing True name "defined in") + = do addErrTc (missingBootThing True name "defined in") + return Nothing where name = availName boot_avail mb_boot_thing = lookupTypeEnv boot_type_env name missing_names = case lookupNameEnv local_export_env name of Nothing -> [name] - Just avail -> availNames boot_avail `minusList` availNames avail + Just avail -> availNames boot_avail + `minusList` availNames avail local_export_env :: NameEnv AvailInfo local_export_env = availsToNameEnv local_exports - check_cls_inst :: DFunId -> TcM (Maybe (Id, Id)) + check_cls_inst :: DFunId -> TcM (Maybe (Id,Id)) -- Returns a pair of the boot dfun in terms of the equivalent -- real dfun. Delicate (like checkBootDecl) because it depends -- on the types lining up precisely even to the ordering of -- the type variables in the foralls. check_cls_inst boot_dfun | (real_dfun : _) <- find_real_dfun boot_dfun - , let local_boot_dfun = Id.mkExportedVanillaId - (idName boot_dfun) (idType real_dfun) - = return (Just (local_boot_dfun, real_dfun)) + , let dfun_name = idName boot_dfun + local_boot_dfun = Id.mkExportedVanillaId dfun_name (idType real_dfun) + = return $ Just (local_boot_dfun, real_dfun) -- Two tricky points here: -- -- * The local_boot_fun should have a Name from the /boot-file/, @@ -943,6 +1058,8 @@ checkHiBootIface' -- otherwise dependency analysis fails (#16038). This -- is another reason for using mkExportedVanillaId, rather -- that modifying boot_dfun, to make local_boot_fun. + -- + -- See Note [DFun impedance matching]. | otherwise = setSrcSpan (nameSrcSpan (getName boot_dfun)) $ @@ -1545,7 +1662,7 @@ tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls, foe_binds ; fo_gres = fi_gres `unionBags` foe_gres - ; fo_fvs = foldr (\gre fvs -> fvs `addOneFV` greMangledName gre) + ; fo_fvs = foldr (\gre fvs -> fvs `addOneFV` (greName gre)) emptyFVs fo_gres ; sig_names = mkNameSet (collectHsValBinders CollNoDictBinders hs_val_binds) @@ -1613,11 +1730,11 @@ tcPreludeClashWarn warnFlag name = do where isLocalDef = gre_lcl x == True -- Names are identical ... - nameClashes = nameOccName (greMangledName x) == nameOccName name + nameClashes = nameOccName (greName x) == nameOccName name -- ... but not the actual definitions, because we don't want to -- warn about a bad definition of e.g. <> in Data.Semigroup, which -- is the (only) proper place where this should be defined - isNotInProperModule = greMangledName x /= name + isNotInProperModule = greName x /= name -- List of all offending definitions clashingElts :: [GlobalRdrElt] @@ -1626,11 +1743,11 @@ tcPreludeClashWarn warnFlag name = do ; traceTc "tcPreludeClashWarn/prelude_functions" (hang (ppr name) 4 (sep [ppr clashingElts])) - ; let warn_msg x = addDiagnosticAt (nameSrcSpan (greMangledName x)) $ + ; let warn_msg x = addDiagnosticAt (nameSrcSpan (greName x)) $ mkTcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag warnFlag) noHints $ (hsep [ text "Local definition of" - , (quotes . ppr . nameOccName . greMangledName) x + , (quotes . ppr . nameOccName . greName) x , text "clashes with a future Prelude name." ] $$ text "This will become an error in a future release." ) @@ -1813,13 +1930,13 @@ checkMainType tcg_env do { rdr_env <- getGlobalRdrEnv ; let dflags = hsc_dflags hsc_env main_occ = getMainOcc dflags - main_gres = lookupGlobalRdrEnv rdr_env main_occ + main_gres = lookupGRE_OccName SameOccName rdr_env main_occ ; case filter isLocalGRE main_gres of { [] -> return emptyWC ; (_:_:_) -> return emptyWC ; [main_gre] -> - do { let main_name = greMangledName main_gre + do { let main_name = greName main_gre ctxt = FunSigCtxt main_name NoRRC ; main_id <- tcLookupId main_name ; (io_ty,_) <- getIOType @@ -2091,23 +2208,21 @@ runTcInteractive hsc_env thing_inside ; let imports = emptyImportAvails { imp_orphs = orphs } upd_envs (gbl_env, lcl_env) = (gbl_env', lcl_env') + where - gbl_env' = gbl_env { tcg_rdr_env = icReaderEnv icxt - , tcg_type_env = type_env - - , tcg_inst_env = tcg_inst_env gbl_env `unionInstEnv` ic_insts `unionInstEnv` home_insts - , tcg_fam_inst_env = extendFamInstEnvList - (extendFamInstEnvList (tcg_fam_inst_env gbl_env) - ic_finsts) - home_fam_insts - , tcg_con_env = mkNameEnv con_fields - -- setting tcg_con_env is necessary - -- to make RecordWildCards work (test: ghci049) - , tcg_fix_env = ic_fix_env icxt - , tcg_default = ic_default icxt - -- must calculate imp_orphs of the ImportAvails - -- so that instance visibility is done correctly - , tcg_imports = imports } + gbl_env' = gbl_env + { tcg_rdr_env = icReaderEnv icxt + , tcg_type_env = type_env + , tcg_inst_env = tcg_inst_env gbl_env `unionInstEnv` ic_insts `unionInstEnv` home_insts + , tcg_fam_inst_env = extendFamInstEnvList + (extendFamInstEnvList (tcg_fam_inst_env gbl_env) + ic_finsts) + home_fam_insts + , tcg_fix_env = ic_fix_env icxt + , tcg_default = ic_default icxt + -- must calculate imp_orphs of the ImportAvails + -- so that instance visibility is done correctly + , tcg_imports = imports } lcl_env' = tcExtendLocalTypeEnv lcl_env lcl_ids @@ -2132,15 +2247,11 @@ runTcInteractive hsc_env thing_inside = Right thing type_env1 = mkTypeEnvWithImplicits top_ty_things - type_env = extendTypeEnvWithIds type_env1 (map instanceDFunId (instEnvElts ic_insts)) + type_env = extendTypeEnvWithIds type_env1 + $ map instanceDFunId (instEnvElts ic_insts) -- Putting the dfuns in the type_env -- is just to keep Core Lint happy - con_fields = [ (dataConName c, mkConInfo (dataConSourceArity c) (dataConFieldLabels c)) - | ATyCon t <- top_ty_things - , c <- tyConDataCons t ] - - {- Note [Initialising the type environment for GHCi] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Most of the Ids in ic_things, defined by the user in 'let' stmts, @@ -2551,7 +2662,7 @@ isGHCiMonad hsc_env ty let occIO = lookupOccEnv rdrEnv (mkOccName tcName ty) case occIO of Just [n] -> do - let name = greMangledName n + let name = greName n ghciClass <- tcLookupClass ghciIoClassName userTyCon <- tcLookupTyCon name let userTy = mkTyConApp userTyCon [] @@ -2955,7 +3066,7 @@ loadUnqualIfaces hsc_env ictxt unqual_mods = [ nameModule name | gre <- globalRdrEnvElts (icReaderEnv ictxt) - , let name = greMangledName gre + , let name = greName gre , nameIsFromExternalPackage home_unit name , isTcOcc (nameOccName name) -- Types and classes only , unQualOK gre ] -- In scope unqualified @@ -3037,12 +3148,12 @@ ppr_types debug type_env | debug = True | otherwise = hasTopUserName id && case idDetails id of - VanillaId -> True - WorkerLikeId{} -> True - RecSelId {} -> True - ClassOpId {} -> True - FCallId {} -> True - _ -> False + VanillaId -> True + WorkerLikeId {} -> True + RecSelId {} -> True + ClassOpId {} -> True + FCallId {} -> True + _ -> False -- Data cons (workers and wrappers), pattern synonyms, -- etc are suppressed (unless -dppr-debug), -- because they appear elsewhere diff --git a/compiler/GHC/Tc/Solver/Monad.hs b/compiler/GHC/Tc/Solver/Monad.hs index 19b3f5089b..a22c135d18 100644 --- a/compiler/GHC/Tc/Solver/Monad.hs +++ b/compiler/GHC/Tc/Solver/Monad.hs @@ -1448,7 +1448,7 @@ recordUsedGREs gres = do { wrapTcS $ TcM.addUsedGREs gre_list -- If a newtype constructor was imported, don't warn about not -- importing it... - ; wrapTcS $ traverse_ (TcM.keepAlive . greMangledName) gre_list } + ; wrapTcS $ traverse_ (TcM.keepAlive . greName) gre_list } -- ...and similarly, if a newtype constructor was defined in the same -- module, don't warn about it being unused. -- See Note [Tracking unused binding and imports] in GHC.Tc.Utils. diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs index afb2047d63..3acfe274d7 100644 --- a/compiler/GHC/Tc/TyCl.hs +++ b/compiler/GHC/Tc/TyCl.hs @@ -62,7 +62,7 @@ import GHC.Builtin.Types (oneDataConTy, unitTy, makeRecoveryTyCon ) import GHC.Rename.Env( lookupConstructorFields ) import GHC.Core.Multiplicity -import GHC.Core.FamInstEnv +import GHC.Core.FamInstEnv ( mkBranchedCoAxiom, mkCoAxBranch ) import GHC.Core.Coercion import GHC.Core.Type import GHC.Core.TyCo.Rep -- for checkValidRoles @@ -1390,7 +1390,7 @@ getInitialKind (InitialKindCheck msig) (FamDecl { tcdFam = , fdTyVars = ktvs , fdResultSig = unLoc -> resultSig , fdInfo = info } } ) - = do { let flav = getFamFlav Nothing info + = do { let flav = familyInfoTyConFlavour Nothing info ctxt = TyFamResKindCtxt name ; tc <- kcDeclHeader (InitialKindCheck msig) name flav ktvs $ case famResultKindSignature resultSig of @@ -1431,7 +1431,7 @@ get_fam_decl_initial_kind mb_parent_tycon -- by default | otherwise -> return AnyKind where - flav = getFamFlav mb_parent_tycon info + flav = familyInfoTyConFlavour mb_parent_tycon info ctxt = TyFamResKindCtxt name -- See Note [Standalone kind signatures for associated types] @@ -1451,7 +1451,7 @@ check_initial_kind_assoc_fam cls Nothing -> return (TheKind liftedTypeKind) where ctxt = TyFamResKindCtxt name - flav = getFamFlav (Just cls) info + flav = familyInfoTyConFlavour (Just cls) info {- Note [Standalone kind signatures for associated types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1536,29 +1536,6 @@ However, there are two twists: -} ---------------------------------- -getFamFlav - :: Maybe TcTyCon -- ^ Just cls <=> this is an associated family of class cls - -> FamilyInfo pass - -> TyConFlavour -getFamFlav mb_parent_tycon info = - case info of - DataFamily -> DataFamilyFlavour mb_parent_tycon - OpenTypeFamily -> OpenTypeFamilyFlavour mb_parent_tycon - ClosedTypeFamily _ -> assert (isNothing mb_parent_tycon) -- See Note [Closed type family mb_parent_tycon] - ClosedTypeFamilyFlavour - -{- Note [Closed type family mb_parent_tycon] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There's no way to write a closed type family inside a class declaration: - - class C a where - type family F a where -- error: parse error on input ‘where’ - -In fact, it is not clear what the meaning of such a declaration would be. -Therefore, 'mb_parent_tycon' of any closed type family has to be Nothing. --} - ------------------------------------------------------------------------ kcLTyClDecl :: LTyClDecl GhcRn -> TcM () -- See Note [Kind checking for type and class decls] @@ -4337,8 +4314,9 @@ checkPartialRecordField all_cons fld sep [text "Use of partial record field selector" <> colon, nest 2 $ quotes (ppr occ_name)]) where - loc = getSrcSpan (flSelector fld) - occ_name = occName fld + sel = flSelector fld + loc = getSrcSpan sel + occ_name = nameOccName sel (cons_with_field, cons_without_field) = partition has_field all_cons has_field con = fld `elem` (dataConFieldLabels con) diff --git a/compiler/GHC/Tc/TyCl/Utils.hs b/compiler/GHC/Tc/TyCl/Utils.hs index 53e58a0e0c..b37977bb47 100644 --- a/compiler/GHC/Tc/TyCl/Utils.hs +++ b/compiler/GHC/Tc/TyCl/Utils.hs @@ -72,7 +72,7 @@ import GHC.Types.SourceFile import GHC.Types.SourceText import GHC.Types.Name import GHC.Types.Name.Env -import GHC.Types.Name.Reader ( mkVarUnqual ) +import GHC.Types.Name.Reader ( mkRdrUnqual ) import GHC.Types.Id import GHC.Types.Id.Info import GHC.Types.Var.Env @@ -896,7 +896,9 @@ mkOneRecordSelector all_cons idDetails fl has_sel sel_name = flSelector fl sel_id = mkExportedLocalId rec_details sel_name sel_ty - rec_details = RecSelId { sel_tycon = idDetails, sel_naughty = is_naughty } + rec_details = RecSelId { sel_tycon = idDetails + , sel_naughty = is_naughty + , sel_fieldLabel = fl } -- Find a representative constructor, con1 cons_w_field = conLikesWithFields all_cons [lbl] @@ -954,7 +956,7 @@ mkOneRecordSelector all_cons idDetails fl has_sel { hfbAnn = noAnn , hfbLHS = L locc (FieldOcc sel_name - (L locn $ mkVarUnqual (field_label lbl))) + (L locn $ mkRdrUnqual (nameOccName sel_name))) , hfbRHS = L loc' (VarPat noExtField (L locn field_var)) , hfbPun = False }) diff --git a/compiler/GHC/Tc/Types.hs b/compiler/GHC/Tc/Types.hs index acf7a0e6af..a6bab74fc0 100644 --- a/compiler/GHC/Tc/Types.hs +++ b/compiler/GHC/Tc/Types.hs @@ -145,7 +145,6 @@ import GHC.Types.Unique.FM import GHC.Types.Basic import GHC.Types.CostCentre.State import GHC.Types.HpcInfo -import GHC.Types.ConInfo (ConFieldEnv) import GHC.Data.IOEnv import GHC.Data.Bag @@ -442,11 +441,7 @@ data TcGblEnv tcg_default :: Maybe [Type], -- ^ Types used for defaulting. @Nothing@ => no @default@ decl - tcg_fix_env :: FixityEnv, -- ^ Just for things in this module - tcg_con_env :: ConFieldEnv, - -- ^ Just for things in this module - -- For information on why this is necessary, see Note [Local constructor info in the renamer] - -- See Note [The interactive package] in "GHC.Runtime.Context" + tcg_fix_env :: FixityEnv, -- ^ Just for things in this module tcg_type_env :: TypeEnv, -- ^ Global type env for the module we are compiling now. All diff --git a/compiler/GHC/Tc/Types/Origin.hs b/compiler/GHC/Tc/Types/Origin.hs index bc1842e368..fb64b55cde 100644 --- a/compiler/GHC/Tc/Types/Origin.hs +++ b/compiler/GHC/Tc/Types/Origin.hs @@ -280,7 +280,7 @@ data SkolemInfoAnon | UnifyForAllSkol -- We are unifying two for-all types TcType -- The instantiated type *inside* the forall - | TyConSkol TyConFlavour Name -- bound in a type declaration of the given flavour + | TyConSkol (TyConFlavour TyCon) Name -- bound in a type declaration of the given flavour | DataConSkol Name -- bound as an existential in a Haskell98 datacon decl or -- as any variable in a GADT datacon decl diff --git a/compiler/GHC/Tc/Utils/Backpack.hs b/compiler/GHC/Tc/Utils/Backpack.hs index bc70d18684..20508c0fa4 100644 --- a/compiler/GHC/Tc/Utils/Backpack.hs +++ b/compiler/GHC/Tc/Utils/Backpack.hs @@ -47,14 +47,18 @@ import GHC.Unit.Module.ModDetails import GHC.Unit.Module.Imported import GHC.Unit.Module.Deps +import GHC.Tc.Errors import GHC.Tc.Errors.Types +import {-# SOURCE #-} GHC.Tc.Module import GHC.Tc.Gen.Export import GHC.Tc.Solver import GHC.Tc.TyCl.Utils import GHC.Tc.Types.Constraint import GHC.Tc.Types.Origin +import GHC.Tc.Utils.Env import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Instantiate +import GHC.Tc.Utils.Unify import GHC.Tc.Utils.TcMType import GHC.Tc.Utils.TcType @@ -71,11 +75,8 @@ import GHC.Iface.Syntax import GHC.Rename.Names import GHC.Rename.Fixity ( lookupFixityRn ) -import GHC.Tc.Utils.Env -import GHC.Tc.Errors -import GHC.Tc.Utils.Unify - import GHC.Utils.Error +import GHC.Utils.Misc ( HasDebugCallStack ) import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Panic.Plain @@ -86,8 +87,6 @@ import GHC.Data.Maybe import Control.Monad import Data.List (find) -import {-# SOURCE #-} GHC.Tc.Module - checkHsigDeclM :: ModIface -> TyThing -> TyThing -> TcRn () checkHsigDeclM sig_iface sig_thing real_thing = do let name = getName real_thing @@ -112,7 +111,7 @@ checkHsigDeclM sig_iface sig_thing real_thing = do -- a sufficient set of entities, since otherwise the renaming and then -- typechecking of the signature 'ModIface' would have failed. checkHsigIface :: TcGblEnv -> GlobalRdrEnv -> ModIface -> ModDetails -> TcRn () -checkHsigIface tcg_env gr sig_iface +checkHsigIface tcg_env gre_env sig_iface ModDetails { md_insts = sig_insts, md_fam_insts = sig_fam_insts, md_types = sig_type_env, md_exports = sig_exports } = do traceTc "checkHsigIface" $ vcat @@ -120,8 +119,8 @@ checkHsigIface tcg_env gr sig_iface mapM_ check_export (map availName sig_exports) failIfErrsM -- See Note [Fail before checking instances in checkHsigIface] unless (null sig_fam_insts) $ - panic ("GHC.Tc.Module.checkHsigIface: Cannot handle family " ++ - "instances in hsig files yet...") + panic ("GHC.Tc.Utils.Backpack.checkHsigIface: " ++ + "Cannot handle family instances in hsig files yet...") -- Delete instances so we don't look them up when -- checking instance satisfiability -- TODO: this should not be necessary @@ -159,8 +158,8 @@ checkHsigIface tcg_env gr sig_iface -- The hsig did NOT define this function; that means it must -- be a reexport. In this case, make sure the 'Name' of the -- reexport matches the 'Name exported here. - | [gre] <- lookupGlobalRdrEnv gr (nameOccName name) = do - let name' = greMangledName gre + | [gre] <- lookupGRE_OccName (AllNameSpaces WantNormal) gre_env (nameOccName name) = do + let name' = greName gre when (name /= name') $ do -- See Note [Error reporting bad reexport] -- TODO: Actually this error swizzle doesn't work @@ -385,7 +384,7 @@ thinModIface avails iface = decl_pred occs decl = nameOccName (ifName decl) `elemOccSet` occs filter_decls occs = filter (decl_pred occs . snd) (mi_decls iface) - exported_occs = mkOccSet [ occName n + exported_occs = mkOccSet [ nameOccName n | a <- avails , n <- availNames a ] exported_decls = filter_decls exported_occs @@ -495,7 +494,7 @@ merge_msg mod_name reqs = -- from 'requirementMerges' into this signature, producing -- a final 'TcGblEnv' that matches the local signature and -- all required signatures. -mergeSignatures :: HsParsedModule -> TcGblEnv -> ModIface -> TcRn TcGblEnv +mergeSignatures :: HasDebugCallStack => HsParsedModule -> TcGblEnv -> ModIface -> TcRn TcGblEnv mergeSignatures (HsParsedModule { hpm_module = L loc (HsModule { hsmodExports = mb_exports }), hpm_src_files = src_files }) @@ -532,7 +531,7 @@ mergeSignatures let outer_mod = tcg_mod tcg_env let inner_mod = tcg_semantic_mod tcg_env - let mod_name = moduleName (tcg_mod tcg_env) + let mod_name = moduleName outer_mod let unit_state = hsc_units hsc_env let dflags = hsc_dflags hsc_env @@ -640,7 +639,7 @@ mergeSignatures is_qual = False, is_dloc = locA loc } ImpAll - rdr_env = mkGlobalRdrEnv (gresFromAvails (Just ispec) as1) + rdr_env = mkGlobalRdrEnv $ gresFromAvails hsc_env (Just ispec) as1 setGblEnv tcg_env { tcg_rdr_env = rdr_env } $ exports_from_avail mb_exports rdr_env @@ -650,7 +649,7 @@ mergeSignatures case mb_r of Just (_, as2) -> return (thinModIface as2 ireq_iface, as2) Nothing -> addMessages msgs >> failM - -- We can't think signatures from non signature packages + -- We can't thin signatures from non-signature packages _ -> return (ireq_iface, as1) -- 3(c). Only identifiers from signature packages are "ok" to -- import (that is, they are safe from a PVP perspective.) @@ -673,7 +672,7 @@ mergeSignatures <- foldM gen_subst (nsubst0, ok_to_use0, []) (zip reqs ireq_ifaces0) let thinned_ifaces = reverse rev_thinned_ifaces exports = nameShapeExports nsubst - rdr_env = mkGlobalRdrEnv (gresFromAvails Nothing exports) + rdr_env = mkGlobalRdrEnv (gresFromAvails hsc_env Nothing exports) _warn_occs = filter (not . (`elemOccSet` ok_to_use)) (exportOccs exports) warns = NoWarnings {- @@ -698,7 +697,7 @@ mergeSignatures -- reexports are picked up correctly tcg_imports = tcg_imports orig_tcg_env, tcg_exports = exports, - tcg_dus = usesOnly (availsToNameSetWithSelectors exports), + tcg_dus = usesOnly (availsToNameSet exports), tcg_warns = warns } $ do tcg_env <- getGblEnv @@ -738,9 +737,9 @@ mergeSignatures let ifaces = lcl_iface : ext_ifaces -- STEP 4.1: Merge fixities (we'll verify shortly) tcg_fix_env - let fix_env = mkNameEnv [ (greMangledName rdr_elt, FixItem occ f) + let fix_env = mkNameEnv [ (greName rdr_elt, FixItem occ f) | (occ, f) <- concatMap mi_fixities ifaces - , rdr_elt <- lookupGlobalRdrEnv rdr_env occ ] + , rdr_elt <- lookupGRE_OccName (AllNameSpaces WantBoth) rdr_env occ ] -- STEP 5: Typecheck the interfaces let type_env_var = tcg_type_env_var tcg_env @@ -875,10 +874,10 @@ mergeSignatures n <- newDFunName (is_cls inst) (is_tys inst) (nameSrcSpan (is_dfun_name inst)) let dfun = setVarName (is_dfun inst) n return (dfun, inst { is_dfun_name = n, is_dfun = dfun }) - tcg_env <- return tcg_env { - tcg_insts = map snd dfun_insts, - tcg_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) (map fst dfun_insts) - } + + tcg_env <- return $ + tcg_env { tcg_insts = map snd dfun_insts + , tcg_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) (map fst dfun_insts) } addDependentFiles src_files @@ -912,7 +911,7 @@ tcRnInstantiateSignature hsc_env this_mod real_loc = logger = hsc_logger hsc_env exportOccs :: [AvailInfo] -> [OccName] -exportOccs = concatMap (map occName . availNames) +exportOccs = concatMap (map nameOccName . availNames) impl_msg :: UnitState -> Module -> InstantiatedModule -> SDoc impl_msg unit_state impl_mod (Module req_uid req_mod_name) @@ -924,7 +923,7 @@ impl_msg unit_state impl_mod (Module req_uid req_mod_name) -- | Check if module implements a signature. (The signature is -- always un-hashed, which is why its components are specified -- explicitly.) -checkImplements :: Module -> InstantiatedModule -> TcRn TcGblEnv +checkImplements :: HasDebugCallStack => Module -> InstantiatedModule -> TcRn TcGblEnv checkImplements impl_mod req_mod@(Module uid mod_name) = do hsc_env <- getTopEnv let unit_state = hsc_units hsc_env @@ -942,7 +941,7 @@ checkImplements impl_mod req_mod@(Module uid mod_name) = do impl_iface <- initIfaceTcRn $ loadSysInterface (text "checkImplements 1") impl_mod let impl_gr = mkGlobalRdrEnv - (gresFromAvails Nothing (mi_exports impl_iface)) + (gresFromAvails hsc_env Nothing (mi_exports impl_iface)) nsubst = mkNameShape (moduleName impl_mod) (mi_exports impl_iface) -- Load all the orphans, so the subsequent 'checkHsigIface' sees @@ -952,9 +951,9 @@ checkImplements impl_mod req_mod@(Module uid mod_name) = do let avails = calculateAvails home_unit other_home_units impl_iface False{- safe -} NotBoot ImportedBySystem - fix_env = mkNameEnv [ (greMangledName rdr_elt, FixItem occ f) + fix_env = mkNameEnv [ (greName rdr_elt, FixItem occ f) | (occ, f) <- mi_fixities impl_iface - , rdr_elt <- lookupGlobalRdrEnv impl_gr occ ] + , rdr_elt <- lookupGRE_OccName (AllNameSpaces WantBoth) impl_gr occ ] updGblEnv (\tcg_env -> tcg_env { -- Setting tcg_rdr_env to treat all exported entities from -- the implementing module as in scope improves error messages, @@ -988,7 +987,7 @@ checkImplements impl_mod req_mod@(Module uid mod_name) = do -- STEP 3: Check that the implementing interface exports everything -- we need. (Notice we IGNORE the Modules in the AvailInfos.) forM_ (exportOccs (mi_exports isig_iface)) $ \occ -> - case lookupGlobalRdrEnv impl_gr occ of + case lookupGRE_OccName SameOccName impl_gr occ of [] -> addErr $ TcRnHsigMissingModuleExport occ unit_state impl_mod _ -> return () failIfErrsM diff --git a/compiler/GHC/Tc/Utils/Env.hs b/compiler/GHC/Tc/Utils/Env.hs index 43263450ac..52bf245dc5 100644 --- a/compiler/GHC/Tc/Utils/Env.hs +++ b/compiler/GHC/Tc/Utils/Env.hs @@ -22,6 +22,7 @@ module GHC.Tc.Utils.Env( tcLookupLocatedGlobal, tcLookupGlobal, tcLookupGlobalOnly, tcLookupTyCon, tcLookupClass, tcLookupDataCon, tcLookupPatSyn, tcLookupConLike, + tcLookupRecSelParent, tcLookupLocatedGlobalId, tcLookupLocatedTyCon, tcLookupLocatedClass, tcLookupAxiom, lookupGlobal, lookupGlobal_maybe, ioLookupDataCon, @@ -74,6 +75,7 @@ module GHC.Tc.Utils.Env( import GHC.Prelude import GHC.Driver.Env +import GHC.Driver.Env.KnotVars import GHC.Driver.Session import GHC.Builtin.Names @@ -96,7 +98,7 @@ import GHC.Tc.Types.Origin ( CtOrigin(UsageEnvironmentOf) ) import GHC.Core.UsageEnv import GHC.Core.InstEnv -import GHC.Core.DataCon ( DataCon, flSelector ) +import GHC.Core.DataCon ( DataCon, dataConTyCon, flSelector ) import GHC.Core.PatSyn ( PatSyn ) import GHC.Core.ConLike import GHC.Core.TyCon @@ -104,6 +106,7 @@ import GHC.Core.Type import GHC.Core.Coercion.Axiom import GHC.Core.Class + import GHC.Unit.Module import GHC.Unit.Home import GHC.Unit.External @@ -126,17 +129,18 @@ import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.Name.Env import GHC.Types.Id +import GHC.Types.Id.Info ( RecSelParent(..) ) import GHC.Types.Var import GHC.Types.Var.Env import GHC.Types.Name.Reader import GHC.Types.TyThing +import GHC.Types.Unique.Set ( nonDetEltsUniqSet ) import qualified GHC.LanguageExtensions as LangExt import GHC.Tc.Errors.Ppr (pprTyThingUsedWrong) import Data.IORef -import Data.List (intercalate) +import Data.List ( intercalate ) import Control.Monad -import GHC.Driver.Env.KnotVars {- ********************************************************************* * * @@ -292,6 +296,17 @@ tcLookupConLike name = do AConLike cl -> return cl _ -> wrongThingErr WrongThingConLike (AGlobal thing) name +tcLookupRecSelParent :: HsRecUpdParent GhcRn -> TcM RecSelParent +tcLookupRecSelParent (RnRecUpdParent { rnRecUpdCons = cons }) + = case any_con of + PatSynName ps -> + RecSelPatSyn <$> tcLookupPatSyn ps + DataConName dc -> + RecSelData . dataConTyCon <$> tcLookupDataCon dc + where + any_con = head $ nonDetEltsUniqSet cons + -- Any constructor will give the same result here. + tcLookupClass :: Name -> TcM Class tcLookupClass name = do thing <- tcLookupGlobal name @@ -508,6 +523,7 @@ tcLookupTcTyCon name = do ATcTyCon tc -> return tc _ -> pprPanic "tcLookupTcTyCon" (ppr name) + getInLocalScope :: TcM (Name -> Bool) getInLocalScope = do { lcl_env <- getLclTypeEnv ; return (`elemNameEnv` lcl_env) } @@ -1064,7 +1080,7 @@ newDFunName clas tys loc = do { is_boot <- tcIsHsBootOrSig ; mod <- getModule ; let info_string = occNameString (getOccName clas) ++ - concatMap (occNameString.getDFunTyKey) tys + concatMap (occNameString . getDFunTyKey) tys ; dfun_occ <- chooseUniqueOccTc (mkDFunOcc info_string is_boot) ; newGlobalBinder mod dfun_occ loc } diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs index a8ab977def..d713fce376 100644 --- a/compiler/GHC/Tc/Utils/Monad.hs +++ b/compiler/GHC/Tc/Utils/Monad.hs @@ -55,7 +55,7 @@ module GHC.Tc.Utils.Monad( getIsGHCi, getGHCiMonad, getInteractivePrintName, tcIsHsBootOrSig, tcIsHsig, tcSelfBootInfo, getGlobalRdrEnv, getRdrEnvs, getImports, - getFixityEnv, extendFixityEnv, getConEnv, + getFixityEnv, extendFixityEnv, getDeclaredDefaultTys, addDependentFiles, @@ -209,7 +209,6 @@ import GHC.Types.Annotations import GHC.Types.Basic( TopLevelFlag, TypeOrKind(..) ) import GHC.Types.CostCentre.State import GHC.Types.SourceFile -import GHC.Types.ConInfo (ConFieldEnv) import qualified GHC.LanguageExtensions as LangExt @@ -301,7 +300,6 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this tcg_src = hsc_src, tcg_rdr_env = emptyGlobalRdrEnv, tcg_fix_env = emptyNameEnv, - tcg_con_env = emptyNameEnv, tcg_default = if moduleUnit mod == primUnit || moduleUnit mod == bignumUnit then Just [] -- See Note [Default types] @@ -943,9 +941,6 @@ extendFixityEnv new_bit = updGblEnv (\env@(TcGblEnv { tcg_fix_env = old_fix_env }) -> env {tcg_fix_env = extendNameEnvList old_fix_env new_bit}) -getConEnv :: TcRn ConFieldEnv -getConEnv = do { env <- getGblEnv; return (tcg_con_env env) } - getDeclaredDefaultTys :: TcRn (Maybe [Type]) getDeclaredDefaultTys = do { env <- getGblEnv; return (tcg_default env) } diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs index 498a17694f..09a1f4562e 100644 --- a/compiler/GHC/ThToHs.hs +++ b/compiler/GHC/ThToHs.hs @@ -60,6 +60,7 @@ import Control.Monad( unless, ap ) import Control.Applicative( (<|>) ) import Data.Bifunctor (first) import Data.Foldable (for_) +import Data.List (head) import Data.List.NonEmpty( NonEmpty (..), nonEmpty ) import qualified Data.List.NonEmpty as NE import Data.Maybe( catMaybes, isNothing ) @@ -69,6 +70,7 @@ import Foreign.ForeignPtr import Foreign.Ptr import System.IO.Unsafe + ------------------------------------------------------------------- -- The external interface @@ -275,7 +277,7 @@ cvtDec (DataD ctxt tc tvs ksig constrs derivs) cvtDec (NewtypeD ctxt tc tvs ksig constr derivs) = do { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs ; ksig' <- cvtKind `traverse` ksig - ; con' <- cvtConstr cNameN constr + ; con' <- cvtConstr (NE.head $ get_cons_names constr) cNameN constr ; derivs' <- cvtDerivs derivs ; let defn = HsDataDefn { dd_ext = noExtField , dd_cType = Nothing @@ -347,7 +349,9 @@ cvtDec (DataFamilyD tc tvs kind) cvtDec (DataInstD ctxt bndrs tys ksig constrs derivs) = do { (ctxt', tc', bndrs', typats') <- cvt_datainst_hdr ctxt bndrs tys ; ksig' <- cvtKind `traverse` ksig - ; cons' <- mapM (cvtConstr cNameN) constrs + + ; let first_datacon = NE.head $ get_cons_names $ head constrs + ; cons' <- mapM (cvtConstr first_datacon cNameN) constrs ; derivs' <- cvtDerivs derivs ; let defn = HsDataDefn { dd_ext = noExtField , dd_cType = Nothing @@ -369,7 +373,7 @@ cvtDec (DataInstD ctxt bndrs tys ksig constrs derivs) cvtDec (NewtypeInstD ctxt bndrs tys ksig constr derivs) = do { (ctxt', tc', bndrs', typats') <- cvt_datainst_hdr ctxt bndrs tys ; ksig' <- cvtKind `traverse` ksig - ; con' <- cvtConstr cNameN constr + ; con' <- cvtConstr (NE.head $ get_cons_names $ constr) cNameN constr ; derivs' <- cvtDerivs derivs ; let defn = HsDataDefn { dd_ext = noExtField , dd_cType = Nothing @@ -440,7 +444,8 @@ cvtDec (TH.PatSynD nm args dir pat) cvtArgs (TH.PrefixPatSyn args) = Hs.PrefixCon noTypeArgs <$> mapM vNameN args cvtArgs (TH.InfixPatSyn a1 a2) = Hs.InfixCon <$> vNameN a1 <*> vNameN a2 cvtArgs (TH.RecordPatSyn sels) - = do { sels' <- mapM (fmap (\ (L li i) -> FieldOcc noExtField (L li i)) . vNameN) sels + = do { let mk_fld = fldNameN (nameBase nm) + ; sels' <- mapM (fmap (\ (L li i) -> FieldOcc noExtField (L li i)) . mk_fld) sels ; vars' <- mapM (vNameN . mkNameS . nameBase) sels ; return $ Hs.RecCon $ zipWith RecordPatSynField sels' vars' } @@ -502,7 +507,10 @@ cvtGenDataDec type_data ctxt tc tvs ksig constrs derivs (failWith KindSigsOnlyAllowedOnGADTs) ; (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs ; ksig' <- cvtKind `traverse` ksig - ; cons' <- mapM (cvtConstr con_name) constrs + + ; let first_datacon = NE.head $ get_cons_names $ head constrs + ; cons' <- mapM (cvtConstr first_datacon con_name) constrs + ; derivs' <- cvtDerivs derivs ; let defn = HsDataDefn { dd_ext = noExtField , dd_cType = Nothing @@ -649,31 +657,32 @@ is_ip_bind decl = Right decl -- Data types --------------------------------------------------- -cvtConstr :: (TH.Name -> CvtM (LocatedN RdrName)) -- ^ convert constructor name - -> TH.Con -> CvtM (LConDecl GhcPs) +cvtConstr :: TH.Name -- ^ name of first constructor of parent type + -> (TH.Name -> CvtM (LocatedN RdrName)) -- ^ convert constructor name + -> TH.Con -> CvtM (LConDecl GhcPs) -cvtConstr con_name (NormalC c strtys) - = do { c' <- con_name c +cvtConstr _ do_con_name (NormalC c strtys) + = do { c' <- do_con_name c ; tys' <- mapM cvt_arg strtys ; returnLA $ mkConDeclH98 noAnn c' Nothing Nothing (PrefixCon noTypeArgs (map hsLinear tys')) } -cvtConstr con_name (RecC c varstrtys) - = do { c' <- con_name c - ; args' <- mapM cvt_id_arg varstrtys +cvtConstr parent_con do_con_name (RecC c varstrtys) + = do { c' <- do_con_name c + ; args' <- mapM (cvt_id_arg parent_con) varstrtys ; con_decl <- wrapParLA (mkConDeclH98 noAnn c' Nothing Nothing . RecCon) args' ; returnLA con_decl } -cvtConstr con_name (InfixC st1 c st2) - = do { c' <- con_name c +cvtConstr _ do_con_name (InfixC st1 c st2) + = do { c' <- do_con_name c ; st1' <- cvt_arg st1 ; st2' <- cvt_arg st2 ; returnLA $ mkConDeclH98 noAnn c' Nothing Nothing (InfixCon (hsLinear st1') (hsLinear st2')) } -cvtConstr con_name (ForallC tvs ctxt con) +cvtConstr parent_con do_con_name (ForallC tvs ctxt con) = do { tvs' <- cvtTvs tvs ; ctxt' <- cvtContext funPrec ctxt - ; L _ con' <- cvtConstr con_name con + ; L _ con' <- cvtConstr parent_con do_con_name con ; returnLA $ add_forall tvs' ctxt' con' } where add_cxt lcxt Nothing = mkHsContextMaybe lcxt @@ -701,22 +710,18 @@ cvtConstr con_name (ForallC tvs ctxt con) where all_tvs = tvs' ++ ex_tvs -cvtConstr con_name (GadtC c strtys ty) = case nonEmpty c of - Nothing -> failWith GadtNoCons - Just c -> do - { c' <- mapM con_name c - ; args <- mapM cvt_arg strtys - ; ty' <- cvtType ty - ; mk_gadt_decl c' (PrefixConGADT $ map hsLinear args) ty'} - -cvtConstr con_name (RecGadtC c varstrtys ty) = case nonEmpty c of - Nothing -> failWith RecGadtNoCons - Just c -> do - { c' <- mapM con_name c - ; ty' <- cvtType ty - ; rec_flds <- mapM cvt_id_arg varstrtys - ; lrec_flds <- returnLA rec_flds - ; mk_gadt_decl c' (RecConGADT lrec_flds noHsUniTok) ty' } +cvtConstr _ do_con_name (GadtC cs strtys ty) + = do { cs' <- mapM do_con_name cs + ; args <- mapM cvt_arg strtys + ; ty' <- cvtType ty + ; mk_gadt_decl cs' (PrefixConGADT $ map hsLinear args) ty'} + +cvtConstr parent_con do_con_name (RecGadtC cs varstrtys ty) + = do { cs' <- mapM do_con_name cs + ; ty' <- cvtType ty + ; rec_flds <- mapM (cvt_id_arg parent_con) varstrtys + ; lrec_flds <- returnLA rec_flds + ; mk_gadt_decl cs' (RecConGADT lrec_flds noHsUniTok) ty' } mk_gadt_decl :: NonEmpty (LocatedN RdrName) -> HsConDeclGADTDetails GhcPs -> LHsType GhcPs -> CvtM (LConDecl GhcPs) @@ -750,9 +755,10 @@ cvt_arg (Bang su ss, ty) ss' = cvtSrcStrictness ss ; returnLA $ HsBangTy noAnn (HsSrcBang NoSourceText su' ss') ty' } -cvt_id_arg :: (TH.Name, TH.Bang, TH.Type) -> CvtM (LConDeclField GhcPs) -cvt_id_arg (i, str, ty) - = do { L li i' <- vNameN i +cvt_id_arg :: TH.Name -- ^ parent constructor name + -> (TH.Name, TH.Bang, TH.Type) -> CvtM (LConDeclField GhcPs) +cvt_id_arg parent_con (i, str, ty) + = do { L li i' <- fldNameN (nameBase parent_con) i ; ty' <- cvt_arg (str,ty) ; returnLA $ ConDeclField { cd_fld_ext = noAnn @@ -1115,7 +1121,10 @@ cvtl e = wrapLA (cvt e) ; flds' <- mapM (cvtFld (wrapParLA mkAmbiguousFieldOcc)) flds - ; return $ RecordUpd noAnn e' (Left flds') } + ; return $ RecordUpd noAnn e' $ + RegularRecUpdFields + { xRecUpdFields = noExtField + , recUpdFields = flds' } } cvt (StaticE e) = fmap (HsStatic noAnn) $ cvtl e cvt (UnboundVarE s) = do -- Use of 'vcName' here instead of 'vName' is -- important, because UnboundVarE may contain @@ -2052,6 +2061,13 @@ tName n = cvtName OccName.tvName n tconNameN n = wrapLN (tconName n) tconName n = cvtName OccName.tcClsName n +-- Field names +fldName :: String -> TH.Name -> CvtM RdrName +fldName con n = cvtName (OccName.fieldName $ fsLit con) n + +fldNameN :: String -> TH.Name -> CvtM (LocatedN RdrName) +fldNameN con n = wrapLN (fldName con n) + ipName :: String -> CvtM HsIPName ipName n = do { unless (okVarOcc n) (failWith (IllegalOccName OccName.varName n)) @@ -2140,9 +2156,10 @@ mk_occ :: OccName.NameSpace -> String -> OccName.OccName mk_occ ns occ = OccName.mkOccName ns occ mk_ghc_ns :: TH.NameSpace -> OccName.NameSpace -mk_ghc_ns TH.DataName = OccName.dataName -mk_ghc_ns TH.TcClsName = OccName.tcClsName -mk_ghc_ns TH.VarName = OccName.varName +mk_ghc_ns TH.DataName = OccName.dataName +mk_ghc_ns TH.TcClsName = OccName.tcClsName +mk_ghc_ns TH.VarName = OccName.varName +mk_ghc_ns (TH.FldName con) = OccName.fieldName (fsLit con) mk_mod :: TH.ModName -> ModuleName mk_mod mod = mkModuleName (TH.modString mod) diff --git a/compiler/GHC/Types/Avail.hs b/compiler/GHC/Types/Avail.hs index 346cf4236c..5b8c5fd9a2 100644 --- a/compiler/GHC/Types/Avail.hs +++ b/compiler/GHC/Types/Avail.hs @@ -7,33 +7,18 @@ module GHC.Types.Avail ( Avails, AvailInfo(..), - avail, - availField, - availTC, availsToNameSet, - availsToNameSetWithSelectors, availsToNameEnv, availExportsDecl, - availName, availGreName, - availNames, availNonFldNames, - availNamesWithSelectors, - availFlds, - availGreNames, - availSubordinateGreNames, + availName, + availNames, + availSubordinateNames, stableAvailCmp, plusAvail, trimAvail, filterAvail, filterAvails, nubAvails, - - GreName(..), - greNameMangledName, - greNamePrintableName, - greNameSrcSpan, - greNameFieldLabel, - partitionGreNames, - stableGreNameCmp, ) where import GHC.Prelude @@ -41,9 +26,7 @@ import GHC.Prelude import GHC.Types.Name import GHC.Types.Name.Env import GHC.Types.Name.Set -import GHC.Types.SrcLoc -import GHC.Types.FieldLabel import GHC.Utils.Binary import GHC.Data.List.SetOps import GHC.Utils.Outputable @@ -52,10 +35,8 @@ import GHC.Utils.Constants (debugIsOn) import Control.DeepSeq import Data.Data ( Data ) -import Data.Either ( partitionEithers ) import Data.Functor.Classes ( liftCompare ) import Data.List ( find ) -import Data.Maybe import qualified Data.Semigroup as S -- ----------------------------------------------------------------------------- @@ -66,7 +47,7 @@ data AvailInfo -- | An ordinary identifier in scope, or a field label without a parent type -- (see Note [Representing pattern synonym fields in AvailInfo]). - = Avail GreName + = Avail Name -- | A type or class in scope -- @@ -75,74 +56,19 @@ data AvailInfo -- -- > AvailTC Eq [Eq, ==, \/=] | AvailTC - Name -- ^ The name of the type or class - [GreName] -- ^ The available pieces of type or class - -- (see Note [Representing fields in AvailInfo]). + Name -- ^ The name of the type or class + [Name] -- ^ The available pieces of type or class - deriving ( Eq -- ^ Used when deciding if the interface has changed - , Data ) + deriving Data -- | A collection of 'AvailInfo' - several things that are \"available\" type Avails = [AvailInfo] -{- -Note [Representing fields in AvailInfo] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See also Note [FieldLabel] in GHC.Types.FieldLabel. - -When -XDuplicateRecordFields is disabled (the normal case), a -datatype like - - data T = MkT { foo :: Int } - -gives rise to the AvailInfo - - AvailTC T [T, MkT, FieldLabel "foo" NoDuplicateRecordFields FieldSelectors foo] - -whereas if -XDuplicateRecordFields is enabled it gives - - AvailTC T [T, MkT, FieldLabel "foo" DuplicateRecordFields FieldSelectors $sel:foo:MkT] - -where the label foo does not match the selector name $sel:foo:MkT. - -The labels in a field list are not necessarily unique: -data families allow the same parent (the family tycon) to have -multiple distinct fields with the same label. For example, - - data family F a - data instance F Int = MkFInt { foo :: Int } - data instance F Bool = MkFBool { foo :: Bool} - -gives rise to - - AvailTC F [ F, MkFInt, MkFBool - , FieldLabel "foo" DuplicateRecordFields FieldSelectors $sel:foo:MkFInt - , FieldLabel "foo" DuplicateRecordFields FieldSelectors $sel:foo:MkFBool ] - -Moreover, note that the flHasDuplicateRecordFields or flFieldSelectors flags -need not be the same for all the elements of the list. In the example above, -this occurs if the two data instances are defined in different modules, with -different states of the `-XDuplicateRecordFields` or `-XNoFieldSelectors` -extensions. Thus it is possible to have - - AvailTC F [ F, MkFInt, MkFBool - , FieldLabel "foo" DuplicateRecordFields FieldSelectors $sel:foo:MkFInt - , FieldLabel "foo" NoDuplicateRecordFields FieldSelectors foo ] - -If the two data instances are defined in different modules, both without -`-XDuplicateRecordFields` or `-XNoFieldSelectors`, it will be impossible to -export them from the same module (even with `-XDuplicateRecordfields` enabled), -because they would be represented identically. The workaround here is to enable -`-XDuplicateRecordFields` or `-XNoFieldSelectors` on the defining modules. See -also #13352. - - -Note [Representing pattern synonym fields in AvailInfo] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +{- Note [Representing pattern synonym fields in AvailInfo] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Record pattern synonym fields cannot be represented using AvailTC like fields of -normal record types (see Note [Representing fields in AvailInfo]), because they -do not always have a parent type constructor. So we represent them using the -Avail constructor, with a NormalGreName that carries the underlying FieldLabel. +normal record types, because they do not always have a parent type constructor. +So we represent them using the Avail constructor. Thus under -XDuplicateRecordFields -XPatternSynoynms, the declaration @@ -150,43 +76,22 @@ Thus under -XDuplicateRecordFields -XPatternSynoynms, the declaration gives rise to the AvailInfo - Avail (NormalGreName MkFoo) - Avail (FieldGreName (FieldLabel "f" True $sel:f:MkFoo)) + Avail MkFoo, Avail f However, if `f` is bundled with a type constructor `T` by using `T(MkFoo,f)` in an export list, then whenever `f` is imported the parent will be `T`, represented as - AvailTC T [ NormalGreName T - , NormalGreName MkFoo - , FieldGreName (FieldLabel "f" True $sel:f:MkFoo) ] - -See also Note [GreNames] in GHC.Types.Name.Reader. + AvailTC T [ T, MkFoo, f ] -} -- | Compare lexicographically stableAvailCmp :: AvailInfo -> AvailInfo -> Ordering -stableAvailCmp (Avail c1) (Avail c2) = c1 `stableGreNameCmp` c2 +stableAvailCmp (Avail c1) (Avail c2) = c1 `stableNameCmp` c2 stableAvailCmp (Avail {}) (AvailTC {}) = LT -stableAvailCmp (AvailTC n ns) (AvailTC m ms) = stableNameCmp n m S.<> liftCompare stableGreNameCmp ns ms +stableAvailCmp (AvailTC n ns) (AvailTC m ms) = stableNameCmp n m S.<> liftCompare stableNameCmp ns ms stableAvailCmp (AvailTC {}) (Avail {}) = GT -stableGreNameCmp :: GreName -> GreName -> Ordering -stableGreNameCmp (NormalGreName n1) (NormalGreName n2) = n1 `stableNameCmp` n2 -stableGreNameCmp (NormalGreName {}) (FieldGreName {}) = LT -stableGreNameCmp (FieldGreName f1) (FieldGreName f2) = flSelector f1 `stableNameCmp` flSelector f2 -stableGreNameCmp (FieldGreName {}) (NormalGreName {}) = GT - -avail :: Name -> AvailInfo -avail n = Avail (NormalGreName n) - -availField :: FieldLabel -> AvailInfo -availField fl = Avail (FieldGreName fl) - -availTC :: Name -> [Name] -> [FieldLabel] -> AvailInfo -availTC n ns fls = AvailTC n (map NormalGreName ns ++ map FieldGreName fls) - - -- ----------------------------------------------------------------------------- -- Operations on AvailInfo @@ -194,10 +99,6 @@ availsToNameSet :: [AvailInfo] -> NameSet availsToNameSet avails = foldr add emptyNameSet avails where add avail set = extendNameSetList set (availNames avail) -availsToNameSetWithSelectors :: [AvailInfo] -> NameSet -availsToNameSetWithSelectors avails = foldr add emptyNameSet avails - where add avail set = extendNameSetList set (availNamesWithSelectors avail) - availsToNameEnv :: [AvailInfo] -> NameEnv AvailInfo availsToNameEnv avails = foldr add emptyNameEnv avails where add avail env = extendNameEnvList env @@ -207,110 +108,29 @@ availsToNameEnv avails = foldr add emptyNameEnv avails -- invariant that the parent is first if it appears at all. availExportsDecl :: AvailInfo -> Bool availExportsDecl (AvailTC ty_name names) - | n : _ <- names = NormalGreName ty_name == n + | n : _ <- names = ty_name == n | otherwise = False availExportsDecl _ = True -- | Just the main name made available, i.e. not the available pieces -- of type or class brought into scope by the 'AvailInfo' availName :: AvailInfo -> Name -availName (Avail n) = greNameMangledName n +availName (Avail n) = n availName (AvailTC n _) = n -availGreName :: AvailInfo -> GreName -availGreName (Avail c) = c -availGreName (AvailTC n _) = NormalGreName n - --- | All names made available by the availability information (excluding overloaded selectors) -availNames :: AvailInfo -> [Name] -availNames (Avail c) = childNonOverloadedNames c -availNames (AvailTC _ cs) = concatMap childNonOverloadedNames cs - -childNonOverloadedNames :: GreName -> [Name] -childNonOverloadedNames (NormalGreName n) = [n] -childNonOverloadedNames (FieldGreName fl) = [ flSelector fl | not (flIsOverloaded fl) ] - --- | All names made available by the availability information (including overloaded selectors) -availNamesWithSelectors :: AvailInfo -> [Name] -availNamesWithSelectors (Avail c) = [greNameMangledName c] -availNamesWithSelectors (AvailTC _ cs) = map greNameMangledName cs - --- | Names for non-fields made available by the availability information -availNonFldNames :: AvailInfo -> [Name] -availNonFldNames (Avail (NormalGreName n)) = [n] -availNonFldNames (Avail (FieldGreName {})) = [] -availNonFldNames (AvailTC _ ns) = mapMaybe f ns - where - f (NormalGreName n) = Just n - f (FieldGreName {}) = Nothing - --- | Fields made available by the availability information -availFlds :: AvailInfo -> [FieldLabel] -availFlds (Avail c) = maybeToList (greNameFieldLabel c) -availFlds (AvailTC _ cs) = mapMaybe greNameFieldLabel cs - -- | Names and fields made available by the availability information. -availGreNames :: AvailInfo -> [GreName] -availGreNames (Avail c) = [c] -availGreNames (AvailTC _ cs) = cs +availNames :: AvailInfo -> [Name] +availNames (Avail c) = [c] +availNames (AvailTC _ cs) = cs -- | Names and fields made available by the availability information, other than -- the main decl itself. -availSubordinateGreNames :: AvailInfo -> [GreName] -availSubordinateGreNames (Avail {}) = [] -availSubordinateGreNames avail@(AvailTC _ ns) +availSubordinateNames :: AvailInfo -> [Name] +availSubordinateNames (Avail {}) = [] +availSubordinateNames avail@(AvailTC _ ns) | availExportsDecl avail = tail ns | otherwise = ns - --- | Used where we may have an ordinary name or a record field label. --- See Note [GreNames] in GHC.Types.Name.Reader. -data GreName = NormalGreName Name - | FieldGreName FieldLabel - deriving (Data, Eq) - -instance Outputable GreName where - ppr (NormalGreName n) = ppr n - ppr (FieldGreName fl) = ppr fl - -instance NFData GreName where - rnf (NormalGreName n) = rnf n - rnf (FieldGreName f) = rnf f - -instance HasOccName GreName where - occName (NormalGreName n) = occName n - occName (FieldGreName fl) = occName fl - -instance Ord GreName where - compare = stableGreNameCmp - --- | A 'Name' for internal use, but not for output to the user. For fields, the --- 'OccName' will be the selector. See Note [GreNames] in GHC.Types.Name.Reader. -greNameMangledName :: GreName -> Name -greNameMangledName (NormalGreName n) = n -greNameMangledName (FieldGreName fl) = flSelector fl - --- | A 'Name' suitable for output to the user. For fields, the 'OccName' will --- be the field label. See Note [GreNames] in GHC.Types.Name.Reader. -greNamePrintableName :: GreName -> Name -greNamePrintableName (NormalGreName n) = n -greNamePrintableName (FieldGreName fl) = fieldLabelPrintableName fl - -greNameSrcSpan :: GreName -> SrcSpan -greNameSrcSpan (NormalGreName n) = nameSrcSpan n -greNameSrcSpan (FieldGreName fl) = nameSrcSpan (flSelector fl) - -greNameFieldLabel :: GreName -> Maybe FieldLabel -greNameFieldLabel (NormalGreName {}) = Nothing -greNameFieldLabel (FieldGreName fl) = Just fl - -partitionGreNames :: [GreName] -> ([Name], [FieldLabel]) -partitionGreNames = partitionEithers . map to_either - where - to_either (NormalGreName n) = Left n - to_either (FieldGreName fl) = Right fl - - -- ----------------------------------------------------------------------------- -- Utility @@ -322,7 +142,7 @@ plusAvail a1@(Avail {}) (Avail {}) = a1 plusAvail (AvailTC _ []) a2@(AvailTC {}) = a2 plusAvail a1@(AvailTC {}) (AvailTC _ []) = a1 plusAvail (AvailTC n1 (s1:ss1)) (AvailTC n2 (s2:ss2)) - = case (NormalGreName n1==s1, NormalGreName n2==s2) of -- Maintain invariant the parent is first + = case (n1 == s1, n2 == s2) of -- Maintain invariant the parent is first (True,True) -> AvailTC n1 (s1 : (ss1 `unionListsOrd` ss2)) (True,False) -> AvailTC n1 (s1 : (ss1 `unionListsOrd` (s2:ss2))) (False,True) -> AvailTC n1 (s2 : ((s1:ss1) `unionListsOrd` ss2)) @@ -332,7 +152,7 @@ plusAvail a1 a2 = pprPanic "GHC.Rename.Env.plusAvail" (hsep [ppr a1,ppr a2]) -- | trims an 'AvailInfo' to keep only a single name trimAvail :: AvailInfo -> Name -> AvailInfo trimAvail avail@(Avail {}) _ = avail -trimAvail avail@(AvailTC n ns) m = case find ((== m) . greNameMangledName) ns of +trimAvail avail@(AvailTC n ns) m = case find (== m) ns of Just c -> AvailTC n [c] Nothing -> pprPanic "trimAvail" (hsep [ppr avail, ppr m]) @@ -344,10 +164,10 @@ filterAvails keep avails = foldr (filterAvail keep) [] avails filterAvail :: (Name -> Bool) -> AvailInfo -> [AvailInfo] -> [AvailInfo] filterAvail keep ie rest = case ie of - Avail c | keep (greNameMangledName c) -> ie : rest + Avail c | keep c -> ie : rest | otherwise -> rest AvailTC tc cs -> - let cs' = filter (keep . greNameMangledName) cs + let cs' = filter keep cs in if null cs' then rest else AvailTC tc cs' : rest @@ -393,19 +213,3 @@ instance Binary AvailInfo where instance NFData AvailInfo where rnf (Avail n) = rnf n rnf (AvailTC a b) = rnf a `seq` rnf b - -instance Binary GreName where - put_ bh (NormalGreName aa) = do - putByte bh 0 - put_ bh aa - put_ bh (FieldGreName ab) = do - putByte bh 1 - put_ bh ab - get bh = do - h <- getByte bh - case h of - 0 -> do aa <- get bh - return (NormalGreName aa) - _ -> do ab <- get bh - return (FieldGreName ab) - diff --git a/compiler/GHC/Types/Basic.hs b/compiler/GHC/Types/Basic.hs index 1ad6b608fc..1f73c82028 100644 --- a/compiler/GHC/Types/Basic.hs +++ b/compiler/GHC/Types/Basic.hs @@ -16,6 +16,7 @@ types that {-# OPTIONS_GHC -Wno-orphans #-} -- Outputable PromotionFlag, Binary PromotionFlag, Outputable Boxity, Binay Boxity {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -109,6 +110,8 @@ module GHC.Types.Basic ( Levity(..), mightBeLifted, mightBeUnlifted, TypeOrConstraint(..), + TyConFlavour(..), TypeOrData(..), tyConFlavourAssoc_maybe, + NonStandardDefaultingStrategy(..), DefaultingStrategy(..), defaultNonStandardTyVars, @@ -124,12 +127,16 @@ import GHC.Utils.Panic import GHC.Utils.Binary import GHC.Types.SourceText import qualified GHC.LanguageExtensions as LangExt -import Data.Data -import qualified Data.Semigroup as Semi import {-# SOURCE #-} Language.Haskell.Syntax.Type (PromotionFlag(..), isPromoted) import Language.Haskell.Syntax.Basic (Boxity(..), isBoxed, ConTag) -{- ********************************************************************* +import Control.DeepSeq ( NFData(..) ) +import Data.Data +import Data.Maybe +import qualified Data.Semigroup as Semi + +{- +************************************************************************ * * Binary choice * * @@ -1970,6 +1977,77 @@ data TypeOrConstraint {- ********************************************************************* * * + TyConFlavour +* * +********************************************************************* -} + +-- | Paints a picture of what a 'TyCon' represents, in broad strokes. +-- This is used towards more informative error messages. +data TyConFlavour tc + = ClassFlavour + | TupleFlavour Boxity + | SumFlavour + | DataTypeFlavour + | NewtypeFlavour + | AbstractTypeFlavour + | OpenFamilyFlavour TypeOrData (Maybe tc) -- Just tc <=> (tc == associated class) + | ClosedTypeFamilyFlavour + | TypeSynonymFlavour + | BuiltInTypeFlavour -- ^ e.g., the @(->)@ 'TyCon'. + | PromotedDataConFlavour + deriving (Eq, Data, Functor) + +instance Outputable (TyConFlavour tc) where + ppr = text . go + where + go ClassFlavour = "class" + go (TupleFlavour boxed) | isBoxed boxed = "tuple" + | otherwise = "unboxed tuple" + go SumFlavour = "unboxed sum" + go DataTypeFlavour = "data type" + go NewtypeFlavour = "newtype" + go AbstractTypeFlavour = "abstract type" + go (OpenFamilyFlavour type_or_data mb_par) + = assoc ++ t_or_d ++ " family" + where + assoc = if isJust mb_par then "associated " else "" + t_or_d = case type_or_data of { IAmType -> "type"; IAmData -> "data" } + go ClosedTypeFamilyFlavour = "type family" + go TypeSynonymFlavour = "type synonym" + go BuiltInTypeFlavour = "built-in type" + go PromotedDataConFlavour = "promoted data constructor" + +instance NFData tc => NFData (TyConFlavour tc) where + rnf ClassFlavour = () + rnf (TupleFlavour !_) = () + rnf SumFlavour = () + rnf DataTypeFlavour = () + rnf NewtypeFlavour = () + rnf AbstractTypeFlavour = () + rnf (OpenFamilyFlavour !_ mb_tc) = rnf mb_tc + rnf ClosedTypeFamilyFlavour = () + rnf TypeSynonymFlavour = () + rnf BuiltInTypeFlavour = () + rnf PromotedDataConFlavour = () + +-- | Get the enclosing class TyCon (if there is one) for the given TyConFlavour +tyConFlavourAssoc_maybe :: TyConFlavour tc -> Maybe tc +tyConFlavourAssoc_maybe (OpenFamilyFlavour _ mb_parent) = mb_parent +tyConFlavourAssoc_maybe _ = Nothing + +-- | Whether something is a type or a data declaration, +-- e.g. a type family or a data family. +data TypeOrData + = IAmData + | IAmType + deriving (Eq, Data) + +instance Outputable TypeOrData where + ppr IAmData = text "data" + ppr IAmType = text "type" + +{- ********************************************************************* +* * Defaulting options * * ********************************************************************* -} diff --git a/compiler/GHC/Types/ConInfo.hs b/compiler/GHC/Types/ConInfo.hs deleted file mode 100644 index b89ce2632d..0000000000 --- a/compiler/GHC/Types/ConInfo.hs +++ /dev/null @@ -1,82 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -module GHC.Types.ConInfo ( - ConFieldEnv, ConInfo(..), mkConInfo, conInfoFields, - ) where - -import GHC.Prelude -import GHC.Types.Name.Env (NameEnv) -import Data.List.NonEmpty (NonEmpty) -import GHC.Types.FieldLabel ( FieldLabel ) -import qualified Data.List.NonEmpty as NonEmpty -import GHC.Types.Basic (Arity) -import GHC.Utils.Outputable (Outputable(..), text, (<+>), equals, braces, (<>)) - -{- Note [Local constructor info in the renamer] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -During renaming, we need certain information about constructors. - -While we can use TypeEnv to get this info for constructors from imported modules, -the same cannot be done for constructors defined in the module -that we are currently renaming, as they have not been type checked yet. - -Hence, we use ConFieldEnv to store the minimal information required to proceed -with renaming, getting it from the parse tree. - -For example, consider - data T = T1 { x, y :: Int } - | T2 { x :: Int } - | T3 - | T4 Int Bool - -Specifically we need to know: -* The fields of the data constructor, so that - - We can complain if you say `T1 { v = 3 }`, where `v` is not a field of `T1` - See the following call stack - * GHC.Rename.Expr.rnExpr (RecordCon case) - * GHC.Rename.Pat.rnHsRecFields - * GHC.Rename.Env.lookupRecFieldOcc - - Ditto if you pattern match on `T1 { v = x }`. - See the following call stack - * GHC.Rename.Pat.rnHsRecPatsAndThen - * GHC.Rename.Pat.rnHsRecFields - * GHC.Rename.Env.lookupRecFieldOcc - - We can fill in the dots if you say `T1 {..}` in construction or pattern matching - See GHC.Rename.Pat.rnHsRecFields.rn_dotdot - -* Whether the contructor is nullary. - We need to know this to accept `T2 {..}`, and `T3 {..}`, but reject `T4 {..}`, - in both construction and pattern matching. - See GHC.Rename.Pat.rnHsRecFields.rn_dotdot - and Note [Nullary constructors and empty record wildcards] - -Note [Nullary constructors and empty record wildcards] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A nullary constructor is one with no arguments. -For example, both `data T = MkT` and `data T = MkT {}` are nullary. - -For consistency and TH convenience, it was agreed that a `{..}` -match or usage on nullary constructors would be accepted. -This is done as as per https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0496-empty-record-wildcards.rst --} -type ConFieldEnv = NameEnv ConInfo - --- | See Note [Local constructor info in the renamer] -data ConInfo - = ConHasRecordFields (NonEmpty FieldLabel) - | ConHasPositionalArgs - | ConIsNullary - deriving stock Eq - -mkConInfo :: Arity -> [FieldLabel] -> ConInfo -mkConInfo 0 _ = ConIsNullary -mkConInfo _ fields = maybe ConHasPositionalArgs ConHasRecordFields $ NonEmpty.nonEmpty fields - -conInfoFields :: ConInfo -> [FieldLabel] -conInfoFields (ConHasRecordFields fields) = NonEmpty.toList fields -conInfoFields ConHasPositionalArgs = [] -conInfoFields ConIsNullary = [] - -instance Outputable ConInfo where - ppr ConIsNullary = text "ConIsNullary" - ppr ConHasPositionalArgs = text "ConHasPositionalArgs" - ppr (ConHasRecordFields fieldLabels) = text "ConHasRecordFields" <> braces (text "fieldLabels" <+> equals <+> ppr fieldLabels) diff --git a/compiler/GHC/Types/Error/Codes.hs b/compiler/GHC/Types/Error/Codes.hs index 3508a218d2..aa4360908b 100644 --- a/compiler/GHC/Types/Error/Codes.hs +++ b/compiler/GHC/Types/Error/Codes.hs @@ -403,14 +403,12 @@ type family GhcDiagnosticCode c = n | n -> c where GhcDiagnosticCode "TcRnDuplicateExport" = 47854 GhcDiagnosticCode "TcRnExportedParentChildMismatch" = 88993 GhcDiagnosticCode "TcRnConflictingExports" = 69158 - GhcDiagnosticCode "TcRnAmbiguousField" = 02256 + GhcDiagnosticCode "TcRnDuplicateFieldExport" = 97219 + GhcDiagnosticCode "TcRnAmbiguousFieldInUpdate" = 56428 + GhcDiagnosticCode "TcRnAmbiguousRecordUpdate" = 02256 GhcDiagnosticCode "TcRnMissingFields" = 20125 GhcDiagnosticCode "TcRnFieldUpdateInvalidType" = 63055 - GhcDiagnosticCode "TcRnNoConstructorHasAllFields" = 14392 - GhcDiagnosticCode "TcRnMixedSelectors" = 40887 GhcDiagnosticCode "TcRnMissingStrictFields" = 95909 - GhcDiagnosticCode "TcRnNoPossibleParentForFields" = 33238 - GhcDiagnosticCode "TcRnBadOverloadedRecordUpdate" = 99339 GhcDiagnosticCode "TcRnStaticFormNotClosed" = 88431 GhcDiagnosticCode "TcRnUselessTypeable" = 90584 GhcDiagnosticCode "TcRnDerivingDefaults" = 20042 @@ -448,7 +446,6 @@ type family GhcDiagnosticCode c = n | n -> c where GhcDiagnosticCode "TcRnUnsupportedCallConv" = 01245 GhcDiagnosticCode "TcRnInvalidCIdentifier" = 95774 GhcDiagnosticCode "TcRnExpectedValueId" = 01570 - GhcDiagnosticCode "TcRnNotARecordSelector" = 47535 GhcDiagnosticCode "TcRnRecSelectorEscapedTyVar" = 55876 GhcDiagnosticCode "TcRnPatSynNotBidirectional" = 16444 GhcDiagnosticCode "TcRnSplicePolymorphicLocalVar" = 06568 @@ -557,6 +554,11 @@ type family GhcDiagnosticCode c = n | n -> c where GhcDiagnosticCode "HasExistentialTyVar" = 07525 GhcDiagnosticCode "HasStrictnessAnnotation" = 04049 + -- TcRnBadRecordUpdate + GhcDiagnosticCode "NoConstructorHasAllFields" = 14392 + GhcDiagnosticCode "MultiplePossibleParents" = 99339 + GhcDiagnosticCode "InvalidTyConParent" = 33238 + -- TcRnPragmaWarning GhcDiagnosticCode "WarningTxt" = 63394 GhcDiagnosticCode "DeprecatedTxt" = 68441 @@ -577,8 +579,6 @@ type family GhcDiagnosticCode c = n | n -> c where GhcDiagnosticCode "CasesExprWithoutAlts" = 91745 GhcDiagnosticCode "ImplicitParamsWithOtherBinds" = 42974 GhcDiagnosticCode "InvalidCCallImpent" = 60220 - GhcDiagnosticCode "RecGadtNoCons" = 18816 - GhcDiagnosticCode "GadtNoCons" = 38140 GhcDiagnosticCode "InvalidTypeInstanceHeader" = 37056 GhcDiagnosticCode "InvalidTyFamInstLHS" = 78486 GhcDiagnosticCode "InvalidImplicitParamBinding" = 51603 @@ -603,6 +603,7 @@ type family GhcDiagnosticCode c = n | n -> c where -- Out of scope errors GhcDiagnosticCode "NotInScope" = 76037 + GhcDiagnosticCode "NotARecordField" = 22385 GhcDiagnosticCode "NoExactName" = 97784 GhcDiagnosticCode "SameName" = 81573 GhcDiagnosticCode "MissingBinding" = 44432 @@ -658,9 +659,11 @@ type family GhcDiagnosticCode c = n | n -> c where -- and this includes outdated diagnostic codes for errors that GHC -- no longer reports. These are collected below. - GhcDiagnosticCode "Example outdated error" = 00000 GhcDiagnosticCode "TcRnNameByTemplateHaskellQuote" = 40027 GhcDiagnosticCode "TcRnIllegalBindingOfBuiltIn" = 69639 + GhcDiagnosticCode "TcRnMixedSelectors" = 40887 + GhcDiagnosticCode "RecGadtNoCons" = 18816 + GhcDiagnosticCode "GadtNoCons" = 38140 {- ********************************************************************* * * @@ -718,6 +721,7 @@ type family ConRecursInto con where ConRecursInto "TcRnIllegalNewtype" = 'Just IllegalNewtypeReason ConRecursInto "TcRnHsigShapeMismatch" = 'Just HsigShapeMismatchReason ConRecursInto "TcRnPatSynInvalidRhs" = 'Just PatSynInvalidRhsReason + ConRecursInto "TcRnBadRecordUpdate" = 'Just BadRecordUpdateReason -- -- TH errors diff --git a/compiler/GHC/Types/FieldLabel.hs b/compiler/GHC/Types/FieldLabel.hs index 89bfd4afee..9c35a3ee30 100644 --- a/compiler/GHC/Types/FieldLabel.hs +++ b/compiler/GHC/Types/FieldLabel.hs @@ -10,7 +10,6 @@ Note [FieldLabel] ~~~~~~~~~~~~~~~~~ - This module defines the representation of FieldLabels as stored in TyCons. As well as a selector name, these have some extra structure to support the DuplicateRecordFields and NoFieldSelectors extensions. @@ -22,60 +21,25 @@ a datatype like has - FieldLabel { flLabel = "foo" - , flHasDuplicateRecordFields = NoDuplicateRecordFields + FieldLabel { flHasDuplicateRecordFields = NoDuplicateRecordFields , flHasFieldSelector = FieldSelectors , flSelector = foo }. -In particular, the Name of the selector has the same string -representation as the label. If DuplicateRecordFields -is enabled, however, the same declaration instead gives +If DuplicateRecordFields is enabled, however, the same declaration instead gives - FieldLabel { flLabel = "foo" - , flHasDuplicateRecordFields = DuplicateRecordFields + FieldLabel { flHasDuplicateRecordFields = DuplicateRecordFields , flHasFieldSelector = FieldSelectors - , flSelector = $sel:foo:MkT }. - -Similarly, the selector name will be mangled if NoFieldSelectors is used -(whether or not DuplicateRecordFields is enabled). See Note [NoFieldSelectors] -in GHC.Rename.Env. - -Now the name of the selector ($sel:foo:MkT) does not match the label of -the field (foo). We must be careful not to show the selector name to -the user! The point of mangling the selector name is to allow a -module to define the same field label in different datatypes: - - data T = MkT { foo :: Int } - data U = MkU { foo :: Bool } - -Now there will be two FieldLabel values for 'foo', one in T and one in -U. They share the same label (FieldLabelString), but the selector -functions differ. - -See also Note [Representing fields in AvailInfo] in GHC.Types.Avail. - -Note [Why selector names include data constructors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -As explained above, a selector name includes the name of the first -data constructor in the type, so that the same label can appear -multiple times in the same module. (This is irrespective of whether -the first constructor has that field, for simplicity.) - -We use a data constructor name, rather than the type constructor name, -because data family instances do not have a representation type -constructor name generated until relatively late in the typechecking -process. - -Of course, datatypes with no constructors cannot have any fields. + , flSelector = foo }. +We need to keep track of whether FieldSelectors or DuplicateRecordFields were +enabled when a record field was defined, as they affect name resolution and +shadowing of record fields, as explained in Note [NoFieldSelectors] in GHC.Types.Name.Reader +and Note [Reporting duplicate local declarations] in GHC.Rename.Names. -} module GHC.Types.FieldLabel ( FieldLabelEnv - , FieldLabel(..) - , fieldSelectorOccName - , fieldLabelPrintableName + , FieldLabel(..), flLabel , DuplicateRecordFields(..) , FieldSelectors(..) , flIsOverloaded @@ -84,10 +48,8 @@ where import GHC.Prelude -import {-# SOURCE #-} GHC.Types.Name.Occurrence import {-# SOURCE #-} GHC.Types.Name -import GHC.Data.FastString import GHC.Data.FastString.Env import GHC.Types.Unique (Uniquable(..)) import GHC.Utils.Outputable @@ -104,20 +66,23 @@ type FieldLabelEnv = DFastStringEnv FieldLabel -- | Fields in an algebraic record type; see Note [FieldLabel]. data FieldLabel = FieldLabel { - flLabel :: FieldLabelString, - -- ^ User-visible label of the field flHasDuplicateRecordFields :: DuplicateRecordFields, -- ^ Was @DuplicateRecordFields@ on in the defining module for this datatype? flHasFieldSelector :: FieldSelectors, -- ^ Was @FieldSelectors@ enabled in the defining module for this datatype? -- See Note [NoFieldSelectors] in GHC.Rename.Env flSelector :: Name - -- ^ Record selector function + -- ^ The 'Name' of the selector function, which uniquely identifies + -- the field label. } deriving (Data, Eq) +-- | User-visible label of a field. +flLabel :: FieldLabel -> FieldLabelString +flLabel = FieldLabelString . occNameFS . nameOccName . flSelector + instance HasOccName FieldLabel where - occName = mkVarOccFS . field_label . flLabel + occName = nameOccName . flSelector instance Outputable FieldLabel where ppr fl = ppr (flLabel fl) <> whenPprDebug (braces (ppr (flSelector fl)) @@ -130,9 +95,6 @@ instance Outputable FieldLabelString where instance Uniquable FieldLabelString where getUnique (FieldLabelString fs) = getUnique fs -instance NFData FieldLabel where - rnf (FieldLabel a b c d) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d - -- | Flag to indicate whether the DuplicateRecordFields extension is enabled. data DuplicateRecordFields = DuplicateRecordFields -- ^ Fields may be duplicated in a single module @@ -148,7 +110,9 @@ instance Outputable DuplicateRecordFields where ppr NoDuplicateRecordFields = text "-dup" instance NFData DuplicateRecordFields where - rnf x = x `seq` () + rnf DuplicateRecordFields = () + rnf NoDuplicateRecordFields = () + -- | Flag to indicate whether the FieldSelectors extension is enabled. data FieldSelectors @@ -165,55 +129,27 @@ instance Outputable FieldSelectors where ppr NoFieldSelectors = text "-sel" instance NFData FieldSelectors where - rnf x = x `seq` () + rnf FieldSelectors = () + rnf NoFieldSelectors = () -- | We need the @Binary Name@ constraint here even though there is an instance -- defined in "GHC.Types.Name", because the we have a SOURCE import, so the -- instance is not in scope. And the instance cannot be added to Name.hs-boot -- because "GHC.Utils.Binary" itself depends on "GHC.Types.Name". instance Binary Name => Binary FieldLabel where - put_ bh (FieldLabel aa ab ac ad) = do - put_ bh (field_label aa) + put_ bh (FieldLabel aa ab ac) = do + put_ bh aa put_ bh ab - put_ bh ac - put_ bh ad + case getUserData bh of + UserData{ ud_put_binding_name = put_binding_name } -> + put_binding_name bh ac get bh = do aa <- get bh ab <- get bh ac <- get bh - ad <- get bh - return (FieldLabel (FieldLabelString aa) ab ac ad) - - --- | Record selector OccNames are built from the underlying field name --- and the name of the first data constructor of the type, to support --- duplicate record field names. --- See Note [Why selector names include data constructors]. -fieldSelectorOccName :: FieldLabelString -> OccName -> DuplicateRecordFields -> FieldSelectors -> OccName -fieldSelectorOccName lbl dc dup_fields_ok has_sel - | shouldMangleSelectorNames dup_fields_ok has_sel = mkRecFldSelOcc str - | otherwise = mkVarOccFS fl - where - fl = field_label lbl - str = concatFS [fsLit ":", fl, fsLit ":", occNameFS dc] - --- | Undo the name mangling described in Note [FieldLabel] to produce a Name --- that has the user-visible OccName (but the selector's unique). This should --- be used only when generating output, when we want to show the label, but may --- need to qualify it with a module prefix. -fieldLabelPrintableName :: FieldLabel -> Name -fieldLabelPrintableName fl - | flIsOverloaded fl = tidyNameOcc (flSelector fl) (mkVarOccFS (field_label $ flLabel fl)) - | otherwise = flSelector fl - --- | Selector name mangling should be used if either DuplicateRecordFields or --- NoFieldSelectors is enabled, so that the OccName of the field can be used for --- something else. See Note [FieldLabel], and Note [NoFieldSelectors] in --- GHC.Rename.Env. -shouldMangleSelectorNames :: DuplicateRecordFields -> FieldSelectors -> Bool -shouldMangleSelectorNames dup_fields_ok has_sel - = dup_fields_ok == DuplicateRecordFields || has_sel == NoFieldSelectors + return (FieldLabel aa ab ac) flIsOverloaded :: FieldLabel -> Bool flIsOverloaded fl = - shouldMangleSelectorNames (flHasDuplicateRecordFields fl) (flHasFieldSelector fl) + flHasDuplicateRecordFields fl == DuplicateRecordFields + || flHasFieldSelector fl == NoFieldSelectors diff --git a/compiler/GHC/Types/GREInfo.hs b/compiler/GHC/Types/GREInfo.hs new file mode 100644 index 0000000000..23d734b7d1 --- /dev/null +++ b/compiler/GHC/Types/GREInfo.hs @@ -0,0 +1,276 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DerivingStrategies #-} + +-- | Renamer-level information about 'Name's. +-- +-- Renamer equivalent of 'TyThing'. +module GHC.Types.GREInfo where + +import GHC.Prelude + +import GHC.Types.Basic +import GHC.Types.FieldLabel +import GHC.Types.Name +import GHC.Types.Unique +import GHC.Types.Unique.Set +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import Control.DeepSeq ( NFData(..), deepseq ) + +import Data.Data ( Data ) +import Data.List.NonEmpty ( NonEmpty ) +import qualified Data.List.NonEmpty as NonEmpty + +{-********************************************************************** +* * + GREInfo +* * +************************************************************************ + +Note [GREInfo] +~~~~~~~~~~~~~~ +In the renamer, we sometimes need a bit more information about a 'Name', e.g. +whether it is a type constructor, class, data constructor, record field, etc. + +For example, when typechecking record construction, the renamer needs to look +up the fields of the data constructor being used (see e.g. GHC.Rename.Pat.rnHsRecFields). +Extra information also allows us to provide better error messages when a fatal +error occurs in the renamer, as it allows us to distinguish classes, type families, +type synonyms, etc. + +For imported Names, we have access to the full type information in the form of +a TyThing (although see Note [Retrieving the GREInfo from interfaces]). +However, for Names in the module currently being renamed, we don't +yet have full information. Instead of using TyThing, we use the GREInfo type, +and this information gets affixed to each element in the GlobalRdrEnv. + +This allows us to treat imported and local Names in a consistent manner: +always look at the GREInfo. + +Note [Retrieving the GREInfo from interfaces] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have a TyThing, we can easily compute the corresponding GREInfo: this is +done in GHC.Types.TyThing.tyThingGREInfo. + +However, one often needs to produce GlobalRdrElts (and thus their GREInfos) +directly after loading interface files, before they are typechecked. For example: + + - GHC.Tc.Module.tcRnModuleTcRnM first calls tcRnImports, which starts off + calling rnImports which transitively calls filterImports. That function + is responsible for coughing up GlobalRdrElts (and their GREInfos) obtained + from interfaces, but we will only typecheck the interfaces after we have + finished processing the imports (see e.g. the logic at the start of tcRnImports + which sets eps_is_boot, which decides whether we should look in the boot + or non-boot interface for any particular module). + - GHC.Tc.Utils.Backpack.mergeSignatures first loads the relevant signature + interfaces to merge them, but only later on does it typecheck them. + +In both of these examples, what's important is that we **lazily** produce the +GREInfo: it should only be consulted once the interfaces have been typechecked, +which will add the necessary information to the type-level environment. +In particular, the respective functions 'filterImports' and 'mergeSignatures' +should NOT force the gre_info field. + +We delay the loading of interfaces by making the gre_info field of 'GlobalRdrElt' +a thunk which, when forced, loads the interface, looks up the 'Name' in the type +environment to get its associated TyThing, and computes the GREInfo from that. +See 'GHC.Rename.Env.lookupGREInfo'. + +A possible alternative design would be to change the AvailInfo datatype to also +store GREInfo. We currently don't do that, as this would mean that every time +an interface re-exports something it has to also provide its GREInfo, which +could lead to bloat. + +Note [Forcing GREInfo] +~~~~~~~~~~~~~~~~~~~~~~ +The GREInfo field of a GlobalRdrElt needs to be lazy, as explained in +Note [Retrieving the GREInfo from interfaces]. For imported things, this field +is usually a thunk which looks up the GREInfo in a type environment +(see GHC.Rename.Env.lookupGREInfo). + +We thus need to be careful not to introduce space leaks: such thunks could end +up retaining old type environments, which would violate invariant (5) of +Note [GHC Heap Invariants] in GHC.Driver.Make. This can happen, for example, +when reloading in GHCi (see e.g. test T15369, which can trigger the ghci leak check +if we're not careful). + +A naive approach is to simply deeply force the whole GlobalRdrEnv. However, +forcing the GREInfo thunks can force the loading of interface files which we +otherwise might not need to load, so it leads to wasted work. + +Instead, whenever we are about to store the GlobalRdrEnv somewhere (such as +in ModDetails), we dehydrate it by stripping away the GREInfo field, turning it +into (). See 'forceGlobalRdrEnv' and its cousin 'hydrateGlobalRdrEnv', +as well as Note [IfGlobalRdrEnv] in GHC.Types.Name.Reader. + +Search for references to this note in the code for illustration. +-} + +-- | Information about a 'Name' that is pertinent to the renamer. +-- +-- See Note [GREInfo] +data GREInfo + -- | No particular information... e.g. a function + = Vanilla + -- | 'TyCon' + | IAmTyCon !(TyConFlavour Name) + -- | 'ConLike' + | IAmConLike !ConInfo + -- ^ The constructor fields. + -- See Note [Local constructor info in the renamer]. + -- | Record field + | IAmRecField !RecFieldInfo + + deriving Data + +instance NFData GREInfo where + rnf Vanilla = () + rnf (IAmTyCon tc) = rnf tc + rnf (IAmConLike info) = rnf info + rnf (IAmRecField info) = rnf info + +plusGREInfo :: GREInfo -> GREInfo -> GREInfo +plusGREInfo Vanilla Vanilla = Vanilla +plusGREInfo (IAmTyCon {}) info2@(IAmTyCon {}) = info2 +plusGREInfo (IAmConLike {}) info2@(IAmConLike {}) = info2 +plusGREInfo (IAmRecField {}) info2@(IAmRecField {}) = info2 +plusGREInfo info1 info2 = pprPanic "plusInfo" $ + vcat [ text "info1:" <+> ppr info1 + , text "info2:" <+> ppr info2 ] + +instance Outputable GREInfo where + ppr Vanilla = text "Vanilla" + ppr (IAmTyCon flav) + = text "TyCon" <+> ppr flav + ppr (IAmConLike info) + = text "ConLike" <+> ppr info + ppr (IAmRecField info) + = text "RecField" <+> ppr info + +{-********************************************************************** +* * + Constructor info +* * +************************************************************************ + +Note [Local constructor info in the renamer] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As explained in Note [GREInfo], information pertinent to the renamer is +stored using the GREInfo datatype. What information do we need about constructors? + +Consider the following example: + + data T = T1 { x, y :: Int } + | T2 { x :: Int } + | T3 + | T4 Int Bool + +We need to know: +* The fields of the data constructor, so that + - We can complain if you say `T1 { v = 3 }`, where `v` is not a field of `T1` + See the following call stack + * GHC.Rename.Expr.rnExpr (RecordCon case) + * GHC.Rename.Pat.rnHsRecFields + * GHC.Rename.Env.lookupRecFieldOcc + - Ditto if you pattern match on `T1 { v = x }`. + See the following call stack + * GHC.Rename.Pat.rnHsRecPatsAndThen + * GHC.Rename.Pat.rnHsRecFields + * GHC.Rename.Env.lookupRecFieldOcc + - We can fill in the dots if you say `T1 {..}` in construction or pattern matching + See GHC.Rename.Pat.rnHsRecFields.rn_dotdot + +* Whether the contructor is nullary. + We need to know this to accept `T2 {..}`, and `T3 {..}`, but reject `T4 {..}`, + in both construction and pattern matching. + See GHC.Rename.Pat.rnHsRecFields.rn_dotdot + and Note [Nullary constructors and empty record wildcards] + +Note [Nullary constructors and empty record wildcards] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A nullary constructor is one with no arguments. +For example, both `data T = MkT` and `data T = MkT {}` are nullary. + +For consistency and TH convenience, it was agreed that a `{..}` +match or usage on nullary constructors would be accepted. +This is done as as per https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0496-empty-record-wildcards.rst +-} + +-- | Information about the record fields of a constructor. +-- +-- See Note [Local constructor info in the renamer] +data ConInfo + = ConHasRecordFields (NonEmpty FieldLabel) + | ConHasPositionalArgs + | ConIsNullary + deriving stock Eq + deriving Data + +instance NFData ConInfo where + rnf ConIsNullary = () + rnf ConHasPositionalArgs = () + rnf (ConHasRecordFields flds) = rnf flds + +mkConInfo :: Arity -> [FieldLabel] -> ConInfo +mkConInfo 0 _ = ConIsNullary +mkConInfo _ fields = maybe ConHasPositionalArgs ConHasRecordFields + $ NonEmpty.nonEmpty fields + +conInfoFields :: ConInfo -> [FieldLabel] +conInfoFields (ConHasRecordFields fields) = NonEmpty.toList fields +conInfoFields ConHasPositionalArgs = [] +conInfoFields ConIsNullary = [] + +instance Outputable ConInfo where + ppr ConIsNullary = text "ConIsNullary" + ppr ConHasPositionalArgs = text "ConHasPositionalArgs" + ppr (ConHasRecordFields fieldLabels) = + text "ConHasRecordFields" <+> braces (ppr fieldLabels) + +-- | The 'Name' of a 'ConLike'. +-- +-- Useful when we are in the renamer and don't yet have a full 'DataCon' or +-- 'PatSyn' to hand. +data ConLikeName + = DataConName { conLikeName_Name :: !Name } + | PatSynName { conLikeName_Name :: !Name } + deriving (Eq, Data) + +instance Outputable ConLikeName where + ppr = ppr . conLikeName_Name + +instance Uniquable ConLikeName where + getUnique = getUnique . conLikeName_Name + +instance NFData ConLikeName where + rnf = rnf . conLikeName_Name + +{-********************************************************************** +* * + Record field info +* * +**********************************************************************-} + +data RecFieldInfo + = RecFieldInfo + { recFieldLabel :: !FieldLabel + , recFieldCons :: !(UniqSet ConLikeName) + -- ^ The constructors which have this field label. + -- Always non-empty. + -- + -- NB: these constructors will always share a single parent, + -- as the field label disambiguates between parents in the presence + -- of duplicate record fields. + } + deriving (Eq, Data) + +instance NFData RecFieldInfo where + rnf (RecFieldInfo lbl cons) + = rnf lbl `seq` nonDetStrictFoldUniqSet deepseq () cons + +instance Outputable RecFieldInfo where + ppr (RecFieldInfo { recFieldLabel = fl, recFieldCons = cons }) + = text "RecFieldInfo" <+> braces + (text "recFieldLabel:" <+> ppr fl <> comma + <+> text "recFieldCons:" <+> pprWithCommas ppr (nonDetEltsUniqSet cons)) diff --git a/compiler/GHC/Types/Id.hs b/compiler/GHC/Types/Id.hs index 28a220cb1d..bbfb8ce09d 100644 --- a/compiler/GHC/Types/Id.hs +++ b/compiler/GHC/Types/Id.hs @@ -480,15 +480,15 @@ isRecordSelector id = case Var.idDetails id of isDataConRecordSelector id = case Var.idDetails id of RecSelId {sel_tycon = RecSelData _} -> True - _ -> False + _ -> False isPatSynRecordSelector id = case Var.idDetails id of RecSelId {sel_tycon = RecSelPatSyn _} -> True - _ -> False + _ -> False isNaughtyRecordSelector id = case Var.idDetails id of RecSelId { sel_naughty = n } -> n - _ -> False + _ -> False isClassOpId id = case Var.idDetails id of ClassOpId {} -> True @@ -527,8 +527,8 @@ isDataConWorkId_maybe id = case Var.idDetails id of _ -> Nothing isDataConWrapId id = case Var.idDetails id of - DataConWrapId _ -> True - _ -> False + DataConWrapId _ -> True + _ -> False isDataConWrapId_maybe id = case Var.idDetails id of DataConWrapId con -> Just con @@ -832,15 +832,15 @@ asNonWorkerLikeId :: Id -> Id asNonWorkerLikeId id = let details = case idDetails id of WorkerLikeId{} -> Just $ VanillaId - JoinId arity Just{} -> Just $ JoinId arity Nothing - _ -> Nothing + JoinId arity Just{} -> Just $ JoinId arity Nothing + _ -> Nothing in maybeModifyIdDetails details id -- | Turn this id into a WorkerLikeId if possible. asWorkerLikeId :: Id -> Id asWorkerLikeId id = let details = case idDetails id of - WorkerLikeId{} -> Nothing + WorkerLikeId{} -> Nothing JoinId _arity Just{} -> Nothing JoinId arity Nothing -> Just (JoinId arity (Just [])) VanillaId -> Just $ WorkerLikeId [] diff --git a/compiler/GHC/Types/Id/Info.hs b/compiler/GHC/Types/Id/Info.hs index 2b6785117d..9ee20a841a 100644 --- a/compiler/GHC/Types/Id/Info.hs +++ b/compiler/GHC/Types/Id/Info.hs @@ -8,9 +8,11 @@ Haskell. [WDP 94/11]) -} - -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE BinaryLiterals #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -18,7 +20,7 @@ module GHC.Types.Id.Info ( -- * The IdDetails type IdDetails(..), pprIdDetails, coVarDetails, isCoVarDetails, JoinArity, isJoinIdDetails_maybe, - RecSelParent(..), + RecSelParent(..), recSelParentName, recSelFirstConName, -- * The IdInfo type IdInfo, -- Abstract @@ -95,6 +97,7 @@ import GHC.Types.Var.Set import GHC.Types.Basic import GHC.Core.DataCon import GHC.Core.TyCon +import GHC.Core.Type (mkTyConApp) import GHC.Core.PatSyn import GHC.Types.ForeignCall import GHC.Unit.Module @@ -105,11 +108,11 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Panic.Plain import GHC.Stg.InferTags.TagSig +import GHC.StgToCmm.Types (LambdaFormInfo) +import Data.Data ( Data ) import Data.Word -import GHC.StgToCmm.Types (LambdaFormInfo) - -- infixl so you can say (id `set` a `set` b) infixl 1 `setRuleInfo`, `setArityInfo`, @@ -138,8 +141,9 @@ data IdDetails -- | The 'Id' for a record selector | RecSelId - { sel_tycon :: RecSelParent - , sel_naughty :: Bool -- True <=> a "naughty" selector which can't actually exist, for example @x@ in: + { sel_tycon :: RecSelParent + , sel_fieldLabel :: FieldLabel + , sel_naughty :: Bool -- True <=> a "naughty" selector which can't actually exist, for example @x@ in: -- data T = forall a. MkT { x :: a } } -- See Note [Naughty record selectors] in GHC.Tc.TyCl @@ -273,17 +277,40 @@ some applied arguments as we won't inline the wrapper/apply their rule if there are unapplied occurrences like `map f xs`. -} --- | Recursive Selector Parent -data RecSelParent = RecSelData TyCon | RecSelPatSyn PatSyn deriving Eq - -- Either `TyCon` or `PatSyn` depending - -- on the origin of the record selector. - -- For a data type family, this is the - -- /instance/ 'TyCon' not the family 'TyCon' +-- | Parent of a record selector function. +-- +-- Either the parent 'TyCon' or 'PatSyn' depending +-- on the origin of the record selector. +-- +-- For a data family, this is the /instance/ 'TyCon', +-- **not** the family 'TyCon'. +data RecSelParent + -- | Parent of a data constructor record field. + -- + -- For a data family, this is the /instance/ 'TyCon'. + = RecSelData TyCon + -- | Parent of a pattern synonym record field: + -- the 'PatSyn' itself. + | RecSelPatSyn PatSyn + deriving (Eq, Data) + +recSelParentName :: RecSelParent -> Name +recSelParentName (RecSelData tc) = tyConName tc +recSelParentName (RecSelPatSyn ps) = patSynName ps + +recSelFirstConName :: RecSelParent -> Name +recSelFirstConName (RecSelData tc) = dataConName $ head $ tyConDataCons tc +recSelFirstConName (RecSelPatSyn ps) = patSynName ps instance Outputable RecSelParent where ppr p = case p of - RecSelData ty_con -> ppr ty_con - RecSelPatSyn ps -> ppr ps + RecSelData tc + | Just (parent_tc, tys) <- tyConFamInst_maybe tc + -> ppr (mkTyConApp parent_tc tys) + | otherwise + -> ppr tc + RecSelPatSyn ps + -> ppr ps -- | Just a synonym for 'CoVarId'. Written separately so it can be -- exported in the hs-boot file. @@ -307,7 +334,7 @@ pprIdDetails VanillaId = empty pprIdDetails other = brackets (pp other) where pp VanillaId = panic "pprIdDetails" - pp (WorkerLikeId dmds) = text "StrictWorker" <> parens (ppr dmds) + pp (WorkerLikeId dmds) = text "StrictWorker" <> parens (ppr dmds) pp (DataConWorkId _) = text "DataCon" pp (DataConWrapId _) = text "DataConWrapper" pp (ClassOpId {}) = text "ClassOp" diff --git a/compiler/GHC/Types/Name.hs b/compiler/GHC/Types/Name.hs index 7d441039e9..8a2f3bbdde 100644 --- a/compiler/GHC/Types/Name.hs +++ b/compiler/GHC/Types/Name.hs @@ -2,6 +2,8 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-orphans #-} -- instance NFData FieldLabel + {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 @@ -63,7 +65,7 @@ module GHC.Types.Name ( -- ** Predicates on 'Name's isSystemName, isInternalName, isExternalName, isTyVarName, isTyConName, isDataConName, - isValName, isVarName, isDynLinkName, + isValName, isVarName, isDynLinkName, isFieldName, isWiredInName, isWiredIn, isBuiltInSyntax, isTupleTyConName, isHoleName, wiredInNameTyThing_maybe, @@ -91,6 +93,7 @@ import GHC.Platform import GHC.Types.Name.Occurrence import GHC.Unit.Module import GHC.Unit.Home +import GHC.Types.FieldLabel import GHC.Types.SrcLoc import GHC.Types.Unique import GHC.Utils.Misc @@ -159,6 +162,10 @@ instance Outputable NameSort where instance NFData Name where rnf Name{..} = rnf n_sort `seq` rnf n_occ `seq` n_uniq `seq` rnf n_loc +-- Needs NFData Name, so the instance is here to avoid cyclic imports. +instance NFData FieldLabel where + rnf (FieldLabel a b c) = rnf a `seq` rnf b `seq` rnf c + instance NFData NameSort where rnf (External m) = rnf m rnf (WiredIn m t b) = rnf m `seq` t `seq` b `seq` () @@ -436,6 +443,9 @@ isValName name = isValOcc (nameOccName name) isVarName :: Name -> Bool isVarName = isVarOcc . nameOccName +isFieldName :: Name -> Bool +isFieldName = isFieldOcc . nameOccName + isSystemName (Name {n_sort = System}) = True isSystemName _ = False @@ -642,13 +652,14 @@ pprName name@(Name {n_sort = sort, n_uniq = uniq, n_occ = occ}) = docWithStyle codeDoc normalDoc where codeDoc = case sort of - WiredIn mod _ _ -> pprModule mod <> char '_' <> ppr_z_occ_name occ - External mod -> pprModule mod <> char '_' <> ppr_z_occ_name occ + WiredIn mod _ _ -> pprModule mod <> char '_' <> z_occ + External mod -> pprModule mod <> char '_' <> z_occ -- In code style, always qualify -- ToDo: maybe we could print all wired-in things unqualified -- in code style, to reduce symbol table bloat? System -> pprUniqueAlways uniq Internal -> pprUniqueAlways uniq + z_occ = ztext $ zEncodeFS $ occNameMangledFS occ normalDoc sty = getPprDebug $ \debug -> @@ -761,11 +772,6 @@ ppr_occ_name occ = ftext (occNameFS occ) -- Don't use pprOccName; instead, just print the string of the OccName; -- we print the namespace in the debug stuff above --- In code style, we Z-encode the strings. The results of Z-encoding each FastString are --- cached behind the scenes in the FastString implementation. -ppr_z_occ_name :: IsLine doc => OccName -> doc -ppr_z_occ_name occ = ztext (zEncodeFS (occNameFS occ)) - -- Prints (if mod information is available) "Defined at <loc>" or -- "Defined in <mod>" information for a Name. pprDefinedAt :: Name -> SDoc diff --git a/compiler/GHC/Types/Name.hs-boot b/compiler/GHC/Types/Name.hs-boot index e7e4cf2c7b..658fc8969f 100644 --- a/compiler/GHC/Types/Name.hs-boot +++ b/compiler/GHC/Types/Name.hs-boot @@ -3,7 +3,7 @@ module GHC.Types.Name ( module GHC.Types.Name.Occurrence ) where -import GHC.Prelude (Eq) +import GHC.Prelude (Eq, Bool) import {-# SOURCE #-} GHC.Types.Name.Occurrence import GHC.Types.Unique import GHC.Utils.Outputable @@ -28,3 +28,4 @@ nameUnique :: Name -> Unique setNameUnique :: Name -> Unique -> Name nameOccName :: Name -> OccName tidyNameOcc :: Name -> OccName -> Name +isFieldName :: Name -> Bool diff --git a/compiler/GHC/Types/Name/Env.hs b/compiler/GHC/Types/Name/Env.hs index 5990355426..f96d3957fb 100644 --- a/compiler/GHC/Types/Name/Env.hs +++ b/compiler/GHC/Types/Name/Env.hs @@ -19,7 +19,9 @@ module GHC.Types.Name.Env ( unitNameEnv, nonDetNameEnvElts, extendNameEnv_C, extendNameEnv_Acc, extendNameEnv, extendNameEnvList, extendNameEnvList_C, - filterNameEnv, mapMaybeNameEnv, anyNameEnv, + filterNameEnv, anyNameEnv, + mapMaybeNameEnv, + extendNameEnvListWith, plusNameEnv, plusNameEnv_C, plusNameEnv_CD, plusNameEnv_CD2, alterNameEnv, lookupNameEnv, lookupNameEnv_NF, delFromNameEnv, delListFromNameEnv, elemNameEnv, mapNameEnv, disjointNameEnv, @@ -113,6 +115,7 @@ plusNameEnv_C :: (a->a->a) -> NameEnv a -> NameEnv a -> NameEnv a plusNameEnv_CD :: (a->a->a) -> NameEnv a -> a -> NameEnv a -> a -> NameEnv a plusNameEnv_CD2 :: (Maybe a->Maybe a->a) -> NameEnv a -> NameEnv a -> NameEnv a extendNameEnvList :: NameEnv a -> [(Name,a)] -> NameEnv a +extendNameEnvListWith :: (a -> Name) -> NameEnv a -> [a] -> NameEnv a extendNameEnvList_C :: (a->a->a) -> NameEnv a -> [(Name,a)] -> NameEnv a delFromNameEnv :: NameEnv a -> Name -> NameEnv a delListFromNameEnv :: NameEnv a -> [Name] -> NameEnv a @@ -133,6 +136,7 @@ isEmptyNameEnv = isNullUFM unitNameEnv x y = unitUFM x y extendNameEnv x y z = addToUFM x y z extendNameEnvList x l = addListToUFM x l +extendNameEnvListWith f x l = addListToUFM x (map (\a -> (f a, a)) l) lookupNameEnv x y = lookupUFM x y alterNameEnv = alterUFM mkNameEnv l = listToUFM l @@ -151,7 +155,7 @@ delFromNameEnv x y = delFromUFM x y delListFromNameEnv x y = delListFromUFM x y filterNameEnv x y = filterUFM x y mapMaybeNameEnv x y = mapMaybeUFM x y -anyNameEnv f x = foldUFM ((||) . f) False x +anyNameEnv f x = nonDetFoldUFM ((||) . f) False x disjointNameEnv x y = disjointUFM x y seqEltsNameEnv seqElt x = seqEltsUFM seqElt x diff --git a/compiler/GHC/Types/Name/Occurrence.hs b/compiler/GHC/Types/Name/Occurrence.hs index e8d42eb0cf..b7d95543b0 100644 --- a/compiler/GHC/Types/Name/Occurrence.hs +++ b/compiler/GHC/Types/Name/Occurrence.hs @@ -3,8 +3,11 @@ (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -} -{-# LANGUAGE DeriveDataTypeable #-} +--{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MagicHash #-} {-# LANGUAGE OverloadedStrings #-} -- | @@ -29,7 +32,7 @@ module GHC.Types.Name.Occurrence ( -- ** Construction -- $real_vs_source_data_constructors - tcName, clsName, tcClsName, dataName, varName, + tcName, clsName, tcClsName, dataName, varName, fieldName, tvName, srcDataName, -- ** Pretty Printing @@ -37,11 +40,12 @@ module GHC.Types.Name.Occurrence ( -- * The 'OccName' type OccName, -- Abstract, instance of Outputable - pprOccName, + pprOccName, occNameMangledFS, -- ** Construction mkOccName, mkOccNameFS, mkVarOcc, mkVarOccFS, + mkRecFieldOcc, mkRecFieldOccFS, mkDataOcc, mkDataOccFS, mkTyVarOcc, mkTyVarOccFS, mkTcOcc, mkTcOccFS, @@ -51,6 +55,8 @@ module GHC.Types.Name.Occurrence ( demoteOccName, demoteOccTvName, promoteOccName, + varToRecFieldOcc, + recFieldToVarOcc, HasOccName(..), -- ** Derived 'OccName's @@ -67,30 +73,35 @@ module GHC.Types.Name.Occurrence ( mkSuperDictSelOcc, mkSuperDictAuxOcc, mkLocalOcc, mkMethodOcc, mkInstTyTcOcc, mkInstTyCoOcc, mkEqPredCoOcc, - mkRecFldSelOcc, mkTyConRepOcc, -- ** Deconstruction occNameFS, occNameString, occNameSpace, isVarOcc, isTvOcc, isTcOcc, isDataOcc, isDataSymOcc, isSymOcc, isValOcc, + isFieldOcc, fieldOcc_maybe, parenSymOcc, startsWithUnderscore, isTcClsNameSpace, isTvNameSpace, isDataConNameSpace, isVarNameSpace, isValNameSpace, + isFieldNameSpace, isTermVarOrFieldNameSpace, -- * The 'OccEnv' type - OccEnv, emptyOccEnv, unitOccEnv, extendOccEnv, mapOccEnv, - lookupOccEnv, mkOccEnv, mkOccEnv_C, extendOccEnvList, elemOccEnv, - nonDetOccEnvElts, foldOccEnv, plusOccEnv, plusOccEnv_C, extendOccEnv_C, + OccEnv, emptyOccEnv, unitOccEnv, extendOccEnv, + mapOccEnv, strictMapOccEnv, + lookupOccEnv, lookupOccEnv_WithFields, lookupFieldsOccEnv, + mkOccEnv, mkOccEnv_C, extendOccEnvList, elemOccEnv, + nonDetOccEnvElts, nonDetFoldOccEnv, + plusOccEnv, plusOccEnv_C, extendOccEnv_Acc, filterOccEnv, delListFromOccEnv, delFromOccEnv, - alterOccEnv, minusOccEnv, minusOccEnv_C, pprOccEnv, + alterOccEnv, minusOccEnv, minusOccEnv_C, minusOccEnv_C_Ns, + pprOccEnv, forceOccEnv, + intersectOccEnv_C, -- * The 'OccSet' type OccSet, emptyOccSet, unitOccSet, mkOccSet, extendOccSet, extendOccSetList, - unionOccSets, unionManyOccSets, minusOccSet, elemOccSet, - isEmptyOccSet, intersectOccSet, - filterOccSet, occSetToEnv, + unionOccSets, unionManyOccSets, elemOccSet, + isEmptyOccSet, -- * Tidying up TidyOccEnv, emptyTidyOccEnv, initTidyOccEnv, @@ -102,9 +113,9 @@ module GHC.Types.Name.Occurrence ( import GHC.Prelude +import GHC.Builtin.Uniques import GHC.Utils.Misc import GHC.Types.Unique -import GHC.Builtin.Uniques import GHC.Types.Unique.FM import GHC.Types.Unique.Set import GHC.Data.FastString @@ -112,10 +123,13 @@ import GHC.Data.FastString.Env import GHC.Utils.Outputable import GHC.Utils.Lexeme import GHC.Utils.Binary +import GHC.Utils.Panic.Plain + import Control.DeepSeq import Data.Char import Data.Data import qualified Data.Semigroup as S +import GHC.Exts( Int(I#), dataToTag# ) {- ************************************************************************ @@ -125,32 +139,108 @@ import qualified Data.Semigroup as S ************************************************************************ -} -data NameSpace = VarName -- Variables, including "real" data constructors - | DataName -- "Source" data constructors - | TvName -- Type variables - | TcClsName -- Type constructors and classes; Haskell has them - -- in the same name space for now. - deriving( Eq, Ord ) +data NameSpace + -- | Variable name space (including "real" data constructors). + = VarName + -- | Record field namespace for the given record. + | FldName + { fldParent :: !FastString + -- ^ The textual name of the parent of the field. + -- + -- - For a field of a datatype, this is the name of the first constructor + -- of the datatype (regardless of whether this constructor has this field). + -- - For a field of a pattern synonym, this is the name of the pattern synonym. + } + -- | "Source" data constructor namespace. + | DataName + -- | Type variable namespace. + | TvName + -- | Type constructor and class namespace. + | TcClsName + -- Haskell has type constructors and classes in the same namespace, for now. + deriving Eq + +instance Ord NameSpace where + compare ns1 ns2 = + case compare (I# (dataToTag# ns1)) (I# (dataToTag# ns2)) of + LT -> LT + GT -> GT + EQ + | FldName { fldParent = p1 } <- ns1 + , FldName { fldParent = p2 } <- ns2 + -> lexicalCompareFS p1 p2 + | otherwise + -> EQ + +instance Uniquable NameSpace where + getUnique (FldName fs) = mkFldNSUnique fs + getUnique VarName = varNSUnique + getUnique DataName = dataNSUnique + getUnique TvName = tvNSUnique + getUnique TcClsName = tcNSUnique + +instance NFData NameSpace where + rnf VarName = () + rnf (FldName par) = rnf par + rnf DataName = () + rnf TvName = () + rnf TcClsName = () --- Note [Data Constructors] --- ~~~~~~~~~~~~~~~~~~~~~~~~ --- see also: Note [Data Constructor Naming] in GHC.Core.DataCon --- --- $real_vs_source_data_constructors --- There are two forms of data constructor: --- --- [Source data constructors] The data constructors mentioned in Haskell source code --- --- [Real data constructors] The data constructors of the representation type, which may not be the same as the source type --- --- For example: --- --- > data T = T !(Int, Int) --- --- The source datacon has type @(Int, Int) -> T@ --- The real datacon has type @Int -> Int -> T@ --- --- GHC chooses a representation based on the strictness etc. +{- +Note [Data Constructors] +~~~~~~~~~~~~~~~~~~~~~~~~ +see also: Note [Data Constructor Naming] in GHC.Core.DataCon + +$real_vs_source_data_constructors +There are two forms of data constructor: + + [Source data constructors] The data constructors mentioned in Haskell source code + + [Real data constructors] The data constructors of the representation type, which may not be the same as the source type + +For example: + +> data T = T !(Int, Int) + +The source datacon has type @(Int, Int) -> T@ +The real datacon has type @Int -> Int -> T@ + +GHC chooses a representation based on the strictness etc. + +Note [Record field namespacing] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Record fields have a separate namespace from variables, to support +DuplicateRecordFields, e.g. in + + data X = MkX { fld :: Int } + data Y = MkY { fld :: Bool } + + f x = x { fld = 3 } + g y = y { fld = False } + +we want the two occurrences of "fld" to refer to the field names associated with +the corresponding data type. + +The namespace for a record field is as follows: + + - for a data type, it is the textual name of the first constructor of the + datatype, whether this constructor has this field or not; + - for a pattern synonym, it is the textual name of the pattern synonym itself. + +Record fields are initially parsed as variables, but the renamer resolves their +namespace in GHC.Rename.Names.newRecordFieldLabel, which is called when renaming +record data declarations and record pattern synonym declarations. + +To illustrate the namespacing, consider the record field "fld" in the following datatype + + data instance A Int Bool Char + = MkA1 | MkA2 { fld :: Int } | MkA3 { bar :: Bool, fld :: Int } + +Its namespace is `FldName "MkA1"`. This is a convention used throughout GHC +to circumvent the fact that we don't have a way to refer to the type constructor +"A Int Bool Char" in the renamer, as data family instances only get given +'Name's in the typechecker. +-} tcName, clsName, tcClsName :: NameSpace dataName, srcDataName :: NameSpace @@ -169,6 +259,9 @@ srcDataName = DataName -- Haskell-source data constructors should be tvName = TvName varName = VarName +fieldName :: FastString -> NameSpace +fieldName = FldName + isDataConNameSpace :: NameSpace -> Bool isDataConNameSpace DataName = True isDataConNameSpace _ = False @@ -182,30 +275,44 @@ isTvNameSpace TvName = True isTvNameSpace _ = False isVarNameSpace :: NameSpace -> Bool -- Variables or type variables, but not constructors -isVarNameSpace TvName = True -isVarNameSpace VarName = True -isVarNameSpace _ = False +isVarNameSpace TvName = True +isVarNameSpace VarName = True +isVarNameSpace (FldName {}) = True +isVarNameSpace _ = False + +-- | Is this a term variable or field name namespace? +isTermVarOrFieldNameSpace :: NameSpace -> Bool +isTermVarOrFieldNameSpace VarName = True +isTermVarOrFieldNameSpace (FldName {}) = True +isTermVarOrFieldNameSpace _ = False isValNameSpace :: NameSpace -> Bool -isValNameSpace DataName = True -isValNameSpace VarName = True -isValNameSpace _ = False +isValNameSpace DataName = True +isValNameSpace VarName = True +isValNameSpace (FldName {}) = True +isValNameSpace _ = False + +isFieldNameSpace :: NameSpace -> Bool +isFieldNameSpace (FldName {}) = True +isFieldNameSpace _ = False pprNameSpace :: NameSpace -> SDoc -pprNameSpace DataName = text "data constructor" -pprNameSpace VarName = text "variable" -pprNameSpace TvName = text "type variable" -pprNameSpace TcClsName = text "type constructor or class" +pprNameSpace DataName = text "data constructor" +pprNameSpace VarName = text "variable" +pprNameSpace TvName = text "type variable" +pprNameSpace TcClsName = text "type constructor or class" +pprNameSpace (FldName p) = text "record field of" <+> ftext p pprNonVarNameSpace :: NameSpace -> SDoc pprNonVarNameSpace VarName = empty pprNonVarNameSpace ns = pprNameSpace ns pprNameSpaceBrief :: NameSpace -> SDoc -pprNameSpaceBrief DataName = char 'd' -pprNameSpaceBrief VarName = char 'v' -pprNameSpaceBrief TvName = text "tv" -pprNameSpaceBrief TcClsName = text "tc" +pprNameSpaceBrief DataName = char 'd' +pprNameSpaceBrief VarName = char 'v' +pprNameSpaceBrief TvName = text "tv" +pprNameSpaceBrief TcClsName = text "tc" +pprNameSpaceBrief (FldName {}) = text "fld" -- demoteNameSpace lowers the NameSpace if possible. We can not know -- in advance, since a TvName can appear in an HsTyVar. @@ -215,6 +322,7 @@ demoteNameSpace VarName = Nothing demoteNameSpace DataName = Nothing demoteNameSpace TvName = Nothing demoteNameSpace TcClsName = Just DataName +demoteNameSpace (FldName {}) = Nothing -- demoteTvNameSpace lowers the NameSpace of a type variable. -- See Note [Demotion] in GHC.Rename.Env. @@ -223,6 +331,7 @@ demoteTvNameSpace TvName = Just VarName demoteTvNameSpace VarName = Nothing demoteTvNameSpace DataName = Nothing demoteTvNameSpace TcClsName = Nothing +demoteTvNameSpace (FldName {}) = Nothing -- promoteNameSpace promotes the NameSpace as follows. -- See Note [Promotion] in GHC.Rename.Env. @@ -231,6 +340,7 @@ promoteNameSpace DataName = Just TcClsName promoteNameSpace VarName = Just TvName promoteNameSpace TcClsName = Nothing promoteNameSpace TvName = Nothing +promoteNameSpace (FldName {}) = Nothing {- ************************************************************************ @@ -255,7 +365,8 @@ instance Eq OccName where instance Ord OccName where -- Compares lexicographically, *not* by Unique of the string - compare (OccName sp1 s1) (OccName sp2 s2) = lexicalCompareFS s1 s2 S.<> compare sp1 sp2 + compare (OccName sp1 s1) (OccName sp2 s2) = + lexicalCompareFS s1 s2 S.<> compare sp1 sp2 instance Data OccName where -- don't traverse? @@ -287,10 +398,41 @@ instance OutputableBndr OccName where pprOccName :: IsLine doc => OccName -> doc pprOccName (OccName sp occ) - = docWithStyle (ztext (zEncodeFS occ)) (\_ -> ftext occ <> whenPprDebug (braces (pprNameSpaceBrief sp))) + = docWithStyle (ztext (zEncodeFS occ)) + (\_ -> ftext occ <> whenPprDebug (braces (pprNameSpaceBrief sp))) {-# SPECIALIZE pprOccName :: OccName -> SDoc #-} {-# SPECIALIZE pprOccName :: OccName -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable +-- | Mangle field names to avoid duplicate symbols. +-- +-- See Note [Mangling OccNames]. +occNameMangledFS :: OccName -> FastString +occNameMangledFS (OccName ns fs) = + case ns of + -- Fields need to include the constructor, to ensure that we don't define + -- duplicate symbols when using DuplicateRecordFields. + FldName con -> concatFS [fsLit "$fld:", con, ":", fs] + -- Otherwise, we can ignore the namespace, as there is no risk of name + -- clashes. + _ -> fs + +{- Note [Mangling OccNames] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When generating a symbol for a Name, we usually discard the NameSpace entirely +(see GHC.Types.Name.pprName). This is because clashes are usually not possible, +e.g. a variable and a data constructor can't clash because data constructors +start with a capital letter or a colon, while variables never do. + +However, record field names, in the presence of DuplicateRecordFields, need this +disambiguation. So, for a record field like + + data A = MkA { foo :: Int } + +we generate the symbol $fld:MkA:foo. We use the constructor 'MkA' to disambiguate, +and not the TyCon A as one might naively expect: this is explained in +Note [Record field namespacing]. +-} + {- ************************************************************************ * * @@ -311,6 +453,24 @@ mkVarOcc s = mkOccName varName s mkVarOccFS :: FastString -> OccName mkVarOccFS fs = mkOccNameFS varName fs +mkRecFieldOcc :: FastString -> String -> OccName +mkRecFieldOcc dc = mkOccName (fieldName dc) + +mkRecFieldOccFS :: FastString -> FastString -> OccName +mkRecFieldOccFS dc = mkOccNameFS (fieldName dc) + +varToRecFieldOcc :: HasDebugCallStack => FastString -> OccName -> OccName +varToRecFieldOcc dc (OccName ns s) = + assert makes_sense $ mkRecFieldOccFS dc s + where + makes_sense = case ns of + VarName -> True + FldName con -> con == dc + _ -> False + +recFieldToVarOcc :: HasDebugCallStack => OccName -> OccName +recFieldToVarOcc (OccName _ns s) = mkVarOccFS s + mkDataOcc :: String -> OccName mkDataOcc = mkOccName dataName @@ -366,83 +526,273 @@ class HasOccName name where * * ************************************************************************ -OccEnvs are used mainly for the envts in ModIfaces. +OccEnvs are used for the GlobalRdrEnv and for the envts in ModIface. -Note [The Unique of an OccName] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -They are efficient, because FastStrings have unique Int# keys. We assume -this key is less than 2^24, and indeed FastStrings are allocated keys -sequentially starting at 0. - -So we can make a Unique using - mkUnique ns key :: Unique -where 'ns' is a Char representing the name space. This in turn makes it -easy to build an OccEnv. --} +Note [OccEnv] +~~~~~~~~~~~~~ +An OccEnv is a map keyed on OccName. Recall that an OccEnv consists of two +components: + + - a namespace, + - a textual name (in the form of a FastString). + +In general, for a given textual name, there is only one appropriate namespace. +However, sometimes we do get an occurrence that belongs to several namespaces: + + - Symbolic identifiers such as (:+) can belong to both the data constructor and + type constructor/class namespaces. + - With duplicate record fields, a field name can belong to several different + namespaces, one for each parent datatype (or pattern synonym). + +So we represent an OccEnv as a nested data structure + + FastStringEnv (UniqFM NameSpace a) -instance Uniquable OccName where - -- See Note [The Unique of an OccName] - getUnique (OccName VarName fs) = mkVarOccUnique fs - getUnique (OccName DataName fs) = mkDataOccUnique fs - getUnique (OccName TvName fs) = mkTvOccUnique fs - getUnique (OccName TcClsName fs) = mkTcOccUnique fs +in which we can first look up the textual name, and then choose which of the +namespaces are relevant. This supports the two main uses of OccEnvs: -newtype OccEnv a = A (UniqFM OccName a) - deriving Data + 1. One wants to look up a specific OccName in the environment, at a specific + namespace. One looks up the textual name, and then the namespace. + 2. One wants to look up something, but isn't sure in advance of the namespace. + So one looks up the textual name, and then can decide what to do based on + the returned map of namespaces. +This data structure isn't performance critical in most situations, but some +improvements to its performance that might be worth it are as follows: + + A. Use a tailor-made data structure for a map keyed on NameSpaces. + + Recall that we have: + + data IntMap a = Bin !Int !Int !(IntMap a) !(IntMap a) + | Tip !Key a + | Nil + + This is already pretty efficient for singletons, but we don't need the + empty case (as we would simply omit the parent key in the OccEnv instead + of storing an empty inner map). + + B. Always ensure the inner map (keyed on namespaces) is evaluated, i.e. + is never a thunk. For this, we would need to use strict operations on + the outer FastStringEnv (but we'd keep using lazy operations on the inner + UniqFM). +-} + +-- | A map keyed on 'OccName'. See Note [OccEnv]. +newtype OccEnv a = MkOccEnv (FastStringEnv (UniqFM NameSpace a)) + deriving Functor + +-- | The empty 'OccEnv'. emptyOccEnv :: OccEnv a -unitOccEnv :: OccName -> a -> OccEnv a +emptyOccEnv = MkOccEnv emptyFsEnv + +-- | A singleton 'OccEnv'. +unitOccEnv :: OccName -> a -> OccEnv a +unitOccEnv (OccName ns s) a = MkOccEnv $ unitFsEnv s (unitUFM ns a) + +-- | Add a single element to an 'OccEnv'. extendOccEnv :: OccEnv a -> OccName -> a -> OccEnv a +extendOccEnv (MkOccEnv as) (OccName ns s) a = + MkOccEnv $ extendFsEnv_C plusUFM as s (unitUFM ns a) + +-- | Extend an 'OccEnv' by a list. +-- +-- 'OccName's later on in the list override earlier 'OccName's. extendOccEnvList :: OccEnv a -> [(OccName, a)] -> OccEnv a +extendOccEnvList = foldl' $ \ env (occ, a) -> extendOccEnv env occ a + +-- | Look an element up in an 'OccEnv'. lookupOccEnv :: OccEnv a -> OccName -> Maybe a -mkOccEnv :: [(OccName,a)] -> OccEnv a -mkOccEnv_C :: (a -> a -> a) -> [(OccName,a)] -> OccEnv a -elemOccEnv :: OccName -> OccEnv a -> Bool -foldOccEnv :: (a -> b -> b) -> b -> OccEnv a -> b -nonDetOccEnvElts :: OccEnv a -> [a] -extendOccEnv_C :: (a->a->a) -> OccEnv a -> OccName -> a -> OccEnv a -extendOccEnv_Acc :: (a->b->b) -> (a->b) -> OccEnv b -> OccName -> a -> OccEnv b -plusOccEnv :: OccEnv a -> OccEnv a -> OccEnv a -plusOccEnv_C :: (a->a->a) -> OccEnv a -> OccEnv a -> OccEnv a -mapOccEnv :: (a->b) -> OccEnv a -> OccEnv b -delFromOccEnv :: OccEnv a -> OccName -> OccEnv a +lookupOccEnv (MkOccEnv as) (OccName ns s) + = do { m <- lookupFsEnv as s + ; lookupUFM m ns } + +-- | Lookup an element in an 'OccEnv', looking in the record field +-- namespace for a variable. +lookupOccEnv_WithFields :: OccEnv a -> OccName -> [a] +lookupOccEnv_WithFields env occ = + case lookupOccEnv env occ of + Nothing -> fieldGREs + Just gre -> gre : fieldGREs + where + fieldGREs + -- If the 'OccName' is a variable, also look up + -- in the record field namespaces. + | isVarOcc occ + = lookupFieldsOccEnv env (occNameFS occ) + | otherwise + = [] + +-- | Look up all the record fields that match with the given 'FastString' +-- in an 'OccEnv'. +lookupFieldsOccEnv :: OccEnv a -> FastString -> [a] +lookupFieldsOccEnv (MkOccEnv as) fld = + case lookupFsEnv as fld of + Nothing -> [] + Just flds -> nonDetEltsUFM $ filter_flds flds + -- NB: non-determinism is OK: in practice we will either end up resolving + -- to a single field or throwing an error. + where + filter_flds = filterUFM_Directly (\ uniq _ -> isFldNSUnique uniq) + +-- | Create an 'OccEnv' from a list. +-- +-- 'OccName's later on in the list override earlier 'OccName's. +mkOccEnv :: [(OccName,a)] -> OccEnv a +mkOccEnv = extendOccEnvList emptyOccEnv + +-- | Create an 'OccEnv' from a list, combining different values +-- with the same 'OccName' using the combining function. +mkOccEnv_C :: (a -> a -> a) -- ^ old -> new -> result + -> [(OccName,a)] + -> OccEnv a +mkOccEnv_C f elts + = MkOccEnv $ foldl' g emptyFsEnv elts + where + g env (OccName ns s, a) = + extendFsEnv_C (plusUFM_C $ flip f) env s (unitUFM ns a) + +-- | Compute whether there is a value keyed by the given 'OccName'. +elemOccEnv :: OccName -> OccEnv a -> Bool +elemOccEnv (OccName ns s) (MkOccEnv as) + = case lookupFsEnv as s of + Nothing -> False + Just m -> ns `elemUFM` m + +-- | Fold over an 'OccEnv'. Non-deterministic, unless the folding function +-- is commutative (i.e. @a1 `f` ( a2 `f` b ) == a2 `f` ( a1 `f` b )@ for all @a1@, @a2@, @b@). +nonDetFoldOccEnv :: (a -> b -> b) -> b -> OccEnv a -> b +nonDetFoldOccEnv f b0 (MkOccEnv as) = + nonDetFoldFsEnv (flip $ nonDetFoldUFM f) b0 as + +-- | Obtain the elements of an 'OccEnv'. +-- +-- The resulting order is non-deterministic. +nonDetOccEnvElts :: OccEnv a -> [a] +nonDetOccEnvElts = nonDetFoldOccEnv (:) [] + +-- | Union of two 'OccEnv's, right-biased. +plusOccEnv :: OccEnv a -> OccEnv a -> OccEnv a +plusOccEnv (MkOccEnv env1) (MkOccEnv env2) + = MkOccEnv $ plusFsEnv_C plusUFM env1 env2 + +-- | Union of two 'OccEnv's with a combining function. +plusOccEnv_C :: (a->a->a) -> OccEnv a -> OccEnv a -> OccEnv a +plusOccEnv_C f (MkOccEnv env1) (MkOccEnv env2) + = MkOccEnv $ plusFsEnv_C (plusUFM_C f) env1 env2 + +-- | Map over an 'OccEnv' ('Functor' instance). +mapOccEnv :: (a->b) -> OccEnv a -> OccEnv b +mapOccEnv = fmap + +-- | Add a single element to an 'OccEnv', using a different function whether +-- the 'OccName' already exists or not. +extendOccEnv_Acc :: forall a b + . (a->b->b) -- ^ add to existing + -> (a->b) -- ^ new element + -> OccEnv b -- ^ old + -> OccName -> a -- ^ new + -> OccEnv b +extendOccEnv_Acc f g (MkOccEnv env) (OccName ns s) = + MkOccEnv . extendFsEnv_Acc f' g' env s + where + f' :: a -> UniqFM NameSpace b -> UniqFM NameSpace b + f' a bs = alterUFM (Just . \ case { Nothing -> g a ; Just b -> f a b }) bs ns + g' a = unitUFM ns (g a) + +-- | Delete one element from an 'OccEnv'. +delFromOccEnv :: forall a. OccEnv a -> OccName -> OccEnv a +delFromOccEnv (MkOccEnv env1) (OccName ns s) = + MkOccEnv $ alterFsEnv f env1 s + where + f :: Maybe (UniqFM NameSpace a) -> Maybe (UniqFM NameSpace a) + f Nothing = Nothing + f (Just m) = + case delFromUFM m ns of + m' | isNullUFM m' -> Nothing + | otherwise -> Just m' + +-- | Delete multiple elements from an 'OccEnv'. delListFromOccEnv :: OccEnv a -> [OccName] -> OccEnv a -filterOccEnv :: (elt -> Bool) -> OccEnv elt -> OccEnv elt -alterOccEnv :: (Maybe elt -> Maybe elt) -> OccEnv elt -> OccName -> OccEnv elt +delListFromOccEnv = foldl' delFromOccEnv + +-- | Filter out all elements in an 'OccEnv' using a predicate. +filterOccEnv :: forall a. (a -> Bool) -> OccEnv a -> OccEnv a +filterOccEnv f (MkOccEnv env) = + MkOccEnv $ mapMaybeFsEnv g env + where + g :: UniqFM NameSpace a -> Maybe (UniqFM NameSpace a) + g ms = + case filterUFM f ms of + m' | isNullUFM m' -> Nothing + | otherwise -> Just m' + +-- | Alter an 'OccEnv', adding or removing an element at the given key. +alterOccEnv :: forall a. (Maybe a -> Maybe a) -> OccEnv a -> OccName -> OccEnv a +alterOccEnv f (MkOccEnv env) (OccName ns s) = + MkOccEnv $ alterFsEnv g env s + where + g :: Maybe (UniqFM NameSpace a) -> Maybe (UniqFM NameSpace a) + g Nothing = fmap (unitUFM ns) (f Nothing) + g (Just m) = + case alterUFM f m ns of + m' | isNullUFM m' -> Nothing + | otherwise -> Just m' + +intersectOccEnv_C :: (a -> b -> c) -> OccEnv a -> OccEnv b -> OccEnv c +intersectOccEnv_C f (MkOccEnv as) (MkOccEnv bs) + = MkOccEnv $ intersectUFM_C (intersectUFM_C f) as bs + +-- | Remove elements of the first 'OccEnv' that appear in the second 'OccEnv'. minusOccEnv :: OccEnv a -> OccEnv b -> OccEnv a +minusOccEnv = minusOccEnv_C_Ns minusUFM --- | Alters (replaces or removes) those elements of the map that are mentioned in the second map -minusOccEnv_C :: (a -> b -> Maybe a) -> OccEnv a -> OccEnv b -> OccEnv a - -emptyOccEnv = A emptyUFM -unitOccEnv x y = A $ unitUFM x y -extendOccEnv (A x) y z = A $ addToUFM x y z -extendOccEnvList (A x) l = A $ addListToUFM x l -lookupOccEnv (A x) y = lookupUFM x y -mkOccEnv l = A $ listToUFM l -elemOccEnv x (A y) = elemUFM x y -foldOccEnv a b (A c) = foldUFM a b c -nonDetOccEnvElts (A x) = nonDetEltsUFM x -plusOccEnv (A x) (A y) = A $ plusUFM x y -plusOccEnv_C f (A x) (A y) = A $ plusUFM_C f x y -extendOccEnv_C f (A x) y z = A $ addToUFM_C f x y z -extendOccEnv_Acc f g (A x) y z = A $ addToUFM_Acc f g x y z -mapOccEnv f (A x) = A $ mapUFM f x -mkOccEnv_C comb l = A $ addListToUFM_C comb emptyUFM l -delFromOccEnv (A x) y = A $ delFromUFM x y -delListFromOccEnv (A x) y = A $ delListFromUFM x y -filterOccEnv x (A y) = A $ filterUFM x y -alterOccEnv fn (A y) k = A $ alterUFM fn y k -minusOccEnv (A x) (A y) = A $ minusUFM x y -minusOccEnv_C fn (A x) (A y) = A $ minusUFM_C fn x y +-- | Alters (replaces or removes) those elements of the first 'OccEnv' that are +-- mentioned in the second 'OccEnv'. +-- +-- Same idea as 'Data.Map.differenceWith'. +minusOccEnv_C :: (a -> b -> Maybe a) + -> OccEnv a -> OccEnv b -> OccEnv a +minusOccEnv_C f = minusOccEnv_C_Ns (minusUFM_C f) + +minusOccEnv_C_Ns :: forall a b + . (UniqFM NameSpace a -> UniqFM NameSpace b -> UniqFM NameSpace a) + -> OccEnv a -> OccEnv b -> OccEnv a +minusOccEnv_C_Ns f (MkOccEnv as) (MkOccEnv bs) = + MkOccEnv $ minusUFM_C g as bs + where + g :: UniqFM NameSpace a -> UniqFM NameSpace b -> Maybe (UniqFM NameSpace a) + g as bs = + let m = f as bs + in if isNullUFM m + then Nothing + else Just m instance Outputable a => Outputable (OccEnv a) where ppr x = pprOccEnv ppr x pprOccEnv :: (a -> SDoc) -> OccEnv a -> SDoc -pprOccEnv ppr_elt (A env) = pprUniqFM ppr_elt env +pprOccEnv ppr_elt (MkOccEnv env) + = brackets $ fsep $ punctuate comma $ + [ ppr uq <+> text ":->" <+> ppr_elt elt + | (uq, elts) <- nonDetUFMToList env + , elt <- nonDetEltsUFM elts ] + +instance NFData a => NFData (OccEnv a) where + rnf = forceOccEnv rnf + +-- | Map over an 'OccEnv' strictly. +strictMapOccEnv :: (a -> b) -> OccEnv a -> OccEnv b +strictMapOccEnv f (MkOccEnv as) = + MkOccEnv $ strictMapFsEnv (strictMapUFM f) as + +-- | Force an 'OccEnv' with the provided function. +forceOccEnv :: (a -> ()) -> OccEnv a -> () +forceOccEnv nf (MkOccEnv fs) = seqEltsUFM (seqEltsUFM nf) fs + +-------------------------------------------------------------------------------- -type OccSet = UniqSet OccName +type OccSet = FastStringEnv (UniqSet NameSpace) emptyOccSet :: OccSet unitOccSet :: OccName -> OccSet @@ -451,27 +801,18 @@ extendOccSet :: OccSet -> OccName -> OccSet extendOccSetList :: OccSet -> [OccName] -> OccSet unionOccSets :: OccSet -> OccSet -> OccSet unionManyOccSets :: [OccSet] -> OccSet -minusOccSet :: OccSet -> OccSet -> OccSet elemOccSet :: OccName -> OccSet -> Bool isEmptyOccSet :: OccSet -> Bool -intersectOccSet :: OccSet -> OccSet -> OccSet -filterOccSet :: (OccName -> Bool) -> OccSet -> OccSet --- | Converts an OccSet to an OccEnv (operationally the identity) -occSetToEnv :: OccSet -> OccEnv OccName - -emptyOccSet = emptyUniqSet -unitOccSet = unitUniqSet -mkOccSet = mkUniqSet -extendOccSet = addOneToUniqSet -extendOccSetList = addListToUniqSet -unionOccSets = unionUniqSets -unionManyOccSets = unionManyUniqSets -minusOccSet = minusUniqSet -elemOccSet = elementOfUniqSet -isEmptyOccSet = isEmptyUniqSet -intersectOccSet = intersectUniqSets -filterOccSet = filterUniqSet -occSetToEnv = A . getUniqSet + +emptyOccSet = emptyFsEnv +unitOccSet (OccName ns s) = unitFsEnv s (unitUniqSet ns) +mkOccSet = extendOccSetList emptyOccSet +extendOccSet occs (OccName ns s) = extendFsEnv occs s (unitUniqSet ns) +extendOccSetList = foldl extendOccSet +unionOccSets = plusFsEnv_C unionUniqSets +unionManyOccSets = foldl' unionOccSets emptyOccSet +elemOccSet (OccName ns s) occs = maybe False (elementOfUniqSet ns) $ lookupFsEnv occs s +isEmptyOccSet = isNullUFM {- ************************************************************************ @@ -487,7 +828,7 @@ occNameString (OccName _ s) = unpackFS s setOccNameSpace :: NameSpace -> OccName -> OccName setOccNameSpace sp (OccName _ occ) = OccName sp occ -isVarOcc, isTvOcc, isTcOcc, isDataOcc :: OccName -> Bool +isVarOcc, isTvOcc, isTcOcc, isDataOcc, isFieldOcc :: OccName -> Bool isVarOcc (OccName VarName _) = True isVarOcc _ = False @@ -498,12 +839,20 @@ isTvOcc _ = False isTcOcc (OccName TcClsName _) = True isTcOcc _ = False +isFieldOcc (OccName (FldName {}) _) = True +isFieldOcc _ = False + +fieldOcc_maybe :: OccName -> Maybe FastString +fieldOcc_maybe (OccName (FldName con) _) = Just con +fieldOcc_maybe _ = Nothing + -- | /Value/ 'OccNames's are those that are either in --- the variable or data constructor namespaces +-- the variable, field name or data constructor namespaces isValOcc :: OccName -> Bool -isValOcc (OccName VarName _) = True -isValOcc (OccName DataName _) = True -isValOcc _ = False +isValOcc (OccName VarName _) = True +isValOcc (OccName DataName _) = True +isValOcc (OccName (FldName {}) _) = True +isValOcc _ = False isDataOcc (OccName DataName _) = True isDataOcc _ = False @@ -518,10 +867,12 @@ isDataSymOcc _ = False -- | Test if the 'OccName' is that for any operator (whether -- it is a data constructor or variable or whatever) isSymOcc :: OccName -> Bool -isSymOcc (OccName DataName s) = isLexConSym s -isSymOcc (OccName TcClsName s) = isLexSym s -isSymOcc (OccName VarName s) = isLexSym s -isSymOcc (OccName TvName s) = isLexSym s +isSymOcc (OccName ns s) = case ns of + DataName -> isLexConSym s + TcClsName -> isLexSym s + VarName -> isLexSym s + TvName -> isLexSym s + FldName {} -> isLexSym s -- Pretty inefficient! parenSymOcc :: OccName -> SDoc -> SDoc @@ -658,10 +1009,6 @@ mkTyConRepOcc occ = mk_simple_deriv varName prefix occ mkGenR = mk_simple_deriv tcName "Rep_" mkGen1R = mk_simple_deriv tcName "Rep1_" --- Overloaded record field selectors -mkRecFldSelOcc :: FastString -> OccName -mkRecFldSelOcc s = mk_deriv varName "$sel" [s] - mk_simple_deriv :: NameSpace -> FastString -> OccName -> OccName mk_simple_deriv sp px occ = mk_deriv sp px [occNameFS occ] @@ -907,13 +1254,19 @@ instance Binary NameSpace where putByte bh 2 put_ bh TcClsName = putByte bh 3 + put_ bh (FldName parent) = do + putByte bh 4 + put_ bh parent get bh = do h <- getByte bh case h of 0 -> return VarName 1 -> return DataName 2 -> return TvName - _ -> return TcClsName + 3 -> return TcClsName + _ -> do + parent <- get bh + return $ FldName { fldParent = parent } instance Binary OccName where put_ bh (OccName aa ab) = do diff --git a/compiler/GHC/Types/Name/Occurrence.hs-boot b/compiler/GHC/Types/Name/Occurrence.hs-boot index cb39f6e679..7b76175e06 100644 --- a/compiler/GHC/Types/Name/Occurrence.hs-boot +++ b/compiler/GHC/Types/Name/Occurrence.hs-boot @@ -8,5 +8,4 @@ class HasOccName name where occName :: name -> OccName occNameFS :: OccName -> FastString -mkRecFldSelOcc :: FastString -> OccName mkVarOccFS :: FastString -> OccName diff --git a/compiler/GHC/Types/Name/Ppr.hs b/compiler/GHC/Types/Name/Ppr.hs index 206ee2e782..6ab771a9e0 100644 --- a/compiler/GHC/Types/Name/Ppr.hs +++ b/compiler/GHC/Types/Name/Ppr.hs @@ -68,7 +68,7 @@ with some holes, we should try to give the user some more useful information. -- | Creates some functions that work out the best ways to format -- names for the user according to a set of heuristics. -mkNamePprCtx :: PromotionTickContext -> UnitEnv -> GlobalRdrEnv -> NamePprCtx +mkNamePprCtx :: Outputable info => PromotionTickContext -> UnitEnv -> GlobalRdrEnvX info -> NamePprCtx mkNamePprCtx ptc unit_env env = QueryQualify (mkQualName env) @@ -79,7 +79,7 @@ mkNamePprCtx ptc unit_env env unit_state = ue_units unit_env home_unit = ue_homeUnit unit_env -mkQualName :: GlobalRdrEnv -> QueryQualifyName +mkQualName :: Outputable info => GlobalRdrEnvX info -> QueryQualifyName mkQualName env = qual_name where qual_name mod occ | [gre] <- unqual_gres @@ -97,7 +97,7 @@ mkQualName env = qual_name where = NameQual (greQualModName gre) | null qual_gres - = if null (lookupGRE_RdrName (mkRdrQual (moduleName mod) occ) env) + = if null (lookupGRE_RdrName SameOccName env (mkRdrQual (moduleName mod) occ)) then NameNotInScope1 else NameNotInScope2 @@ -127,14 +127,14 @@ mkQualName env = qual_name where right_name gre = greDefinitionModule gre == Just mod - unqual_gres = lookupGRE_RdrName (mkRdrUnqual occ) env - qual_gres = filter right_name (lookupGlobalRdrEnv env occ) + unqual_gres = lookupGRE_RdrName SameOccName env (mkRdrUnqual occ) + qual_gres = filter right_name (lookupGRE_OccName SameOccName env occ) -- we can mention a module P:M without the P: qualifier iff -- "import M" would resolve unambiguously to P:M. (if P is the -- current package we can just assume it is unqualified). -mkPromTick :: PromotionTickContext -> GlobalRdrEnv -> QueryPromotionTick +mkPromTick :: PromotionTickContext -> GlobalRdrEnvX info -> QueryPromotionTick mkPromTick ptc env | ptcPrintRedundantPromTicks ptc = alwaysPrintPromTick | otherwise = print_prom_tick @@ -150,7 +150,7 @@ mkPromTick ptc env = ptcListTuplePuns ptc | Just occ' <- promoteOccName occ - , [] <- lookupGRE_RdrName (mkRdrUnqual occ') env + , [] <- lookupGRE_RdrName SameOccName env (mkRdrUnqual occ') = -- Could not find a corresponding type name in the environment, -- so the data name is unambiguous. Promotion tick not needed. False diff --git a/compiler/GHC/Types/Name/Reader.hs b/compiler/GHC/Types/Name/Reader.hs index 7c52a94584..4b05eedb39 100644 --- a/compiler/GHC/Types/Name/Reader.hs +++ b/compiler/GHC/Types/Name/Reader.hs @@ -5,6 +5,8 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} -- | -- #name_types# @@ -44,30 +46,50 @@ module GHC.Types.Name.Reader ( localRdrEnvElts, minusLocalRdrEnv, -- * Global mapping of 'RdrName' to 'GlobalRdrElt's - GlobalRdrEnv, emptyGlobalRdrEnv, mkGlobalRdrEnv, plusGlobalRdrEnv, - lookupGlobalRdrEnv, extendGlobalRdrEnv, greOccName, shadowNames, + GlobalRdrEnvX, GlobalRdrEnv, IfGlobalRdrEnv, + emptyGlobalRdrEnv, mkGlobalRdrEnv, plusGlobalRdrEnv, + extendGlobalRdrEnv, greOccName, pprGlobalRdrEnv, globalRdrEnvElts, - lookupGRE_RdrName, lookupGRE_RdrName', lookupGRE_Name, - lookupGRE_GreName, lookupGRE_FieldLabel, - lookupGRE_Name_OccName, + + -- ** Looking up 'GlobalRdrElt's + FieldsOrSelectors(..), filterFieldGREs, allowGRE, + WhichGREs(..), lookupGRE_OccName, lookupGRE_RdrName, lookupGRE_Name, + lookupGRE_FieldLabel, getGRE_NameQualifier_maybes, transformGREs, pickGREs, pickGREsModExp, -- * GlobalRdrElts - gresFromAvails, gresFromAvail, localGREsFromAvail, availFromGRE, + availFromGRE, greRdrNames, greSrcSpan, greQualModName, gresToAvailInfo, greDefinitionModule, greDefinitionSrcSpan, - greMangledName, grePrintableName, - greFieldLabel, + greFieldLabel_maybe, -- ** Global 'RdrName' mapping elements: 'GlobalRdrElt', 'Provenance', 'ImportSpec' - GlobalRdrElt(..), isLocalGRE, isRecFldGRE, + GlobalRdrEltX(..), GlobalRdrElt, IfGlobalRdrElt, FieldGlobalRdrElt, + greName, forceGlobalRdrEnv, hydrateGlobalRdrEnv, + isLocalGRE, isRecFldGRE, + fieldGREInfo, isDuplicateRecFldGRE, isNoFieldSelectorGRE, isFieldSelectorGRE, unQualOK, qualSpecOK, unQualSpecOK, pprNameProvenance, - GreName(..), greNameSrcSpan, + vanillaGRE, localVanillaGRE, localTyConGRE, + localConLikeGRE, localFieldGREs, + gresToNameSet, + + -- ** Shadowing + greClashesWith, shadowNames, + + -- ** Information attached to a 'GlobalRdrElt' + ConLikeName(..), + GREInfo(..), RecFieldInfo(..), + plusGREInfo, + recFieldConLike_maybe, recFieldInfo_maybe, + fieldGRE_maybe, fieldGRELabel, + + -- ** Parent information Parent(..), greParent_maybe, + mkParent, availParent, ImportSpec(..), ImpDeclSpec(..), ImpItemSpec(..), importSpecLoc, importSpecModule, isExplicitItem, bestImport, @@ -77,28 +99,36 @@ module GHC.Types.Name.Reader ( import GHC.Prelude -import GHC.Unit.Module -import GHC.Types.Name +import GHC.Data.Bag +import GHC.Data.FastString +import GHC.Data.Maybe + import GHC.Types.Avail +import GHC.Types.Basic +import GHC.Types.GREInfo +import GHC.Types.FieldLabel +import GHC.Types.Name +import GHC.Types.Name.Env + ( NameEnv, nonDetNameEnvElts, emptyNameEnv, extendNameEnv_Acc ) import GHC.Types.Name.Set -import GHC.Data.Maybe import GHC.Types.SrcLoc as SrcLoc -import GHC.Data.FastString -import GHC.Types.FieldLabel -import GHC.Utils.Outputable -import GHC.Types.Unique import GHC.Types.Unique.FM import GHC.Types.Unique.Set + +import GHC.Unit.Module + import GHC.Utils.Misc as Utils +import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Types.Name.Env - -import Language.Haskell.Syntax.Basic (FieldLabelString(..)) +import Control.DeepSeq +import Control.Monad ( guard ) import Data.Data -import Data.List( sortBy ) +import Data.List ( sortBy ) +import qualified Data.List.NonEmpty as NE +import qualified Data.Map.Strict as Map import qualified Data.Semigroup as S -import GHC.Data.Bag +import System.IO.Unsafe ( unsafePerformIO ) {- ************************************************************************ @@ -391,7 +421,7 @@ instance Outputable LocalRdrEnv where <+> pprUFM (getUniqSet ns) (braces . pprWithCommas ppr) ] <+> char '}') where - ppr_elt name = parens (ppr (getUnique (nameOccName name))) <+> ppr name + ppr_elt name = parens (ppr (nameOccName name)) <+> ppr name -- So we can see if the keys line up correctly emptyLocalRdrEnv :: LocalRdrEnv @@ -462,7 +492,7 @@ the in-scope-name-set. -} -- | Global Reader Environment -type GlobalRdrEnv = OccEnv [GlobalRdrElt] +type GlobalRdrEnv = GlobalRdrEnvX GREInfo -- ^ Keyed by 'OccName'; when looking up a qualified name -- we look up the 'OccName' part, and then check the 'Provenance' -- to see if the appropriate qualification is valid. This @@ -483,23 +513,88 @@ type GlobalRdrEnv = OccEnv [GlobalRdrElt] -- -- INVARIANT 3: If the GlobalRdrEnv maps [occ -> gre], then -- greOccName gre = occ + +-- | A 'GlobalRdrEnv' in which the 'GlobalRdrElt's don't have any 'GREInfo' +-- attached to them. This is useful to avoid space leaks, see Note [IfGlobalRdrEnv]. +type IfGlobalRdrEnv = GlobalRdrEnvX () + +-- | Parametrises 'GlobalRdrEnv' over the presence or absence of 'GREInfo'. +-- +-- See Note [IfGlobalRdrEnv]. +type GlobalRdrEnvX info = OccEnv [GlobalRdrEltX info] + +-- | Global Reader Element +-- +-- An element of the 'GlobalRdrEnv'. + +type GlobalRdrElt = GlobalRdrEltX GREInfo + +-- | A 'GlobalRdrElt' in which we stripped out the 'GREInfo' field, +-- in order to avoid space leaks. -- --- NB: greOccName gre is usually the same as --- nameOccName (greMangledName gre), but not always in the --- case of record selectors; see Note [GreNames] +-- See Note [IfGlobalRdrEnv]. +type IfGlobalRdrElt = GlobalRdrEltX () -- | Global Reader Element -- --- An element of the 'GlobalRdrEnv' -data GlobalRdrElt - = GRE { gre_name :: !GreName -- ^ See Note [GreNames] - , gre_par :: !Parent -- ^ See Note [Parents] - , gre_lcl :: !Bool -- ^ True <=> the thing was defined locally - , gre_imp :: !(Bag ImportSpec) -- ^ In scope through these imports +-- An element of the 'GlobalRdrEnv'. +-- +-- Why do we parametrise over the 'gre_info' field? See Note [IfGlobalRdrEnv]. +data GlobalRdrEltX info + = GRE { gre_name :: !Name + , gre_par :: !Parent -- ^ See Note [Parents] + , gre_lcl :: !Bool -- ^ True <=> the thing was defined locally + , gre_imp :: !(Bag ImportSpec) -- ^ In scope through these imports + , gre_info :: info + -- ^ Information the renamer knows about this particular 'Name'. + -- + -- Careful about forcing this field! Forcing it can trigger + -- the loading of interface files. + -- + -- Note [Retrieving the GREInfo from interfaces] in GHC.Types.GREInfo. } deriving (Data) -- INVARIANT: either gre_lcl = True or gre_imp is non-empty -- See Note [GlobalRdrElt provenance] +{- Note [IfGlobalRdrEnv] +~~~~~~~~~~~~~~~~~~~~~~~~ +Information pertinent to the renamer about a 'Name' is stored in the fields of +'GlobalRdrElt'. The 'gre_info' field, described in Note [GREInfo] in GHC.Types.GREInfo, +is a bit special: as Note [Retrieving the GREInfo from interfaces] in GHC.Types.GREInfo +describes, for imported 'Name's it is usually obtained by a look up in a type environment, +and forcing can cause the interface file for the module defining the 'Name' to be +loaded. As described in Note [Forcing GREInfo] in GHC.Types.GREInfo, keeping it +a thunk can cause space leaks, while forcing it can cause extra work to be done. +So it's best to discard it when we don't need it, for example when we are about +to store it in a 'ModIface'. + +We thus parametrise 'GlobalRdrElt' (and 'GlobalRdrEnv') over the presence or +absence of the 'GREInfo' field. + + - When we are about to stash the 'GlobalRdrElt' in a long-lived data structure, + e.g. a 'ModIface', we force it by setting all the 'GREInfo' fields to '()'. + See 'forceGlobalRdrEnv'. + - To go back the other way, we use 'hydrateGlobalRdrEnv', which sets the + 'gre_info' fields back to lazy lookups. + +This parametrisation also helps ensure that we don't accidentally force the +GREInfo field (which can cause unnecessary loading of interface files). +In particular, the 'lookupGRE_OccName' is statically guaranteed to not consult +the 'GREInfo' field when its first argument is 'SameOccName', which is important +as we sometimes need to use this function with an 'IfaceGlobalRdrEnv' in which +the 'GREInfo' fields have been stripped. +-} + +-- | A 'FieldGlobalRdrElt' is a 'GlobalRdrElt' +-- in which the 'gre_info' field is 'IAmRecField'. +type FieldGlobalRdrElt = GlobalRdrElt + +greName :: GlobalRdrEltX info -> Name +greName = gre_name + +instance NFData IfGlobalRdrElt where + rnf !_ = () + -- | See Note [Parents] data Parent = NoParent | ParentIs { par_is :: Name } @@ -580,56 +675,12 @@ pattern synonym can be bundled with a type constructor on export, in which case whenever the pattern synonym is imported the gre_par will be ParentIs. Thus the gre_name and gre_par fields are independent, because a normal datatype -introduces FieldGreNames using ParentIs, but a record pattern synonym can -introduce FieldGreNames that use NoParent. (In the past we represented fields -using an additional constructor of the Parent type, which could not adequately -represent this situation.) See also +introduces FieldGlobalRdrElts using ParentIs, but a record pattern synonym can +introduce FieldGlobalRdrElts that use NoParent. (In the past we represented +fields using an additional constructor of the Parent type, which could not +adequately represent this situation.) See also Note [Representing pattern synonym fields in AvailInfo] in GHC.Types.Avail. - -Note [GreNames] -~~~~~~~~~~~~~~~ -A `GlobalRdrElt` has a field `gre_name :: GreName`, which uniquely -identifies what the `GlobalRdrElt` describes. There are two sorts of -`GreName` (see the data type decl): - -* NormalGreName Name: this is used for most entities; the Name - uniquely identifies it. It is stored in the GlobalRdrEnv under - the OccName of the Name. - -* FieldGreName FieldLabel: is used only for field labels of a - record. With -XDuplicateRecordFields there may be many field - labels `x` in scope; e.g. - data T1 = MkT1 { x :: Int } - data T2 = MkT2 { x :: Bool } - Each has a different GlobalRdrElt with a distinct GreName. - The two fields are uniquely identified by their record selectors, - which are stored in the FieldLabel, and have mangled names like - `$sel:x:MkT1`. See Note [FieldLabel] in GHC.Types.FieldLabel. - - These GREs are stored in the GlobalRdrEnv under the OccName of the - field (i.e. "x" in both cases above), /not/ the OccName of the mangled - record selector function. - -A GreName, and hence a GRE, has both a "printable" and a "mangled" Name. These -are identical for normal names, but for record fields compiled with --XDuplicateRecordFields they will differ. So we have two pairs of functions: - - * greNameMangledName :: GreName -> Name - greMangledName :: GlobalRdrElt -> Name - The "mangled" Name is the actual Name of the selector function, - e.g. $sel:x:MkT1. This should not be displayed to the user, but is used to - uniquely identify the field in the renamer, and later in the backend. - - * greNamePrintableName :: GreName -> Name - grePrintableName :: GlobalRdrElt -> Name - The "printable" Name is the "manged" Name with its OccName replaced with that - of the field label. This is how the field should be output to the user. - -Since the right Name to use is context-dependent, we do not define a NamedThing -instance for GREName (or GlobalRdrElt), but instead make the choice explicit. - - Note [Combining parents] ~~~~~~~~~~~~~~~~~~~~~~~~ With an associated type we might have @@ -658,73 +709,80 @@ those. For T that will mean we have That's why plusParent picks the "best" case. -} --- | make a 'GlobalRdrEnv' where all the elements point to the same --- Provenance (useful for "hiding" imports, or imports with no details). -gresFromAvails :: Maybe ImportSpec -> [AvailInfo] -> [GlobalRdrElt] --- prov = Nothing => locally bound --- Just spec => imported as described by spec -gresFromAvails prov avails - = concatMap (gresFromAvail (const prov)) avails - -localGREsFromAvail :: AvailInfo -> [GlobalRdrElt] --- Turn an Avail into a list of LocalDef GlobalRdrElts -localGREsFromAvail = gresFromAvail (const Nothing) - -gresFromAvail :: (Name -> Maybe ImportSpec) -> AvailInfo -> [GlobalRdrElt] -gresFromAvail prov_fn avail - = map mk_gre (availNonFldNames avail) ++ map mk_fld_gre (availFlds avail) +vanillaGRE :: (Name -> Maybe ImportSpec) -> Parent -> Name -> GlobalRdrElt +vanillaGRE prov_fn par n = + case prov_fn n of + -- Nothing => bound locally + -- Just is => imported from 'is' + Nothing -> GRE { gre_name = n, gre_par = par + , gre_lcl = True, gre_imp = emptyBag + , gre_info = Vanilla } + Just is -> GRE { gre_name = n, gre_par = par + , gre_lcl = False, gre_imp = unitBag is + , gre_info = Vanilla } + +localVanillaGRE :: Parent -> Name -> GlobalRdrElt +localVanillaGRE = vanillaGRE (const Nothing) + +-- | Create a local 'GlobalRdrElt' for a 'TyCon'. +localTyConGRE :: TyConFlavour Name + -> Name + -> GlobalRdrElt +localTyConGRE flav nm = + ( localVanillaGRE par nm ) + { gre_info = IAmTyCon flav } where - mk_gre n - = case prov_fn n of -- Nothing => bound locally - -- Just is => imported from 'is' - Nothing -> GRE { gre_name = NormalGreName n, gre_par = mkParent n avail - , gre_lcl = True, gre_imp = emptyBag } - Just is -> GRE { gre_name = NormalGreName n, gre_par = mkParent n avail - , gre_lcl = False, gre_imp = unitBag is } - - mk_fld_gre fl - = case prov_fn (flSelector fl) of -- Nothing => bound locally - -- Just is => imported from 'is' - Nothing -> GRE { gre_name = FieldGreName fl, gre_par = availParent avail - , gre_lcl = True, gre_imp = emptyBag } - Just is -> GRE { gre_name = FieldGreName fl, gre_par = availParent avail - , gre_lcl = False, gre_imp = unitBag is } - -instance HasOccName GlobalRdrElt where + par = case tyConFlavourAssoc_maybe flav of + Nothing -> NoParent + Just p -> ParentIs p + +localConLikeGRE :: Parent -> (ConLikeName, ConInfo) -> GlobalRdrElt +localConLikeGRE p (con_nm, con_info) = + ( localVanillaGRE p $ conLikeName_Name con_nm ) + { gre_info = IAmConLike con_info } + +localFieldGREs :: Parent -> [(ConLikeName, ConInfo)] -> [GlobalRdrElt] +localFieldGREs p cons = + [ ( localVanillaGRE p fld_nm ) + { gre_info = IAmRecField fld_info } + | (S.Arg fld_nm fl, fl_cons) <- flds + , let fld_info = RecFieldInfo { recFieldLabel = fl + , recFieldCons = fl_cons } ] + where + -- We are given a map taking a constructor to its fields, but we want + -- a map taking a field to the contructors which have it. + -- We thus need to convert [(Con, [Field])] into [(Field, [Con])]. + flds = Map.toList + $ Map.fromListWith unionUniqSets + [ (S.Arg (flSelector fl) fl, unitUniqSet con) + | (con, con_info) <- cons + , ConHasRecordFields fls <- [con_info] + , fl <- NE.toList fls ] + +instance HasOccName (GlobalRdrEltX info) where occName = greOccName --- | See Note [GreNames] -greOccName :: GlobalRdrElt -> OccName -greOccName = occName . gre_name - --- | A 'Name' for the GRE for internal use. Careful: the 'OccName' of this --- 'Name' is not necessarily the same as the 'greOccName' (see Note [GreNames]). -greMangledName :: GlobalRdrElt -> Name -greMangledName = greNameMangledName . gre_name - --- | A 'Name' for the GRE suitable for output to the user. Its 'OccName' will --- be the 'greOccName' (see Note [GreNames]). -grePrintableName :: GlobalRdrElt -> Name -grePrintableName = greNamePrintableName . gre_name +greOccName :: GlobalRdrEltX info -> OccName +greOccName ( GRE { gre_name = nm } ) = nameOccName nm -- | The SrcSpan of the name pointed to by the GRE. -greDefinitionSrcSpan :: GlobalRdrElt -> SrcSpan -greDefinitionSrcSpan = nameSrcSpan . greMangledName +greDefinitionSrcSpan :: GlobalRdrEltX info -> SrcSpan +greDefinitionSrcSpan = nameSrcSpan . greName -- | The module in which the name pointed to by the GRE is defined. -greDefinitionModule :: GlobalRdrElt -> Maybe Module -greDefinitionModule = nameModule_maybe . greMangledName +greDefinitionModule :: GlobalRdrEltX info -> Maybe Module +greDefinitionModule = nameModule_maybe . greName -greQualModName :: GlobalRdrElt -> ModuleName +greQualModName :: Outputable info => GlobalRdrEltX info -> ModuleName -- Get a suitable module qualifier for the GRE -- (used in mkPrintUnqualified) --- Precondition: the greMangledName is always External +-- Precondition: the gre_name is always External greQualModName gre@(GRE { gre_lcl = lcl, gre_imp = iss }) | lcl, Just mod <- greDefinitionModule gre = moduleName mod | Just is <- headMaybe iss = is_as (is_decl is) | otherwise = pprPanic "greQualModName" (ppr gre) -greRdrNames :: GlobalRdrElt -> [RdrName] +greRdrNames :: GlobalRdrEltX info -> [RdrName] greRdrNames gre@GRE{ gre_lcl = lcl, gre_imp = iss } = bagToList $ (if lcl then unitBag unqual else emptyBag) `unionBags` concatMapBag do_spec (mapBag is_decl iss) where @@ -740,7 +798,7 @@ greRdrNames gre@GRE{ gre_lcl = lcl, gre_imp = iss } -- definition site is used, otherwise the location of the import -- declaration. We want to sort the export locations in -- exportClashErr by this SrcSpan, we need to extract it: -greSrcSpan :: GlobalRdrElt -> SrcSpan +greSrcSpan :: Outputable info => GlobalRdrEltX info -> SrcSpan greSrcSpan gre@(GRE { gre_lcl = lcl, gre_imp = iss } ) | lcl = greDefinitionSrcSpan gre | Just is <- headMaybe iss = is_dloc (is_decl is) @@ -756,16 +814,20 @@ availParent (AvailTC m _) = ParentIs m availParent (Avail {}) = NoParent -greParent_maybe :: GlobalRdrElt -> Maybe Name +greParent_maybe :: GlobalRdrEltX info -> Maybe Name greParent_maybe gre = case gre_par gre of NoParent -> Nothing ParentIs n -> Just n +gresToNameSet :: [GlobalRdrEltX info] -> NameSet +gresToNameSet gres = foldr add emptyNameSet gres + where add gre set = extendNameSet set (greName gre) + -- | Takes a list of distinct GREs and folds them -- into AvailInfos. This is more efficient than mapping each individual --- GRE to an AvailInfo and the folding using `plusAvail` but needs the +-- GRE to an AvailInfo and then folding using `plusAvail`, but needs the -- uniqueness assumption. -gresToAvailInfo :: [GlobalRdrElt] -> [AvailInfo] +gresToAvailInfo :: forall info. [GlobalRdrEltX info] -> [AvailInfo] gresToAvailInfo gres = nonDetNameEnvElts avail_env where @@ -773,7 +835,7 @@ gresToAvailInfo gres (avail_env, _) = foldl' add (emptyNameEnv, emptyNameSet) gres add :: (NameEnv AvailInfo, NameSet) - -> GlobalRdrElt + -> GlobalRdrEltX info -> (NameEnv AvailInfo, NameSet) add (env, done) gre | name `elemNameSet` done @@ -782,43 +844,68 @@ gresToAvailInfo gres = ( extendNameEnv_Acc comb availFromGRE env key gre , done `extendNameSet` name ) where - name = greMangledName gre + name = greName gre key = case greParent_maybe gre of Just parent -> parent - Nothing -> greMangledName gre + Nothing -> greName gre -- We want to insert the child `k` into a list of children but -- need to maintain the invariant that the parent is first. -- -- We also use the invariant that `k` is not already in `ns`. - insertChildIntoChildren :: Name -> [GreName] -> GreName -> [GreName] + insertChildIntoChildren :: Name -> [Name] -> Name -> [Name] insertChildIntoChildren _ [] k = [k] insertChildIntoChildren p (n:ns) k - | NormalGreName p == k = k:n:ns + | p == k = k:n:ns | otherwise = n:k:ns - comb :: GlobalRdrElt -> AvailInfo -> AvailInfo + comb :: GlobalRdrEltX info -> AvailInfo -> AvailInfo comb _ (Avail n) = Avail n -- Duplicated name, should not happen comb gre (AvailTC m ns) = case gre_par gre of - NoParent -> AvailTC m (gre_name gre:ns) -- Not sure this ever happens - ParentIs {} -> AvailTC m (insertChildIntoChildren m ns (gre_name gre)) + NoParent -> AvailTC m (greName gre:ns) -- Not sure this ever happens + ParentIs {} -> AvailTC m (insertChildIntoChildren m ns (greName gre)) -availFromGRE :: GlobalRdrElt -> AvailInfo +availFromGRE :: GlobalRdrEltX info -> AvailInfo availFromGRE (GRE { gre_name = child, gre_par = parent }) = case parent of - ParentIs p -> AvailTC p [child] - NoParent | NormalGreName me <- child, isTyConName me -> AvailTC me [child] - | otherwise -> Avail child + ParentIs p + -> AvailTC p [child] + NoParent + | isTyConName child -- NB: don't force the GREInfo field unnecessarily. + -> AvailTC child [child] + | otherwise + -> Avail child -emptyGlobalRdrEnv :: GlobalRdrEnv +emptyGlobalRdrEnv :: GlobalRdrEnvX info emptyGlobalRdrEnv = emptyOccEnv -globalRdrEnvElts :: GlobalRdrEnv -> [GlobalRdrElt] -globalRdrEnvElts env = foldOccEnv (++) [] env +globalRdrEnvElts :: GlobalRdrEnvX info -> [GlobalRdrEltX info] +globalRdrEnvElts env = nonDetFoldOccEnv (++) [] env + +-- | Drop all 'GREInfo' fields in a 'GlobalRdrEnv' in order to +-- avoid space leaks. +-- +-- See Note [Forcing GREInfo] in GHC.Types.GREInfo. +forceGlobalRdrEnv :: GlobalRdrEnvX info -> IfGlobalRdrEnv +forceGlobalRdrEnv rdrs = + strictMapOccEnv (strictMap (\ gre -> gre { gre_info = () })) rdrs -instance Outputable GlobalRdrElt where - ppr gre = hang (ppr (greMangledName gre) <+> ppr (gre_par gre)) +-- | Hydrate a previously dehydrated 'GlobalRdrEnv', +-- by (lazily!) looking up the 'GREInfo' using the provided function. +-- +-- See Note [Forcing GREInfo] in GHC.Types.GREInfo. +hydrateGlobalRdrEnv :: forall info noInfo + . (Name -> IO info) + -> GlobalRdrEnvX noInfo -> GlobalRdrEnvX info +hydrateGlobalRdrEnv f = mapOccEnv (fmap g) + where + g gre = gre { gre_info = unsafePerformIO $ f (greName gre) } + -- NB: use unsafePerformIO to delay the lookup until it is forced. + -- See also 'GHC.Rename.Env.lookupGREInfo'. + +instance Outputable info => Outputable (GlobalRdrEltX info) where + ppr gre = hang (ppr (greName gre) <+> ppr (gre_par gre) <+> ppr (gre_info gre)) 2 (pprNameProvenance gre) pprGlobalRdrEnv :: Bool -> GlobalRdrEnv -> SDoc @@ -831,66 +918,220 @@ pprGlobalRdrEnv locals_only env remove_locals gres | locals_only = filter isLocalGRE gres | otherwise = gres pp [] = empty - pp gres@(gre:_) = hang (ppr occ - <+> parens (text "unique" <+> ppr (getUnique occ)) - <> colon) - 2 (vcat (map ppr gres)) + pp gres@(gre:_) = hang (ppr occ <> colon) + 2 (vcat (map ppr gres)) where - occ = nameOccName (greMangledName gre) - -lookupGlobalRdrEnv :: GlobalRdrEnv -> OccName -> [GlobalRdrElt] -lookupGlobalRdrEnv env occ_name = case lookupOccEnv env occ_name of - Nothing -> [] - Just gres -> gres - -lookupGRE_RdrName :: RdrName -> GlobalRdrEnv -> [GlobalRdrElt] --- ^ Look for this 'RdrName' in the global environment. Omits record fields --- without selector functions (see Note [NoFieldSelectors] in GHC.Rename.Env). -lookupGRE_RdrName rdr_name env = - filter (not . isNoFieldSelectorGRE) (lookupGRE_RdrName' rdr_name env) - -lookupGRE_RdrName' :: RdrName -> GlobalRdrEnv -> [GlobalRdrElt] --- ^ Look for this 'RdrName' in the global environment. Includes record fields --- without selector functions (see Note [NoFieldSelectors] in GHC.Rename.Env). -lookupGRE_RdrName' rdr_name env - = case lookupOccEnv env (rdrNameOcc rdr_name) of - Nothing -> [] - Just gres -> pickGREs rdr_name gres - -lookupGRE_Name :: GlobalRdrEnv -> Name -> Maybe GlobalRdrElt --- ^ Look for precisely this 'Name' in the environment. This tests --- whether it is in scope, ignoring anything else that might be in --- scope with the same 'OccName'. -lookupGRE_Name env name - = lookupGRE_Name_OccName env name (nameOccName name) - -lookupGRE_GreName :: GlobalRdrEnv -> GreName -> Maybe GlobalRdrElt --- ^ Look for precisely this 'GreName' in the environment. This tests --- whether it is in scope, ignoring anything else that might be in --- scope with the same 'OccName'. -lookupGRE_GreName env gname - = lookupGRE_Name_OccName env (greNameMangledName gname) (occName gname) - -lookupGRE_FieldLabel :: GlobalRdrEnv -> FieldLabel -> Maybe GlobalRdrElt --- ^ Look for a particular record field selector in the environment, where the --- selector name and field label may be different: the GlobalRdrEnv is keyed on --- the label. See Note [GreNames] for why this happens. -lookupGRE_FieldLabel env fl - = lookupGRE_Name_OccName env (flSelector fl) (mkVarOccFS (field_label $ flLabel fl)) - -lookupGRE_Name_OccName :: GlobalRdrEnv -> Name -> OccName -> Maybe GlobalRdrElt --- ^ Look for precisely this 'Name' in the environment, but with an 'OccName' --- that might differ from that of the 'Name'. See 'lookupGRE_FieldLabel' and --- Note [GreNames]. -lookupGRE_Name_OccName env name occ - = case [ gre | gre <- lookupGlobalRdrEnv env occ - , greMangledName gre == name ] of + occ = nameOccName (greName gre) + +{- +Note [NoFieldSelectors] +~~~~~~~~~~~~~~~~~~~~~~~ +The NoFieldSelectors extension allows record fields to be defined without +bringing the corresponding selector functions into scope. However, such fields +may still be used in contexts such as record construction, pattern matching or +update. This requires us to distinguish contexts in which selectors are required +from those in which any field may be used. For example: + + {-# LANGUAGE NoFieldSelectors #-} + module M (T(foo), foo) where -- T(foo) refers to the field, + -- unadorned foo to the value binding + data T = MkT { foo :: Int } + foo = () + + bar = foo -- refers to the value binding, field ignored + + module N where + import M (T(..)) + baz = MkT { foo = 3 } -- refers to the field + oops = foo -- an error: the field is in scope but the value binding is not + +Each 'FieldLabel' indicates (in the 'flHasFieldSelector' field) whether the +FieldSelectors extension was enabled in the defining module. This allows them +to be filtered out by 'filterFieldGREs'. + +Even when NoFieldSelectors is in use, we still generate selector functions +internally. For example, the expression + getField @"foo" t +or (with dot-notation) + t.foo +extracts the `foo` field of t::T, and hence needs the selector function +(see Note [HasField instances] in GHC.Tc.Instance.Class). + +In many of the name lookup functions in this module we pass a FieldsOrSelectors +value, indicating what we are looking for: + + * WantNormal: fields are in scope only if they have an accompanying selector + function, e.g. we are looking up a variable in an expression + (lookupExprOccRn). + + * WantBoth: any name or field will do, regardless of whether the selector + function is available, e.g. record updates (lookupRecUpdFields) with + NoDisambiguateRecordFields. + + * WantField: any field will do, regardless of whether the selector function is + available, but ignoring any non-field names, e.g. record updates + (lookupRecUpdFields with DisambiguateRecordFields. + +----------------------------------------------------------------------------------- + Context FieldsOrSelectors +----------------------------------------------------------------------------------- + Record construction/pattern match WantField, but unless DisambiguateRecordFields + e.g. MkT { foo = 3 } is in effect, also look up using WantBoth + Record update, e.g. e { foo = 3 } to report when a non-field clashes with a field. + + :info in GHCi WantBoth + + Variable occurrence in expression WantNormal + Type variable, data constructor + Pretty much everything else +----------------------------------------------------------------------------------- +-} + +fieldGRE_maybe :: GlobalRdrElt -> Maybe FieldGlobalRdrElt +fieldGRE_maybe gre = do + guard (isRecFldGRE gre) + return gre + +fieldGRELabel :: HasDebugCallStack => FieldGlobalRdrElt -> FieldLabel +fieldGRELabel = recFieldLabel . fieldGREInfo + +fieldGREInfo :: HasDebugCallStack => FieldGlobalRdrElt -> RecFieldInfo +fieldGREInfo gre + = assertPpr (isRecFldGRE gre) (ppr gre) $ + case gre_info gre of + IAmRecField info -> info + info -> pprPanic "fieldGREInfo" $ + vcat [ text "gre_name:" <+> ppr (greName gre) + , text "info:" <+> ppr info ] + +recFieldConLike_maybe :: HasDebugCallStack => GlobalRdrElt -> Maybe ConInfo +recFieldConLike_maybe gre = + case gre_info gre of + IAmConLike info -> Just info + _ -> Nothing + +recFieldInfo_maybe :: HasDebugCallStack => GlobalRdrElt -> Maybe RecFieldInfo +recFieldInfo_maybe gre = + case gre_info gre of + IAmRecField info -> assertPpr (isRecFldGRE gre) (ppr gre) $ Just info + _ -> Nothing + +-- | When looking up GREs, we may or may not want to include fields that were +-- defined in modules with @NoFieldSelectors@ enabled. See Note +-- [NoFieldSelectors]. +data FieldsOrSelectors + = WantNormal -- ^ Include normal names, and fields with selectors, but + -- ignore fields without selectors. + | WantBoth -- ^ Include normal names and all fields (regardless of whether + -- they have selectors). + | WantField -- ^ Include only fields, with or without selectors, ignoring + -- any non-fields in scope. + deriving Eq + +filterFieldGREs :: FieldsOrSelectors -> [GlobalRdrElt] -> [GlobalRdrElt] +filterFieldGREs WantBoth = id +filterFieldGREs fos = filter (allowGRE fos) + +allowGRE :: FieldsOrSelectors -> GlobalRdrElt -> Bool +allowGRE WantBoth _ + = True +allowGRE WantNormal gre + -- NB: we only need to consult the GREInfo for record field GREs, + -- to check whether they define field selectors. + -- By checking 'isRecFldGRE' first, which only consults the NameSpace, + -- we avoid forcing the GREInfo for things that aren't record fields. + | isRecFldGRE gre + = flHasFieldSelector (fieldGRELabel gre) == FieldSelectors + | otherwise + = True +allowGRE WantField gre + = isRecFldGRE gre + +-- | How should we look up in a 'GlobalRdrEnv'? Should we only look up +-- names with the exact same 'OccName', or do we allow different 'NameSpace's? +-- +-- Depending on the answer, we might need more or less information from the +-- 'GlobalRdrEnv', e.g. if we want to include matching record fields we need +-- to know if the corresponding record fields define field selectors, for which +-- we need to consult the 'GREInfo'. This is why this datatype is a GADT. +-- +-- See Note [IfGlobalRdrEnv]. +data WhichGREs info where + -- | Look for this specific 'OccName', with the exact same 'NameSpace', + -- in the 'GlobalRdrEnv'. + SameOccName :: WhichGREs info + -- | If the 'OccName' is a variable, also look up in the record field namespaces. + -- + -- Used to look up variables which might refer to record fields. + IncludeFields :: FieldsOrSelectors + -- ^ - Should we include record fields defined with @-XNoFieldSelectors@? + -- - Should we include non-fields? + -- + -- See Note [NoFieldSelectors]. + -> WhichGREs GREInfo + -- | Like @'IncludeFields'@, but if the 'OccName' is a field, + -- also look up in the variable namespace. + -- + -- Used to check if there are name clashes. + AllNameSpaces :: FieldsOrSelectors -> WhichGREs GREInfo + +-- | Look for this 'OccName' in the global environment. +-- +-- The 'WhichGREs' argument specifies which 'GlobalRdrElt's we are interested in. +lookupGRE_OccName :: WhichGREs info -> GlobalRdrEnvX info -> OccName -> [GlobalRdrEltX info] +lookupGRE_OccName what env occ + -- If the 'RdrName' is a variable, we might also need + -- to look up in the record field namespaces. + | isVarOcc occ + , Just flds <- mb_flds + = normal ++ flds + -- If the 'RdrName' is a record field, we might want to check + -- the variable namespace too. + | isFieldOcc occ + , Just flds <- mb_flds + = flds ++ case what of { AllNameSpaces {} -> vars; _ -> [] } + | otherwise + = normal + + where + mb_flds = + case what of + IncludeFields fos -> Just $ filterFieldGREs fos $ concat $ lookupFieldsOccEnv env (occNameFS occ) + AllNameSpaces fos -> Just $ filterFieldGREs fos $ concat $ lookupFieldsOccEnv env (occNameFS occ) + SameOccName -> Nothing + + normal = fromMaybe [] $ lookupOccEnv env occ + vars = fromMaybe [] $ lookupOccEnv env (recFieldToVarOcc occ) + +-- | Like 'lookupGRE_OccName', but for a 'RdrName'. +lookupGRE_RdrName :: WhichGREs info -> GlobalRdrEnvX info -> RdrName -> [GlobalRdrEltX info] +lookupGRE_RdrName what env rdr = + pickGREs rdr $ lookupGRE_OccName what env (rdrNameOcc rdr) + +-- | Look for precisely this 'Name' in the environment. +-- +-- This tests whether it is in scope, ignoring anything +-- else that might be in scope which doesn't have the same 'Unique'. +lookupGRE_Name :: Outputable info => GlobalRdrEnvX info -> Name -> Maybe (GlobalRdrEltX info) +lookupGRE_Name env name = + let occ = nameOccName name + in case [ gre | gre <- lookupGRE_OccName SameOccName env occ + , gre_name gre == name ] of [] -> Nothing [gre] -> Just gre - gres -> pprPanic "lookupGRE_Name_OccName" + gres -> pprPanic "lookupGRE_Name" (ppr name $$ ppr occ $$ ppr gres) -- See INVARIANT 1 on GlobalRdrEnv +-- | Look for a particular record field selector in the environment. +lookupGRE_FieldLabel :: GlobalRdrEnv -> FieldLabel -> Maybe FieldGlobalRdrElt +lookupGRE_FieldLabel env fl = + case lookupGRE_Name env (flSelector fl) of + Nothing -> Nothing + Just gre -> + assertPpr (isRecFldGRE gre) + (vcat [ text "lookupGre_FieldLabel:" <+> ppr fl ]) $ + Just gre getGRE_NameQualifier_maybes :: GlobalRdrEnv -> Name -> [Maybe [ModuleName]] -- Returns all the qualifiers by which 'x' is in scope @@ -905,35 +1146,37 @@ getGRE_NameQualifier_maybes env name | lcl = Nothing | otherwise = Just $ map (is_as . is_decl) (bagToList iss) -isLocalGRE :: GlobalRdrElt -> Bool -isLocalGRE (GRE {gre_lcl = lcl }) = lcl +isLocalGRE :: GlobalRdrEltX info -> Bool +isLocalGRE (GRE { gre_lcl = lcl }) = lcl -isRecFldGRE :: GlobalRdrElt -> Bool -isRecFldGRE = isJust . greFieldLabel +-- | Is this a record field GRE? +-- +-- Important: does /not/ consult the 'GreInfo' field. +isRecFldGRE :: GlobalRdrEltX info -> Bool +isRecFldGRE (GRE { gre_name = nm }) = isFieldName nm isDuplicateRecFldGRE :: GlobalRdrElt -> Bool -- ^ Is this a record field defined with DuplicateRecordFields? --- (See Note [GreNames]) isDuplicateRecFldGRE = - maybe False ((DuplicateRecordFields ==) . flHasDuplicateRecordFields) . greFieldLabel + maybe False ((DuplicateRecordFields ==) . flHasDuplicateRecordFields) . greFieldLabel_maybe isNoFieldSelectorGRE :: GlobalRdrElt -> Bool -- ^ Is this a record field defined with NoFieldSelectors? -- (See Note [NoFieldSelectors] in GHC.Rename.Env) isNoFieldSelectorGRE = - maybe False ((NoFieldSelectors ==) . flHasFieldSelector) . greFieldLabel + maybe False ((NoFieldSelectors ==) . flHasFieldSelector) . greFieldLabel_maybe isFieldSelectorGRE :: GlobalRdrElt -> Bool -- ^ Is this a record field defined with FieldSelectors? -- (See Note [NoFieldSelectors] in GHC.Rename.Env) isFieldSelectorGRE = - maybe False ((FieldSelectors ==) . flHasFieldSelector) . greFieldLabel + maybe False ((FieldSelectors ==) . flHasFieldSelector) . greFieldLabel_maybe -greFieldLabel :: GlobalRdrElt -> Maybe FieldLabel +greFieldLabel_maybe :: GlobalRdrElt -> Maybe FieldLabel -- ^ Returns the field label of this GRE, if it has one -greFieldLabel = greNameFieldLabel . gre_name +greFieldLabel_maybe = fmap fieldGRELabel . fieldGRE_maybe -unQualOK :: GlobalRdrElt -> Bool +unQualOK :: GlobalRdrEltX info -> Bool -- ^ Test if an unqualified version of this thing would be in scope unQualOK (GRE {gre_lcl = lcl, gre_imp = iss }) | lcl = True @@ -972,7 +1215,7 @@ Now the "ambiguous occurrence" message can correctly report how the ambiguity arises. -} -pickGREs :: RdrName -> [GlobalRdrElt] -> [GlobalRdrElt] +pickGREs :: RdrName -> [GlobalRdrEltX info] -> [GlobalRdrEltX info] -- ^ Takes a list of GREs which have the right OccName 'x' -- Pick those GREs that are in scope -- * Qualified, as 'M.x' if want_qual is Qual M _ @@ -985,14 +1228,14 @@ pickGREs (Unqual {}) gres = mapMaybe pickUnqualGRE gres pickGREs (Qual mod _) gres = mapMaybe (pickQualGRE mod) gres pickGREs _ _ = [] -- I don't think this actually happens -pickUnqualGRE :: GlobalRdrElt -> Maybe GlobalRdrElt +pickUnqualGRE :: GlobalRdrEltX info -> Maybe (GlobalRdrEltX info) pickUnqualGRE gre@(GRE { gre_lcl = lcl, gre_imp = iss }) | not lcl, null iss' = Nothing | otherwise = Just (gre { gre_imp = iss' }) where iss' = filterBag unQualSpecOK iss -pickQualGRE :: ModuleName -> GlobalRdrElt -> Maybe GlobalRdrElt +pickQualGRE :: ModuleName -> GlobalRdrEltX info -> Maybe (GlobalRdrEltX info) pickQualGRE mod gre@(GRE { gre_lcl = lcl, gre_imp = iss }) | not lcl', null iss' = Nothing | otherwise = Just (gre { gre_lcl = lcl', gre_imp = iss' }) @@ -1005,7 +1248,7 @@ pickQualGRE mod gre@(GRE { gre_lcl = lcl, gre_imp = iss }) Just n_mod -> moduleName n_mod == mod Nothing -> False -pickGREsModExp :: ModuleName -> [GlobalRdrElt] -> [(GlobalRdrElt,GlobalRdrElt)] +pickGREsModExp :: ModuleName -> [GlobalRdrEltX info] -> [(GlobalRdrEltX info,GlobalRdrEltX info)] -- ^ Pick GREs that are in scope *both* qualified *and* unqualified -- Return each GRE that is, as a pair -- (qual_gre, unqual_gre) @@ -1021,12 +1264,15 @@ pickGREsModExp mod gres = mapMaybe (pickBothGRE mod) gres -- parser will generate Exact RdrNames for them, so the -- cluttered envt is no use. Really, it's only useful for -- GHC.Base and GHC.Tuple. -pickBothGRE :: ModuleName -> GlobalRdrElt -> Maybe (GlobalRdrElt, GlobalRdrElt) +pickBothGRE :: ModuleName -> GlobalRdrEltX info -> Maybe (GlobalRdrEltX info, GlobalRdrEltX info) pickBothGRE mod gre - | isBuiltInSyntax (greMangledName gre) = Nothing + | isBuiltInSyntax (greName gre) + = Nothing | Just gre1 <- pickQualGRE mod gre - , Just gre2 <- pickUnqualGRE gre = Just (gre1, gre2) - | otherwise = Nothing + , Just gre2 <- pickUnqualGRE gre + = Just (gre1, gre2) + | otherwise + = Nothing -- Building GlobalRdrEnvs @@ -1044,7 +1290,7 @@ mkGlobalRdrEnv gres insertGRE :: GlobalRdrElt -> [GlobalRdrElt] -> [GlobalRdrElt] insertGRE new_g [] = [new_g] insertGRE new_g (old_g : old_gs) - | gre_name new_g == gre_name old_g + | greName new_g == greName old_g = new_g `plusGRE` old_g : old_gs | otherwise = old_g : insertGRE new_g old_gs @@ -1055,7 +1301,8 @@ plusGRE g1 g2 = GRE { gre_name = gre_name g1 , gre_lcl = gre_lcl g1 || gre_lcl g2 , gre_imp = gre_imp g1 `unionBags` gre_imp g2 - , gre_par = gre_par g1 `plusParent` gre_par g2 } + , gre_par = gre_par g1 `plusParent` gre_par g2 + , gre_info = gre_info g1 `plusGREInfo` gre_info g2 } transformGREs :: (GlobalRdrElt -> GlobalRdrElt) -> [OccName] @@ -1077,9 +1324,10 @@ extendGlobalRdrEnv env gre {- Note [GlobalRdrEnv shadowing] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Before adding new names to the GlobalRdrEnv we nuke some existing entries; -this is "shadowing". The actual work is done by RdrEnv.shadowNames. +this is "shadowing". The actual work is done by GHC.Types.Name.Reader.shadowNames. Suppose - env' = shadowNames env f `extendGlobalRdrEnv` M.f + + env' = shadowNames env { f } `extendGlobalRdrEnv` { M.f } Then: * Looking up (Unqual f) in env' should succeed, returning M.f, @@ -1147,29 +1395,61 @@ There are two reasons for shadowing: rnSrcDecls will first call extendGlobalRdrEnvRn with C[f] from the class decl, and *separately* extend the envt with the value binding. At that stage, the class op 'f' will have an Internal name. + +Wrinkle [Shadowing namespaces] + + In the following GHCi session: + + > data A = MkA { foo :: Int } + > foo = False + > bar = foo + + We expect the variable 'foo' to shadow the record field 'foo', even though + they are in separate namespaces, so that the occurrence of 'foo' in the body + of 'bar' is not ambiguous. + -} -shadowNames :: GlobalRdrEnv -> OccEnv a -> GlobalRdrEnv +shadowNames :: GlobalRdrEnv -> GlobalRdrEnv -> GlobalRdrEnv -- Remove certain old GREs that share the same OccName as this new Name. -- See Note [GlobalRdrEnv shadowing] for details -shadowNames = minusOccEnv_C (\gres _ -> Just (mapMaybe shadow gres)) +shadowNames env new_gres = + minusOccEnv_C_Ns (nonDetStrictFoldUFM shadow_many) env new_gres where - shadow :: GlobalRdrElt -> Maybe GlobalRdrElt - shadow - old_gre@(GRE { gre_lcl = lcl, gre_imp = iss }) - = case greDefinitionModule old_gre of - Nothing -> Just old_gre -- Old name is Internal; do not shadow - Just old_mod - | null iss' -- Nothing remains - -> Nothing + shadow_many :: [GlobalRdrElt] + -> UniqFM NameSpace [GlobalRdrElt] + -> UniqFM NameSpace [GlobalRdrElt] + shadow_many news olds_map = + ( `mapMaybeUFM` olds_map ) $ \ olds -> + case foldl' shadow_one olds news of + res | null res + -> Nothing | otherwise - -> Just (old_gre { gre_lcl = False, gre_imp = iss' }) + -> Just res + + shadow_one :: [GlobalRdrElt] -> GlobalRdrElt -> [GlobalRdrElt] + shadow_one olds new = + ( `mapMaybe` olds ) $ \ old -> + if new `greClashesWith` old + then shadow old + else Just old + + shadow :: GlobalRdrElt -> Maybe GlobalRdrElt + shadow old_gre@(GRE { gre_lcl = lcl, gre_imp = iss }) = + case greDefinitionModule old_gre of + Nothing -> Just old_gre -- Old name is Internal; do not shadow + Just old_mod + | null iss' -- Nothing remains + -> Nothing - where - iss' = lcl_imp `unionBags` mapMaybeBag set_qual iss - lcl_imp | lcl = listToBag [mk_fake_imp_spec old_gre old_mod] - | otherwise = emptyBag + | otherwise + -> Just (old_gre { gre_lcl = False, gre_imp = iss' }) + + where + iss' = lcl_imp `unionBags` mapBag set_qual iss + lcl_imp | lcl = unitBag $ mk_fake_imp_spec old_gre old_mod + | otherwise = emptyBag mk_fake_imp_spec old_gre old_mod -- Urgh! = ImpSpec id_spec ImpAll @@ -1180,9 +1460,32 @@ shadowNames = minusOccEnv_C (\gres _ -> Just (mapMaybe shadow gres)) , is_qual = True , is_dloc = greDefinitionSrcSpan old_gre } - set_qual :: ImportSpec -> Maybe ImportSpec - set_qual is = Just (is { is_decl = (is_decl is) { is_qual = True } }) + set_qual :: ImportSpec -> ImportSpec + set_qual is = is { is_decl = (is_decl is) { is_qual = True } } + + +-- | @greClashesWith gre old_gre@ computes whether @gre@ clashes with @old_gre@ +-- (assuming they both have the same underlying 'occNameFS'). +greClashesWith :: GlobalRdrElt -> (GlobalRdrElt -> Bool) +greClashesWith gre old_gre + | ns == old_ns + = True + -- A new variable shadows record fields with field selectors. + | ns == varName + = isFieldSelectorGRE old_gre + + -- A new record field... + | isFieldNameSpace ns + -- ... shadows variables if it defines a field selector. + = ( old_ns == varName && isFieldSelectorGRE gre ) + -- ... shadows record fields unless it is a duplicate record field. + || ( isFieldNameSpace old_ns && not (isDuplicateRecFldGRE gre) ) + | otherwise + = False + where + ns = occNameSpace $ greOccName gre + old_ns = occNameSpace $ greOccName old_gre {- ************************************************************************ @@ -1336,14 +1639,13 @@ isExplicitItem :: ImpItemSpec -> Bool isExplicitItem ImpAll = False isExplicitItem (ImpSome {is_explicit = exp}) = exp -pprNameProvenance :: GlobalRdrElt -> SDoc +pprNameProvenance :: GlobalRdrEltX info -> SDoc -- ^ Print out one place where the name was define/imported -- (With -dppr-debug, print them all) -pprNameProvenance gre@(GRE { gre_lcl = lcl, gre_imp = iss }) +pprNameProvenance (GRE { gre_name = name, gre_lcl = lcl, gre_imp = iss }) = ifPprDebug (vcat pp_provs) (head pp_provs) where - name = greMangledName gre pp_provs = pp_lcl ++ map pp_is (bagToList iss) pp_lcl = if lcl then [text "defined at" <+> ppr (nameSrcLoc name)] else [] diff --git a/compiler/GHC/Types/Name/Shape.hs b/compiler/GHC/Types/Name/Shape.hs index 19e97ef2c6..18adadd5a0 100644 --- a/compiler/GHC/Types/Name/Shape.hs +++ b/compiler/GHC/Types/Name/Shape.hs @@ -17,9 +17,7 @@ import GHC.Driver.Env import GHC.Unit.Module -import GHC.Types.Unique.FM import GHC.Types.Avail -import GHC.Types.FieldLabel import GHC.Types.Name import GHC.Types.Name.Env @@ -87,7 +85,7 @@ mkNameShape :: ModuleName -> [AvailInfo] -> NameShape mkNameShape mod_name as = NameShape mod_name as $ mkOccEnv $ do a <- as - n <- availName a : availNamesWithSelectors a + n <- availName a : availNames a return (occName n, n) -- | Given an existing 'NameShape', merge it with a list of 'AvailInfo's @@ -180,24 +178,14 @@ substName env n | Just n' <- lookupNameEnv env n = n' -- for type constructors, where it is sufficient to substitute the 'availName' -- to induce a substitution on 'availNames'. substNameAvailInfo :: HscEnv -> ShNameSubst -> AvailInfo -> IO AvailInfo -substNameAvailInfo _ env (Avail (NormalGreName n)) = return (Avail (NormalGreName (substName env n))) -substNameAvailInfo _ env (Avail (FieldGreName fl)) = - return (Avail (FieldGreName fl { flSelector = substName env (flSelector fl) })) +substNameAvailInfo _ env (Avail gre) = + return $ Avail (substName env gre) substNameAvailInfo hsc_env env (AvailTC n ns) = let mb_mod = fmap nameModule (lookupNameEnv env n) - in AvailTC (substName env n) <$> mapM (setNameGreName hsc_env mb_mod) ns + in AvailTC (substName env n) <$> mapM (setName hsc_env mb_mod) ns -setNameGreName :: HscEnv -> Maybe Module -> GreName -> IO GreName -setNameGreName hsc_env mb_mod gname = case gname of - NormalGreName n -> NormalGreName <$> initIfaceLoad hsc_env (setNameModule mb_mod n) - FieldGreName fl -> FieldGreName <$> setNameFieldSelector hsc_env mb_mod fl - --- | Set the 'Module' of a 'FieldSelector' -setNameFieldSelector :: HscEnv -> Maybe Module -> FieldLabel -> IO FieldLabel -setNameFieldSelector _ Nothing f = return f -setNameFieldSelector hsc_env mb_mod (FieldLabel l b has_sel sel) = do - sel' <- initIfaceLoad hsc_env $ setNameModule mb_mod sel - return (FieldLabel l b has_sel sel') +setName :: HscEnv -> Maybe Module -> Name -> IO Name +setName hsc_env mb_mod nm = initIfaceLoad hsc_env (setNameModule mb_mod nm) {- ************************************************************************ @@ -226,19 +214,19 @@ mergeAvails as1 as2 = -- with only name holes from @flexi@ unifiable (all other name holes rigid.) uAvailInfos :: ModuleName -> [AvailInfo] -> [AvailInfo] -> Either HsigShapeMismatchReason ShNameSubst uAvailInfos flexi as1 as2 = -- pprTrace "uAvailInfos" (ppr as1 $$ ppr as2) $ - let mkOE as = listToUFM $ do a <- as - n <- availNames a - return (nameOccName n, a) + let mkOE as = mkOccEnv [(nameOccName n, a) | a <- as, n <- availNames a] in foldM (\subst (a1, a2) -> uAvailInfo flexi subst a1 a2) emptyNameEnv - (nonDetEltsUFM (intersectUFM_C (,) (mkOE as1) (mkOE as2))) + (nonDetOccEnvElts $ intersectOccEnv_C (,) (mkOE as1) (mkOE as2)) -- Edward: I have to say, this is pretty clever. -- | Unify two 'AvailInfo's, given an existing substitution @subst@, -- with only name holes from @flexi@ unifiable (all other name holes rigid.) uAvailInfo :: ModuleName -> ShNameSubst -> AvailInfo -> AvailInfo -> Either HsigShapeMismatchReason ShNameSubst -uAvailInfo flexi subst (Avail (NormalGreName n1)) (Avail (NormalGreName n2)) = uName flexi subst n1 n2 -uAvailInfo flexi subst (AvailTC n1 _) (AvailTC n2 _) = uName flexi subst n1 n2 +uAvailInfo flexi subst (Avail n1) (Avail n2) + = uName flexi subst n1 n2 +uAvailInfo flexi subst (AvailTC n1 _) (AvailTC n2 _) + = uName flexi subst n1 n2 uAvailInfo _ _ a1 a2 = Left $ HsigShapeSortMismatch a1 a2 -- | Unify two 'Name's, given an existing substitution @subst@, diff --git a/compiler/GHC/Types/TyThing.hs b/compiler/GHC/Types/TyThing.hs index ab400204d5..cb7b57095c 100644 --- a/compiler/GHC/Types/TyThing.hs +++ b/compiler/GHC/Types/TyThing.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE LambdaCase #-} + -- | A global typecheckable-thing, essentially anything that has a name. module GHC.Types.TyThing ( TyThing (..) @@ -15,7 +17,7 @@ module GHC.Types.TyThing , isImplicitTyThing , tyThingParent_maybe , tyThingsTyCoVars - , tyThingAvailInfo + , tyThingLocalGREs, tyThingGREInfo , tyThingTyCon , tyThingCoAxiom , tyThingDataCon @@ -27,11 +29,12 @@ where import GHC.Prelude import GHC.Types.Name +import GHC.Types.Name.Reader import GHC.Types.Var import GHC.Types.Var.Set import GHC.Types.Id import GHC.Types.Id.Info -import GHC.Types.Avail +import GHC.Types.Unique.Set import GHC.Core.Class import GHC.Core.DataCon @@ -276,22 +279,83 @@ tyThingsTyCoVars tts = Nothing -> tyCoVarsOfType $ tyConKind tc ttToVarSet (ACoAxiom _) = emptyVarSet --- | The Names that a TyThing should bring into scope. Used to build --- the GlobalRdrEnv for the InteractiveContext. -tyThingAvailInfo :: TyThing -> [AvailInfo] -tyThingAvailInfo (ATyCon t) - = case tyConClass_maybe t of - Just c -> [availTC n ((n : map getName (classMethods c) - ++ map getName (classATs c))) [] ] - where n = getName c - Nothing -> [availTC n (n : map getName dcs) flds] - where n = getName t - dcs = tyConDataCons t - flds = tyConFieldLabels t -tyThingAvailInfo (AConLike (PatSynCon p)) - = avail (getName p) : map availField (patSynFieldLabels p) -tyThingAvailInfo t - = [avail (getName t)] +-- | The 'GlobalRdrElt's that a 'TyThing' should bring into scope. +-- Used to build the 'GlobalRdrEnv' for the InteractiveContext. +tyThingLocalGREs :: TyThing -> [GlobalRdrElt] +tyThingLocalGREs ty_thing = + case ty_thing of + ATyCon t + | Just c <- tyConClass_maybe t + -> myself NoParent + : ( map (localVanillaGRE (ParentIs $ className c) . getName) (classMethods c) + ++ map tc_GRE (classATs c) ) + | otherwise + -> let dcs = tyConDataCons t + par = ParentIs $ tyConName t + mk_nm = DataConName . dataConName + in myself NoParent + : map (dc_GRE par) dcs + ++ + localFieldGREs par + [ (mk_nm dc, con_info) + | dc <- dcs + , let con_info = conLikeConInfo (RealDataCon dc) ] + AConLike con -> + let par = case con of + PatSynCon {} -> NoParent + -- NoParent for local pattern synonyms as per + -- Note [Parents] in GHC.Types.Name.Reader. + RealDataCon dc -> ParentIs $ tyConName $ dataConTyCon dc + in + myself par : + localFieldGREs par + [(conLikeConLikeName con, conLikeConInfo con)] + AnId id + | RecSelId { sel_tycon = RecSelData tc } <- idDetails id + -> [ myself (ParentIs $ tyConName tc) ] + -- Fallback to NoParent for PatSyn record selectors, + -- as per Note [Parents] in GHC.Types.Name.Reader. + _ -> [ myself NoParent ] + where + tc_GRE :: TyCon -> GlobalRdrElt + tc_GRE at = localTyConGRE + (fmap tyConName $ tyConFlavour at) + (tyConName at) + dc_GRE :: Parent -> DataCon -> GlobalRdrElt + dc_GRE par dc = + let con_info = conLikeConInfo (RealDataCon dc) + in localConLikeGRE par (DataConName $ dataConName dc, con_info) + myself :: Parent -> GlobalRdrElt + myself p = + (localVanillaGRE p (getName ty_thing)) + { gre_info = tyThingGREInfo ty_thing } + +-- | Obtain information pertinent to the renamer about a particular 'TyThing'. +-- +-- This extracts out renamer information from typechecker information. +tyThingGREInfo :: TyThing -> GREInfo +tyThingGREInfo = \case + AConLike con -> IAmConLike $ conLikeConInfo con + AnId id -> case idDetails id of + RecSelId { sel_tycon = parent, sel_fieldLabel = fl } -> + let relevant_cons = case parent of + RecSelPatSyn ps -> unitUniqSet $ PatSynName (patSynName ps) + RecSelData tc -> + let dcs = map RealDataCon $ tyConDataCons tc in + case conLikesWithFields dcs [flLabel fl] of + [] -> pprPanic "tyThingGREInfo: no DataCons with this FieldLabel" $ + vcat [ text "id:" <+> ppr id + , text "fl:" <+> ppr fl + , text "dcs:" <+> ppr dcs ] + cons -> mkUniqSet $ map conLikeConLikeName cons + in IAmRecField $ + RecFieldInfo + { recFieldLabel = fl + , recFieldCons = relevant_cons } + _ -> Vanilla + ATyCon tc -> + IAmTyCon (fmap tyConName $ tyConFlavour tc) + _ -> Vanilla -- | Get the 'TyCon' from a 'TyThing' if it is a type constructor thing. Panics otherwise tyThingTyCon :: HasDebugCallStack => TyThing -> TyCon diff --git a/compiler/GHC/Types/TypeEnv.hs b/compiler/GHC/Types/TypeEnv.hs index a431c3ddfc..75d6855a4c 100644 --- a/compiler/GHC/Types/TypeEnv.hs +++ b/compiler/GHC/Types/TypeEnv.hs @@ -93,4 +93,3 @@ extendTypeEnvWithIds env ids plusTypeEnv :: TypeEnv -> TypeEnv -> TypeEnv plusTypeEnv env1 env2 = plusNameEnv env1 env2 - diff --git a/compiler/GHC/Types/Unique/FM.hs b/compiler/GHC/Types/Unique/FM.hs index 137e985f92..bdd14156dd 100644 --- a/compiler/GHC/Types/Unique/FM.hs +++ b/compiler/GHC/Types/Unique/FM.hs @@ -44,7 +44,7 @@ module GHC.Types.Unique.FM ( addListToUFM,addListToUFM_C, addToUFM_Directly, addListToUFM_Directly, - adjustUFM, alterUFM, + adjustUFM, alterUFM, alterUFM_Directly, adjustUFM_Directly, delFromUFM, delFromUFM_Directly, @@ -64,10 +64,11 @@ module GHC.Types.Unique.FM ( intersectUFM_C, disjointUFM, equalKeysUFM, - nonDetStrictFoldUFM, foldUFM, nonDetStrictFoldUFM_DirectlyM, + nonDetStrictFoldUFM, nonDetFoldUFM, nonDetStrictFoldUFM_DirectlyM, + nonDetFoldWithKeyUFM, nonDetStrictFoldUFM_Directly, anyUFM, allUFM, seqEltsUFM, - mapUFM, mapUFM_Directly, + mapUFM, mapUFM_Directly, strictMapUFM, mapMaybeUFM, elemUFM, elemUFM_Directly, filterUFM, filterUFM_Directly, partitionUFM, @@ -165,10 +166,10 @@ addToUFM_Directly (UFM m) u v = UFM (M.insert (getKey u) v m) addToUFM_C :: Uniquable key - => (elt -> elt -> elt) -- old -> new -> result - -> UniqFM key elt -- old - -> key -> elt -- new - -> UniqFM key elt -- result + => (elt -> elt -> elt) -- ^ old -> new -> result + -> UniqFM key elt -- ^ old + -> key -> elt -- ^ new + -> UniqFM key elt -- ^ result -- Arguments of combining function of M.insertWith and addToUFM_C are flipped. addToUFM_C f (UFM m) k v = UFM (M.insertWith (flip f) (getKey $ getUnique k) v m) @@ -177,9 +178,9 @@ addToUFM_Acc :: Uniquable key => (elt -> elts -> elts) -- Add to existing -> (elt -> elts) -- New element - -> UniqFM key elts -- old + -> UniqFM key elts -- old -> key -> elt -- new - -> UniqFM key elts -- result + -> UniqFM key elts -- result addToUFM_Acc exi new (UFM m) k v = UFM (M.insertWith (\_new old -> exi v old) (getKey $ getUnique k) (new v) m) @@ -188,11 +189,11 @@ addToUFM_Acc exi new (UFM m) k v = -- otherwise compute the element to add using the passed function. addToUFM_L :: Uniquable key - => (key -> elt -> elt -> elt) -- key,old,new + => (key -> elt -> elt -> elt) -- ^ key,old,new -> key -> elt -- new -> UniqFM key elt - -> (Maybe elt, UniqFM key elt) -- old, result + -> (Maybe elt, UniqFM key elt) -- ^ old, result addToUFM_L f k v (UFM m) = coerce $ M.insertLookupWithKey @@ -203,12 +204,19 @@ addToUFM_L f k v (UFM m) = alterUFM :: Uniquable key - => (Maybe elt -> Maybe elt) -- How to adjust - -> UniqFM key elt -- old - -> key -- new - -> UniqFM key elt -- result + => (Maybe elt -> Maybe elt) -- ^ How to adjust + -> UniqFM key elt -- ^ old + -> key -- ^ new + -> UniqFM key elt -- ^ result alterUFM f (UFM m) k = UFM (M.alter f (getKey $ getUnique k) m) +alterUFM_Directly + :: (Maybe elt -> Maybe elt) -- ^ How to adjust + -> UniqFM key elt -- ^ old + -> Unique -- ^ new + -> UniqFM key elt -- ^ result +alterUFM_Directly f (UFM m) k = UFM (M.alter f (getKey k) m) + -- | Add elements to the map, combining existing values with inserted ones using -- the given function. addListToUFM_C @@ -356,8 +364,18 @@ intersectUFM_C f (UFM x) (UFM y) = UFM (M.intersectionWith f x y) disjointUFM :: UniqFM key elt1 -> UniqFM key elt2 -> Bool disjointUFM (UFM x) (UFM y) = M.disjoint x y -foldUFM :: (elt -> a -> a) -> a -> UniqFM key elt -> a -foldUFM k z (UFM m) = M.foldr k z m +-- | Fold over a 'UniqFM'. +-- +-- Non-deterministic, unless the folding function is commutative +-- (i.e. @a1 `f` ( a2 `f` b ) == a2 `f` ( a1 `f` b )@ for all @a1@, @a2@, @b@). +nonDetFoldUFM :: (elt -> a -> a) -> a -> UniqFM key elt -> a +nonDetFoldUFM f z (UFM m) = M.foldr f z m + +-- | Like 'nonDetFoldUFM', but with the 'Unique' key as well. +nonDetFoldWithKeyUFM :: (Unique -> elt -> a -> a) -> a -> UniqFM key elt -> a +nonDetFoldWithKeyUFM f z (UFM m) = M.foldrWithKey f' z m + where + f' k e a = f (getUnique k) e a mapUFM :: (elt1 -> elt2) -> UniqFM key elt1 -> UniqFM key elt2 mapUFM f (UFM m) = UFM (M.map f m) @@ -368,6 +386,9 @@ mapMaybeUFM f (UFM m) = UFM (M.mapMaybe f m) mapUFM_Directly :: (Unique -> elt1 -> elt2) -> UniqFM key elt1 -> UniqFM key elt2 mapUFM_Directly f (UFM m) = UFM (M.mapWithKey (f . getUnique) m) +strictMapUFM :: (a -> b) -> UniqFM k a -> UniqFM k b +strictMapUFM f (UFM a) = UFM $ MS.map f a + filterUFM :: (elt -> Bool) -> UniqFM key elt -> UniqFM key elt filterUFM p (UFM m) = UFM (M.filter p m) @@ -411,7 +432,7 @@ allUFM :: (elt -> Bool) -> UniqFM key elt -> Bool allUFM p (UFM m) = M.foldr ((&&) . p) True m seqEltsUFM :: (elt -> ()) -> UniqFM key elt -> () -seqEltsUFM seqElt = foldUFM (\v rest -> seqElt v `seq` rest) () +seqEltsUFM seqElt = nonDetFoldUFM (\v rest -> seqElt v `seq` rest) () -- See Note [Deterministic UniqFM] to learn about nondeterminism. -- If you use this please provide a justification why it doesn't introduce diff --git a/compiler/GHC/Types/Unique/Map.hs b/compiler/GHC/Types/Unique/Map.hs index 4f79792811..6bfe5bb5ff 100644 --- a/compiler/GHC/Types/Unique/Map.hs +++ b/compiler/GHC/Types/Unique/Map.hs @@ -237,4 +237,4 @@ nonDetEltsUniqMap :: UniqMap k a -> [(k, a)] nonDetEltsUniqMap (UniqMap m) = nonDetEltsUFM m nonDetFoldUniqMap :: ((k, a) -> b -> b) -> b -> UniqMap k a -> b -nonDetFoldUniqMap go z (UniqMap m) = foldUFM go z m +nonDetFoldUniqMap go z (UniqMap m) = nonDetFoldUFM go z m diff --git a/compiler/GHC/Types/Unique/Set.hs b/compiler/GHC/Types/Unique/Set.hs index 88e56f9e44..56710ebe9a 100644 --- a/compiler/GHC/Types/Unique/Set.hs +++ b/compiler/GHC/Types/Unique/Set.hs @@ -72,7 +72,7 @@ emptyUniqSet = UniqSet emptyUFM unitUniqSet :: Uniquable a => a -> UniqSet a unitUniqSet x = UniqSet $ unitUFM x x -mkUniqSet :: Uniquable a => [a] -> UniqSet a +mkUniqSet :: Uniquable a => [a] -> UniqSet a mkUniqSet = foldl' addOneToUniqSet emptyUniqSet addOneToUniqSet :: Uniquable a => UniqSet a -> a -> UniqSet a @@ -186,7 +186,7 @@ getUniqSet = getUniqSet' -- | 'unsafeUFMToUniqSet' converts a @'UniqFM' a@ into a @'UniqSet' a@ -- assuming, without checking, that it maps each 'Unique' to a value -- that has that 'Unique'. See Note [UniqSet invariant]. -unsafeUFMToUniqSet :: UniqFM a a -> UniqSet a +unsafeUFMToUniqSet :: UniqFM a a -> UniqSet a unsafeUFMToUniqSet = UniqSet instance Outputable a => Outputable (UniqSet a) where diff --git a/compiler/GHC/Unit/Module/Env.hs b/compiler/GHC/Unit/Module/Env.hs index aec4add585..c982539688 100644 --- a/compiler/GHC/Unit/Module/Env.hs +++ b/compiler/GHC/Unit/Module/Env.hs @@ -6,6 +6,7 @@ module GHC.Unit.Module.Env , extendModuleEnvList_C, plusModuleEnv_C , delModuleEnvList, delModuleEnv, plusModuleEnv, lookupModuleEnv , lookupWithDefaultModuleEnv, mapModuleEnv, mkModuleEnv, emptyModuleEnv + , alterModuleEnv , partitionModuleEnv , moduleEnvKeys, moduleEnvElts, moduleEnvToList , unitModuleEnv, isEmptyModuleEnv @@ -147,6 +148,9 @@ partitionModuleEnv f (ModuleEnv e) = (ModuleEnv a, ModuleEnv b) where (a,b) = Map.partition f e +alterModuleEnv :: (Maybe a -> Maybe a) -> Module -> ModuleEnv a -> ModuleEnv a +alterModuleEnv f m (ModuleEnv e) = ModuleEnv (Map.alter f (NDModule m) e) + mkModuleEnv :: [(Module, a)] -> ModuleEnv a mkModuleEnv xs = ModuleEnv (Map.fromList [(NDModule k, v) | (k,v) <- xs]) diff --git a/compiler/GHC/Unit/Module/ModIface.hs b/compiler/GHC/Unit/Module/ModIface.hs index 9838f227b9..c981a92bc2 100644 --- a/compiler/GHC/Unit/Module/ModIface.hs +++ b/compiler/GHC/Unit/Module/ModIface.hs @@ -206,7 +206,7 @@ data ModIface_ (phase :: ModIfacePhase) -- combined with mi_decls allows us to restart code generation. -- See Note [Interface Files with Core Definitions] and Note [Interface File with Core: Sharing RHSs] - mi_globals :: !(Maybe GlobalRdrEnv), + mi_globals :: !(Maybe IfGlobalRdrEnv), -- ^ Binds all the things defined at the top level in -- the /original source/ code for this module. which -- is NOT the same as mi_exports, nor mi_decls (which @@ -558,7 +558,7 @@ instance ( NFData (IfaceBackendExts (phase :: ModIfacePhase)) , mi_decls, mi_extra_decls, mi_globals, mi_insts , mi_fam_insts, mi_rules, mi_hpc, mi_trust, mi_trust_pkg , mi_complete_matches, mi_docs, mi_final_exts - , mi_ext_fields, mi_src_hash}) + , mi_ext_fields, mi_src_hash }) = rnf mi_module `seq` rnf mi_sig_of `seq` mi_hsc_src @@ -572,6 +572,10 @@ instance ( NFData (IfaceBackendExts (phase :: ModIfacePhase)) `seq` rnf mi_decls `seq` rnf mi_extra_decls `seq` mi_globals + -- NB: we already removed any potential space leaks in 'mi_globals' by + -- dehydrating, that is, by turning the 'GlobalRdrEnv' into a 'IfGlobalRdrEnv'. + -- This means we don't need to use 'rnf' here. + -- See Note [Forcing GREInfo] in GHC.Types.GREInfo. `seq` rnf mi_insts `seq` rnf mi_fam_insts `seq` rnf mi_rules diff --git a/compiler/GHC/Utils/Binary.hs b/compiler/GHC/Utils/Binary.hs index 7d07cfeba0..7534d65918 100644 --- a/compiler/GHC/Utils/Binary.hs +++ b/compiler/GHC/Utils/Binary.hs @@ -1260,16 +1260,6 @@ instance Binary ModuleName where put_ bh (ModuleName fs) = put_ bh fs get bh = do fs <- get bh; return (ModuleName fs) --- instance Binary FunctionOrData where --- put_ bh IsFunction = putByte bh 0 --- put_ bh IsData = putByte bh 1 --- get bh = do --- h <- getByte bh --- case h of --- 0 -> return IsFunction --- 1 -> return IsData --- _ -> panic "Binary FunctionOrData" - -- instance Binary TupleSort where -- put_ bh BoxedTuple = putByte bh 0 -- put_ bh UnboxedTuple = putByte bh 1 diff --git a/compiler/GHC/Utils/Monad.hs b/compiler/GHC/Utils/Monad.hs index d91570223c..e5a8007865 100644 --- a/compiler/GHC/Utils/Monad.hs +++ b/compiler/GHC/Utils/Monad.hs @@ -11,6 +11,7 @@ module GHC.Utils.Monad , MonadIO(..) , zipWith3M, zipWith3M_, zipWith4M, zipWithAndUnzipM + , zipWith3MNE , mapAndUnzipM, mapAndUnzip3M, mapAndUnzip4M, mapAndUnzip5M , mapAccumLM , mapSndM @@ -97,6 +98,15 @@ zipWithAndUnzipM f (x:xs) (y:ys) ; return (c:cs, d:ds) } zipWithAndUnzipM _ _ _ = return ([], []) +-- | 'zipWith3M' for 'NonEmpty' lists. +zipWith3MNE :: Monad m + => (a -> b -> c -> m d) + -> NonEmpty a -> NonEmpty b -> NonEmpty c -> m (NonEmpty d) +zipWith3MNE f ~(x :| xs) ~(y :| ys) ~(z :| zs) + = do { w <- f x y z + ; ws <- zipWith3M f xs ys zs + ; return $ w :| ws } + {- Note [Inline @mapAndUnzipNM@ functions] diff --git a/compiler/GHC/Utils/Outputable.hs b/compiler/GHC/Utils/Outputable.hs index 55e2bb2a9a..f63d515b83 100644 --- a/compiler/GHC/Utils/Outputable.hs +++ b/compiler/GHC/Utils/Outputable.hs @@ -31,7 +31,8 @@ module GHC.Utils.Outputable ( SDoc, runSDoc, PDoc(..), docToSDoc, interppSP, interpp'SP, interpp'SP', - pprQuotedList, pprWithCommas, quotedListWithOr, quotedListWithNor, + pprQuotedList, pprWithCommas, + quotedListWithOr, quotedListWithNor, quotedListWithAnd, pprWithBars, spaceIfSingleQuote, isEmpty, nest, @@ -150,6 +151,7 @@ import Numeric (showFFloat) import Data.Graph (SCC(..)) import Data.List (intersperse) import Data.List.NonEmpty (NonEmpty (..)) +import Data.Semigroup (Arg(..)) import qualified Data.List.NonEmpty as NEL import Data.Time import Data.Time.Format.ISO8601 @@ -949,6 +951,9 @@ instance (Outputable a) => Outputable [a] where instance (Outputable a) => Outputable (NonEmpty a) where ppr = ppr . NEL.toList +instance (Outputable a, Outputable b) => Outputable (Arg a b) where + ppr (Arg a b) = text "Arg" <+> ppr a <+> ppr b + instance (Outputable a) => Outputable (Set a) where ppr s = braces (pprWithCommas ppr (Set.toList s)) @@ -1383,6 +1388,11 @@ quotedListWithNor :: [SDoc] -> SDoc quotedListWithNor xs@(_:_:_) = quotedList (init xs) <+> text "nor" <+> quotes (last xs) quotedListWithNor xs = quotedList xs +quotedListWithAnd :: [SDoc] -> SDoc +-- [x,y,z] ==> `x', `y' and `z' +quotedListWithAnd xs@(_:_:_) = quotedList (init xs) <+> text "and" <+> quotes (last xs) +quotedListWithAnd xs = quotedList xs + {- ************************************************************************ * * diff --git a/compiler/Language/Haskell/Syntax/Decls.hs b/compiler/Language/Haskell/Syntax/Decls.hs index 0af2cfbf94..52475a9dfe 100644 --- a/compiler/Language/Haskell/Syntax/Decls.hs +++ b/compiler/Language/Haskell/Syntax/Decls.hs @@ -45,7 +45,7 @@ module Language.Haskell.Syntax.Decls ( FamilyDecl(..), LFamilyDecl, -- ** Instance declarations - InstDecl(..), LInstDecl, FamilyInfo(..), + InstDecl(..), LInstDecl, FamilyInfo(..), familyInfoTyConFlavour, TyFamInstDecl(..), LTyFamInstDecl, TyFamDefltDecl, LTyFamDefltDecl, DataFamInstDecl(..), LDataFamInstDecl, @@ -99,12 +99,14 @@ import Language.Haskell.Syntax.Extension import Language.Haskell.Syntax.Type import Language.Haskell.Syntax.Basic (Role) -import GHC.Types.Basic (TopLevelFlag, OverlapMode, RuleName, Activation) +import GHC.Types.Basic (TopLevelFlag, OverlapMode, RuleName, Activation + ,TyConFlavour(..), TypeOrData(..)) import GHC.Types.ForeignCall (CType, CCallConv, Safety, Header, CLabelString, CCallTarget, CExportSpec) import GHC.Types.Fixity (LexicalFixity) import GHC.Core.Type (Specificity) import GHC.Unit.Module.Warnings (WarningTxt) +import GHC.Utils.Panic.Plain ( assert ) import GHC.Hs.Doc (LHsDoc) -- ROMES:TODO Discuss in #21592 whether this is parsed AST or base AST @@ -863,6 +865,28 @@ data FamilyInfo pass -- said "type family Foo x where .." | ClosedTypeFamily (Maybe [LTyFamInstEqn pass]) +familyInfoTyConFlavour + :: Maybe tc -- ^ Just cls <=> this is an associated family of class cls + -> FamilyInfo pass + -> TyConFlavour tc +familyInfoTyConFlavour mb_parent_tycon info = + case info of + DataFamily -> OpenFamilyFlavour IAmData mb_parent_tycon + OpenTypeFamily -> OpenFamilyFlavour IAmType mb_parent_tycon + ClosedTypeFamily _ -> assert (isNothing mb_parent_tycon) + -- See Note [Closed type family mb_parent_tycon] + ClosedTypeFamilyFlavour + +{- Note [Closed type family mb_parent_tycon] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There's no way to write a closed type family inside a class declaration: + + class C a where + type family F a where -- error: parse error on input ‘where’ + +In fact, it is not clear what the meaning of such a declaration would be. +Therefore, 'mb_parent_tycon' of any closed type family has to be Nothing. +-} {- ********************************************************************* * * diff --git a/compiler/Language/Haskell/Syntax/Expr.hs b/compiler/Language/Haskell/Syntax/Expr.hs index 1af91044dd..46419787f8 100644 --- a/compiler/Language/Haskell/Syntax/Expr.hs +++ b/compiler/Language/Haskell/Syntax/Expr.hs @@ -5,6 +5,7 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] @@ -39,7 +40,6 @@ import GHC.Data.FastString (FastString) -- libraries: import Data.Data hiding (Fixity(..)) import Data.Bool -import Data.Either import Data.Eq import Data.Maybe import Data.List.NonEmpty ( NonEmpty ) @@ -147,6 +147,19 @@ type LHsRecProj p arg = XRec p (RecProj p arg) type RecUpdProj p = RecProj p (LHsExpr p) type LHsRecUpdProj p = XRec p (RecUpdProj p) +-- | Haskell Record Update Fields. +data LHsRecUpdFields p where + -- | A regular (non-overloaded) record update. + RegularRecUpdFields + :: { xRecUpdFields :: XLHsRecUpdLabels p + , recUpdFields :: [LHsRecUpdField p p] } + -> LHsRecUpdFields p + -- | An overloaded record update. + OverloadedRecUpdFields + :: { xOLRecUpdFields :: XLHsOLRecUpdLabels p + , olRecUpdFields :: [LHsRecUpdProj p] } + -> LHsRecUpdFields p + {- ************************************************************************ * * @@ -463,7 +476,7 @@ data HsExpr p | RecordUpd { rupd_ext :: XRecordUpd p , rupd_expr :: LHsExpr p - , rupd_flds :: Either [LHsRecUpdField p] [LHsRecUpdProj p] + , rupd_flds :: LHsRecUpdFields p } -- For a type family, the arg types are of the *instance* tycon, -- not the family tycon diff --git a/compiler/Language/Haskell/Syntax/Extension.hs b/compiler/Language/Haskell/Syntax/Extension.hs index 9ad16c0cd7..b184f1f46b 100644 --- a/compiler/Language/Haskell/Syntax/Extension.hs +++ b/compiler/Language/Haskell/Syntax/Extension.hs @@ -432,6 +432,8 @@ type family XDo x type family XExplicitList x type family XRecordCon x type family XRecordUpd x +type family XLHsRecUpdLabels x +type family XLHsOLRecUpdLabels x type family XGetField x type family XProjection x type family XExprWithTySig x diff --git a/compiler/Language/Haskell/Syntax/ImpExp.hs b/compiler/Language/Haskell/Syntax/ImpExp.hs index fcb8ede0e7..08be638003 100644 --- a/compiler/Language/Haskell/Syntax/ImpExp.hs +++ b/compiler/Language/Haskell/Syntax/ImpExp.hs @@ -127,7 +127,7 @@ data IE pass -- ^ Imported or exported Thing With given imported or exported -- -- The thing is a Class/Type and the imported or exported things are - -- methods/constructors and record fields; see Note [IEThingWith] + -- its children. -- - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnOpen', -- 'GHC.Parser.Annotation.AnnClose', -- 'GHC.Parser.Annotation.AnnComma', diff --git a/compiler/Language/Haskell/Syntax/Pat.hs b/compiler/Language/Haskell/Syntax/Pat.hs index 66b9708bfe..5e6f12c4b8 100644 --- a/compiler/Language/Haskell/Syntax/Pat.hs +++ b/compiler/Language/Haskell/Syntax/Pat.hs @@ -280,13 +280,13 @@ type LHsFieldBind p id arg = XRec p (HsFieldBind id arg) type LHsRecField p arg = XRec p (HsRecField p arg) -- | Located Haskell Record Update Field -type LHsRecUpdField p = XRec p (HsRecUpdField p) +type LHsRecUpdField p q = XRec p (HsRecUpdField p q) -- | Haskell Record Field type HsRecField p arg = HsFieldBind (LFieldOcc p) arg -- | Haskell Record Update Field -type HsRecUpdField p = HsFieldBind (LAmbiguousFieldOcc p) (LHsExpr p) +type HsRecUpdField p q = HsFieldBind (LAmbiguousFieldOcc p) (LHsExpr q) -- | Haskell Field Binding -- @@ -353,7 +353,7 @@ data HsFieldBind lhs rhs = HsFieldBind { -- -- hfbLHS = Unambiguous "x" $sel:x:MkS :: AmbiguousFieldOcc Id -- --- See also Note [Disambiguating record fields] in GHC.Tc.Gen.Head. +-- See also Note [Disambiguating record updates] in GHC.Rename.Pat. hsRecFields :: forall p arg.UnXRec p => HsRecFields p arg -> [XCFieldOcc p] hsRecFields rbinds = Data.List.map (hsRecFieldSel . unXRec @p) (rec_flds rbinds) @@ -363,4 +363,3 @@ hsRecFieldsArgs rbinds = Data.List.map (hfbRHS . unXRec @p) (rec_flds rbinds) hsRecFieldSel :: forall p arg. UnXRec p => HsRecField p arg -> XCFieldOcc p hsRecFieldSel = foExt . unXRec @p . hfbLHS - diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 2cf8c04bff..2f37328c39 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -753,7 +753,6 @@ Library GHC.Types.Basic GHC.Types.BreakInfo GHC.Types.CompleteMatch - GHC.Types.ConInfo GHC.Types.CostCentre GHC.Types.CostCentre.State GHC.Types.Cpr @@ -765,6 +764,7 @@ Library GHC.Types.Fixity.Env GHC.Types.ForeignCall GHC.Types.ForeignStubs + GHC.Types.GREInfo GHC.Types.Hint GHC.Types.Hint.Ppr GHC.Types.HpcInfo diff --git a/docs/users_guide/9.6.1-notes.rst b/docs/users_guide/9.6.1-notes.rst index eaed67da22..5cf40a310b 100644 --- a/docs/users_guide/9.6.1-notes.rst +++ b/docs/users_guide/9.6.1-notes.rst @@ -215,6 +215,11 @@ Runtime system - Add `Foreign.C.Types.ConstPtr` was added to encode ``const``-qualified pointer return types in foreign declarations when using ``CApiFFI`` extension. +- The ``RecordUpd`` constructor of ``HsExpr`` now takes an ``HsRecUpdFields`` + instead of ``Either [LHsRecUpdField p] [LHsRecUpdProj p]``. + Instead of ``Left ..``, use the constructor ``RegularRecUpdFields``, and instead + of ``Right ..``, use the constructor ``OverloadedRecUpdFields``. + ``ghc-heap`` library ~~~~~~~~~~~~~~~~~~~~ diff --git a/docs/users_guide/9.8.1-notes.rst b/docs/users_guide/9.8.1-notes.rst index 97d7829ce3..003e3ed78b 100644 --- a/docs/users_guide/9.8.1-notes.rst +++ b/docs/users_guide/9.8.1-notes.rst @@ -46,6 +46,20 @@ Compiler A new warning group :ghc-flag:`-Wextended-warnings` includes all such warnings regardless of category. See :ref:`warning-deprecated-pragma`. +- GHC is now better at disambiguating record updates in the presence of duplicate + record fields. The following program is now accepted :: + + {-# LANGUAGE DuplicateRecordFields #-} + + data R = MkR1 { foo :: Int } + | MkR2 { bar :: Int } + + data S = MkS { foo :: Int, bar :: Int } + + blah x = x { foo = 5, bar = 6 } + + The point is that only the type S has a constructor with both fields "foo" + and "bar", so this record update is unambiguous. GHCi ~~~~ @@ -82,6 +96,17 @@ Runtime system ``ghc-heap`` library ~~~~~~~~~~~~~~~~~~~~ +``template-haskell`` library +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +- The ``GadtC`` and ``RecGadtC`` constructors of the ``Con`` datatype now take + non-empty lists of constructors. This means that the ``gadtC`` and ``recGadtC`` + smart constructors also expect non-empty lists as arguments. + +- Record fields now belong to separate ``NameSpace``s, keyed by the parent of + the record field. This is the name of the first constructor of the parent type, + even if this constructor does not have the field in question. + This change enables TemplateHaskell support for ``DuplicateRecordFields``. Included libraries ------------------ diff --git a/ghc/GHCi/UI/Info.hs b/ghc/GHCi/UI/Info.hs index 0f78fa5075..505a1da68f 100644 --- a/ghc/GHCi/UI/Info.hs +++ b/ghc/GHCi/UI/Info.hs @@ -59,7 +59,7 @@ data ModInfo = ModInfo -- ^ Generated set of information about all spans in the -- module that correspond to some kind of identifier for -- which there will be type info and/or location info. - , modinfoRdrEnv :: !(Strict.Maybe GlobalRdrEnv) + , modinfoRdrEnv :: !(Strict.Maybe IfGlobalRdrEnv) -- ^ What's in scope in the module. , modinfoLastUpdate :: !UTCTime -- ^ The timestamp of the file used to generate this record. @@ -316,6 +316,8 @@ getModInfo name = do module_info = tm_checked_module_info typechecked !rdr_env = case modInfoRdrEnv module_info of Just rdrs -> Strict.Just rdrs + -- NB: this has already been deeply forced; no need to do that again. + -- See test case T15369 and Note [Forcing GREInfo] in GHC.Types.GREInfo. Nothing -> Strict.Nothing ts <- liftIO $ getModificationTime $ srcFilePath m return $ @@ -331,7 +333,7 @@ modInfo_rdrs :: ModInfo -> [Name] modInfo_rdrs mi = case modinfoRdrEnv mi of Strict.Nothing -> [] - Strict.Just env -> map greMangledName $ globalRdrEnvElts env + Strict.Just env -> map greName $ globalRdrEnvElts env -- | Get ALL source spans in the module. processAllTypeCheckedModule :: TypecheckedModule -> [SpanInfo] diff --git a/ghc/GHCi/UI/Monad.hs b/ghc/GHCi/UI/Monad.hs index 3016dd66d5..5b360f7400 100644 --- a/ghc/GHCi/UI/Monad.hs +++ b/ghc/GHCi/UI/Monad.hs @@ -51,7 +51,7 @@ import GHC.Types.SafeHaskell import GHC.Driver.Make (ModIfaceCache(..)) import GHC.Unit import GHC.Types.Name.Reader as RdrName (mkOrig) -import qualified GHC.Types.Name.Ppr as Ppr (mkNamePprCtx ) +import qualified GHC.Types.Name.Ppr as Ppr (mkNamePprCtx) import GHC.Builtin.Names (gHC_GHCI_HELPERS) import GHC.Runtime.Interpreter import GHC.Runtime.Context @@ -367,10 +367,11 @@ printForUserNeverQualify doc = do printForUserModInfo :: GhcMonad m => GHC.ModuleInfo -> SDoc -> m () printForUserModInfo info = printForUserGlobalRdrEnv (GHC.modInfoRdrEnv info) -printForUserGlobalRdrEnv :: GhcMonad m => Maybe GlobalRdrEnv -> SDoc -> m () +printForUserGlobalRdrEnv :: (GhcMonad m, Outputable info) + => Maybe (GlobalRdrEnvX info) -> SDoc -> m () printForUserGlobalRdrEnv mb_rdr_env doc = do dflags <- GHC.getInteractiveDynFlags - name_ppr_ctx <- mkNamePprCtxFromGlobalRdrEnv dflags mb_rdr_env + name_ppr_ctx <- mkNamePprCtxFromGlobalRdrEnv dflags mb_rdr_env liftIO $ Ppr.printForUser dflags stdout name_ppr_ctx AllTheWay doc where mkNamePprCtxFromGlobalRdrEnv _ Nothing = GHC.getNamePprCtx diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs index 35bca47d25..542f1e16b6 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs @@ -23,7 +23,7 @@ import qualified Language.Haskell.TH.Syntax as TH import Control.Applicative(liftA, Applicative(..)) import qualified Data.Kind as Kind (Type) import Data.Word( Word8 ) -import Data.List.NonEmpty ( NonEmpty(..) ) +import Data.List.NonEmpty ( NonEmpty(..), toList ) import GHC.Exts (TYPE) import Prelude hiding (Applicative(..)) @@ -680,10 +680,10 @@ forallC ns ctxt con = do con' <- con pure $ ForallC ns' ctxt' con' -gadtC :: Quote m => [Name] -> [m StrictType] -> m Type -> m Con +gadtC :: Quote m => NonEmpty Name -> [m StrictType] -> m Type -> m Con gadtC cons strtys ty = liftA2 (GadtC cons) (sequenceA strtys) ty -recGadtC :: Quote m => [Name] -> [m VarStrictType] -> m Type -> m Con +recGadtC :: Quote m => NonEmpty Name -> [m VarStrictType] -> m Type -> m Con recGadtC cons varstrtys ty = liftA2 (RecGadtC cons) (sequenceA varstrtys) ty ------------------------------------------------------------------------------- @@ -1177,7 +1177,7 @@ docCons :: (Q Con, Maybe String, [Maybe String]) -> Q () docCons (c, md, arg_docs) = do c' <- c -- Attach docs to the constructors - sequence_ [ putDoc (DeclDoc nm) d | Just d <- [md], nm <- get_cons_names c' ] + sequence_ [ putDoc (DeclDoc nm) d | Just d <- [md], nm <- toList $ get_cons_names c' ] -- Attach docs to the arguments case c' of -- Record selector documentation isn't stored in the argument map, @@ -1188,18 +1188,6 @@ docCons (c, md, arg_docs) = do ] _ -> sequence_ [ putDoc (ArgDoc nm i) arg_doc - | nm <- get_cons_names c' + | nm <- toList $ get_cons_names c' , (i, Just arg_doc) <- zip [0..] arg_docs ] - where - get_cons_names :: Con -> [Name] - get_cons_names (NormalC n _) = [n] - get_cons_names (RecC n _) = [n] - get_cons_names (InfixC _ n _) = [n] - get_cons_names (ForallC _ _ cons) = get_cons_names cons - -- GadtC can have multiple names, e.g - -- > data Bar a where - -- > MkBar1, MkBar2 :: a -> Bar a - -- Will have one GadtC with [MkBar1, MkBar2] as names - get_cons_names (GadtC ns _ _) = ns - get_cons_names (RecGadtC ns _ _) = ns diff --git a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs index cedb974976..d3101a985b 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs @@ -11,6 +11,7 @@ module Language.Haskell.TH.Ppr where import Text.PrettyPrint (render) import Language.Haskell.TH.PprLib import Language.Haskell.TH.Syntax +import qualified Data.List.NonEmpty as NE ( toList ) import Data.Word ( Word8 ) import Data.Char ( toLower, chr) import GHC.Show ( showMultiLineString ) @@ -682,22 +683,22 @@ instance Ppr Con where <+> pprName' Infix c <+> pprBangType st2 - ppr (ForallC ns ctxt (GadtC c sts ty)) - = commaSepApplied c <+> dcolon <+> pprForall ns ctxt + ppr (ForallC ns ctxt (GadtC cs sts ty)) + = commaSepApplied (NE.toList cs) <+> dcolon <+> pprForall ns ctxt <+> pprGadtRHS sts ty - ppr (ForallC ns ctxt (RecGadtC c vsts ty)) - = commaSepApplied c <+> dcolon <+> pprForall ns ctxt + ppr (ForallC ns ctxt (RecGadtC cs vsts ty)) + = commaSepApplied (NE.toList cs) <+> dcolon <+> pprForall ns ctxt <+> pprRecFields vsts ty ppr (ForallC ns ctxt con) = pprForall ns ctxt <+> ppr con - ppr (GadtC c sts ty) - = commaSepApplied c <+> dcolon <+> pprGadtRHS sts ty + ppr (GadtC cs sts ty) + = commaSepApplied (NE.toList cs) <+> dcolon <+> pprGadtRHS sts ty - ppr (RecGadtC c vsts ty) - = commaSepApplied c <+> dcolon <+> pprRecFields vsts ty + ppr (RecGadtC cs vsts ty) + = commaSepApplied (NE.toList cs) <+> dcolon <+> pprRecFields vsts ty instance Ppr PatSynDir where ppr Unidir = text "<-" diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs index 8be340bf93..6668273a14 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs @@ -48,6 +48,7 @@ import System.IO ( hPutStrLn, stderr ) import Data.Char ( isAlpha, isAlphaNum, isUpper, ord ) import Data.Int import Data.List.NonEmpty ( NonEmpty(..) ) +import qualified Data.List.NonEmpty as NE ( singleton ) import Data.Void ( Void, absurd ) import Data.Word import Data.Ratio @@ -1498,8 +1499,9 @@ dataToExpQ = dataToQa varOrConE litE (foldl appE) -- See #10796. varOrConE s = case nameSpace s of - Just VarName -> return (VarE s) - Just DataName -> return (ConE s) + Just VarName -> return (VarE s) + Just (FldName {}) -> return (VarE s) + Just DataName -> return (ConE s) _ -> error $ "Can't construct an expression from name " ++ showName s appE x y = do { a <- x; b <- y; return (AppE a b)} @@ -1675,6 +1677,14 @@ data NameSpace = VarName -- ^ Variables | DataName -- ^ Data constructors | TcClsName -- ^ Type constructors and classes; Haskell has them -- in the same name space for now. + | FldName + { fldParent :: !String + -- ^ The textual name of the parent of the field. + -- + -- - For a field of a datatype, this is the name of the first constructor + -- of the datatype (regardless of whether this constructor has this field). + -- - For a field of a pattern synonym, this is the name of the pattern synonym. + } deriving( Eq, Ord, Show, Data, Generic ) -- | @Uniq@ is used by GHC to distinguish names from each other. @@ -1834,6 +1844,13 @@ mkNameG_v = mkNameG VarName mkNameG_tc = mkNameG TcClsName mkNameG_d = mkNameG DataName +mkNameG_fld :: String -- ^ package + -> String -- ^ module + -> String -- ^ parent (first constructor of parent type) + -> String -- ^ field name + -> Name +mkNameG_fld pkg modu con occ = mkNameG (FldName con) pkg modu occ + data NameIs = Alone | Applied | Infix showName :: Name -> String @@ -1857,11 +1874,11 @@ showName' ni nm -- We may well want to distinguish them in the end. -- Ditto NameU and NameL nms = case nm of - Name occ NameS -> occString occ - Name occ (NameQ m) -> modString m ++ "." ++ occString occ - Name occ (NameG _ _ m) -> modString m ++ "." ++ occString occ - Name occ (NameU u) -> occString occ ++ "_" ++ show u - Name occ (NameL u) -> occString occ ++ "_" ++ show u + Name occ NameS -> occString occ + Name occ (NameQ m) -> modString m ++ "." ++ occString occ + Name occ (NameG _ _ m) -> modString m ++ "." ++ occString occ + Name occ (NameU u) -> occString occ ++ "_" ++ show u + Name occ (NameL u) -> occString occ ++ "_" ++ show u pnam = classify nms @@ -2705,10 +2722,10 @@ data Con = NormalC Name [BangType] -- ^ @C Int a@ | RecC Name [VarBangType] -- ^ @C { v :: Int, w :: a }@ | InfixC BangType Name BangType -- ^ @Int :+ a@ | ForallC [TyVarBndr Specificity] Cxt Con -- ^ @forall a. Eq a => C [a]@ - | GadtC [Name] [BangType] + | GadtC (NonEmpty Name) [BangType] Type -- See Note [GADT return type] -- ^ @C :: a -> b -> T b Int@ - | RecGadtC [Name] [VarBangType] + | RecGadtC (NonEmpty Name) [VarBangType] Type -- See Note [GADT return type] -- ^ @C :: { v :: Int } -> T b Int@ deriving (Show, Eq, Ord, Data, Generic) @@ -2907,3 +2924,15 @@ cmpEq _ = False thenCmp :: Ordering -> Ordering -> Ordering thenCmp EQ o2 = o2 thenCmp o1 _ = o1 + +get_cons_names :: Con -> NonEmpty Name +get_cons_names (NormalC n _) = NE.singleton n +get_cons_names (RecC n _) = NE.singleton n +get_cons_names (InfixC _ n _) = NE.singleton n +get_cons_names (ForallC _ _ con) = get_cons_names con +-- GadtC can have multiple names, e.g +-- > data Bar a where +-- > MkBar1, MkBar2 :: a -> Bar a +-- Will have one GadtC with [MkBar1, MkBar2] as names +get_cons_names (GadtC ns _ _) = ns +get_cons_names (RecGadtC ns _ _) = ns
\ No newline at end of file diff --git a/libraries/template-haskell/changelog.md b/libraries/template-haskell/changelog.md index 8382efd1fc..821c776d96 100644 --- a/libraries/template-haskell/changelog.md +++ b/libraries/template-haskell/changelog.md @@ -1,5 +1,17 @@ # Changelog for [`template-haskell` package](http://hackage.haskell.org/package/template-haskell) +## 2.21.0.0 + + * The `GadtC` and `RecGadtC` constructors of the `Con` datatype now take + non-empty lists of constructors. This means that the `gadtC` and `recGadtC` + smart constructors also expect non-empty lists as arguments. + + * Record fields now belong to separate `NameSpace`s, keyed by the parent of + the record field. This is the name of the first constructor of the parent type, + even if this constructor does not have the field in question. + + This change enables TemplateHaskell support for `DuplicateRecordFields`. + ## 2.20.0.0 * The `Ppr.pprInfixT` function has gained a `Precedence` argument. diff --git a/testsuite/tests/backpack/reexport/T23080a.bkp b/testsuite/tests/backpack/reexport/T23080a.bkp new file mode 100644 index 0000000000..3ca2d22cda --- /dev/null +++ b/testsuite/tests/backpack/reexport/T23080a.bkp @@ -0,0 +1,9 @@ +unit t23080-unit1 where + signature H1 where + data T +unit t23080-unit2 where + dependency t23080-unit1[H1=<H2>] + module B where + data T = MkT + signature H2 (T(MkT)) where + import B diff --git a/testsuite/tests/backpack/reexport/T23080b.bkp b/testsuite/tests/backpack/reexport/T23080b.bkp new file mode 100644 index 0000000000..bb4d86ab9e --- /dev/null +++ b/testsuite/tests/backpack/reexport/T23080b.bkp @@ -0,0 +1,9 @@ +unit t23080-unit1 where + signature H1 where + data T +unit t23080-unit2 where + dependency t23080-unit1[H1=<H2>] + module B where + data T = MkT { fld :: T } + signature H2 (T(fld)) where + import B diff --git a/testsuite/tests/backpack/reexport/all.T b/testsuite/tests/backpack/reexport/all.T index f677f01f2e..5bab153169 100644 --- a/testsuite/tests/backpack/reexport/all.T +++ b/testsuite/tests/backpack/reexport/all.T @@ -9,3 +9,5 @@ test('bkpreex07', normal, backpack_typecheck, ['']) test('bkpreex08', normal, backpack_typecheck, ['']) test('bkpreex09', normal, backpack_typecheck, ['']) test('bkpreex10', normal, backpack_typecheck, ['']) +test('T23080a', expect_broken(23080), backpack_typecheck, ['']) +test('T23080b', expect_broken(23080), backpack_typecheck, ['']) diff --git a/testsuite/tests/backpack/reexport/bkpreex05.bkp b/testsuite/tests/backpack/reexport/bkpreex05.bkp index e496ed76fa..811ff69b89 100644 --- a/testsuite/tests/backpack/reexport/bkpreex05.bkp +++ b/testsuite/tests/backpack/reexport/bkpreex05.bkp @@ -1,28 +1,28 @@ unit bar where - signature A(bar) where - data A = A { foo :: Int, bar :: Bool } + signature H1(bar) where + data A = MkA { foo :: Int, bar :: Bool } unit foo where - signature A(foo) where - data A = A { foo :: Int, bar :: Bool } + signature H2(foo) where + data A = MkA { foo :: Int, bar :: Bool } unit impl where - module A1 where - data A = A { foo :: Int, bar :: Bool } - module A2 where - data A = A { foo :: Int, bar :: Bool } - module A(foo, bar) where - import A1(foo) - import A2(bar) + module M1 where + data A = MkA { foo :: Int, bar :: Bool } + module M2 where + data A = MkA { foo :: Int, bar :: Bool } + module M(foo, bar) where + import M1(foo) + import M2(bar) -- Kind of boring test now haha unit barimpl where - dependency bar[A=impl:A] + dependency bar[H1=impl:M] unit fooimpl where - dependency foo[A=impl:A] + dependency foo[H2=impl:M] unit foobarimpl where - dependency foo[A=impl:A] - dependency bar[A=impl:A] + dependency foo[H2=impl:M] + dependency bar[H1=impl:M] diff --git a/testsuite/tests/count-deps/CountDepsAst.stdout b/testsuite/tests/count-deps/CountDepsAst.stdout index efd58af99f..652a35a9b7 100644 --- a/testsuite/tests/count-deps/CountDepsAst.stdout +++ b/testsuite/tests/count-deps/CountDepsAst.stdout @@ -201,7 +201,6 @@ GHC.Types.Avail GHC.Types.Basic GHC.Types.BreakInfo GHC.Types.CompleteMatch -GHC.Types.ConInfo GHC.Types.CostCentre GHC.Types.CostCentre.State GHC.Types.Cpr @@ -213,6 +212,7 @@ GHC.Types.Fixity GHC.Types.Fixity.Env GHC.Types.ForeignCall GHC.Types.ForeignStubs +GHC.Types.GREInfo GHC.Types.Hint GHC.Types.Hint.Ppr GHC.Types.HpcInfo diff --git a/testsuite/tests/count-deps/CountDepsParser.stdout b/testsuite/tests/count-deps/CountDepsParser.stdout index f1116f5198..4850f57f96 100644 --- a/testsuite/tests/count-deps/CountDepsParser.stdout +++ b/testsuite/tests/count-deps/CountDepsParser.stdout @@ -208,7 +208,6 @@ GHC.Types.Avail GHC.Types.Basic GHC.Types.BreakInfo GHC.Types.CompleteMatch -GHC.Types.ConInfo GHC.Types.CostCentre GHC.Types.CostCentre.State GHC.Types.Cpr @@ -220,6 +219,7 @@ GHC.Types.Fixity GHC.Types.Fixity.Env GHC.Types.ForeignCall GHC.Types.ForeignStubs +GHC.Types.GREInfo GHC.Types.Hint GHC.Types.Hint.Ppr GHC.Types.HpcInfo diff --git a/testsuite/tests/deriving/should_compile/T13919.stderr b/testsuite/tests/deriving/should_compile/T13919.stderr index e57fc77371..02cfb71aaa 100644 --- a/testsuite/tests/deriving/should_compile/T13919.stderr +++ b/testsuite/tests/deriving/should_compile/T13919.stderr @@ -1,3 +1,3 @@ T13919.hs:13:19: warning: [-Wunused-top-binds (in -Wextra, -Wunused-binds)] - Defined but not used: ‘bar4’ + Defined but not used: record field of Foo4 ‘bar4’ diff --git a/testsuite/tests/gadt/T18191.stderr b/testsuite/tests/gadt/T18191.stderr index b8c6c60bdc..ce877d0332 100644 --- a/testsuite/tests/gadt/T18191.stderr +++ b/testsuite/tests/gadt/T18191.stderr @@ -1,20 +1,26 @@ T18191.hs:6:11: error: - GADT constructor type signature cannot contain nested ‘forall’s or contexts - In the definition of data constructor ‘MkT’ + • GADT constructor type signature cannot contain nested ‘forall’s or contexts + • In the definition of data constructor ‘MkT’ T18191.hs:9:11: error: - GADT constructor type signature cannot contain nested ‘forall’s or contexts - In the definition of data constructor ‘MkS’ + • GADT constructor type signature cannot contain nested ‘forall’s or contexts + • In the definition of data constructor ‘MkS’ T18191.hs:12:11: error: - GADT constructor type signature cannot contain nested ‘forall’s or contexts - In the definition of data constructor ‘MkU’ + • GADT constructor type signature cannot contain nested ‘forall’s or contexts + • In the definition of data constructor ‘MkU’ T18191.hs:15:21: error: - GADT constructor type signature cannot contain nested ‘forall’s or contexts - In the definition of data constructor ‘MkZ1’ + • GADT constructor type signature cannot contain nested ‘forall’s or contexts + • In the definition of data constructor ‘MkZ1’ + +T18191.hs:15:31: error: [GHC-89246] + Record syntax is illegal here: {unZ1 :: (a, b)} T18191.hs:16:19: error: - GADT constructor type signature cannot contain nested ‘forall’s or contexts - In the definition of data constructor ‘MkZ2’ + • GADT constructor type signature cannot contain nested ‘forall’s or contexts + • In the definition of data constructor ‘MkZ2’ + +T18191.hs:16:27: error: [GHC-89246] + Record syntax is illegal here: {unZ1 :: (a, b)} diff --git a/testsuite/tests/ghci.debugger/scripts/break006.stderr b/testsuite/tests/ghci.debugger/scripts/break006.stderr index 80419e9f35..705e9b359c 100644 --- a/testsuite/tests/ghci.debugger/scripts/break006.stderr +++ b/testsuite/tests/ghci.debugger/scripts/break006.stderr @@ -8,7 +8,7 @@ instance Show Ordering -- Defined in ‘GHC.Show’ instance Show a => Show (Maybe a) -- Defined in ‘GHC.Show’ ...plus 25 others - ...plus 12 instances involving out-of-scope types + ...plus 13 instances involving out-of-scope types (use -fprint-potential-instances to see them all) • In a stmt of an interactive GHCi command: print it @@ -21,6 +21,6 @@ instance Show Ordering -- Defined in ‘GHC.Show’ instance Show a => Show (Maybe a) -- Defined in ‘GHC.Show’ ...plus 25 others - ...plus 12 instances involving out-of-scope types + ...plus 13 instances involving out-of-scope types (use -fprint-potential-instances to see them all) • In a stmt of an interactive GHCi command: print it diff --git a/testsuite/tests/ghci.debugger/scripts/print019.stderr b/testsuite/tests/ghci.debugger/scripts/print019.stderr index 0febc62927..ce45768335 100644 --- a/testsuite/tests/ghci.debugger/scripts/print019.stderr +++ b/testsuite/tests/ghci.debugger/scripts/print019.stderr @@ -8,6 +8,6 @@ instance Show Ordering -- Defined in ‘GHC.Show’ instance Show TyCon -- Defined in ‘GHC.Show’ ...plus 32 others - ...plus 13 instances involving out-of-scope types + ...plus 14 instances involving out-of-scope types (use -fprint-potential-instances to see them all) • In a stmt of an interactive GHCi command: print it diff --git a/testsuite/tests/ghci/scripts/T22125.script b/testsuite/tests/ghci/scripts/T22125.script new file mode 100644 index 0000000000..166d650dd9 --- /dev/null +++ b/testsuite/tests/ghci/scripts/T22125.script @@ -0,0 +1,6 @@ +:seti -XTypeFamilies -XDuplicateRecordFields -XDerivingStrategies +data family D a +data instance D Int = MkD0 | MkDInt { x :: Int, y :: Bool } deriving Show +data instance D Bool = MkDBool { x :: Int } +f r = r { y = True, x = 14 } +f (MkDInt 3 False) diff --git a/testsuite/tests/ghci/scripts/T22125.stdout b/testsuite/tests/ghci/scripts/T22125.stdout new file mode 100644 index 0000000000..1a6c1af6ab --- /dev/null +++ b/testsuite/tests/ghci/scripts/T22125.stdout @@ -0,0 +1 @@ +MkDInt {x = 14, y = True} diff --git a/testsuite/tests/ghci/scripts/T23062.script b/testsuite/tests/ghci/scripts/T23062.script new file mode 100644 index 0000000000..ee46726247 --- /dev/null +++ b/testsuite/tests/ghci/scripts/T23062.script @@ -0,0 +1,5 @@ +:seti -XDuplicateRecordFields -XDerivingStrategies +data A = MkA { foo :: Int, bar :: Int } deriving stock Show +data B = MkB { foo :: Int } +f r = r { foo = 3, bar = 4 } +f (MkA { foo = 2, bar = 3 }) diff --git a/testsuite/tests/ghci/scripts/T23062.stdout b/testsuite/tests/ghci/scripts/T23062.stdout new file mode 100644 index 0000000000..fe41ddb4e5 --- /dev/null +++ b/testsuite/tests/ghci/scripts/T23062.stdout @@ -0,0 +1 @@ +MkA {foo = 3, bar = 4} diff --git a/testsuite/tests/ghci/scripts/all.T b/testsuite/tests/ghci/scripts/all.T index fa22b7ae8d..90c3b05514 100755 --- a/testsuite/tests/ghci/scripts/all.T +++ b/testsuite/tests/ghci/scripts/all.T @@ -370,6 +370,8 @@ test('T21110', [extra_files(['T21110A.hs'])], ghci_script, test('T17830', [filter_stdout_lines(r'======.*')], ghci_script, ['T17830.script']) test('T21294a', normal, ghci_script, ['T21294a.script']) test('T21507', normal, ghci_script, ['T21507.script']) +test('T22125', normal, ghci_script, ['T22125.script']) test('T22695', normal, ghci_script, ['T22695.script']) test('T22817', normal, ghci_script, ['T22817.script']) test('T22908', normal, ghci_script, ['T22908.script']) +test('T23062', normal, ghci_script, ['T23062.script']) diff --git a/testsuite/tests/ghci/scripts/ghci065.stdout b/testsuite/tests/ghci/scripts/ghci065.stdout index e4048832cc..543a6caf20 100644 --- a/testsuite/tests/ghci/scripts/ghci065.stdout +++ b/testsuite/tests/ghci/scripts/ghci065.stdout @@ -9,13 +9,13 @@ Data3 :: * -- Type constructor defined at ghci065.hs:20:1 Data4 :: Int -> Data4 -- Data constructor defined at ghci065.hs:25:3 -- | This is the haddock comment of a data constructor for Data4. -dupeField :: DupeFields2 -> Int - -- Identifier defined at ghci065.hs:32:9 --- ^ This is the second haddock comment of a duplicate record field. - dupeField :: DupeFields1 -> Int -- Identifier defined at ghci065.hs:28:9 -- ^ This is the first haddock comment of a duplicate record field. + +dupeField :: DupeFields2 -> Int + -- Identifier defined at ghci065.hs:32:9 +-- ^ This is the second haddock comment of a duplicate record field. func1 :: Int -> Int -> Int -- Identifier defined at ghci065.hs:41:1 -- | This is the haddock comment of a function declaration for func1. diff --git a/testsuite/tests/linters/notes.stdout b/testsuite/tests/linters/notes.stdout index 0a8b2161fe..51fef76584 100644 --- a/testsuite/tests/linters/notes.stdout +++ b/testsuite/tests/linters/notes.stdout @@ -6,48 +6,43 @@ ref compiler/GHC/Core/Opt/Simplify/Iteration.hs:4009:8: Note [Lambda-boun ref compiler/GHC/Core/Opt/Simplify/Utils.hs:1343:37: Note [Gentle mode] ref compiler/GHC/Core/Opt/Specialise.hs:1790:28: Note [Arity decrease] ref compiler/GHC/Core/TyCo/Rep.hs:1556:31: Note [What prevents a constraint from floating] -ref compiler/GHC/Driver/Main.hs:1761:34: Note [simpleTidyPgm - mkBootModDetailsTc] -ref compiler/GHC/Driver/Session.hs:3976:49: Note [Eta-reduction in -O0] -ref compiler/GHC/Hs/Expr.hs:191:63: Note [Pending Splices] -ref compiler/GHC/Hs/Expr.hs:1706:87: Note [Lifecycle of a splice] -ref compiler/GHC/Hs/Expr.hs:1742:7: Note [Pending Splices] +ref compiler/GHC/Driver/Main.hs:1762:34: Note [simpleTidyPgm - mkBootModDetailsTc] +ref compiler/GHC/Driver/Session.hs:3993:49: Note [Eta-reduction in -O0] +ref compiler/GHC/Hs/Expr.hs:194:63: Note [Pending Splices] +ref compiler/GHC/Hs/Expr.hs:1736:87: Note [Lifecycle of a splice] +ref compiler/GHC/Hs/Expr.hs:1772:7: Note [Pending Splices] ref compiler/GHC/Hs/Extension.hs:146:5: Note [Strict argument type constraints] ref compiler/GHC/Hs/Pat.hs:143:74: Note [Lifecycle of a splice] ref compiler/GHC/HsToCore/Pmc/Solver.hs:858:20: Note [COMPLETE sets on data families] ref compiler/GHC/HsToCore/Quote.hs:1476:7: Note [How brackets and nested splices are handled] -ref compiler/GHC/Rename/Pat.hs:890:29: Note [Disambiguating record fields] ref compiler/GHC/Stg/Unarise.hs:442:32: Note [Renaming during unarisation] ref compiler/GHC/StgToCmm.hs:106:18: Note [codegen-split-init] ref compiler/GHC/StgToCmm.hs:109:18: Note [pipeline-split-init] ref compiler/GHC/StgToCmm/Expr.hs:585:4: Note [case on bool] ref compiler/GHC/StgToCmm/Expr.hs:853:3: Note [alg-alt heap check] -ref compiler/GHC/Tc/Gen/Expr.hs:1212:23: Note [Disambiguating record fields] -ref compiler/GHC/Tc/Gen/Expr.hs:1427:7: Note [Disambiguating record fields] -ref compiler/GHC/Tc/Gen/Expr.hs:1530:11: Note [Deprecating ambiguous fields] -ref compiler/GHC/Tc/Gen/HsType.hs:557:56: Note [Skolem escape prevention] -ref compiler/GHC/Tc/Gen/HsType.hs:2622:7: Note [Matching a kind signature with a declaration] +ref compiler/GHC/Tc/Gen/HsType.hs:556:56: Note [Skolem escape prevention] +ref compiler/GHC/Tc/Gen/HsType.hs:2621:7: Note [Matching a kind signature with a declaration] ref compiler/GHC/Tc/Gen/Pat.hs:176:20: Note [Typing patterns in pattern bindings] ref compiler/GHC/Tc/Gen/Pat.hs:1127:7: Note [Matching polytyped patterns] ref compiler/GHC/Tc/Gen/Sig.hs:81:10: Note [Overview of type signatures] -ref compiler/GHC/Tc/Gen/Splice.hs:359:16: Note [How brackets and nested splices are handled] -ref compiler/GHC/Tc/Gen/Splice.hs:534:35: Note [PendingRnSplice] -ref compiler/GHC/Tc/Gen/Splice.hs:658:7: Note [How brackets and nested splices are handled] -ref compiler/GHC/Tc/Gen/Splice.hs:891:11: Note [How brackets and nested splices are handled] +ref compiler/GHC/Tc/Gen/Splice.hs:357:16: Note [How brackets and nested splices are handled] +ref compiler/GHC/Tc/Gen/Splice.hs:532:35: Note [PendingRnSplice] +ref compiler/GHC/Tc/Gen/Splice.hs:656:7: Note [How brackets and nested splices are handled] +ref compiler/GHC/Tc/Gen/Splice.hs:889:11: Note [How brackets and nested splices are handled] ref compiler/GHC/Tc/Instance/Family.hs:474:35: Note [Constrained family instances] -ref compiler/GHC/Tc/Module.hs:708:15: Note [Extra dependencies from .hs-boot files] +ref compiler/GHC/Tc/Module.hs:711:15: Note [Extra dependencies from .hs-boot files] ref compiler/GHC/Tc/Solver/Rewrite.hs:1008:7: Note [Stability of rewriting] -ref compiler/GHC/Tc/TyCl.hs:1119:6: Note [Unification variables need fresh Names] -ref compiler/GHC/Tc/Types.hs:697:33: Note [Extra dependencies from .hs-boot files] -ref compiler/GHC/Tc/Types.hs:1428:47: Note [Care with plugin imports] -ref compiler/GHC/Tc/Types/Constraint.hs:223:34: Note [NonCanonical Semantics] +ref compiler/GHC/Tc/TyCl.hs:1120:6: Note [Unification variables need fresh Names] +ref compiler/GHC/Tc/Types.hs:692:33: Note [Extra dependencies from .hs-boot files] +ref compiler/GHC/Tc/Types.hs:1423:47: Note [Care with plugin imports] +ref compiler/GHC/Tc/Types/Constraint.hs:255:34: Note [NonCanonical Semantics] ref compiler/GHC/Types/Demand.hs:306:25: Note [Preserving Boxity of results is rarely a win] ref compiler/GHC/Unit/Module/Deps.hs:81:13: Note [Structure of dep_boot_mods] -ref compiler/GHC/Utils/Monad.hs:400:34: Note [multiShotIO] +ref compiler/GHC/Utils/Monad.hs:410:34: Note [multiShotIO] ref compiler/Language/Haskell/Syntax/Binds.hs:200:31: Note [fun_id in Match] -ref compiler/Language/Haskell/Syntax/Pat.hs:356:12: Note [Disambiguating record fields] ref configure.ac:210:10: Note [Linking ghc-bin against threaded stage0 RTS] ref docs/core-spec/core-spec.mng:177:6: Note [TyBinders] -ref hadrian/src/Expression.hs:134:30: Note [Linking ghc-bin against threaded stage0 RTS] +ref hadrian/src/Expression.hs:145:30: Note [Linking ghc-bin against threaded stage0 RTS] ref linters/lint-notes/Notes.hs:32:29: Note [" <> T.unpack x <> "] ref linters/lint-notes/Notes.hs:69:22: Note [...] ref testsuite/config/ghc:272:10: Note [WayFlags] diff --git a/testsuite/tests/overloadedrecflds/ghci/GHCiDRF.stdout b/testsuite/tests/overloadedrecflds/ghci/GHCiDRF.stdout index 08406f9387..c912c3c4ee 100644 --- a/testsuite/tests/overloadedrecflds/ghci/GHCiDRF.stdout +++ b/testsuite/tests/overloadedrecflds/ghci/GHCiDRF.stdout @@ -3,18 +3,18 @@ GHCiDRF.foo :: T -> Int <interactive>:1:1: error: Ambiguous occurrence ‘GHCiDRF.bar’ It could refer to - either the field ‘bar’ of record ‘U’, defined at GHCiDRF.hs:4:16 - or the field ‘bar’ of record ‘T’, defined at GHCiDRF.hs:3:28 + either the field ‘bar’ of record ‘T’, defined at GHCiDRF.hs:3:28 + or the field ‘bar’ of record ‘U’, defined at GHCiDRF.hs:4:16 type T :: * data T = MkT {foo :: Int, ...} -- Defined at GHCiDRF.hs:3:16 -type U :: * -data U = MkU {GHCiDRF.bar :: Bool} - -- Defined at GHCiDRF.hs:4:16 - type T :: * -data T = MkT {..., GHCiDRF.bar :: Int} +data T = MkT {..., bar :: Int} -- Defined at GHCiDRF.hs:3:28 + +type U :: * +data U = MkU {bar :: Bool} + -- Defined at GHCiDRF.hs:4:16 GHCiDRF.foo :: GHCiDRF.T -> Int <interactive>:1:1: error: diff --git a/testsuite/tests/overloadedrecflds/ghci/T19664.hs b/testsuite/tests/overloadedrecflds/ghci/T19664.hs new file mode 100644 index 0000000000..e7e38193a0 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/ghci/T19664.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE QuasiQuotes, TemplateHaskell, DuplicateRecordFields #-} + +module T19664 where + +import Language.Haskell.TH + +left = undefined + +([] <$) $ runIO . print =<< [d| + data Tree + = Node { left :: Tree, right :: Tree } + | Leaf { value :: Int } + deriving Show + |] diff --git a/testsuite/tests/overloadedrecflds/ghci/T19664.script b/testsuite/tests/overloadedrecflds/ghci/T19664.script new file mode 100644 index 0000000000..92f69cfe8c --- /dev/null +++ b/testsuite/tests/overloadedrecflds/ghci/T19664.script @@ -0,0 +1,2 @@ +:seti -XDuplicateRecordFields +:l T19664 diff --git a/testsuite/tests/overloadedrecflds/ghci/T19664.stdout b/testsuite/tests/overloadedrecflds/ghci/T19664.stdout new file mode 100644 index 0000000000..3742c489c8 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/ghci/T19664.stdout @@ -0,0 +1 @@ +[DataD [] Tree_6989586621679019412 [] Nothing [RecC Node_6989586621679019413 [(left_6989586621679019416,Bang NoSourceUnpackedness NoSourceStrictness,ConT Tree_6989586621679019412),(right_6989586621679019415,Bang NoSourceUnpackedness NoSourceStrictness,ConT Tree_6989586621679019412)],RecC Leaf_6989586621679019414 [(value_6989586621679019417,Bang NoSourceUnpackedness NoSourceStrictness,ConT GHC.Types.Int)]] [DerivClause Nothing [ConT GHC.Show.Show]]] diff --git a/testsuite/tests/overloadedrecflds/ghci/all.T b/testsuite/tests/overloadedrecflds/ghci/all.T index 17f4f82ff5..6e775149e5 100644 --- a/testsuite/tests/overloadedrecflds/ghci/all.T +++ b/testsuite/tests/overloadedrecflds/ghci/all.T @@ -4,3 +4,4 @@ test('T13438', [expect_broken(13438), combined_output], ghci_script, ['T13438.sc test('GHCiDRF', [extra_files(['GHCiDRF.hs']), combined_output], ghci_script, ['GHCiDRF.script']) test('T19322', combined_output, ghci_script, ['T19322.script']) test('T19314', combined_output, ghci_script, ['T19314.script']) +test('T19664', [ignore_stdout, extra_files(['T19664.hs'])], ghci_script, ['T19664.script']) diff --git a/testsuite/tests/overloadedrecflds/ghci/duplicaterecfldsghci01.script b/testsuite/tests/overloadedrecflds/ghci/duplicaterecfldsghci01.script index 2aa0a15be8..cca0b8a93f 100644 --- a/testsuite/tests/overloadedrecflds/ghci/duplicaterecfldsghci01.script +++ b/testsuite/tests/overloadedrecflds/ghci/duplicaterecfldsghci01.script @@ -5,13 +5,12 @@ data T a = MkT { foo :: Bool, bar :: a -> a } let t = MkT { foo = True, bar = id } (\MkT{foo=foo} -> foo) t :info foo -:type foo -foo (MkS 42) bar (MkT True id) True :set -XNoDuplicateRecordFields -- Should be ambiguous :type foo data U = MkU { foo :: Int } -- New foo should shadow the old ones +:info foo :type foo foo (MkU 42) diff --git a/testsuite/tests/overloadedrecflds/ghci/duplicaterecfldsghci01.stdout b/testsuite/tests/overloadedrecflds/ghci/duplicaterecfldsghci01.stdout index ae87b8ea19..b34e509ecc 100644 --- a/testsuite/tests/overloadedrecflds/ghci/duplicaterecfldsghci01.stdout +++ b/testsuite/tests/overloadedrecflds/ghci/duplicaterecfldsghci01.stdout @@ -1,15 +1,20 @@ True +type S :: * +data S = MkS {foo :: Int} + -- Defined at <interactive>:3:16 + type T :: * -> * data T a = MkT {foo :: Bool, ...} -- Defined at <interactive>:4:18 -foo :: T a -> Bool - -<interactive>:9:6: error: [GHC-83865] - • Couldn't match expected type ‘T a0’ with actual type ‘S’ - • In the first argument of ‘foo’, namely ‘(MkS 42)’ - In the expression: foo (MkS 42) - In an equation for ‘it’: it = foo (MkS 42) True -foo :: T a -> Bool + +<interactive>:1:1: error: + Ambiguous occurrence ‘foo’ + It could refer to + either the field ‘foo’ of record ‘S’, defined at <interactive>:3:16 + or the field ‘foo’ of record ‘T’, defined at <interactive>:4:18 +type U :: * +data U = MkU {foo :: Int} + -- Defined at <interactive>:12:16 foo :: U -> Int 42 diff --git a/testsuite/tests/overloadedrecflds/should_compile/BootFldReexport.hs b/testsuite/tests/overloadedrecflds/should_compile/BootFldReexport.hs new file mode 100644 index 0000000000..a0e527f1b3 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_compile/BootFldReexport.hs @@ -0,0 +1,8 @@ +module BootFldReexport where + +import {-# SOURCE #-} BootFldReexport_N + ( fld {- variable -} ) +import BootFldReexport_O + ( fld {- record field -} ) + +test3 = fld diff --git a/testsuite/tests/overloadedrecflds/should_compile/BootFldReexport.stderr b/testsuite/tests/overloadedrecflds/should_compile/BootFldReexport.stderr new file mode 100644 index 0000000000..0830beb7fc --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_compile/BootFldReexport.stderr @@ -0,0 +1,11 @@ + +BootFldReexport.hs:8:9: error: + Ambiguous occurrence ‘fld’ + It could refer to + either ‘BootFldReexport_N.fld’, + imported from ‘BootFldReexport_N’ at BootFldReexport.hs:4:5-7 + (and originally defined in ‘BootFldReexport_O’ + at BootFldReexport_O.hs-boot:4:1-13) + or the field ‘fld’ of record ‘BootFldReexport_O.O’, + imported from ‘BootFldReexport_O’ at BootFldReexport.hs:6:5-7 + (and originally defined at BootFldReexport_O.hs:5:16-18) diff --git a/testsuite/tests/overloadedrecflds/should_compile/BootFldReexport_B.hs b/testsuite/tests/overloadedrecflds/should_compile/BootFldReexport_B.hs new file mode 100644 index 0000000000..8d8024313c --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_compile/BootFldReexport_B.hs @@ -0,0 +1,5 @@ +module BootFldReexport_B where + +import {-# SOURCE #-} BootFldReexport_N + +test2 = fld diff --git a/testsuite/tests/overloadedrecflds/should_compile/BootFldReexport_N.hs b/testsuite/tests/overloadedrecflds/should_compile/BootFldReexport_N.hs new file mode 100644 index 0000000000..8a28e3705c --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_compile/BootFldReexport_N.hs @@ -0,0 +1,5 @@ +module BootFldReexport_N ( module BootFldReexport_O ) where +import BootFldReexport_O +import BootFldReexport + +test1 = fld diff --git a/testsuite/tests/overloadedrecflds/should_compile/BootFldReexport_N.hs-boot b/testsuite/tests/overloadedrecflds/should_compile/BootFldReexport_N.hs-boot new file mode 100644 index 0000000000..49c9c7c996 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_compile/BootFldReexport_N.hs-boot @@ -0,0 +1,2 @@ +module BootFldReexport_N ( module BootFldReexport_O ) where +import {-# SOURCE #-} BootFldReexport_O
\ No newline at end of file diff --git a/testsuite/tests/overloadedrecflds/should_compile/BootFldReexport_O.hs b/testsuite/tests/overloadedrecflds/should_compile/BootFldReexport_O.hs new file mode 100644 index 0000000000..733f7e3ed6 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_compile/BootFldReexport_O.hs @@ -0,0 +1,5 @@ +module BootFldReexport_O where + +import BootFldReexport_B + +data O = MkO { fld :: O } diff --git a/testsuite/tests/overloadedrecflds/should_compile/BootFldReexport_O.hs-boot b/testsuite/tests/overloadedrecflds/should_compile/BootFldReexport_O.hs-boot new file mode 100644 index 0000000000..617ec6fb90 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_compile/BootFldReexport_O.hs-boot @@ -0,0 +1,4 @@ +module BootFldReexport_O where + +data O +fld :: O -> O diff --git a/testsuite/tests/overloadedrecflds/should_compile/DupFldFixity1.hs b/testsuite/tests/overloadedrecflds/should_compile/DupFldFixity1.hs new file mode 100644 index 0000000000..58e7afe673 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_compile/DupFldFixity1.hs @@ -0,0 +1,9 @@ + + +{-# LANGUAGE DuplicateRecordFields #-} + +module DupFldFixity1 where + +data A = MkA { fld :: A -> A } + +infixr 4 `fld` diff --git a/testsuite/tests/overloadedrecflds/should_compile/DupFldFixity2.hs b/testsuite/tests/overloadedrecflds/should_compile/DupFldFixity2.hs new file mode 100644 index 0000000000..85811c3b0f --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_compile/DupFldFixity2.hs @@ -0,0 +1,12 @@ + +{-# LANGUAGE NoFieldSelectors #-} + +module DupFldFixity2 where + +data A = MkA { fld :: A -> A } +data B + +fld :: B -> B -> B +fld x _ = x + +infixr 4 `fld` diff --git a/testsuite/tests/overloadedrecflds/should_compile/DupFldFixity3.hs b/testsuite/tests/overloadedrecflds/should_compile/DupFldFixity3.hs new file mode 100644 index 0000000000..73d8490d57 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_compile/DupFldFixity3.hs @@ -0,0 +1,9 @@ + +{-# LANGUAGE DuplicateRecordFields #-} + +module DupFldFixity3 where + +data A = MkA { fld :: A -> A } +data B = MkB { fld :: A -> A } + +infixr 4 `fld` diff --git a/testsuite/tests/overloadedrecflds/should_compile/NoDRFModuleExport.hs b/testsuite/tests/overloadedrecflds/should_compile/NoDRFModuleExport.hs new file mode 100644 index 0000000000..11a21af800 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_compile/NoDRFModuleExport.hs @@ -0,0 +1,6 @@ +-- Test that we can re-export a module defining +-- duplicate record fields, without ourselves enabling +-- the DuplicateRecordFields extension. + +module NoDRFModuleExport ( module NoDRFModuleExport_aux ) where + import NoDRFModuleExport_aux diff --git a/testsuite/tests/overloadedrecflds/should_compile/NoDRFModuleExport_aux.hs b/testsuite/tests/overloadedrecflds/should_compile/NoDRFModuleExport_aux.hs new file mode 100644 index 0000000000..4720fdd547 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_compile/NoDRFModuleExport_aux.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE DuplicateRecordFields #-} +module NoDRFModuleExport_aux where + data A = MkA { foo :: A } + data B = MkB { foo :: B } diff --git a/testsuite/tests/overloadedrecflds/should_compile/OverloadedRecFlds10_A.hs b/testsuite/tests/overloadedrecflds/should_compile/OverloadedRecFlds10_A.hs new file mode 100644 index 0000000000..ae25153621 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_compile/OverloadedRecFlds10_A.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE TypeFamilies #-} +module OverloadedRecFlds10_A where + +data family F a +data instance F Int = MkFInt { foo :: Int } diff --git a/testsuite/tests/overloadedrecflds/should_compile/OverloadedRecFlds10_B.hs b/testsuite/tests/overloadedrecflds/should_compile/OverloadedRecFlds10_B.hs new file mode 100644 index 0000000000..0f7be47880 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_compile/OverloadedRecFlds10_B.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TypeFamilies #-} +module OverloadedRecFlds10_B (F(..)) where + +import OverloadedRecFlds10_A hiding (foo) + +data instance F Bool = MkFBool { foo :: Int } diff --git a/testsuite/tests/overloadedrecflds/should_compile/OverloadedRecFlds10_C.hs b/testsuite/tests/overloadedrecflds/should_compile/OverloadedRecFlds10_C.hs new file mode 100644 index 0000000000..29c4863334 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_compile/OverloadedRecFlds10_C.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE DuplicateRecordFields, TypeFamilies #-} +module OverloadedRecFlds10_C (F(..)) where + +import OverloadedRecFlds10_A + +data instance F Char = MkFChar { foo :: Char } diff --git a/testsuite/tests/overloadedrecflds/should_fail/T11103.hs b/testsuite/tests/overloadedrecflds/should_compile/T11103.hs index 2791dc4fca..6662b29cfa 100644 --- a/testsuite/tests/overloadedrecflds/should_fail/T11103.hs +++ b/testsuite/tests/overloadedrecflds/should_compile/T11103.hs @@ -1,9 +1,7 @@ --- When using DuplicateRecordFields with TemplateHaskell, it is not possible to --- reify ambiguous names that are output by reifying field labels. --- See also overloadedrecflds/should_run/overloadedrecfldsrun04.hs - {-# LANGUAGE DuplicateRecordFields, TemplateHaskell #-} +module T11103 where + import Language.Haskell.TH import Language.Haskell.TH.Syntax diff --git a/testsuite/tests/overloadedrecflds/should_compile/T13352.hs b/testsuite/tests/overloadedrecflds/should_compile/T13352.hs new file mode 100644 index 0000000000..9d85b725b6 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_compile/T13352.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE DuplicateRecordFields #-} +module T13352 (S(foo), T(foo)) where + import T13352_A (S(..)) + import T13352_B (T(..)) diff --git a/testsuite/tests/overloadedrecflds/should_compile/T13352_A.hs b/testsuite/tests/overloadedrecflds/should_compile/T13352_A.hs new file mode 100644 index 0000000000..2639b4bb38 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_compile/T13352_A.hs @@ -0,0 +1,2 @@ +module T13352_A where + data S = MkS { foo :: Int } diff --git a/testsuite/tests/overloadedrecflds/should_compile/T13352_B.hs b/testsuite/tests/overloadedrecflds/should_compile/T13352_B.hs new file mode 100644 index 0000000000..b04cd1168f --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_compile/T13352_B.hs @@ -0,0 +1,2 @@ +module T13352_B where + data T = MkT { foo :: Int } diff --git a/testsuite/tests/overloadedrecflds/should_compile/T13352_hard.hs b/testsuite/tests/overloadedrecflds/should_compile/T13352_hard.hs new file mode 100644 index 0000000000..982305e71d --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_compile/T13352_hard.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE DuplicateRecordFields #-} +module T13352_hard (S(foo), T(foo)) where + import T13352_hard_A (S(..)) + import T13352_hard_B (T(..)) diff --git a/testsuite/tests/overloadedrecflds/should_compile/T13352_hard.stderr b/testsuite/tests/overloadedrecflds/should_compile/T13352_hard.stderr new file mode 100644 index 0000000000..bd4bf93121 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_compile/T13352_hard.stderr @@ -0,0 +1,9 @@ + +T13352_hard.hs:2:29: error: [GHC-69158] + Conflicting exports for ‘foo’: + ‘S(foo)’ exports ‘T13352_hard_A.foo’ + imported from ‘T13352_hard_A’ at T13352_hard.hs:3:25-29 + (and originally defined at T13352_hard_A.hs:3:16-18) + ‘T(foo)’ exports ‘T13352_hard_B.foo’ + imported from ‘T13352_hard_B’ at T13352_hard.hs:4:25-29 + (and originally defined at T13352_hard_B.hs:3:16-18) diff --git a/testsuite/tests/overloadedrecflds/should_compile/T13352_hard_A.hs b/testsuite/tests/overloadedrecflds/should_compile/T13352_hard_A.hs new file mode 100644 index 0000000000..3fcba12280 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_compile/T13352_hard_A.hs @@ -0,0 +1,3 @@ +{-# LANGUAGE DuplicateRecordFields #-} +module T13352_hard_A where + data S = C { foo :: Int } diff --git a/testsuite/tests/overloadedrecflds/should_compile/T13352_hard_B.hs b/testsuite/tests/overloadedrecflds/should_compile/T13352_hard_B.hs new file mode 100644 index 0000000000..7271dda542 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_compile/T13352_hard_B.hs @@ -0,0 +1,3 @@ +{-# LANGUAGE DuplicateRecordFields #-} +module T13352_hard_B where + data T = C { foo :: Int } diff --git a/testsuite/tests/overloadedrecflds/should_compile/T14848.hs b/testsuite/tests/overloadedrecflds/should_compile/T14848.hs new file mode 100644 index 0000000000..f19ebbecca --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_compile/T14848.hs @@ -0,0 +1,10 @@ +{-# language TemplateHaskell #-} +{-# language DuplicateRecordFields #-} + +module T14848 where +import Language.Haskell.TH +import Language.Haskell.TH.Syntax + +data A = A {x :: Int, y :: String} +a = A 3 "test" +test = $([e|case a of A {x = b} -> b|]) diff --git a/testsuite/tests/overloadedrecflds/should_compile/T17551.hs b/testsuite/tests/overloadedrecflds/should_compile/T17551.hs new file mode 100644 index 0000000000..8fe5d9f808 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_compile/T17551.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE TemplateHaskell #-} + +module T17551 where + +import Language.Haskell.TH + +data Foo = Foo { foo :: Int } +data Bar = Bar { foo :: Int } + +$(do + TyConI (DataD _ _ _ _ [RecC con [(field, _, _)]] _) <- reify ''Bar + reify field + pure [] + ) diff --git a/testsuite/tests/overloadedrecflds/should_compile/T21720.hs b/testsuite/tests/overloadedrecflds/should_compile/T21720.hs new file mode 100644 index 0000000000..072bde217a --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_compile/T21720.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# OPTIONS_GHC -dcore-lint #-} + +module T21720 where + +import Language.Haskell.TH + +main :: IO () +main = pure () + +$(do + let noBang = Bang NoSourceUnpackedness NoSourceStrictness + let mkData tn cn fn = DataD [] tn [] Nothing [RecC cn [(fn, noBang, ConT ''Integer)]] [] + r1 <- mkData <$> newName "R1" <*> newName "C1" <*> newName "f" + r2 <- mkData <$> newName "R2" <*> newName "C2" <*> newName "f" + pure [r1,r2] + ) diff --git a/testsuite/tests/overloadedrecflds/should_compile/T21898.hs b/testsuite/tests/overloadedrecflds/should_compile/T21898.hs new file mode 100644 index 0000000000..b7b0b051e8 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_compile/T21898.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE DuplicateRecordFields, PatternSynonyms #-} + +module T21898 where + +pattern P :: Int -> Int -> (Int, Int) +pattern P { proj_x, proj_y } = (proj_x, proj_y) + +pattern Q1 :: Int -> Int +pattern Q1 { proj_x } = proj_x + +pattern Q2 :: Int -> Int +pattern Q2 { proj_y } = proj_y + +blah :: (Int, Int) -> (Int, Int) +blah p = p { proj_x = 0, proj_y = 1 } diff --git a/testsuite/tests/overloadedrecflds/should_compile/T22160.hs b/testsuite/tests/overloadedrecflds/should_compile/T22160.hs new file mode 100644 index 0000000000..28aaa3c735 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_compile/T22160.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE DisambiguateRecordFields #-} + +module T22160 where + +import T22160_A +import T22160_B +import T22160_C + +eg r = r { x = 1, y = 1 } diff --git a/testsuite/tests/overloadedrecflds/should_compile/T22160_A.hs b/testsuite/tests/overloadedrecflds/should_compile/T22160_A.hs new file mode 100644 index 0000000000..341df010ba --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_compile/T22160_A.hs @@ -0,0 +1,3 @@ +module T22160_A where + +data A = MkA { x :: Int } diff --git a/testsuite/tests/overloadedrecflds/should_compile/T22160_B.hs b/testsuite/tests/overloadedrecflds/should_compile/T22160_B.hs new file mode 100644 index 0000000000..2da5511e6c --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_compile/T22160_B.hs @@ -0,0 +1,3 @@ +module T22160_B where + +data B = MkB { y :: Int } diff --git a/testsuite/tests/overloadedrecflds/should_compile/T22160_C.hs b/testsuite/tests/overloadedrecflds/should_compile/T22160_C.hs new file mode 100644 index 0000000000..450463e0a6 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_compile/T22160_C.hs @@ -0,0 +1,3 @@ +module T22160_C where + +data C = MkC { x, y :: Int } diff --git a/testsuite/tests/overloadedrecflds/should_compile/T23010.hs b/testsuite/tests/overloadedrecflds/should_compile/T23010.hs new file mode 100644 index 0000000000..7ae1ff5f98 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_compile/T23010.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE DuplicateRecordFields #-} + +module T23010 ( A(..) ) where + +import T23010_aux ( X ) + +data A = MkA { fld :: A, other :: X } +data B = MkB { fld :: B } diff --git a/testsuite/tests/overloadedrecflds/should_compile/T23010.hs-boot b/testsuite/tests/overloadedrecflds/should_compile/T23010.hs-boot new file mode 100644 index 0000000000..ea72bd20f6 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_compile/T23010.hs-boot @@ -0,0 +1,7 @@ +{-# LANGUAGE DuplicateRecordFields #-} + +module T23010 where + +data A + +fld :: A -> A diff --git a/testsuite/tests/overloadedrecflds/should_compile/T23010_aux.hs b/testsuite/tests/overloadedrecflds/should_compile/T23010_aux.hs new file mode 100644 index 0000000000..1f1280b26a --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_compile/T23010_aux.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE DuplicateRecordFields #-} + +module T23010_aux where + +import {-# SOURCE #-} T23010 ( fld ) + +data X +bar = fld diff --git a/testsuite/tests/overloadedrecflds/should_compile/all.T b/testsuite/tests/overloadedrecflds/should_compile/all.T index 9d49752f2b..000fd696e4 100644 --- a/testsuite/tests/overloadedrecflds/should_compile/all.T +++ b/testsuite/tests/overloadedrecflds/should_compile/all.T @@ -12,3 +12,38 @@ test('T19154', normal, compile, ['']) test('T20723', normal, compile, ['']) test('T20989', normal, compile, ['']) test('T21625', [], multimod_compile, ['T21625', '-v0']) +test('DupFldFixity1', normal, compile, ['']) +test('DupFldFixity2', normal, compile, ['']) +test('T23010', [extra_files(['T23010.hs-boot', 'T23010_aux.hs'])] + , multimod_compile + , ['T23010', '-v0']) +test('T14848', req_th, compile, ['']) +test('T17551', req_th, compile, ['']) +test('T11103', req_th, compile, ['']) +test('T13352' + , [extra_files(['T13352_A.hs', 'T13352_B.hs'])] + , multimod_compile, ['T13352_A T13352_B T13352', '-v0']) +test('T13352_hard' + , [extra_files(['T13352_hard_A.hs', 'T13352_hard_B.hs'])] + , multimod_compile_fail, ['T13352_hard_A T13352_hard_B T13352_hard', '-v0']) +test('T21720', req_th, compile, ['']) +test('T21898', normal, compile, ['']) +test('T22160', [extra_files(['T22160_A.hs', 'T22160_B.hs', 'T22160_C.hs'])] + , multimod_compile, ['T22160_A T22160_B T22160_C T22160', '-v0']) +test('DupFldFixity3', normal, compile, ['']) +test('overloadedrecflds10' + , [extra_files(['OverloadedRecFlds10_A.hs', 'OverloadedRecFlds10_B.hs', 'OverloadedRecFlds10_C.hs'])] + , multimod_compile + , ['overloadedrecflds10', '-v0']) +test('NoDRFModuleExport' + , [extra_files(['NoDRFModuleExport_aux.hs'])] + , multimod_compile + , ['NoDRFModuleExport', '-v0']) +test('BootFldReexport' + , [extra_files([ 'BootFldReexport_N.hs', 'BootFldReexport_N.hs-boot' + , 'BootFldReexport_O.hs', 'BootFldReexport_O.hs-boot' + , 'BootFldReexport_B.hs' ])] + , multimod_compile_fail + # Should either pass or give an ambiguity error when compiling + # the final module (BootFldReexport), but not fail earlier. + , ['BootFldReexport', '-v0']) diff --git a/testsuite/tests/overloadedrecflds/should_compile/overloadedrecflds10.hs b/testsuite/tests/overloadedrecflds/should_compile/overloadedrecflds10.hs new file mode 100644 index 0000000000..c85d303d0e --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_compile/overloadedrecflds10.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE DuplicateRecordFields #-} +module Main (main, F(..)) where + +import OverloadedRecFlds10_B +import OverloadedRecFlds10_C + +main = return () diff --git a/testsuite/tests/overloadedrecflds/should_fail/DRF9156.stderr b/testsuite/tests/overloadedrecflds/should_fail/DRF9156.stderr index ea1d10dc10..5e18bdf59a 100644 --- a/testsuite/tests/overloadedrecflds/should_fail/DRF9156.stderr +++ b/testsuite/tests/overloadedrecflds/should_fail/DRF9156.stderr @@ -1,5 +1,3 @@ -DRF9156.hs:4:19: error: - Multiple declarations of ‘f1’ - Declared at: DRF9156.hs:3:15 - DRF9156.hs:4:19 +DRF9156.hs:4:19: error: [GHC-85524] + Duplicate field name ‘f1’ in record declaration diff --git a/testsuite/tests/overloadedrecflds/should_fail/DRFHoleFits.stderr b/testsuite/tests/overloadedrecflds/should_fail/DRFHoleFits.stderr index 61779352c3..1fb78b2175 100644 --- a/testsuite/tests/overloadedrecflds/should_fail/DRFHoleFits.stderr +++ b/testsuite/tests/overloadedrecflds/should_fail/DRFHoleFits.stderr @@ -1,5 +1,3 @@ -[1 of 2] Compiling DRFHoleFits_A ( DRFHoleFits_A.hs, DRFHoleFits_A.o ) -[2 of 2] Compiling DRFHoleFits ( DRFHoleFits.hs, DRFHoleFits.o ) DRFHoleFits.hs:7:7: error: [GHC-88464] • Found hole: _ :: T -> Int @@ -19,6 +17,6 @@ DRFHoleFits.hs:8:7: error: [GHC-88464] baz :: A.S -> Int (bound at DRFHoleFits.hs:8:1) Valid hole fits include baz :: A.S -> Int (defined at DRFHoleFits.hs:8:1) - DRFHoleFits_A.foo :: A.S -> Int + A.foo :: A.S -> Int (imported qualified from ‘DRFHoleFits_A’ at DRFHoleFits.hs:3:1-35 (and originally defined at DRFHoleFits_A.hs:5:16-18)) diff --git a/testsuite/tests/overloadedrecflds/should_fail/DRFUnused.stderr b/testsuite/tests/overloadedrecflds/should_fail/DRFUnused.stderr index e020e8cd82..88e9e6537f 100644 --- a/testsuite/tests/overloadedrecflds/should_fail/DRFUnused.stderr +++ b/testsuite/tests/overloadedrecflds/should_fail/DRFUnused.stderr @@ -2,6 +2,6 @@ DRFUnused.hs:18:5: error: Ambiguous occurrence ‘foo’ It could refer to - either the field ‘foo’ of record ‘U’, defined at DRFUnused.hs:12:16 + either the field ‘foo’ of record ‘S’, defined at DRFUnused.hs:10:16 or the field ‘foo’ of record ‘T’, defined at DRFUnused.hs:11:16 - or the field ‘foo’ of record ‘S’, defined at DRFUnused.hs:10:16 + or the field ‘foo’ of record ‘U’, defined at DRFUnused.hs:12:16 diff --git a/testsuite/tests/overloadedrecflds/should_fail/NFS9156.stderr b/testsuite/tests/overloadedrecflds/should_fail/NFS9156.stderr index 66ab58fcbd..c735f618e8 100644 --- a/testsuite/tests/overloadedrecflds/should_fail/NFS9156.stderr +++ b/testsuite/tests/overloadedrecflds/should_fail/NFS9156.stderr @@ -1,5 +1,3 @@ -NFS9156.hs:4:19: error: - Multiple declarations of ‘f1’ - Declared at: NFS9156.hs:3:15 - NFS9156.hs:4:19 +NFS9156.hs:4:19: error: [GHC-85524] + Duplicate field name ‘f1’ in record declaration diff --git a/testsuite/tests/overloadedrecflds/should_fail/NFSExport.hs b/testsuite/tests/overloadedrecflds/should_fail/NFSExport.hs index 839b32bae4..86c21c2dcf 100644 --- a/testsuite/tests/overloadedrecflds/should_fail/NFSExport.hs +++ b/testsuite/tests/overloadedrecflds/should_fail/NFSExport.hs @@ -1,3 +1,3 @@ {-# LANGUAGE NoFieldSelectors #-} module NFSExport (T(foo), foo) where -- only T(foo) is supported -data T = MkT { foo :: Bool } +data T = MkT { foo :: T } diff --git a/testsuite/tests/overloadedrecflds/should_fail/NFSMixed.hs b/testsuite/tests/overloadedrecflds/should_fail/NFSMixed.hs index d2b3d8dd1b..05ddc0cd39 100644 --- a/testsuite/tests/overloadedrecflds/should_fail/NFSMixed.hs +++ b/testsuite/tests/overloadedrecflds/should_fail/NFSMixed.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE DisambiguateRecordFields #-} + module NFSMixed where import NFSMixedA diff --git a/testsuite/tests/overloadedrecflds/should_fail/NFSMixed.stderr b/testsuite/tests/overloadedrecflds/should_fail/NFSMixed.stderr index 0419feb764..3f50bfe597 100644 --- a/testsuite/tests/overloadedrecflds/should_fail/NFSMixed.stderr +++ b/testsuite/tests/overloadedrecflds/should_fail/NFSMixed.stderr @@ -1,13 +1,7 @@ -NFSMixed.hs:5:18: error: - Ambiguous occurrence ‘foo’ - It could refer to - either the field ‘foo’ of record ‘Foo’, - imported from ‘NFSMixedA’ at NFSMixed.hs:3:1-16 - (and originally defined at NFSMixedA.hs:4:18-20) - or the field ‘foo’ of record ‘Bar’, - imported from ‘NFSMixedA’ at NFSMixed.hs:3:1-16 - (and originally defined at NFSMixedA.hs:5:18-20) - or ‘NFSMixedA.foo’, - imported from ‘NFSMixedA’ at NFSMixed.hs:3:1-16 - (and originally defined at NFSMixedA.hs:8:1-3) +NFSMixed.hs:7:14: error: [GHC-99339] + • Ambiguous record update with field ‘foo’ + This field appears in both datatypes ‘Foo’ and ‘Bar’ + • In the expression: x {foo = 0} + In the expression: \ x -> x {foo = 0} + In an equation for ‘test’: test = \ x -> x {foo = 0} diff --git a/testsuite/tests/overloadedrecflds/should_fail/NoFieldSelectorsFail.stderr b/testsuite/tests/overloadedrecflds/should_fail/NoFieldSelectorsFail.stderr index 6810d549ff..301b6bc4b8 100644 --- a/testsuite/tests/overloadedrecflds/should_fail/NoFieldSelectorsFail.stderr +++ b/testsuite/tests/overloadedrecflds/should_fail/NoFieldSelectorsFail.stderr @@ -9,32 +9,35 @@ NoFieldSelectorsFail.hs:9:14: error: imported from ‘NoFieldSelectorsFailA’ at NoFieldSelectorsFail.hs:4:1-28 (and originally defined at NoFieldSelectorsFailA.hs:6:18-20) -NoFieldSelectorsFail.hs:12:15: error: - Ambiguous occurrence ‘foo’ - It could refer to - either the field ‘foo’ of record ‘Foo’, - imported from ‘NoFieldSelectorsFailA’ at NoFieldSelectorsFail.hs:4:1-28 - (and originally defined at NoFieldSelectorsFailA.hs:5:18-20) - or the field ‘foo’ of record ‘Bar’, - imported from ‘NoFieldSelectorsFailA’ at NoFieldSelectorsFail.hs:4:1-28 - (and originally defined at NoFieldSelectorsFailA.hs:6:18-20) +NoFieldSelectorsFail.hs:12:15: error: [GHC-56428] + Ambiguous record field ‘foo’. + It could refer to any of the following: + • record field ‘foo’ of ‘Foo’, + imported from ‘NoFieldSelectorsFailA’ at NoFieldSelectorsFail.hs:4:1-28 + (and originally defined at NoFieldSelectorsFailA.hs:5:18-20) + • record field ‘foo’ of ‘Bar’, + imported from ‘NoFieldSelectorsFailA’ at NoFieldSelectorsFail.hs:4:1-28 + (and originally defined at NoFieldSelectorsFailA.hs:6:18-20) + Suggested fix: Perhaps you intended to use DisambiguateRecordFields -NoFieldSelectorsFail.hs:14:15: error: - Ambiguous occurrence ‘foo’ - It could refer to - either the field ‘foo’ of record ‘Foo’, - imported from ‘NoFieldSelectorsFailA’ at NoFieldSelectorsFail.hs:4:1-28 - (and originally defined at NoFieldSelectorsFailA.hs:5:18-20) - or the field ‘foo’ of record ‘Bar’, - imported from ‘NoFieldSelectorsFailA’ at NoFieldSelectorsFail.hs:4:1-28 - (and originally defined at NoFieldSelectorsFailA.hs:6:18-20) +NoFieldSelectorsFail.hs:14:15: error: [GHC-56428] + Ambiguous record field ‘foo’. + It could refer to any of the following: + • record field ‘foo’ of ‘Foo’, + imported from ‘NoFieldSelectorsFailA’ at NoFieldSelectorsFail.hs:4:1-28 + (and originally defined at NoFieldSelectorsFailA.hs:5:18-20) + • record field ‘foo’ of ‘Bar’, + imported from ‘NoFieldSelectorsFailA’ at NoFieldSelectorsFail.hs:4:1-28 + (and originally defined at NoFieldSelectorsFailA.hs:6:18-20) + Suggested fix: Perhaps you intended to use DisambiguateRecordFields -NoFieldSelectorsFail.hs:16:15: error: - Ambiguous occurrence ‘bar’ - It could refer to - either the field ‘bar’ of record ‘Foo’, - imported from ‘NoFieldSelectorsFailA’ at NoFieldSelectorsFail.hs:4:1-28 - (and originally defined at NoFieldSelectorsFailA.hs:5:30-32) - or ‘NoFieldSelectorsFailA.bar’, - imported from ‘NoFieldSelectorsFailA’ at NoFieldSelectorsFail.hs:4:1-28 - (and originally defined at NoFieldSelectorsFailA.hs:8:1-3) +NoFieldSelectorsFail.hs:16:15: error: [GHC-56428] + Ambiguous record field ‘bar’. + It could refer to any of the following: + • record field ‘bar’ of ‘Foo’, + imported from ‘NoFieldSelectorsFailA’ at NoFieldSelectorsFail.hs:4:1-28 + (and originally defined at NoFieldSelectorsFailA.hs:5:30-32) + • variable ‘bar’, + imported from ‘NoFieldSelectorsFailA’ at NoFieldSelectorsFail.hs:4:1-28 + (and originally defined at NoFieldSelectorsFailA.hs:8:1-3) + Suggested fix: Perhaps you intended to use DisambiguateRecordFields diff --git a/testsuite/tests/overloadedrecflds/should_fail/NoParent.stderr b/testsuite/tests/overloadedrecflds/should_fail/NoParent.stderr index b75b8c1df5..a18161d2e9 100644 --- a/testsuite/tests/overloadedrecflds/should_fail/NoParent.stderr +++ b/testsuite/tests/overloadedrecflds/should_fail/NoParent.stderr @@ -2,5 +2,5 @@ NoParent.hs:2:18: error: [GHC-88993] • The type constructor ‘A’ is not the parent of the record selector ‘x’. Record selectors can only be exported with their parent type constructor. - Parents: C, B + Parents: B, C • In the export: A(x) diff --git a/testsuite/tests/overloadedrecflds/should_fail/T11103.stderr b/testsuite/tests/overloadedrecflds/should_fail/T11103.stderr deleted file mode 100644 index 076d067d36..0000000000 --- a/testsuite/tests/overloadedrecflds/should_fail/T11103.stderr +++ /dev/null @@ -1,6 +0,0 @@ - -T11103.hs:13:2: error: - Ambiguous occurrence ‘Main.foo’ - It could refer to - either the field ‘foo’ of record ‘S’, defined at T11103.hs:11:16 - or the field ‘foo’ of record ‘R’, defined at T11103.hs:10:16 diff --git a/testsuite/tests/overloadedrecflds/should_fail/T11167_ambiguous_fixity.stderr b/testsuite/tests/overloadedrecflds/should_fail/T11167_ambiguous_fixity.stderr index 709ee2312d..277a5bd0ac 100644 --- a/testsuite/tests/overloadedrecflds/should_fail/T11167_ambiguous_fixity.stderr +++ b/testsuite/tests/overloadedrecflds/should_fail/T11167_ambiguous_fixity.stderr @@ -5,12 +5,12 @@ T11167_ambiguous_fixity.hs:6:16: error: Ambiguous occurrence ‘foo’ It could refer to - either the field ‘foo’ of record ‘C’, - imported from ‘T11167_ambiguous_fixity_A’ at T11167_ambiguous_fixity.hs:3:1-32 - (and originally defined at T11167_ambiguous_fixity_A.hs:4:16-18) - or the field ‘foo’ of record ‘A’, + either the field ‘foo’ of record ‘A’, imported from ‘T11167_ambiguous_fixity_A’ at T11167_ambiguous_fixity.hs:3:1-32 (and originally defined at T11167_ambiguous_fixity_A.hs:3:16-18) + or the field ‘foo’ of record ‘C’, + imported from ‘T11167_ambiguous_fixity_A’ at T11167_ambiguous_fixity.hs:3:1-32 + (and originally defined at T11167_ambiguous_fixity_A.hs:4:16-18) or the field ‘foo’ of record ‘B’, imported from ‘T11167_ambiguous_fixity_B’ at T11167_ambiguous_fixity.hs:4:1-32 (and originally defined at T11167_ambiguous_fixity_B.hs:2:16-18) diff --git a/testsuite/tests/overloadedrecflds/should_fail/T13132_duplicaterecflds.stderr b/testsuite/tests/overloadedrecflds/should_fail/T13132_duplicaterecflds.stderr index a2a4428b0b..462b00416c 100644 --- a/testsuite/tests/overloadedrecflds/should_fail/T13132_duplicaterecflds.stderr +++ b/testsuite/tests/overloadedrecflds/should_fail/T13132_duplicaterecflds.stderr @@ -2,10 +2,10 @@ T13132_duplicaterecflds.hs:7:16: error: Ambiguous occurrence ‘runContT’ It could refer to - either the field ‘runContT’ of record ‘ContT2’, - defined at T13132_duplicaterecflds.hs:5:33 - or the field ‘runContT’ of record ‘ContT’, + either the field ‘runContT’ of record ‘ContT’, defined at T13132_duplicaterecflds.hs:4:31 + or the field ‘runContT’ of record ‘ContT2’, + defined at T13132_duplicaterecflds.hs:5:33 T13132_duplicaterecflds.hs:9:11: error: The operator ‘runContT’ [infixl 9] of a section @@ -16,7 +16,7 @@ T13132_duplicaterecflds.hs:9:11: error: T13132_duplicaterecflds.hs:9:12: error: Ambiguous occurrence ‘runContT’ It could refer to - either the field ‘runContT’ of record ‘ContT2’, - defined at T13132_duplicaterecflds.hs:5:33 - or the field ‘runContT’ of record ‘ContT’, + either the field ‘runContT’ of record ‘ContT’, defined at T13132_duplicaterecflds.hs:4:31 + or the field ‘runContT’ of record ‘ContT2’, + defined at T13132_duplicaterecflds.hs:5:33 diff --git a/testsuite/tests/overloadedrecflds/should_fail/T14953.stderr b/testsuite/tests/overloadedrecflds/should_fail/T14953.stderr index 144e306483..19003fc78c 100644 --- a/testsuite/tests/overloadedrecflds/should_fail/T14953.stderr +++ b/testsuite/tests/overloadedrecflds/should_fail/T14953.stderr @@ -4,10 +4,10 @@ T14953.hs:2:33: error: [GHC-69158] Conflicting exports for ‘unR’: - ‘module T14953_A’ exports ‘unR’ + ‘module T14953_A’ exports ‘T14953_A.unR’ imported from ‘T14953_A’ at T14953.hs:3:1-15 (and originally defined at T14953_A.hs:3:13-15) - ‘module T14953_B’ exports ‘unR’ + ‘module T14953_B’ exports ‘T14953_B.unR’ imported from ‘T14953_B’ at T14953.hs:4:1-15 (and originally defined at T14953_B.hs:3:13-15) diff --git a/testsuite/tests/overloadedrecflds/should_fail/T16745.stderr b/testsuite/tests/overloadedrecflds/should_fail/T16745.stderr index 61a9567788..5969a540e0 100644 --- a/testsuite/tests/overloadedrecflds/should_fail/T16745.stderr +++ b/testsuite/tests/overloadedrecflds/should_fail/T16745.stderr @@ -6,9 +6,9 @@ T16745A.hs:8:9: error: Ambiguous occurrence ‘field’ It could refer to - either the field ‘field’ of record ‘T16745B.R’, - imported from ‘T16745B’ at T16745A.hs:3:24-28 - (and originally defined at T16745B.hs:11:14-18) - or ‘T16745B.field’, + either ‘T16745B.field’, imported from ‘T16745B’ at T16745A.hs:3:24-28 (and originally defined in ‘T16745C’ at T16745C.hs:2:1-5) + or the field ‘field’ of record ‘T16745B.R’, + imported from ‘T16745B’ at T16745A.hs:3:24-28 + (and originally defined at T16745B.hs:11:14-18) diff --git a/testsuite/tests/overloadedrecflds/should_fail/T17420.stderr b/testsuite/tests/overloadedrecflds/should_fail/T17420.stderr index 5089f19ce2..e1db5fa195 100644 --- a/testsuite/tests/overloadedrecflds/should_fail/T17420.stderr +++ b/testsuite/tests/overloadedrecflds/should_fail/T17420.stderr @@ -4,9 +4,9 @@ T17420.hs:6:17: error: Ambiguous occurrence ‘name’ It could refer to - either the field ‘name’ of record ‘Human’, - imported from ‘T17420A’ at T17420.hs:4:1-14 - (and originally defined at T17420A.hs:5:22-25) - or the field ‘name’ of record ‘Dog’, + either the field ‘name’ of record ‘Dog’, imported from ‘T17420A’ at T17420.hs:4:1-14 (and originally defined at T17420A.hs:4:18-21) + or the field ‘name’ of record ‘Human’, + imported from ‘T17420A’ at T17420.hs:4:1-14 + (and originally defined at T17420A.hs:5:22-25) diff --git a/testsuite/tests/overloadedrecflds/should_fail/T18999_NoDisambiguateRecordFields.stderr b/testsuite/tests/overloadedrecflds/should_fail/T18999_NoDisambiguateRecordFields.stderr index d271efc7f8..f462dcb187 100644 --- a/testsuite/tests/overloadedrecflds/should_fail/T18999_NoDisambiguateRecordFields.stderr +++ b/testsuite/tests/overloadedrecflds/should_fail/T18999_NoDisambiguateRecordFields.stderr @@ -8,11 +8,12 @@ T18999_NoDisambiguateRecordFields.hs:6:13: error: or the field ‘not’ of record ‘Foo’, defined at T18999_NoDisambiguateRecordFields.hs:4:18 -T18999_NoDisambiguateRecordFields.hs:8:11: error: - Ambiguous occurrence ‘not’ - It could refer to - either ‘Prelude.not’, - imported from ‘Prelude’ at T18999_NoDisambiguateRecordFields.hs:2:8-40 - (and originally defined in ‘GHC.Classes’) - or the field ‘not’ of record ‘Foo’, - defined at T18999_NoDisambiguateRecordFields.hs:4:18 +T18999_NoDisambiguateRecordFields.hs:8:11: error: [GHC-56428] + Ambiguous record field ‘not’. + It could refer to any of the following: + • record field ‘not’ of ‘Foo’, + defined at T18999_NoDisambiguateRecordFields.hs:4:18 + • variable ‘not’, + imported from ‘Prelude’ at T18999_NoDisambiguateRecordFields.hs:2:8-40 + (and originally defined in ‘GHC.Classes’) + Suggested fix: Perhaps you intended to use DisambiguateRecordFields diff --git a/testsuite/tests/overloadedrecflds/should_fail/T19287.hs b/testsuite/tests/overloadedrecflds/should_fail/T19287.hs index f3dedbe4bc..793d0e61e7 100644 --- a/testsuite/tests/overloadedrecflds/should_fail/T19287.hs +++ b/testsuite/tests/overloadedrecflds/should_fail/T19287.hs @@ -1,7 +1,7 @@ {-# LANGUAGE DuplicateRecordFields #-} module Main where -data R a b = R { x :: a , x :: b} +data R a b = R { x :: a , x :: b } unsafeCoerce :: a -> b unsafeCoerce i = case (R i i){x = i} of diff --git a/testsuite/tests/overloadedrecflds/should_fail/T19287.stderr b/testsuite/tests/overloadedrecflds/should_fail/T19287.stderr index c0c5a0caa9..03a88e1f78 100644 --- a/testsuite/tests/overloadedrecflds/should_fail/T19287.stderr +++ b/testsuite/tests/overloadedrecflds/should_fail/T19287.stderr @@ -1,5 +1,3 @@ -T19287.hs:4:27: error: - Multiple declarations of ‘x’ - Declared at: T19287.hs:4:18 - T19287.hs:4:27 +T19287.hs:4:27: error: [GHC-85524] + Duplicate field name ‘x’ in record declaration diff --git a/testsuite/tests/overloadedrecflds/should_fail/T21946.hs b/testsuite/tests/overloadedrecflds/should_fail/T21946.hs new file mode 100644 index 0000000000..fdd0f09749 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/T21946.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE DuplicateRecordFields, PatternSynonyms #-} + +module T21946 where + +pattern R1 :: Int -> Int +pattern R1 { fld } = fld + +pattern R2 :: Bool -> Bool +pattern R2 { fld } = fld + +f r = (r :: Int) { fld = undefined } diff --git a/testsuite/tests/overloadedrecflds/should_fail/T21946.stderr b/testsuite/tests/overloadedrecflds/should_fail/T21946.stderr new file mode 100644 index 0000000000..61254e3e3d --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/T21946.stderr @@ -0,0 +1,8 @@ + +T21946.hs:11:7: error: [GHC-33238] + • No data constructor of type constructor ‘Int’ + has all of the fields: + ‘fld’ + NB: type-directed disambiguation is not supported for pattern synonym record fields. + • In the expression: (r :: Int) {fld = undefined} + In an equation for ‘f’: f r = (r :: Int) {fld = undefined} diff --git a/testsuite/tests/overloadedrecflds/should_fail/T21959.hs b/testsuite/tests/overloadedrecflds/should_fail/T21959.hs new file mode 100644 index 0000000000..b10c2a1355 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/T21959.hs @@ -0,0 +1,6 @@ +module T21959 where + +data R = R { fld :: Int } + +f :: R -> R +f r = r { T21959.fld = 1, fld = 2 } diff --git a/testsuite/tests/overloadedrecflds/should_fail/T21959.stderr b/testsuite/tests/overloadedrecflds/should_fail/T21959.stderr new file mode 100644 index 0000000000..49d00962a0 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/T21959.stderr @@ -0,0 +1,3 @@ + +T21959.hs:6:7: error: [GHC-85524] + Duplicate field name ‘fld’ in record update diff --git a/testsuite/tests/overloadedrecflds/should_fail/T23010_fail.hs b/testsuite/tests/overloadedrecflds/should_fail/T23010_fail.hs new file mode 100644 index 0000000000..83421fd2de --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/T23010_fail.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE DuplicateRecordFields #-} + +module T23010_fail where + +import T23010_fail_aux ( X ) +data A = MkA { fld :: A, other :: X } +data B = MkB { fld :: B } diff --git a/testsuite/tests/overloadedrecflds/should_fail/T23010_fail.hs-boot b/testsuite/tests/overloadedrecflds/should_fail/T23010_fail.hs-boot new file mode 100644 index 0000000000..699c994b1f --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/T23010_fail.hs-boot @@ -0,0 +1,7 @@ +{-# LANGUAGE DuplicateRecordFields #-} + +module T23010_fail where + +data A + +fld :: A -> A diff --git a/testsuite/tests/overloadedrecflds/should_fail/T23010_fail.stderr b/testsuite/tests/overloadedrecflds/should_fail/T23010_fail.stderr new file mode 100644 index 0000000000..61e93b95bb --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/T23010_fail.stderr @@ -0,0 +1,8 @@ + +T23010_fail.hs-boot:7:1: error: + Ambiguous occurrence ‘T23010_fail.fld’ + It could refer to + either the field ‘fld’ of record ‘A’, + defined at T23010_fail.hs:6:16 + or the field ‘fld’ of record ‘B’, + defined at T23010_fail.hs:7:16 diff --git a/testsuite/tests/overloadedrecflds/should_fail/T23010_fail_aux.hs b/testsuite/tests/overloadedrecflds/should_fail/T23010_fail_aux.hs new file mode 100644 index 0000000000..d1e5cfefb7 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/T23010_fail_aux.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE DuplicateRecordFields #-} + +module T23010_fail_aux where + +import {-# SOURCE #-} T23010_fail ( fld ) + +data X +bar = fld diff --git a/testsuite/tests/overloadedrecflds/should_fail/T23063.hs b/testsuite/tests/overloadedrecflds/should_fail/T23063.hs new file mode 100644 index 0000000000..c2b57bdafd --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/T23063.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE DuplicateRecordFields #-} +module T23063 where +import qualified T23063_aux as A + +baz = _ :: A.S -> Int diff --git a/testsuite/tests/overloadedrecflds/should_fail/T23063.stderr b/testsuite/tests/overloadedrecflds/should_fail/T23063.stderr new file mode 100644 index 0000000000..89cfdc7a2d --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/T23063.stderr @@ -0,0 +1,12 @@ + +T23063.hs:5:7: error: [GHC-88464] + • Found hole: _ :: A.S -> Int + • In the expression: _ :: A.S -> Int + In an equation for ‘baz’: baz = _ :: A.S -> Int + • Relevant bindings include + baz :: A.S -> Int (bound at T23063.hs:5:1) + Valid hole fits include + baz :: A.S -> Int (defined at T23063.hs:5:1) + A.foo :: A.S -> Int + (imported qualified from ‘T23063_aux’ at T23063.hs:3:1-32 + (and originally defined at T23063_aux.hs:4:16-18)) diff --git a/testsuite/tests/overloadedrecflds/should_fail/T23063_aux.hs b/testsuite/tests/overloadedrecflds/should_fail/T23063_aux.hs new file mode 100644 index 0000000000..d5552ebd6d --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/T23063_aux.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE DuplicateRecordFields #-} +module T23063_aux where + +data S = MkS { foo :: Int } diff --git a/testsuite/tests/overloadedrecflds/should_fail/all.T b/testsuite/tests/overloadedrecflds/should_fail/all.T index 28ec4f7b7e..2da5c8da2f 100644 --- a/testsuite/tests/overloadedrecflds/should_fail/all.T +++ b/testsuite/tests/overloadedrecflds/should_fail/all.T @@ -1,4 +1,6 @@ -test('overloadedrecfldsfail01', normal, compile_fail, ['']) +test('overloadedrecfldsfail01a', normal, compile_fail, ['']) +test('overloadedrecfldsfail01b', normal, compile_fail, ['']) +test('overloadedrecfldsfail01c', normal, compile_fail, ['']) test('overloadedrecfldsfail02', normal, compile_fail, ['']) test('overloadedrecfldsfail03', normal, compile_fail, ['']) test('overloadedrecfldsfail04', [extra_files(['OverloadedRecFldsFail04_A.hs'])], multimod_compile_fail, @@ -20,7 +22,6 @@ test('overloadedrecfldsfail14', normal, compile_fail, ['']) test('overloadedlabelsfail01', normal, compile_fail, ['']) test('overloadedlabelsfail02', normal, compile_fail, ['']) test('overloadedlabelsfail03', normal, compile_fail, ['']) -test('T11103', req_th, compile_fail, ['']) test('T11167_ambiguous_fixity', [], multimod_compile_fail, ['T11167_ambiguous_fixity', '']) test('T13132_duplicaterecflds', normal, compile_fail, ['']) @@ -37,7 +38,7 @@ test('T17420', [extra_files(['T17420A.hs'])], multimod_compile_fail, test('T17469', [extra_files(['T17469A.hs'])], multimod_compile_fail, ['T17469', '']) test('T17965', normal, compile_fail, ['']) -test('DRFHoleFits', extra_files(['DRFHoleFits_A.hs']), multimod_compile_fail, ['DRFHoleFits', '']) +test('DRFHoleFits', extra_files(['DRFHoleFits_A.hs']), multimod_compile_fail, ['DRFHoleFits', '-v0']) test('DRFPartialFields', normal, compile_fail, ['']) test('T16745', extra_files(['T16745C.hs', 'T16745B.hs']), multimod_compile_fail, ['T16745A', '']) test('FieldSelectors', normal, compile_fail, ['']) @@ -52,3 +53,9 @@ test('T18999_NoDisambiguateRecordFields', normal, compile_fail, ['']) test('DRFUnused', normal, compile_fail, ['']) test('T19287', normal, compile_fail, ['']) test('overloadedrecfldswasrunnowfail06', normal, compile_fail, ['']) +test('T21946', normal, compile_fail, ['']) +test('T21959', normal, compile_fail, ['']) +test('T23010_fail', [extra_files(['T23010_fail.hs-boot', 'T23010_fail_aux.hs'])] + , multimod_compile_fail + , ['T23010_fail T23010_fail_aux', '-v0']) +test('T23063', extra_files(['T23063_aux.hs']), multimod_compile_fail, ['T23063', '-v0'])
\ No newline at end of file diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail01.stderr b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail01.stderr index 66089a586e..a2cdc2bfd5 100644 --- a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail01.stderr +++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail01.stderr @@ -1,22 +1,4 @@ -overloadedrecfldsfail01.hs:11:10: error: [GHC-99339] - • Record update is ambiguous, and requires a type signature - • In the expression: r {x = 3} - In an equation for ‘upd1’: upd1 r = r {x = 3} - -overloadedrecfldsfail01.hs:14:10: error: [GHC-33238] - • No type has all these fields: ‘x’, ‘y’, ‘z’ - • In the expression: r {x = 3, y = True, z = False} - In an equation for ‘upd2’: upd2 r = r {x = 3, y = True, z = False} - -overloadedrecfldsfail01.hs:17:10: error: [GHC-54721] - • ‘x’ is not a (visible) field of type ‘U’ - • In the expression: r {w = True, x = 3, y = True} :: U - In an equation for ‘upd3’: - upd3 r = r {w = True, x = 3, y = True} :: U - -overloadedrecfldsfail01.hs:17:10: error: [GHC-54721] - • ‘w’ is not a (visible) field of type ‘U’ - • In the expression: r {w = True, x = 3, y = True} :: U - In an equation for ‘upd3’: - upd3 r = r {w = True, x = 3, y = True} :: U +overloadedrecfldsfail01.hs:14:10: error: + Invalid record update. + No constructor in scope has all of the following fields: ‘z’, ‘y’ diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail01a.hs b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail01a.hs new file mode 100644 index 0000000000..be7284267e --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail01a.hs @@ -0,0 +1,13 @@ +-- Test ambiguous updates are rejected with appropriate error messages + +{-# LANGUAGE DuplicateRecordFields #-} + +module OverloadedRecFieldsFail1a where + +data R = MkR { w :: Bool, x :: Int, y :: Bool } +data S = MkS { w :: Bool, x :: Int, y :: Bool } +data T = MkT { x :: Int, z :: Bool } +data U = MkU { y :: Bool } + +-- Straightforward ambiguous update +upd1 r = r { x = 3 } diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail01a.stderr b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail01a.stderr new file mode 100644 index 0000000000..7ac58b0e43 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail01a.stderr @@ -0,0 +1,6 @@ + +overloadedrecfldsfail01a.hs:13:10: error: [GHC-99339] + • Ambiguous record update with field ‘x’ + This field appears in all of the datatypes ‘R’, ‘S’ and ‘T’ + • In the expression: r {x = 3} + In an equation for ‘upd1’: upd1 r = r {x = 3} diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail01b.hs b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail01b.hs new file mode 100644 index 0000000000..d3e14f4056 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail01b.hs @@ -0,0 +1,13 @@ +-- Test ambiguous updates are rejected with appropriate error messages + +{-# LANGUAGE DuplicateRecordFields #-} + +module OverloadedRecFieldsFail1b where + +data R = MkR { w :: Bool, x :: Int, y :: Bool } +data S = MkS { w :: Bool, x :: Int, y :: Bool } +data T = MkT { x :: Int, z :: Bool } +data U = MkU { y :: Bool } + +-- No type has all these fields +upd2 r = r { x = 3, y = True, z = False } diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail01b.stderr b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail01b.stderr new file mode 100644 index 0000000000..2a55c5d92b --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail01b.stderr @@ -0,0 +1,4 @@ + +overloadedrecfldsfail01b.hs:13:10: error: [GHC-14392] + Invalid record update. + No constructor in scope has all of the following fields: ‘z’, ‘y’ diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail01.hs b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail01c.hs index 8ce9be7d47..cfa079e7b9 100644 --- a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail01.hs +++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail01c.hs @@ -2,18 +2,12 @@ {-# LANGUAGE DuplicateRecordFields #-} +module OverloadedRecFieldsFail1c where + data R = MkR { w :: Bool, x :: Int, y :: Bool } data S = MkS { w :: Bool, x :: Int, y :: Bool } data T = MkT { x :: Int, z :: Bool } data U = MkU { y :: Bool } --- Straightforward ambiguous update -upd1 r = r { x = 3 } - --- No type has all these fields -upd2 r = r { x = 3, y = True, z = False } - -- User-specified type does not have these fields upd3 r = r { w = True, x = 3, y = True } :: U - -main = return () diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail01c.stderr b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail01c.stderr new file mode 100644 index 0000000000..146e364e99 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail01c.stderr @@ -0,0 +1,8 @@ + +overloadedrecfldsfail01c.hs:13:10: error: [GHC-33238] + • No data constructor of type constructor ‘U’ + has all of the fields: + ‘w’, ‘x’, ‘y’ + • In the expression: r {w = True, x = 3, y = True} :: U + In an equation for ‘upd3’: + upd3 r = r {w = True, x = 3, y = True} :: U diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail02.stderr b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail02.stderr index f6d03433fb..6a27569776 100644 --- a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail02.stderr +++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail02.stderr @@ -2,7 +2,7 @@ overloadedrecfldsfail02.hs:8:18: error: Ambiguous occurrence ‘x’ It could refer to - either the field ‘x’ of record ‘S’, - defined at overloadedrecfldsfail02.hs:6:16 - or the field ‘x’ of record ‘R’, + either the field ‘x’ of record ‘R’, defined at overloadedrecfldsfail02.hs:5:16 + or the field ‘x’ of record ‘S’, + defined at overloadedrecfldsfail02.hs:6:16 diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail05.stderr b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail05.stderr index 3e2e0572f1..bff9bd544f 100644 --- a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail05.stderr +++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail05.stderr @@ -1,3 +1,3 @@ overloadedrecfldsfail05.hs:7:16: error: [-Wunused-top-binds (in -Wextra, -Wunused-binds), Werror=unused-top-binds] - Defined but not used: ‘foo’ + Defined but not used: record field of MkT ‘foo’ diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail06.stderr b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail06.stderr index 7567a038b4..3f0b17106a 100644 --- a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail06.stderr +++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail06.stderr @@ -4,14 +4,14 @@ OverloadedRecFldsFail06_A.hs:9:15: warning: [-Wunused-top-binds (in -Wextra, -Wu Defined but not used: data constructor ‘MkUnused’ OverloadedRecFldsFail06_A.hs:9:42: warning: [-Wunused-top-binds (in -Wextra, -Wunused-binds)] - Defined but not used: ‘unused2’ + Defined but not used: record field of MkUnused ‘unused2’ OverloadedRecFldsFail06_A.hs:9:59: warning: [-Wunused-top-binds (in -Wextra, -Wunused-binds)] - Defined but not used: ‘used_locally’ + Defined but not used: record field of MkUnused ‘used_locally’ [2 of 3] Compiling Main ( overloadedrecfldsfail06.hs, overloadedrecfldsfail06.o ) overloadedrecfldsfail06.hs:7:1: error: [-Wunused-imports (in -Wextra), Werror=unused-imports] - The import of ‘Unused(unused), V(x), U(y), MkV, Unused’ + The import of ‘MkV, Unused, Unused(unused), V(x), U(y)’ from module ‘OverloadedRecFldsFail06_A’ is redundant overloadedrecfldsfail06.hs:8:1: error: [-Wunused-imports (in -Wextra), Werror=unused-imports] @@ -24,13 +24,15 @@ overloadedrecfldsfail06.hs:9:1: error: [-Wunused-imports (in -Wextra), Werror=un from module ‘OverloadedRecFldsFail06_A’ is redundant overloadedrecfldsfail06.hs:10:1: error: [-Wunused-imports (in -Wextra), Werror=unused-imports] - The qualified import of ‘U(x), U’ + The qualified import of ‘U, U(x)’ from module ‘OverloadedRecFldsFail06_A’ is redundant overloadedrecfldsfail06.hs:15:22: error: [GHC-02256] [-Wambiguous-fields (in -Wdefault), Werror=ambiguous-fields] - The record update u {x = True} with type U is ambiguous. - This will not be supported by -XDuplicateRecordFields in future releases of GHC. + Ambiguous record update with parent type constructor ‘U’. + This type-directed disambiguation mechanism will not be supported by -XDuplicateRecordFields in future releases of GHC. + Consider disambiguating using module qualification instead. overloadedrecfldsfail06.hs:18:28: error: [GHC-02256] [-Wambiguous-fields (in -Wdefault), Werror=ambiguous-fields] - The record update v {P.x = 3} with type V is ambiguous. - This will not be supported by -XDuplicateRecordFields in future releases of GHC. + Ambiguous record update with parent type constructor ‘V’. + This type-directed disambiguation mechanism will not be supported by -XDuplicateRecordFields in future releases of GHC. + Consider disambiguating using module qualification instead. diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail08.stderr b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail08.stderr index d364f079d8..24085ea57c 100644 --- a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail08.stderr +++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail08.stderr @@ -1,5 +1,4 @@ overloadedrecfldsfail08.hs:9:9: error: [GHC-14392] - • No constructor has all these fields: ‘x’, ‘y’ - • In the expression: e {x = 3, y = True} - In an equation for ‘foo’: foo e = e {x = 3, y = True} + Invalid record update. + No constructor in scope has all of the following fields: ‘x’, ‘y’ diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail10.hs b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail10.hs index ccb25d3387..508d5a69c1 100644 --- a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail10.hs +++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail10.hs @@ -1,8 +1,8 @@ --- Modules A and B both declare F(foo) --- Module C declares F($sel:foo:MkFChar) but exports A.F(foo) as well --- Thus we can't export F(..) even with DuplicateRecordFields enabled +-- Module A exports $fld:MkFInt:foo +-- Module B exports $fld:MkFBool:foo +-- Module C exports $fld:MkFChar:foo and re-exports $fld:MkFInt:foo +-- Thus we can't export F(..) without -XDuplicateRecordFields -{-# LANGUAGE DuplicateRecordFields #-} module Main (main, F(..)) where import OverloadedRecFldsFail10_B diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail10.stderr b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail10.stderr index 8b113e19ee..ad62403ddc 100644 --- a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail10.stderr +++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail10.stderr @@ -3,12 +3,28 @@ [3 of 5] Compiling OverloadedRecFldsFail10_C ( OverloadedRecFldsFail10_C.hs, OverloadedRecFldsFail10_C.o ) [4 of 5] Compiling Main ( overloadedrecfldsfail10.hs, overloadedrecfldsfail10.o ) -overloadedrecfldsfail10.hs:6:20: error: [GHC-69158] - Conflicting exports for ‘foo’: - ‘F(..)’ exports ‘OverloadedRecFldsFail10_B.foo’ +overloadedrecfldsfail10.hs:6:20: error: [GHC-97219] + Duplicate record field ‘foo’ in export list: + ‘F(..)’ exports the field ‘foo’ + belonging to the constructor ‘MkFChar’ + imported from ‘OverloadedRecFldsFail10_C’ at overloadedrecfldsfail10.hs:9:1-32 + (and originally defined at OverloadedRecFldsFail10_C.hs:6:34-36) + ‘F(..)’ exports the field ‘foo’ + belonging to the constructor ‘MkFInt’ + imported from ‘OverloadedRecFldsFail10_C’ at overloadedrecfldsfail10.hs:9:1-32 + (and originally defined in ‘OverloadedRecFldsFail10_A’ + at OverloadedRecFldsFail10_A.hs:5:32-34) + Suggested fix: Perhaps you intended to use DuplicateRecordFields + +overloadedrecfldsfail10.hs:6:20: error: [GHC-97219] + Duplicate record field ‘foo’ in export list: + ‘F(..)’ exports the field ‘foo’ + belonging to the constructor ‘MkFBool’ imported from ‘OverloadedRecFldsFail10_B’ at overloadedrecfldsfail10.hs:8:1-32 (and originally defined at OverloadedRecFldsFail10_B.hs:6:34-36) - ‘F(..)’ exports ‘OverloadedRecFldsFail10_C.foo’ + ‘F(..)’ exports the field ‘foo’ + belonging to the constructor ‘MkFInt’ imported from ‘OverloadedRecFldsFail10_C’ at overloadedrecfldsfail10.hs:9:1-32 (and originally defined in ‘OverloadedRecFldsFail10_A’ at OverloadedRecFldsFail10_A.hs:5:32-34) + Suggested fix: Perhaps you intended to use DuplicateRecordFields diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail11.stderr b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail11.stderr index a146a0e9c6..54472f4293 100644 --- a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail11.stderr +++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail11.stderr @@ -4,9 +4,9 @@ overloadedrecfldsfail11.hs:5:15: error: Ambiguous occurrence ‘foo’ It could refer to - either the field ‘foo’ of record ‘T’, - imported from ‘OverloadedRecFldsFail11_A’ at overloadedrecfldsfail11.hs:3:1-32 - (and originally defined at OverloadedRecFldsFail11_A.hs:6:16-18) - or the field ‘foo’ of record ‘S’, + either the field ‘foo’ of record ‘S’, imported from ‘OverloadedRecFldsFail11_A’ at overloadedrecfldsfail11.hs:3:1-32 (and originally defined at OverloadedRecFldsFail11_A.hs:5:16-18) + or the field ‘foo’ of record ‘T’, + imported from ‘OverloadedRecFldsFail11_A’ at overloadedrecfldsfail11.hs:3:1-32 + (and originally defined at OverloadedRecFldsFail11_A.hs:6:16-18) diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail13.stderr b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail13.stderr index 20c9e2dd97..4fb285b327 100644 --- a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail13.stderr +++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail13.stderr @@ -2,31 +2,31 @@ overloadedrecfldsfail13.hs:10:5: error: Ambiguous occurrence ‘x’ It could refer to - either the field ‘x’ of record ‘T’, - defined at overloadedrecfldsfail13.hs:7:16 - or the field ‘x’ of record ‘S’, + either the field ‘x’ of record ‘S’, defined at overloadedrecfldsfail13.hs:6:16 + or the field ‘x’ of record ‘T’, + defined at overloadedrecfldsfail13.hs:7:16 overloadedrecfldsfail13.hs:12:5: error: Ambiguous occurrence ‘x’ It could refer to - either the field ‘x’ of record ‘T’, - defined at overloadedrecfldsfail13.hs:7:16 - or the field ‘x’ of record ‘S’, + either the field ‘x’ of record ‘S’, defined at overloadedrecfldsfail13.hs:6:16 + or the field ‘x’ of record ‘T’, + defined at overloadedrecfldsfail13.hs:7:16 overloadedrecfldsfail13.hs:15:5: error: Ambiguous occurrence ‘x’ It could refer to - either the field ‘x’ of record ‘T’, - defined at overloadedrecfldsfail13.hs:7:16 - or the field ‘x’ of record ‘S’, + either the field ‘x’ of record ‘S’, defined at overloadedrecfldsfail13.hs:6:16 + or the field ‘x’ of record ‘T’, + defined at overloadedrecfldsfail13.hs:7:16 overloadedrecfldsfail13.hs:18:5: error: Ambiguous occurrence ‘x’ It could refer to - either the field ‘x’ of record ‘T’, - defined at overloadedrecfldsfail13.hs:7:16 - or the field ‘x’ of record ‘S’, + either the field ‘x’ of record ‘S’, defined at overloadedrecfldsfail13.hs:6:16 + or the field ‘x’ of record ‘T’, + defined at overloadedrecfldsfail13.hs:7:16 diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail14.stderr b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail14.stderr index 7b0d276a96..400a633946 100644 --- a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail14.stderr +++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail14.stderr @@ -1,5 +1,3 @@ -overloadedrecfldsfail14.hs:12:7: error: [GHC-33238] - • No type has all these fields: ‘x’, ‘y’ - • In the expression: r {x = 3, y = False} - In an equation for ‘f’: f r = r {x = 3, y = False} +overloadedrecfldsfail14.hs:12:18: error: [GHC-22385] + Not in scope: record field ‘y’ diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldswasrunnowfail06.stderr b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldswasrunnowfail06.stderr index 789d87a6a3..c5f1e431c9 100644 --- a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldswasrunnowfail06.stderr +++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldswasrunnowfail06.stderr @@ -2,39 +2,39 @@ overloadedrecfldswasrunnowfail06.hs:11:11: error: Ambiguous occurrence ‘x’ It could refer to - either the field ‘x’ of record ‘U’, - defined at overloadedrecfldswasrunnowfail06.hs:8:18 + either the field ‘x’ of record ‘S’, + defined at overloadedrecfldswasrunnowfail06.hs:6:16 or the field ‘x’ of record ‘T’, defined at overloadedrecfldswasrunnowfail06.hs:7:16 - or the field ‘x’ of record ‘S’, - defined at overloadedrecfldswasrunnowfail06.hs:6:16 + or the field ‘x’ of record ‘U’, + defined at overloadedrecfldswasrunnowfail06.hs:8:18 overloadedrecfldswasrunnowfail06.hs:13:11: error: Ambiguous occurrence ‘x’ It could refer to - either the field ‘x’ of record ‘U’, - defined at overloadedrecfldswasrunnowfail06.hs:8:18 + either the field ‘x’ of record ‘S’, + defined at overloadedrecfldswasrunnowfail06.hs:6:16 or the field ‘x’ of record ‘T’, defined at overloadedrecfldswasrunnowfail06.hs:7:16 - or the field ‘x’ of record ‘S’, - defined at overloadedrecfldswasrunnowfail06.hs:6:16 + or the field ‘x’ of record ‘U’, + defined at overloadedrecfldswasrunnowfail06.hs:8:18 overloadedrecfldswasrunnowfail06.hs:15:13: error: Ambiguous occurrence ‘x’ It could refer to - either the field ‘x’ of record ‘U’, - defined at overloadedrecfldswasrunnowfail06.hs:8:18 + either the field ‘x’ of record ‘S’, + defined at overloadedrecfldswasrunnowfail06.hs:6:16 or the field ‘x’ of record ‘T’, defined at overloadedrecfldswasrunnowfail06.hs:7:16 - or the field ‘x’ of record ‘S’, - defined at overloadedrecfldswasrunnowfail06.hs:6:16 + or the field ‘x’ of record ‘U’, + defined at overloadedrecfldswasrunnowfail06.hs:8:18 overloadedrecfldswasrunnowfail06.hs:21:20: error: Ambiguous occurrence ‘x’ It could refer to - either the field ‘x’ of record ‘U’, - defined at overloadedrecfldswasrunnowfail06.hs:8:18 + either the field ‘x’ of record ‘S’, + defined at overloadedrecfldswasrunnowfail06.hs:6:16 or the field ‘x’ of record ‘T’, defined at overloadedrecfldswasrunnowfail06.hs:7:16 - or the field ‘x’ of record ‘S’, - defined at overloadedrecfldswasrunnowfail06.hs:6:16 + or the field ‘x’ of record ‘U’, + defined at overloadedrecfldswasrunnowfail06.hs:8:18 diff --git a/testsuite/tests/overloadedrecflds/should_run/T17551b.hs b/testsuite/tests/overloadedrecflds/should_run/T17551b.hs new file mode 100644 index 0000000000..c78da2b23c --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_run/T17551b.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE TemplateHaskell #-} + +module Main where + +data Foo = Foo { foo :: Int, biz :: Bool } +data Bar = Bar { foo :: Int } + +main :: IO () +main = print $ + $$( [|| \ ( Bar { foo } ) -> foo ||] ) ( Bar 3 ) + + case $$( [|| \ r -> r { foo = 2, biz = False } ||] ) ( Foo 1 False ) of + Foo { foo } -> foo + diff --git a/testsuite/tests/overloadedrecflds/should_run/T17551b.stdout b/testsuite/tests/overloadedrecflds/should_run/T17551b.stdout new file mode 100644 index 0000000000..7ed6ff82de --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_run/T17551b.stdout @@ -0,0 +1 @@ +5 diff --git a/testsuite/tests/overloadedrecflds/should_run/all.T b/testsuite/tests/overloadedrecflds/should_run/all.T index ce4bbfd728..b3a08e7138 100644 --- a/testsuite/tests/overloadedrecflds/should_run/all.T +++ b/testsuite/tests/overloadedrecflds/should_run/all.T @@ -18,3 +18,4 @@ test('hasfieldrun02', normal, compile_and_run, ['']) test('T12243', normal, compile_and_run, ['']) test('T11228', normal, compile_and_run, ['']) test('T11671_run', normal, compile_and_run, ['']) +test('T17551b', [req_th], compile_and_run, ['']) diff --git a/testsuite/tests/parser/should_compile/T14189.stderr b/testsuite/tests/parser/should_compile/T14189.stderr index caede8b720..1bd38be52a 100644 --- a/testsuite/tests/parser/should_compile/T14189.stderr +++ b/testsuite/tests/parser/should_compile/T14189.stderr @@ -186,14 +186,14 @@ (L (SrcSpanAnn (EpAnnNotUsed) { T14189.hs:3:3-15 }) (IEThingWith - [(L - { T14189.hs:3:11 } - (FieldLabel - (FieldLabelString - {FastString: "f"}) - (NoDuplicateRecordFields) - (FieldSelectors) - {Name: T14189.f}))] + (EpAnn + (Anchor + { T14189.hs:3:3-8 } + (UnchangedAnchor)) + [(AddEpAnn AnnOpenP (EpaSpan { T14189.hs:3:10 })) + ,(AddEpAnn AnnCloseP (EpaSpan { T14189.hs:3:15 }))] + (EpaComments + [])) (L (SrcSpanAnn (EpAnnNotUsed) { T14189.hs:3:3-8 }) (IEName @@ -203,6 +203,21 @@ {Name: T14189.MyType}))) (NoIEWildcard) [(L + (SrcSpanAnn (EpAnn + (Anchor + { T14189.hs:3:11 } + (UnchangedAnchor)) + (AnnListItem + [(AddCommaAnn + (EpaSpan { T14189.hs:3:12 }))]) + (EpaComments + [])) { T14189.hs:3:11 }) + (IEName + (NoExtField) + (L + (SrcSpanAnn (EpAnnNotUsed) { T14189.hs:3:11 }) + {Name: T14189.f}))) + ,(L (SrcSpanAnn (EpAnnNotUsed) { T14189.hs:3:13-14 }) (IEName (NoExtField) @@ -211,17 +226,9 @@ {Name: T14189.NT})))])) [(AvailTC {Name: T14189.MyType} - [(NormalGreName - {Name: T14189.MyType}) - ,(NormalGreName - {Name: T14189.NT}) - ,(FieldGreName - (FieldLabel - (FieldLabelString - {FastString: "f"}) - (NoDuplicateRecordFields) - (FieldSelectors) - {Name: T14189.f}))])])]) + [{Name: T14189.MyType} + ,{Name: T14189.f} + ,{Name: T14189.NT}])])]) (Nothing))) diff --git a/testsuite/tests/patsyn/should_fail/mixed-pat-syn-record-sels.stderr b/testsuite/tests/patsyn/should_fail/mixed-pat-syn-record-sels.stderr index 934a55a87e..3c20c90285 100644 --- a/testsuite/tests/patsyn/should_fail/mixed-pat-syn-record-sels.stderr +++ b/testsuite/tests/patsyn/should_fail/mixed-pat-syn-record-sels.stderr @@ -1,5 +1,4 @@ mixed-pat-syn-record-sels.hs:9:9: error: [GHC-14392] - • No constructor has all these fields: ‘a’, ‘b’ - • In the expression: x {a = True, b = False} - In an equation for ‘foo’: foo x = x {a = True, b = False} + Invalid record update. + No constructor in scope has all of the following fields: ‘a’, ‘b’ diff --git a/testsuite/tests/patsyn/should_fail/records-mixing-fields.stderr b/testsuite/tests/patsyn/should_fail/records-mixing-fields.stderr index 77901b9eee..9829eef3c3 100644 --- a/testsuite/tests/patsyn/should_fail/records-mixing-fields.stderr +++ b/testsuite/tests/patsyn/should_fail/records-mixing-fields.stderr @@ -1,14 +1,5 @@ -records-mixing-fields.hs:10:14: error: [GHC-40887] - • Cannot use a mixture of pattern synonym and record selectors - Record selectors defined by ‘MyRec’: qux - Pattern synonym selectors defined by ‘HisRec’: f1 - • In the expression: a {f1 = 1, qux = "two"} - In an equation for ‘updater1’: updater1 a = a {f1 = 1, qux = "two"} - -records-mixing-fields.hs:12:14: error: [GHC-40887] - • Cannot use a mixture of pattern synonym and record selectors - Record selectors defined by ‘MyRec’: foo - Pattern synonym selectors defined by ‘HisRec’: f1 - • In the expression: a {f1 = 1, foo = 2} - In an equation for ‘updater2’: updater2 a = a {f1 = 1, foo = 2} +records-mixing-fields.hs:10:14: error: [GHC-14392] + Invalid record update. + No constructor in scope has all of the following fields: + ‘f1’, ‘qux’ diff --git a/testsuite/tests/perf/compiler/Makefile b/testsuite/tests/perf/compiler/Makefile index 33d2878db7..762883b0b4 100644 --- a/testsuite/tests/perf/compiler/Makefile +++ b/testsuite/tests/perf/compiler/Makefile @@ -32,4 +32,3 @@ MultiLayerModulesTH_OneShot_Prep: MultiLayerModulesTH_Make_Prep InstanceMatching: ./genMatchingTest 0 '$(TEST_HC)' $(TEST_HC_OPTS) -fno-code -fwrite-interface Defs.hs - diff --git a/testsuite/tests/perf/compiler/all.T b/testsuite/tests/perf/compiler/all.T index 96d30e8017..37a6fdb2f9 100644 --- a/testsuite/tests/perf/compiler/all.T +++ b/testsuite/tests/perf/compiler/all.T @@ -660,3 +660,12 @@ test ('InfiniteListFusion', [collect_stats('bytes allocated',2), when(arch('i386'), skip), js_broken(22576)], compile_and_run, ['-O2 -package ghc']) + +# Track performance of record update renaming/typechecking +test('RecordUpdPerf', + [ collect_compiler_stats('bytes allocated',2), + pre_cmd('./genRecordUpdPerf'), + extra_files(['genRecordUpdPerf']), + ], + multimod_compile, + ['RecordUpdPerf', '-fno-code -v0']) diff --git a/testsuite/tests/perf/compiler/genRecordUpdPerf b/testsuite/tests/perf/compiler/genRecordUpdPerf new file mode 100755 index 0000000000..2ccbb67407 --- /dev/null +++ b/testsuite/tests/perf/compiler/genRecordUpdPerf @@ -0,0 +1,24 @@ +#!/usr/bin/env bash +RECORDS=15 +FIELDS=20 +UPDATES_PER_RECORD=5 +echo "{-# LANGUAGE DuplicateRecordFields #-}" > RecordUpdPerf.hs +echo "module RecordUpdPerf where" >> RecordUpdPerf.hs +for r in $(seq -w 1 $RECORDS); do + echo "data R$r = MkR$r {" >> RecordUpdPerf.hs + for f in $(seq -w 1 $FIELDS); do + echo " r$f :: Int," >> RecordUpdPerf.hs + echo " s${r}_$f :: Int," >> RecordUpdPerf.hs + done + echo " t :: Bool }" >> RecordUpdPerf.hs +done + +for u in $(seq -w 1 $UPDATES_PER_RECORD); do + for r in $(seq -w 1 $RECORDS); do + echo "f${r}_$u r = r {" >> RecordUpdPerf.hs + for f in $(seq -w 1 $FIELDS); do + echo " r$f = $u * $r * $f," >> RecordUpdPerf.hs + done + echo " s${r}_$FIELDS = $u + $r }" >> RecordUpdPerf.hs + done +done diff --git a/testsuite/tests/perf/compiler/hard_hole_fits.stderr b/testsuite/tests/perf/compiler/hard_hole_fits.stderr index bfabc44219..694741f71d 100644 --- a/testsuite/tests/perf/compiler/hard_hole_fits.stderr +++ b/testsuite/tests/perf/compiler/hard_hole_fits.stderr @@ -492,10 +492,7 @@ hard_hole_fits.hs:38:33: warning: [GHC-88464] [-Wtyped-holes (in -Wdefault)] • Found hole: _ :: Int • In an equation for ‘testMe’: testMe (RecordUpd xru gl gls) = _ • Relevant bindings include - gls :: Either - [Language.Haskell.Syntax.Pat.LHsRecUpdField GhcPs] - [LHsRecUpdProj GhcPs] - (bound at hard_hole_fits.hs:38:26) + gls :: LHsRecUpdFields GhcPs (bound at hard_hole_fits.hs:38:26) gl :: LHsExpr GhcPs (bound at hard_hole_fits.hs:38:23) xru :: Language.Haskell.Syntax.Extension.XRecordUpd GhcPs (bound at hard_hole_fits.hs:38:19) diff --git a/testsuite/tests/plugins/static-plugins.stdout b/testsuite/tests/plugins/static-plugins.stdout index 5da8e9bee8..98d70197cd 100644 --- a/testsuite/tests/plugins/static-plugins.stdout +++ b/testsuite/tests/plugins/static-plugins.stdout @@ -5,9 +5,9 @@ interfacePlugin: GHC.Base interfacePlugin: GHC.Float interfacePlugin: GHC.Prim.Ext interfacePlugin: System.IO -typeCheckPlugin (rn) interfacePlugin: GHC.Types interfacePlugin: GHC.Show +typeCheckPlugin (rn) interfacePlugin: GHC.TopHandler typeCheckPlugin (tc) interfacePlugin: GHC.CString diff --git a/testsuite/tests/rename/should_compile/T22122.hs b/testsuite/tests/rename/should_compile/T22122.hs new file mode 100644 index 0000000000..25f8377e96 --- /dev/null +++ b/testsuite/tests/rename/should_compile/T22122.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} + +module T22122 where + +import T22122_aux ( data_decls, record_upds ) + +-- This test checks that we can handle record declarations and updates +-- when the field 'Name's share the same underlying string. + +-- data D1 = MkD1 { fld1 :: Char, fld2 :: String } +-- data D2 = MkD2A { fld1 :: Char } | MkD2B { fld2 :: String } +$(return data_decls) + +-- rec_upd r = r { fld1 = 'c', fld2 = "foo" } +$(return record_upds) diff --git a/testsuite/tests/rename/should_compile/T22122_aux.hs b/testsuite/tests/rename/should_compile/T22122_aux.hs new file mode 100644 index 0000000000..b62aaa5840 --- /dev/null +++ b/testsuite/tests/rename/should_compile/T22122_aux.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} + +module T22122_aux where + +import Language.Haskell.TH.Syntax + ( Name, Type(ConT), Lit(CharL, StringL) + , Dec(DataD, FunD), Con(RecC), Exp(LitE, VarE, RecUpdE), Pat(VarP) + , Clause(Clause), Body(NormalB) + , Bang(..), SourceUnpackedness(..), SourceStrictness(..) + , newNameIO ) +import System.IO.Unsafe + ( unsafePerformIO ) + + +data Names a + = Names { d1_name, d2_name + , mkd1_name, mkd2a_name, mkd2b_name + , d1_fld1_name, d1_fld2_name, d2_fld1_name, d2_fld2_name + , upd_name, upd_var_name :: a } + deriving stock ( Functor, Foldable, Traversable ) + +string_names :: Names String +string_names = + Names + { d1_name = "D1" + , d2_name = "D2" + , mkd1_name = "MkD1" + , mkd2a_name = "MkD2A" + , mkd2b_name = "MkD2B" + , d1_fld1_name = "fld" -- these are deliberately the same, + , d1_fld2_name = "fld" -- to check that we correctly use the exact Names + , d2_fld1_name = "fld" -- in a record update, and not simply the + , d2_fld2_name = "fld" -- field label strings + , upd_name = "upd" + , upd_var_name = "r" + } + +names :: Names Name +names = unsafePerformIO $ traverse newNameIO string_names + +noBang :: Bang +noBang = Bang NoSourceUnpackedness NoSourceStrictness + +-- data D1 = MkD1 { fld1 :: Char, fld2 :: String } +-- data D2 = MkD2A { fld1 :: Char } | MkD2B { fld2 :: String } +data_decls :: [ Dec ] +data_decls = [ d1, d2 ] + where + Names { .. } = names + d1 = DataD [] d1_name [] Nothing [mkd1] [] + d2 = DataD [] d2_name [] Nothing [mkd2_a, mkd2_b] [] + mkd1 = RecC mkd1_name [(d1_fld1_name, noBang, ConT ''Char), (d1_fld2_name, noBang, ConT ''String)] + mkd2_a = RecC mkd2a_name [(d2_fld1_name, noBang, ConT ''Char)] + mkd2_b = RecC mkd2b_name [(d2_fld2_name, noBang, ConT ''String)] + +-- upd r = r { fld1 = 'c', fld2 = "foo" } +record_upds :: [ Dec ] +record_upds = [ rec_upd ] + where + Names { .. } = names + rec_upd = FunD upd_name [upd_clause] + upd_clause = Clause [VarP upd_var_name] (NormalB rec_upd_body) [] + rec_upd_body = RecUpdE (VarE upd_var_name) + [ (d1_fld1_name, LitE (CharL 'c')) + , (d1_fld2_name, LitE (StringL "foo")) ] diff --git a/testsuite/tests/rename/should_compile/all.T b/testsuite/tests/rename/should_compile/all.T index ba05c88357..55f58fcebc 100644 --- a/testsuite/tests/rename/should_compile/all.T +++ b/testsuite/tests/rename/should_compile/all.T @@ -208,3 +208,4 @@ test('GADTSymbolicRecordRecordWildcard', normal, compile, ['']) test('ImportNullaryRecordWildcard', [extra_files(['NullaryRecordWildcard.hs', 'NullaryRecordRecordWildcard.hs'])], multimod_compile, ['ImportNullaryRecordWildcard', '-v0']) test('GHCINullaryRecordWildcard', combined_output, ghci_script, ['GHCINullaryRecordWildcard.script']) test('GHCIImplicitImportNullaryRecordWildcard', combined_output, ghci_script, ['GHCIImplicitImportNullaryRecordWildcard.script']) +test('T22122', [expect_broken(22122), extra_files(['T22122_aux.hs'])], multimod_compile, ['T22122', '-v0']) diff --git a/testsuite/tests/rename/should_fail/T11167_ambig.stderr b/testsuite/tests/rename/should_fail/T11167_ambig.stderr index 8c9c6a7848..74c7064414 100644 --- a/testsuite/tests/rename/should_fail/T11167_ambig.stderr +++ b/testsuite/tests/rename/should_fail/T11167_ambig.stderr @@ -2,15 +2,15 @@ T11167_ambig.hs:10:13: error: Ambiguous occurrence ‘runContT’ It could refer to - either the field ‘runContT’ of record ‘ContT'’, - defined at T11167_ambig.hs:7:32 - or the field ‘runContT’ of record ‘ContT’, + either the field ‘runContT’ of record ‘ContT’, defined at T11167_ambig.hs:6:30 + or the field ‘runContT’ of record ‘ContT'’, + defined at T11167_ambig.hs:7:32 T11167_ambig.hs:17:9: error: Ambiguous occurrence ‘runContT’ It could refer to - either the field ‘runContT’ of record ‘ContT'’, - defined at T11167_ambig.hs:7:32 - or the field ‘runContT’ of record ‘ContT’, + either the field ‘runContT’ of record ‘ContT’, defined at T11167_ambig.hs:6:30 + or the field ‘runContT’ of record ‘ContT'’, + defined at T11167_ambig.hs:7:32 diff --git a/testsuite/tests/rename/should_fail/T12681.stderr b/testsuite/tests/rename/should_fail/T12681.stderr index 3a48d80c17..6b57b8517b 100644 --- a/testsuite/tests/rename/should_fail/T12681.stderr +++ b/testsuite/tests/rename/should_fail/T12681.stderr @@ -1,4 +1,5 @@ T12681.hs:4:17: error: [GHC-76037] Not in scope: ‘a’ - Suggested fix: Perhaps use ‘T12681a.a’ (imported from T12681a) + Suggested fix: + Perhaps use record field of A ‘T12681a.a’ (imported from T12681a) diff --git a/testsuite/tests/rename/should_fail/T19843f.stderr b/testsuite/tests/rename/should_fail/T19843f.stderr index c7c4d5dc58..4cf8e47089 100644 --- a/testsuite/tests/rename/should_fail/T19843f.stderr +++ b/testsuite/tests/rename/should_fail/T19843f.stderr @@ -1,8 +1,4 @@ -T19843f.hs:8:12: error: [GHC-76037] - Not in scope: ‘mup’ - Suggested fix: Perhaps use ‘mop’ (line 5) - -T19843f.hs:10:10: error: [GHC-76037] - Not in scope: ‘mup’ - Suggested fix: Perhaps use ‘mop’ (line 5) +T19843f.hs:8:12: error: [GHC-22385] + Not in scope: record field ‘mup’ + Suggested fix: Perhaps use record field of A ‘mop’ (line 5) diff --git a/testsuite/tests/rename/should_fail/T19843g.stderr b/testsuite/tests/rename/should_fail/T19843g.stderr index 78ee13eadf..e6441413be 100644 --- a/testsuite/tests/rename/should_fail/T19843g.stderr +++ b/testsuite/tests/rename/should_fail/T19843g.stderr @@ -1,4 +1,4 @@ -T19843g.hs:10:12: error: [GHC-76037] - Not in scope: ‘mup’ - Suggested fix: Perhaps use ‘mop’ (line 7) +T19843g.hs:10:12: error: [GHC-22385] + Not in scope: record field ‘mup’ + Suggested fix: Perhaps use record field of A ‘mop’ (line 7) diff --git a/testsuite/tests/rename/should_fail/T19843h.stderr b/testsuite/tests/rename/should_fail/T19843h.stderr index 43cf59befd..55d3fcdd96 100644 --- a/testsuite/tests/rename/should_fail/T19843h.stderr +++ b/testsuite/tests/rename/should_fail/T19843h.stderr @@ -2,7 +2,7 @@ T19843h.hs:14:7: error: [GHC-39999] • No instance for ‘GHC.Records.HasField "mup" r4 a4’ arising from selecting the field ‘mup’ - Perhaps use ‘mop’ (line 11) + Perhaps use record field of A ‘mop’ (line 11) • In the expression: undefined.mup In an equation for ‘foo’: foo = undefined.mup @@ -27,7 +27,7 @@ T19843h.hs:20:8: error: [GHC-39999] T19843h.hs:24:8: error: [GHC-39999] • No instance for ‘GHC.Records.HasField "getAll" r0 a0’ arising from selecting the field ‘getAll’ - Perhaps use ‘getAlt’ (imported from Data.Monoid) + Perhaps use record field of Alt ‘getAlt’ (imported from Data.Monoid) Perhaps you want to add ‘getAll’ to the import list in the import of ‘Data.Monoid’ (T19843h.hs:9:1-28). • In the expression: undefined.getAll diff --git a/testsuite/tests/rename/should_fail/T21605a.stderr b/testsuite/tests/rename/should_fail/T21605a.stderr index 7be47098df..ce199cfb8f 100644 --- a/testsuite/tests/rename/should_fail/T21605a.stderr +++ b/testsuite/tests/rename/should_fail/T21605a.stderr @@ -4,7 +4,6 @@ T21605a.hs:5:13: error: [GHC-76037] NB: the module ‘Prelude’ does not export ‘true’. Suggested fix: Perhaps use one of these: + data constructor ‘Prelude.True’ (imported from Prelude), type constructor or class ‘Prelude.Num’ (imported from Prelude), - type constructor or class ‘Prelude.Ord’ (imported from Prelude), - type constructor or class ‘Prelude.Enum’ (imported from Prelude) - + type constructor or class ‘Prelude.Ord’ (imported from Prelude) diff --git a/testsuite/tests/rename/should_fail/T21605d.stderr b/testsuite/tests/rename/should_fail/T21605d.stderr index 3db644aa93..0c0c3975af 100644 --- a/testsuite/tests/rename/should_fail/T21605d.stderr +++ b/testsuite/tests/rename/should_fail/T21605d.stderr @@ -1,8 +1,9 @@ -T21605d.hs:3:9: [GHC-37479] + +T21605d.hs:3:9: error: [GHC-37479] ‘Prelude.id’ is a term-level binding and can not be used at the type level. Suggested fix: Perhaps use one of these: + data constructor ‘Prelude.EQ’ (imported from Prelude), type constructor or class ‘Prelude.Eq’ (imported from Prelude), - type constructor or class ‘Prelude.IO’ (imported from Prelude), - type constructor or class ‘Prelude.Ord’ (imported from Prelude)
\ No newline at end of file + data constructor ‘Prelude.GT’ (imported from Prelude) diff --git a/testsuite/tests/rename/should_fail/T7943.hs b/testsuite/tests/rename/should_fail/T7943.hs index a1a99d508a..335cb350c7 100644 --- a/testsuite/tests/rename/should_fail/T7943.hs +++ b/testsuite/tests/rename/should_fail/T7943.hs @@ -1,4 +1,4 @@ module T7943 where data Foo = A { bar :: String } - | B String { bar :: String } + | B String { bar :: String } diff --git a/testsuite/tests/rename/should_fail/T7943.stderr b/testsuite/tests/rename/should_fail/T7943.stderr index 3100928e51..352d4c1f40 100644 --- a/testsuite/tests/rename/should_fail/T7943.stderr +++ b/testsuite/tests/rename/should_fail/T7943.stderr @@ -1,6 +1,3 @@ -T7943.hs:4:22: error: [GHC-89246] - • Record syntax is illegal here: {bar :: String} - • In the type ‘{bar :: String}’ - In the definition of data constructor ‘B’ - In the data declaration for ‘Foo’ +T7943.hs:4:21: error: [GHC-89246] + Record syntax is illegal here: {bar :: String} diff --git a/testsuite/tests/rename/should_fail/T9077.stderr b/testsuite/tests/rename/should_fail/T9077.stderr index a3a9d49ece..c20800b12f 100644 --- a/testsuite/tests/rename/should_fail/T9077.stderr +++ b/testsuite/tests/rename/should_fail/T9077.stderr @@ -1,2 +1,2 @@ -T9077.hs:3:12: Record syntax is illegal here: {} +T9077.hs:3:12: error: [GHC-89246] Record syntax is illegal here: {} diff --git a/testsuite/tests/rename/should_fail/T9156.stderr b/testsuite/tests/rename/should_fail/T9156.stderr index 361ed379df..1dbfb9b02e 100644 --- a/testsuite/tests/rename/should_fail/T9156.stderr +++ b/testsuite/tests/rename/should_fail/T9156.stderr @@ -1,5 +1,3 @@ -T9156.hs:4:19: - Multiple declarations of ‘f1’ - Declared at: T9156.hs:3:15 - T9156.hs:4:19 +T9156.hs:4:19: error: [GHC-85524] + Duplicate field name ‘f1’ in record declaration diff --git a/testsuite/tests/rename/should_fail/T9156_DF.hs b/testsuite/tests/rename/should_fail/T9156_DF.hs new file mode 100644 index 0000000000..aa55756c71 --- /dev/null +++ b/testsuite/tests/rename/should_fail/T9156_DF.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE TypeFamilies #-} + +module T9156_DF where + +data X = MkX + +data family D a +data instance D Int + = D1 { f1 :: X } + | D2 { f1 :: X, f2 :: X, f1 :: X } diff --git a/testsuite/tests/rename/should_fail/T9156_DF.stderr b/testsuite/tests/rename/should_fail/T9156_DF.stderr new file mode 100644 index 0000000000..61e2af19a4 --- /dev/null +++ b/testsuite/tests/rename/should_fail/T9156_DF.stderr @@ -0,0 +1,3 @@ + +T9156_DF.hs:10:29: error: [GHC-85524] + Duplicate field name ‘f1’ in record declaration diff --git a/testsuite/tests/rename/should_fail/all.T b/testsuite/tests/rename/should_fail/all.T index 2255117886..8d3029bd06 100644 --- a/testsuite/tests/rename/should_fail/all.T +++ b/testsuite/tests/rename/should_fail/all.T @@ -104,6 +104,7 @@ test('RnStaticPointersFail02', [], compile_fail, ['']) test('RnStaticPointersFail03', [], compile_fail, ['-dsuppress-uniques']) test('T9006', [], multimod_compile_fail, ['T9006', '-v0']) test('T9156', normal, compile_fail, ['']) +test('T9156_DF', normal, compile_fail, ['']) test('T9177', normal, compile_fail, ['']) test('T9177a', normal, compile_fail, ['']) test('T9436', normal, compile_fail, ['']) diff --git a/testsuite/tests/rename/should_fail/rn_dup.hs b/testsuite/tests/rename/should_fail/rn_dup.hs index 927e15ff32..7c2fc3380e 100644 --- a/testsuite/tests/rename/should_fail/rn_dup.hs +++ b/testsuite/tests/rename/should_fail/rn_dup.hs @@ -12,7 +12,7 @@ data P = MkP { rf :: Int, rf :: Int } data Q = MkQ { rf :: Int } class C a where - data CT a + data CT a f :: CT a -> a data CT a f :: CT a -> a diff --git a/testsuite/tests/rename/should_fail/rn_dup.stderr b/testsuite/tests/rename/should_fail/rn_dup.stderr index 5c4246d8b6..907fc38fe8 100644 --- a/testsuite/tests/rename/should_fail/rn_dup.stderr +++ b/testsuite/tests/rename/should_fail/rn_dup.stderr @@ -9,14 +9,12 @@ rn_dup.hs:9:10: error: Declared at: rn_dup.hs:7:10 rn_dup.hs:9:10 -rn_dup.hs:12:16: error: - Multiple declarations of ‘rf’ - Declared at: rn_dup.hs:11:27 - rn_dup.hs:12:16 +rn_dup.hs:11:27: error: [GHC-85524] + Duplicate field name ‘rf’ in record declaration rn_dup.hs:12:16: error: Multiple declarations of ‘rf’ - Declared at: rn_dup.hs:11:16 + Declared at: rn_dup.hs:11:27 rn_dup.hs:12:16 rn_dup.hs:17:3: error: diff --git a/testsuite/tests/rename/should_fail/rnfail054.stderr b/testsuite/tests/rename/should_fail/rnfail054.stderr index 04fff51118..3cb01c63da 100644 --- a/testsuite/tests/rename/should_fail/rnfail054.stderr +++ b/testsuite/tests/rename/should_fail/rnfail054.stderr @@ -1,5 +1,3 @@ -rnfail054.hs:6:13: error: [GHC-47535] - • ‘foo’ is not a record selector - • In the expression: x {foo = 1} - In an equation for ‘foo’: foo x = x {foo = 1} +rnfail054.hs:6:13: error: [GHC-22385] + Not in scope: record field ‘foo’ diff --git a/testsuite/tests/rep-poly/T20113.stderr b/testsuite/tests/rep-poly/T20113.stderr index 3d52dbe734..1358d188ea 100644 --- a/testsuite/tests/rep-poly/T20113.stderr +++ b/testsuite/tests/rep-poly/T20113.stderr @@ -4,12 +4,11 @@ T20113.hs:7:35: error: [GHC-55287] does not have a fixed runtime representation. Its type is: a :: TYPE rep - • In the pattern: MkY {y_fld = $sel:y_fld:MkY} - In an equation for ‘T20113.$sel:y_fld:MkY’: - T20113.$sel:y_fld:MkY MkY {y_fld = $sel:y_fld:MkY} = $sel:y_fld:MkY + • In the pattern: MkY {y_fld = y_fld} + In an equation for ‘y_fld’: y_fld MkY {y_fld = y_fld} = y_fld T20113.hs:7:35: error: [GHC-55287] - The first pattern in the equation for ‘$sel:y_fld:MkY’ + The first pattern in the equation for ‘y_fld’ does not have a fixed runtime representation. Its type is: Y a :: TYPE rep diff --git a/testsuite/tests/th/T10279.stderr b/testsuite/tests/th/T10279.stderr index 5993cdbf82..4a06b1d775 100644 --- a/testsuite/tests/th/T10279.stderr +++ b/testsuite/tests/th/T10279.stderr @@ -4,5 +4,8 @@ T10279.hs:10:9: error: [GHC-52243] no unit id matching ‘rts-1.0.2’ was found (This unit ID looks like the source package ID; the real unit ID is ‘rts’) - • In the expression: rts-1.0.2:A.Foo - In an equation for ‘blah’: blah = (rts-1.0.2:A.Foo) + • In the untyped splice: + $(conE + (Name + (mkOccName "Foo") + (NameG VarName (mkPkgName "rts-1.0.2") (mkModName "A")))) diff --git a/testsuite/tests/th/T10828.hs b/testsuite/tests/th/T10828.hs index ffb4525f6a..d73b5015ae 100644 --- a/testsuite/tests/th/T10828.hs +++ b/testsuite/tests/th/T10828.hs @@ -6,6 +6,7 @@ module T10828 where import Language.Haskell.TH hiding (Type) import System.IO import Data.Kind (Type) +import qualified Data.List.NonEmpty as NE ( singleton ) $( do { decl <- [d| data family D a :: Type -> Type data instance D Int Bool :: Type where @@ -33,7 +34,7 @@ $( return [ DataD [] (mkName "T") [ PlainTV (mkName "a") () ] (Just StarT) - [ GadtC [(mkName "MkT")] + [ GadtC (NE.singleton (mkName "MkT")) [ ( Bang NoSourceUnpackedness NoSourceStrictness , VarT (mkName "a") ) @@ -46,7 +47,7 @@ $( return , ForallC [PlainTV (mkName "a") SpecifiedSpec, PlainTV (mkName "b") SpecifiedSpec] [AppT (AppT EqualityT (VarT $ mkName "a" ) ) (ConT $ mkName "Int") ] $ - RecGadtC [(mkName "MkC")] + RecGadtC (NE.singleton (mkName "MkC")) [ ( mkName "foo" , Bang NoSourceUnpackedness NoSourceStrictness , VarT (mkName "a") diff --git a/testsuite/tests/th/T10828b.hs b/testsuite/tests/th/T10828b.hs index 03706d6b7c..36e91eb11a 100644 --- a/testsuite/tests/th/T10828b.hs +++ b/testsuite/tests/th/T10828b.hs @@ -4,6 +4,7 @@ module T10828b where import Language.Haskell.TH import System.IO +import qualified Data.List.NonEmpty as NE ( singleton ) -- attempting to mix GADT and normal constructors $( return @@ -23,7 +24,7 @@ $( return [AppT (AppT EqualityT (VarT $ mkName "a" ) ) (ConT $ mkName "Int") ] $ RecGadtC - [ (mkName "MkC")] + (NE.singleton (mkName "MkC")) [ ( mkName "foo" , Bang NoSourceUnpackedness NoSourceStrictness , VarT (mkName "a") diff --git a/testsuite/tests/th/T10828b.stderr b/testsuite/tests/th/T10828b.stderr index 357c86c458..6e78ca9087 100644 --- a/testsuite/tests/th/T10828b.stderr +++ b/testsuite/tests/th/T10828b.stderr @@ -1,5 +1,5 @@ -T10828b.hs:9:2: error: [GHC-24104] +T10828b.hs:10:2: error: [GHC-24104] Cannot mix GADT constructors with Haskell 98 constructors When splicing a TH declaration: data T a :: * diff --git a/testsuite/tests/th/T11345.hs b/testsuite/tests/th/T11345.hs index 2288cdad15..11de6d8bd5 100644 --- a/testsuite/tests/th/T11345.hs +++ b/testsuite/tests/th/T11345.hs @@ -5,6 +5,7 @@ module Main (main) where import Language.Haskell.TH +import qualified Data.List.NonEmpty as NE ( singleton ) infixr 7 :***: data GADT a where @@ -16,11 +17,11 @@ $(do gadtName <- newName "GADT2" infixName <- newName ":****:" a <- newName "a" return [ DataD [] gadtName [KindedTV a () StarT] Nothing - [ GadtC [prefixName] + [ GadtC (NE.singleton prefixName) [ (Bang NoSourceUnpackedness NoSourceStrictness,ConT ''Int) , (Bang NoSourceUnpackedness NoSourceStrictness,ConT ''Int) ] (AppT (ConT gadtName) (ConT ''Int)) - , GadtC [infixName] + , GadtC (NE.singleton infixName) [ (Bang NoSourceUnpackedness NoSourceStrictness,ConT ''Int) , (Bang NoSourceUnpackedness NoSourceStrictness,ConT ''Int) ] (AppT (ConT gadtName) (ConT ''Int)) diff --git a/testsuite/tests/th/T11941.stderr b/testsuite/tests/th/T11941.stderr index 39a25c7425..7a66251092 100644 --- a/testsuite/tests/th/T11941.stderr +++ b/testsuite/tests/th/T11941.stderr @@ -1,7 +1,7 @@ -T11941.hs:7:30: error: [GHC-76037] - Not in scope: ‘getFrst’ +T11941.hs:7:30: error: [GHC-22385] + Not in scope: record field ‘getFrst’ Suggested fix: Perhaps use one of these: - ‘getFirst’ (imported from Data.Monoid), - ‘getLast’ (imported from Data.Monoid) + record field of First ‘getFirst’ (imported from Data.Monoid), + record field of Last ‘getLast’ (imported from Data.Monoid) diff --git a/testsuite/tests/th/T17379a.hs b/testsuite/tests/th/T17379a.hs deleted file mode 100644 index 66702bb9b8..0000000000 --- a/testsuite/tests/th/T17379a.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE GADTSyntax #-} - -module T17379a where - -import Language.Haskell.TH - -$(let typ = mkName "T" in pure [ DataD [] typ [] Nothing [GadtC [] [] (ConT typ)] [] ]) diff --git a/testsuite/tests/th/T17379a.stderr b/testsuite/tests/th/T17379a.stderr deleted file mode 100644 index ebb899e750..0000000000 --- a/testsuite/tests/th/T17379a.stderr +++ /dev/null @@ -1,4 +0,0 @@ - -T17379a.hs:8:2: error: [GHC-38140] - GadtC must have at least one constructor name - When splicing a TH declaration: data T where :: T diff --git a/testsuite/tests/th/T17379b.hs b/testsuite/tests/th/T17379b.hs deleted file mode 100644 index c83d180d18..0000000000 --- a/testsuite/tests/th/T17379b.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE GADTSyntax #-} - -module T17379b where - -import Language.Haskell.TH - -$(let typ = mkName "T" in pure [ DataD [] typ [] Nothing [RecGadtC [] [] (ConT typ)] [] ]) diff --git a/testsuite/tests/th/T17379b.stderr b/testsuite/tests/th/T17379b.stderr deleted file mode 100644 index 9a4aabc250..0000000000 --- a/testsuite/tests/th/T17379b.stderr +++ /dev/null @@ -1,4 +0,0 @@ - -T17379b.hs:8:2: error: [GHC-18816] - RecGadtC must have at least one constructor name - When splicing a TH declaration: data T where :: {} -> T diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T index a4f948bc76..2b792da6e2 100644 --- a/testsuite/tests/th/all.T +++ b/testsuite/tests/th/all.T @@ -504,8 +504,6 @@ test('T17296', normal, compile, ['-v0']) test('T17305', normal, compile, ['-v0']) test('T17380', normal, compile_fail, ['']) test('T17394', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques']) -test('T17379a', normal, compile_fail, ['']) -test('T17379b', normal, compile_fail, ['']) test('T17461', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques']) test('T17511', normal, compile, ['']) test('T17608', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques']) diff --git a/testsuite/tests/typecheck/should_compile/QualifiedRecordUpdate.hs b/testsuite/tests/typecheck/should_compile/QualifiedRecordUpdate.hs new file mode 100644 index 0000000000..3657ab4463 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/QualifiedRecordUpdate.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE DuplicateRecordFields #-} + +module QualifiedRecordUpdate where + +import QualifiedRecordUpdate_aux ( R(fld1, fld2), S(fld1, fld2) ) +import qualified QualifiedRecordUpdate_aux as B ( R(fld1, fld2), S(fld1) ) + +-- Unambiguous record update: the only record datatype in the B namespace +-- which contains field fld2 is R. +f r = r { B.fld1 = 3, B.fld2 = False } diff --git a/testsuite/tests/typecheck/should_compile/QualifiedRecordUpdate_aux.hs b/testsuite/tests/typecheck/should_compile/QualifiedRecordUpdate_aux.hs new file mode 100644 index 0000000000..c03abe277c --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/QualifiedRecordUpdate_aux.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE DuplicateRecordFields #-} + +module QualifiedRecordUpdate_aux where + +data R = R { fld1 :: Int, fld2 :: Bool } +data S = S { fld1 :: Int, fld2 :: Bool, fld3 :: Char } diff --git a/testsuite/tests/typecheck/should_compile/T21443.hs b/testsuite/tests/typecheck/should_compile/T21443.hs new file mode 100644 index 0000000000..7dbd451c09 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T21443.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE DuplicateRecordFields #-} + +module T21443 where + +data R = MkR1 { foo :: Int } + | MkR2 { bar :: Int } + +data S = MkS { foo :: Int, bar :: Int } + +blah x = x { foo = 5, bar = 6 } diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T index 327dd93675..4c200961f4 100644 --- a/testsuite/tests/typecheck/should_compile/all.T +++ b/testsuite/tests/typecheck/should_compile/all.T @@ -865,4 +865,8 @@ test('T22985a', normal, compile, ['-O']) test('T22985b', normal, compile, ['']) test('T23018', normal, compile, ['']) test('T21909', normal, compile, ['']) -test('T21909b', normal, compile, [''])
\ No newline at end of file +test('T21909b', normal, compile, ['']) +test('T21443', normal, compile, ['']) +test('QualifiedRecordUpdate', + [ extra_files(['QualifiedRecordUpdate_aux.hs']) ] + , multimod_compile, ['QualifiedRecordUpdate', '-v0']) diff --git a/testsuite/tests/typecheck/should_fail/T12035.hs b/testsuite/tests/typecheck/should_fail/T12035.hs index 87e20ff07c..cd12eee917 100644 --- a/testsuite/tests/typecheck/should_fail/T12035.hs +++ b/testsuite/tests/typecheck/should_fail/T12035.hs @@ -1,7 +1,7 @@ module T12035 where import T12035a type T = Bool -y = f True +--y = f True -- This should error that 'type T = Int' doesn't match 'data T', -- NOT that f expects argument of type T but got Bool. diff --git a/testsuite/tests/typecheck/should_fail/T21444.hs b/testsuite/tests/typecheck/should_fail/T21444.hs new file mode 100644 index 0000000000..28f2010dbd --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T21444.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE DuplicateRecordFields #-} + +module T21444 where + +data S = MkS { foo, bar, baz :: Int } +data T = MkT { foo, bar, baz :: Int } + +blah x = x { foo = 1, bar = 2, baz = 3 } diff --git a/testsuite/tests/typecheck/should_fail/T21444.stderr b/testsuite/tests/typecheck/should_fail/T21444.stderr new file mode 100644 index 0000000000..cd4795c969 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T21444.stderr @@ -0,0 +1,6 @@ + +T21444.hs:8:10: error: [GHC-99339] + • Ambiguous record update with fields ‘foo’, ‘bar’ and ‘baz’ + These fields appear in both datatypes ‘S’ and ‘T’ + • In the expression: x {foo = 1, bar = 2, baz = 3} + In an equation for ‘blah’: blah x = x {foo = 1, bar = 2, baz = 3} diff --git a/testsuite/tests/typecheck/should_fail/T7989.stderr b/testsuite/tests/typecheck/should_fail/T7989.stderr index 7413b06648..f5271b2167 100644 --- a/testsuite/tests/typecheck/should_fail/T7989.stderr +++ b/testsuite/tests/typecheck/should_fail/T7989.stderr @@ -1,15 +1,4 @@ T7989.hs:6:7: error: [GHC-14392] - • No constructor has all these fields: ‘a0’, ‘b0’ - • In the expression: x {a0 = 3, a1 = 2, b0 = 4, b1 = 5} - In an equation for ‘f’: f x = x {a0 = 3, a1 = 2, b0 = 4, b1 = 5} - -T7989.hs:9:7: error: [GHC-14392] - • No constructor has all these fields: ‘x’, ‘y’, ‘z’ - • In the expression: a {x = 0, y = 0, z = 0, v = 0} - In an equation for ‘g’: g a = a {x = 0, y = 0, z = 0, v = 0} - -T7989.hs:11:7: error: [GHC-14392] - • No constructor has all these fields: ‘x’, ‘a0’ - • In the expression: a {x = 0, a0 = 0} - In an equation for ‘h’: h a = a {x = 0, a0 = 0} + Invalid record update. + No constructor in scope has all of the following fields: ‘a0’, ‘b0’ diff --git a/testsuite/tests/typecheck/should_fail/all.T b/testsuite/tests/typecheck/should_fail/all.T index 209f292737..2afc480451 100644 --- a/testsuite/tests/typecheck/should_fail/all.T +++ b/testsuite/tests/typecheck/should_fail/all.T @@ -675,3 +675,4 @@ test('T19627', normal, compile_fail, ['']) test('PatSynExistential', normal, compile_fail, ['']) test('PatSynArity', normal, compile_fail, ['']) test('PatSynUnboundVar', normal, compile_fail, ['']) +test('T21444', normal, compile_fail, ['']) diff --git a/testsuite/tests/typecheck/should_fail/tcfail114.stderr b/testsuite/tests/typecheck/should_fail/tcfail114.stderr index 7516ebb712..b751b31cd0 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail114.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail114.stderr @@ -1,5 +1,3 @@ -tcfail114.hs:11:20: error: [GHC-47535] - • ‘foo’ is not a record selector - • In the expression: undefined {foo = ()} - In an equation for ‘test’: test = undefined {foo = ()} +tcfail114.hs:11:20: error: [GHC-22385] + Not in scope: record field ‘foo’ diff --git a/testsuite/tests/warnings/should_compile/DodgyExports01.stderr b/testsuite/tests/warnings/should_compile/DodgyExports01.stderr index d3cae826ab..f916bcfaa4 100644 --- a/testsuite/tests/warnings/should_compile/DodgyExports01.stderr +++ b/testsuite/tests/warnings/should_compile/DodgyExports01.stderr @@ -1,5 +1,4 @@ DodgyExports01.hs:2:13: warning: [GHC-75356] [-Wdodgy-exports (in -Wextra)] The export item ‘T(..)’ suggests that - ‘T’ has (in-scope) constructors or class methods, - but it has none + ‘T’ has (in-scope) constructors or record fields, but it has none diff --git a/utils/check-exact/ExactPrint.hs b/utils/check-exact/ExactPrint.hs index d4f1961176..04d0b831e6 100644 --- a/utils/check-exact/ExactPrint.hs +++ b/utils/check-exact/ExactPrint.hs @@ -3136,6 +3136,7 @@ instance (ExactPrint body) -- --------------------------------------------------------------------- +-- instance ExactPrint (HsRecUpdField GhcPs q) where instance (ExactPrint (LocatedA body)) => ExactPrint (HsFieldBind (LocatedAn NoEpAnns (AmbiguousFieldOcc GhcPs)) (LocatedA body)) where getAnnotationEntry x = fromAnn (hfbAnn x) @@ -3151,17 +3152,18 @@ instance (ExactPrint (LocatedA body)) return (HsFieldBind an0 f' arg' isPun) -- --------------------------------------------------------------------- -instance - (ExactPrint (HsFieldBind (LocatedAn NoEpAnns (a GhcPs)) body), - ExactPrint (HsFieldBind (LocatedAn NoEpAnns (b GhcPs)) body)) - => ExactPrint - (Either [LocatedA (HsFieldBind (LocatedAn NoEpAnns (a GhcPs)) body)] - [LocatedA (HsFieldBind (LocatedAn NoEpAnns (b GhcPs)) body)]) where +instance ExactPrint (LHsRecUpdFields GhcPs) where getAnnotationEntry = const NoEntryVal setAnnotationAnchor a _ _ = a - exact (Left rbinds) = Left <$> markAnnotated rbinds - exact (Right pbinds) = Right <$> markAnnotated pbinds + exact flds@(RegularRecUpdFields { recUpdFields = rbinds }) = do + debugM $ "RegularRecUpdFields" + rbinds' <- markAnnotated rbinds + return $ flds { recUpdFields = rbinds' } + exact flds@(OverloadedRecUpdFields { olRecUpdFields = pbinds }) = do + debugM $ "OverloadedRecUpdFields" + pbinds' <- markAnnotated pbinds + return $ flds { olRecUpdFields = pbinds' } -- --------------------------------------------------------------------- diff --git a/utils/haddock b/utils/haddock -Subproject 6f1b9093395f4b12298b8b785b855a637206f5f +Subproject d19850b8046876e92dfef045d8a5558b951f165 |