diff options
| author | sheaf <sam.derbyshire@gmail.com> | 2023-03-17 12:48:21 +0100 |
|---|---|---|
| committer | sheaf <sam.derbyshire@gmail.com> | 2023-03-29 13:57:33 +0200 |
| commit | 3f374399e2dbebcdfe5bc31f94fc502b46d0cf4f (patch) | |
| tree | a5103e3d597c2d724173e070a22759ce50a9d2e7 | |
| parent | 76bb4c586084d7fdcf0e5ce52623abbfca527c55 (diff) | |
| download | haskell-3f374399e2dbebcdfe5bc31f94fc502b46d0cf4f.tar.gz | |
Handle records in the renamer
This patch moves the field-based logic for disambiguating record updates
to the renamer. The type-directed logic, scheduled for removal, remains
in the typechecker.
To do this properly (and fix the myriad of bugs surrounding the treatment
of duplicate record fields), we took the following main steps:
1. Create GREInfo, a renamer-level equivalent to TyThing which stores
information pertinent to the renamer.
This allows us to uniformly treat imported and local Names in the
renamer, as described in Note [GREInfo].
2. Remove GreName. Instead of a GlobalRdrElt storing GreNames, which
distinguished between normal names and field names, we now store
simple Names in GlobalRdrElt, along with the new GREInfo information
which allows us to recover the FieldLabel for record fields.
3. Add namespacing for record fields, within the OccNames themselves.
This allows us to remove the mangling of duplicate field selectors.
This change ensures we don't print mangled names to the user in
error messages, and allows us to handle duplicate record fields
in Template Haskell.
4. Move record disambiguation to the renamer, and operate on the
level of data constructors instead, to handle #21443.
The error message text for ambiguous record updates has also been
changed to reflect that type-directed disambiguation is on the way
out.
(3) means that OccEnv is now a bit more complex: we first key on the
textual name, which gives an inner map keyed on NameSpace:
OccEnv a ~ FastStringEnv (UniqFM NameSpace a)
Note that this change, along with (2), both increase the memory residency
of GlobalRdrEnv = OccEnv [GlobalRdrElt], which causes a few tests to
regress somewhat in compile-time allocation.
Even though (3) simplified a lot of code (in particular the treatment of
field selectors within Template Haskell and in error messages), it came
with one important wrinkle: in the situation of
-- M.hs-boot
module M where { data A; foo :: A -> Int }
-- M.hs
module M where { data A = MkA { foo :: Int } }
we have that M.hs-boot exports a variable foo, which is supposed to match
with the record field foo that M exports. To solve this issue, we add a
new impedance-matching binding to M
foo{var} = foo{fld}
This mimics the logic that existed already for impedance-binding DFunIds,
but getting it right was a bit tricky.
See Note [Record field impedance matching] in GHC.Tc.Module.
We also needed to be careful to avoid introducing space leaks in GHCi.
So we dehydrate the GlobalRdrEnv before storing it anywhere, e.g. in
ModIface. This means stubbing out all the GREInfo fields, with the
function forceGlobalRdrEnv.
When we read it back in, we rehydrate with rehydrateGlobalRdrEnv.
This robustly avoids any space leaks caused by retaining old type
environments.
Fixes #13352 #14848 #17381 #17551 #19664 #21443 #21444 #21720 #21898 #21946 #21959 #22125 #22160 #23010 #23062 #23063
Updates haddock submodule
-------------------------
Metric Increase:
MultiComponentModules
MultiLayerModules
MultiLayerModulesDefsGhci
MultiLayerModulesNoCode
T13701
T14697
hard_hole_fits
-------------------------
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 |