diff --git a/compiler/GHC/Core/ConLike.hs b/compiler/GHC/Core/ConLike.hs
index e609bd4b51b3021ea3037ab6f8c52c1d479f43fb..683e03d187356883cd52deef96cb1a5127941edd 100644
--- a/compiler/GHC/Core/ConLike.hs
+++ b/compiler/GHC/Core/ConLike.hs
@@ -47,6 +47,7 @@ import GHC.Utils.Outputable
import Data.Maybe( isJust )
import qualified Data.Data as Data
+import qualified Data.List as List
{-
************************************************************************
@@ -224,8 +225,10 @@ conLikeFieldType (RealDataCon dc) label = dataConFieldType dc label
-- | The ConLikes that have *all* the given fields
-conLikesWithFields :: [ConLike] -> [FieldLabelString] -> [ConLike]
-conLikesWithFields con_likes lbls = filter has_flds con_likes
+conLikesWithFields :: [ConLike] -> [FieldLabelString]
+ -> ( [ConLike] -- ConLikes containing the fields
+ , [ConLike] ) -- ConLikes not containing the fields
+conLikesWithFields con_likes lbls = List.partition has_flds con_likes
where has_flds dc = all (has_fld dc) lbls
has_fld dc lbl = any (\ fl -> flLabel fl == lbl) (conLikeFieldLabels dc)
diff --git a/compiler/GHC/Driver/Flags.hs b/compiler/GHC/Driver/Flags.hs
index 736505c7f10ab54c6f684d9e8a1b6a1549eb552f..005a324017f2fe4caffd18a38d6edc8dae0db017 100644
--- a/compiler/GHC/Driver/Flags.hs
+++ b/compiler/GHC/Driver/Flags.hs
@@ -684,6 +684,7 @@ data WarningFlag =
| Opt_WarnMissingRoleAnnotations -- Since 9.8
| Opt_WarnImplicitRhsQuantification -- Since 9.8
| Opt_WarnIncompleteExportWarnings -- Since 9.8
+ | Opt_WarnIncompleteRecordSelectors -- Since 9.10
deriving (Eq, Ord, Show, Enum)
-- | Return the names of a WarningFlag
@@ -794,6 +795,7 @@ warnFlagNames wflag = case wflag of
Opt_WarnMissingRoleAnnotations -> "missing-role-annotations" :| []
Opt_WarnImplicitRhsQuantification -> "implicit-rhs-quantification" :| []
Opt_WarnIncompleteExportWarnings -> "incomplete-export-warnings" :| []
+ Opt_WarnIncompleteRecordSelectors -> "incomplete-record-selectors" :| []
-- -----------------------------------------------------------------------------
-- Standard sets of warning options
diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs
index 60ba6526bbb23be35d38860ed487bbb05fdf417a..49ab225cf0e06e424e66a2e95bca818f9aa3962b 100644
--- a/compiler/GHC/Driver/Session.hs
+++ b/compiler/GHC/Driver/Session.hs
@@ -2263,7 +2263,8 @@ wWarningFlagsDeps = mconcat [
warnSpec Opt_WarnTermVariableCapture,
warnSpec Opt_WarnMissingRoleAnnotations,
warnSpec Opt_WarnImplicitRhsQuantification,
- warnSpec Opt_WarnIncompleteExportWarnings
+ warnSpec Opt_WarnIncompleteExportWarnings,
+ warnSpec Opt_WarnIncompleteRecordSelectors
]
warningGroupsDeps :: [(Deprecation, FlagSpec WarningGroup)]
diff --git a/compiler/GHC/HsToCore/Errors/Ppr.hs b/compiler/GHC/HsToCore/Errors/Ppr.hs
index cc7222f447c5566b9eb9264cf4d72dca3ee355e6..402b5a2f49e3d7ff7c4e8fa42e17333af2ff608b 100644
--- a/compiler/GHC/HsToCore/Errors/Ppr.hs
+++ b/compiler/GHC/HsToCore/Errors/Ppr.hs
@@ -207,6 +207,10 @@ instance Diagnostic DsMessage where
<+> text "for"<+> quotes (ppr lhs_id)
<+> text "might fire first")
]
+ DsIncompleteRecordSelector name cons_wo_field not_full_examples -> mkSimpleDecorated $
+ text "The application of the record field" <+> quotes (ppr name)
+ <+> text "may fail for the following constructors:"
+ <+> vcat (map ppr cons_wo_field ++ [text "..." | not_full_examples])
diagnosticReason = \case
DsUnknownMessage m -> diagnosticReason m
@@ -237,6 +241,7 @@ instance Diagnostic DsMessage where
DsRecBindsNotAllowedForUnliftedTys{} -> ErrorWithoutFlag
DsRuleMightInlineFirst{} -> WarningWithFlag Opt_WarnInlineRuleShadowing
DsAnotherRuleMightFireFirst{} -> WarningWithFlag Opt_WarnInlineRuleShadowing
+ DsIncompleteRecordSelector{} -> WarningWithFlag Opt_WarnIncompleteRecordSelectors
diagnosticHints = \case
DsUnknownMessage m -> diagnosticHints m
@@ -273,6 +278,7 @@ instance Diagnostic DsMessage where
DsRecBindsNotAllowedForUnliftedTys{} -> noHints
DsRuleMightInlineFirst _ lhs_id rule_act -> [SuggestAddInlineOrNoInlinePragma lhs_id rule_act]
DsAnotherRuleMightFireFirst _ bad_rule _ -> [SuggestAddPhaseToCompetingRule bad_rule]
+ DsIncompleteRecordSelector{} -> noHints
diagnosticCode = constructorCode
diff --git a/compiler/GHC/HsToCore/Errors/Types.hs b/compiler/GHC/HsToCore/Errors/Types.hs
index 608bfa28544780b186d2f1d1b6fbca1f40b7ba8a..a5b85218fad5f5362860dea6ac7ac1c4e3ef5520 100644
--- a/compiler/GHC/HsToCore/Errors/Types.hs
+++ b/compiler/GHC/HsToCore/Errors/Types.hs
@@ -8,6 +8,7 @@ import GHC.Prelude
import GHC.Core (CoreRule, CoreExpr, RuleName)
import GHC.Core.DataCon
+import GHC.Core.ConLike
import GHC.Core.Type
import GHC.Driver.DynFlags (DynFlags, xopt)
import GHC.Driver.Flags (WarningFlag)
@@ -147,6 +148,23 @@ data DsMessage
!RuleName -- the \"bad\" rule
!Var
+ {-| DsIncompleteRecordSelector is a warning triggered when we are not certain whether
+ a record selector application will be successful. Currently, this means that
+ the warning is triggered when there is a record selector of a data type that
+ does not have that field in all its constructors.
+
+ Example(s):
+ data T = T1 | T2 {x :: Bool}
+ f :: T -> Bool
+ f a = x a
+
+ Test cases:
+ DsIncompleteRecSel1
+ DsIncompleteRecSel2
+ DsIncompleteRecSel3
+ -}
+ | DsIncompleteRecordSelector !Name ![ConLike] !Bool
+
deriving Generic
-- The positional number of the argument for an expression (first, second, third, etc)
diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs
index 59970138dd1b27d194350cb5efaf384ec8878257..8b0283f6e5bd87101befba4c52ac15bc0c72e5da 100644
--- a/compiler/GHC/HsToCore/Expr.hs
+++ b/compiler/GHC/HsToCore/Expr.hs
@@ -3,6 +3,7 @@
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
+{-# LANGUAGE LambdaCase #-}
{-
(c) The University of Glasgow 2006
@@ -31,7 +32,7 @@ import GHC.HsToCore.Monad
import GHC.HsToCore.Pmc
import GHC.HsToCore.Errors.Types
import GHC.Types.SourceText
-import GHC.Types.Name
+import GHC.Types.Name hiding (varName)
import GHC.Core.FamInstEnv( topNormaliseType )
import GHC.HsToCore.Quote
import GHC.HsToCore.Ticks (stripTicksTopHsExpr)
@@ -51,6 +52,7 @@ import GHC.Core.Make
import GHC.Driver.Session
import GHC.Types.CostCentre
import GHC.Types.Id
+import GHC.Types.Id.Info
import GHC.Types.Id.Make
import GHC.Unit.Module
import GHC.Core.ConLike
@@ -67,6 +69,7 @@ import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Core.PatSyn
import Control.Monad
+import GHC.Types.Error
{-
************************************************************************
@@ -230,7 +233,38 @@ dsLExpr (L loc e) = putSrcSpanDsA loc $ dsExpr e
-- | Desugar a typechecked expression.
dsExpr :: HsExpr GhcTc -> DsM CoreExpr
dsExpr (HsVar _ (L _ id)) = dsHsVar id
-dsExpr (HsRecSel _ (FieldOcc id _)) = dsHsVar id
+
+{- Record selectors are warned about if they are not
+present in all of the parent data type's constructor,
+or always in case of pattern synonym record selectors
+(regulated by a flag). However, this only produces
+a warning if it's not a part of a record selector
+application. For example:
+
+ data T = T1 | T2 {s :: Bool}
+ f x = s x -- the warning from this case will be supressed
+
+See the `HsApp` case for where it is filtered out
+-}
+dsExpr (HsRecSel _ (FieldOcc id _))
+ = do { let name = getName id
+ RecSelId {sel_cons = (_, cons_wo_field)}
+ = idDetails id
+ ; cons_trimmed <- trim_cons cons_wo_field
+ ; unless (null cons_wo_field) $ diagnosticDs
+ $ DsIncompleteRecordSelector name cons_trimmed (cons_trimmed /= cons_wo_field)
+ -- This only produces a warning if it's not a part of a
+ -- record selector application (e.g. `s a` where `s` is a selector)
+ -- See the `HsApp` case for where it is filtered out
+ ; dsHsVar id }
+ where
+ trim_cons :: [ConLike] -> DsM [ConLike]
+ trim_cons cons_wo_field = do
+ dflags <- getDynFlags
+ let maxConstructors = maxUncoveredPatterns dflags
+ return $ take maxConstructors cons_wo_field
+
+
dsExpr (HsUnboundVar (HER ref _ _) _) = dsEvTerm =<< readMutVar ref
-- See Note [Holes] in GHC.Tc.Types.Constraint
@@ -297,9 +331,27 @@ dsExpr (HsLamCase _ lc_variant matches)
= uncurry mkCoreLams <$> matchWrapper (LamCaseAlt lc_variant) Nothing matches
dsExpr e@(HsApp _ fun arg)
- = do { fun' <- dsLExpr fun
+ -- We want to have a special case that uses the PMC information to filter
+ -- out some of the incomplete record selectors warnings and not trigger
+ -- the warning emitted during the desugaring of dsExpr(HsRecSel)
+ -- See Note [Detecting incomplete record selectors] in GHC.HsToCore.Pmc
+ = do { (msgs, fun') <- captureMessagesDs $ dsLExpr fun
+ -- Make sure to filter out the generic incomplete record selector warning
+ -- if it's a raw record selector
; arg' <- dsLExpr arg
+ ; case getIdFromTrivialExpr_maybe fun' of
+ Just fun_id | isRecordSelector fun_id
+ -> do { let msgs' = filterMessages is_incomplete_rec_sel_msg msgs
+ ; addMessagesDs msgs'
+ ; pmcRecSel fun_id arg' }
+ _ -> addMessagesDs msgs
; return $ mkCoreAppDs (text "HsApp" <+> ppr e) fun' arg' }
+ where
+ is_incomplete_rec_sel_msg :: MsgEnvelope DsMessage -> Bool
+ is_incomplete_rec_sel_msg (MsgEnvelope {errMsgDiagnostic = DsIncompleteRecordSelector{}})
+ = False
+ is_incomplete_rec_sel_msg _ = True
+
dsExpr e@(HsAppType {}) = dsHsWrapped e
diff --git a/compiler/GHC/HsToCore/Monad.hs b/compiler/GHC/HsToCore/Monad.hs
index 6ba19bb95892004e6cd7a2363cc44f3f9019ea46..1a6533103b0429449a73fddf32e7d9ef7a541613 100644
--- a/compiler/GHC/HsToCore/Monad.hs
+++ b/compiler/GHC/HsToCore/Monad.hs
@@ -45,6 +45,7 @@ module GHC.HsToCore.Monad (
-- Warnings and errors
DsWarning, diagnosticDs, errDsCoreExpr,
failWithDs, failDs, discardWarningsDs,
+ addMessagesDs, captureMessagesDs,
-- Data types
DsMatchContext(..),
@@ -443,6 +444,12 @@ diagnosticDs dsMessage
; let msg = mkMsgEnvelope diag_opts loc (ds_name_ppr_ctx env) dsMessage
; updMutVar (ds_msgs env) (\ msgs -> msg `addMessage` msgs) }
+addMessagesDs :: Messages DsMessage -> DsM ()
+addMessagesDs msgs1
+ = do { msg_var <- ds_msgs <$> getGblEnv
+ ; msgs0 <- liftIO $ readIORef msg_var
+ ; liftIO $ writeIORef msg_var (msgs0 `unionMessages` msgs1) }
+
-- | Issue an error, but return the expression for (), so that we can continue
-- reporting errors.
errDsCoreExpr :: DsMessage -> DsM CoreExpr
@@ -458,6 +465,13 @@ failWithDs msg
failDs :: DsM a
failDs = failM
+captureMessagesDs :: DsM a -> DsM (Messages DsMessage, a)
+captureMessagesDs thing_inside
+ = do { msg_var <- liftIO $ newIORef emptyMessages
+ ; res <- updGblEnv (\gbl -> gbl {ds_msgs = msg_var}) thing_inside
+ ; msgs <- liftIO $ readIORef msg_var
+ ; return (msgs, res) }
+
mkNamePprCtxDs :: DsM NamePprCtx
mkNamePprCtxDs = ds_name_ppr_ctx <$> getGblEnv
diff --git a/compiler/GHC/HsToCore/Pmc.hs b/compiler/GHC/HsToCore/Pmc.hs
index 9fde238fe97178f724e4065ab1d1149f8deaa9f1..ca49e530a77bf048b8b1f4df5e13e51324b2a92c 100644
--- a/compiler/GHC/HsToCore/Pmc.hs
+++ b/compiler/GHC/HsToCore/Pmc.hs
@@ -35,11 +35,12 @@
-- 'ldiMatch'. See Section 4.1 of the paper.
module GHC.HsToCore.Pmc (
-- Checking and printing
- pmcPatBind, pmcMatches, pmcGRHSs,
+ pmcPatBind, pmcMatches, pmcGRHSs, pmcRecSel,
isMatchContextPmChecked, isMatchContextPmChecked_SinglePat,
-- See Note [Long-distance information]
- addTyCs, addCoreScrutTmCs, addHsScrutTmCs, getLdiNablas
+ addTyCs, addCoreScrutTmCs, addHsScrutTmCs, getLdiNablas,
+ getNFirstUncovered
) where
import GHC.Prelude
@@ -51,7 +52,7 @@ import GHC.HsToCore.Pmc.Desugar
import GHC.HsToCore.Pmc.Check
import GHC.HsToCore.Pmc.Solver
import GHC.Types.Basic (Origin(..))
-import GHC.Core (CoreExpr)
+import GHC.Core
import GHC.Driver.DynFlags
import GHC.Hs
import GHC.Types.Id
@@ -59,21 +60,20 @@ import GHC.Types.SrcLoc
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
-import GHC.Types.Var (EvVar)
+import GHC.Types.Var (EvVar, Var (..))
+import GHC.Types.Id.Info
import GHC.Tc.Utils.TcType (evVarPred)
-import GHC.Tc.Utils.Monad (updTopFlags)
import {-# SOURCE #-} GHC.HsToCore.Expr (dsLExpr)
import GHC.HsToCore.Monad
import GHC.Data.Bag
-import GHC.Data.IOEnv (unsafeInterleaveM)
import GHC.Data.OrdList
-import GHC.Utils.Monad (mapMaybeM)
import Control.Monad (when, forM_)
import qualified Data.Semigroup as Semi
import Data.List.NonEmpty ( NonEmpty(..) )
import qualified Data.List.NonEmpty as NE
import Data.Coerce
+import GHC.Tc.Utils.Monad
--
-- * Exported entry points to the checker
@@ -193,9 +193,92 @@ pmcMatches ctxt vars matches = {-# SCC "pmcMatches" #-} do
{-# SCC "formatReportWarnings" #-} formatReportWarnings ReportMatchGroup ctxt vars result
return (NE.toList (ldiMatchGroup (cr_ret result)))
+{-
+Note [Detecting incomplete record selectors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A record selector occurence is incomplete iff. it could fail due to
+being applied to a data type constructor not present for this record field.
+
+e.g.
+ data T = T1 | T2 {x :: Int}
+ d = x someComputation -- `d` may fail
+
+There are 4 parts to detecting and warning about
+incomplete record selectors to consider:
+
+ - Computing which constructors a general application of a record field will succeed on,
+ and which ones it will fail on. This is stored in the `sel_cons` field of
+ `IdDetails` datatype, which is a part of an `Id` and calculated when renaming a
+ record selector in `mkOneRecordSelector`
+
+ - Emitting a warning whenever a `HasField` constraint is solved.
+ This is checked in `matchHasField` and emitted only for when
+ the constraint is resolved with an implicit instance rather than a
+ custom one (since otherwise the warning will be emitted in
+ the custom implementation anyways)
+
+ e.g.
+ g :: HasField "x" t Int => t -> Int
+ g = getField @"x"
+
+ f :: T -> Int
+ f = g -- warning will be emitted here
+
+ - Emitting a warning for a general occurence of the record selector
+ This is done during the renaming of a `HsRecSel` expression in `dsExpr`
+ and simply pulls the information about incompleteness from the `Id`
+
+ e.g.
+ l :: T -> Int
+ l a = x a -- warning will be emitted here
+
+ - Emitting a warning for a record selector `sel` applied to a variable `y`.
+ In that case we want to use the long-distance information from the
+ pattern match checker to rule out impossible constructors
+ (See Note [Long-distance information]). We first add constraints to
+ the long-distance `Nablas` that `y` cannot be one of the constructors that
+ contain `sel` (function `checkRecSel` in GHC.HsToCore.Pmc.Check). If the
+ `Nablas` are still inhabited, we emit a warning with the inhabiting constructors
+ as examples of where `sel` may fail.
+
+ e.g.
+ z :: T -> Int
+ z T1 = 0
+ z a = x a -- warning will not be emitted here since `a` can only be `T2`
+-}
+
+pmcRecSel :: Id -- ^ Id of the selector
+ -> CoreExpr -- ^ Core expression of the argument to the selector
+ -> DsM ()
+pmcRecSel sel_id arg
+ | RecSelId{ sel_cons = (cons_w_field, _ : _) } <- idDetails sel_id = do
+ !missing <- getLdiNablas
+
+ tracePm "pmcRecSel {" (ppr sel_id)
+ CheckResult{ cr_ret = PmRecSel{ pr_arg_var = arg_id }, cr_uncov = uncov_nablas }
+ <- unCA (checkRecSel (PmRecSel () arg cons_w_field)) missing
+ tracePm "}: " $ ppr uncov_nablas
+
+ inhabited <- isInhabited uncov_nablas
+ when inhabited $ warn_incomplete arg_id uncov_nablas
+ where
+ sel_name = varName sel_id
+ warn_incomplete arg_id uncov_nablas = do
+ dflags <- getDynFlags
+ let maxConstructors = maxUncoveredPatterns dflags
+ unc_examples <- getNFirstUncovered MinimalCover [arg_id] (maxConstructors + 1) uncov_nablas
+ let cons = [con | unc_example <- unc_examples
+ , Just (PACA (PmAltConLike con) _ _) <- [lookupSolution unc_example arg_id]]
+ not_full_examples = length cons == (maxConstructors + 1)
+ cons' = take maxConstructors cons
+ diagnosticDs $ DsIncompleteRecordSelector sel_name cons' not_full_examples
+
+pmcRecSel _ _ = return ()
+
{- Note [pmcPatBind doesn't warn on pattern guards]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@pmcPatBind@'s main purpose is to check vanilla pattern bindings, like
+>>>>>>> 8760510af3 (This MR is an implementation of the proposal #516.)
@x :: Int; Just x = e@, which is in a @PatBindRhs@ context.
But its caller is also called for individual pattern guards in a @StmtCtxt@.
For example, both pattern guards in @f x y | True <- x, False <- y = ...@ will
diff --git a/compiler/GHC/HsToCore/Pmc/Check.hs b/compiler/GHC/HsToCore/Pmc/Check.hs
index 0adc29406e18d8be2a1ea2681b42d5bd412e477f..09108c0a64e2b65e3ca23f651de012361c401f0d 100644
--- a/compiler/GHC/HsToCore/Pmc/Check.hs
+++ b/compiler/GHC/HsToCore/Pmc/Check.hs
@@ -19,7 +19,7 @@
-- "GHC.HsToCore.Pmc.Solver".
module GHC.HsToCore.Pmc.Check (
CheckAction(..),
- checkMatchGroup, checkGRHSs, checkPatBind, checkEmptyCase
+ checkMatchGroup, checkGRHSs, checkPatBind, checkEmptyCase, checkRecSel
) where
import GHC.Prelude
@@ -33,11 +33,15 @@ import GHC.Driver.DynFlags
import GHC.Utils.Outputable
import GHC.Tc.Utils.TcType (evVarPred)
import GHC.Data.OrdList
+import GHC.Data.Bag
import qualified Data.Semigroup as Semi
import Data.List.NonEmpty ( NonEmpty(..) )
import qualified Data.List.NonEmpty as NE
import Data.Coerce
+import GHC.Types.Var
+import GHC.Core
+import GHC.Core.Utils
-- | Coverage checking action. Can be composed 'leftToRight' or 'topToBottom'.
newtype CheckAction a = CA { unCA :: Nablas -> DsM (CheckResult a) }
@@ -185,6 +189,20 @@ checkEmptyCase pe@(PmEmptyCase { pe_var = var }) = CA $ \inc -> do
checkPatBind :: (PmPatBind Pre) -> CheckAction (PmPatBind Post)
checkPatBind = coerce checkGRHS
+checkRecSel :: PmRecSel () -> CheckAction (PmRecSel Id)
+-- See Note [Detecting incomplete record selectors] in GHC.HsToCore.Pmc
+checkRecSel pr@(PmRecSel { pr_arg = arg, pr_cons = cons }) = CA $ \inc -> do
+ arg_id <- case arg of
+ Var arg_id -> return arg_id
+ _ -> mkPmId $ exprType arg
+
+ let con_cts = map (PhiNotConCt arg_id . PmAltConLike) cons
+ arg_ct = PhiCoreCt arg_id arg
+ phi_cts = listToBag (arg_ct : con_cts)
+ unc <- addPhiCtsNablas inc phi_cts
+ pure CheckResult { cr_ret = pr{ pr_arg_var = arg_id }, cr_uncov = unc, cr_approx = mempty }
+
+
{- Note [Checking EmptyCase]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-XEmptyCase is useful for matching on empty data types like 'Void'. For example,
diff --git a/compiler/GHC/HsToCore/Pmc/Types.hs b/compiler/GHC/HsToCore/Pmc/Types.hs
index d3046e58124bb3d7c959010c6073472764547979..46c159c9518ed829790363e81cb63f8afa919447 100644
--- a/compiler/GHC/HsToCore/Pmc/Types.hs
+++ b/compiler/GHC/HsToCore/Pmc/Types.hs
@@ -21,7 +21,8 @@ module GHC.HsToCore.Pmc.Types (
SrcInfo(..), PmGrd(..), GrdVec(..),
-- ** Guard tree language
- PmMatchGroup(..), PmMatch(..), PmGRHSs(..), PmGRHS(..), PmPatBind(..), PmEmptyCase(..),
+ PmMatchGroup(..), PmMatch(..), PmGRHSs(..), PmGRHS(..),
+ PmPatBind(..), PmEmptyCase(..), PmRecSel(..),
-- * Coverage Checking types
RedSets (..), Precision (..), CheckResult (..),
@@ -43,6 +44,7 @@ import GHC.Types.Id
import GHC.Types.Var (EvVar)
import GHC.Types.SrcLoc
import GHC.Utils.Outputable
+import GHC.Core.ConLike
import GHC.Core.Type
import GHC.Core
@@ -130,6 +132,8 @@ newtype PmPatBind p =
-- rather than on the pattern bindings.
PmPatBind (PmGRHS p)
+-- A guard tree denoting a record selector application
+data PmRecSel v = PmRecSel { pr_arg_var :: v, pr_arg :: CoreExpr, pr_cons :: [ConLike] }
instance Outputable SrcInfo where
ppr (SrcInfo (L (RealSrcSpan rss _) _)) = ppr (srcSpanStartLine rss)
ppr (SrcInfo (L s _)) = ppr s
diff --git a/compiler/GHC/HsToCore/Pmc/Utils.hs b/compiler/GHC/HsToCore/Pmc/Utils.hs
index b208723e7b4542cec3511b8d4810f0b6dfeeb7b9..12423142f68b80f2f4aa5addb43f96fa77c4f739 100644
--- a/compiler/GHC/HsToCore/Pmc/Utils.hs
+++ b/compiler/GHC/HsToCore/Pmc/Utils.hs
@@ -61,6 +61,7 @@ allPmCheckWarnings =
, Opt_WarnIncompleteUniPatterns
, Opt_WarnIncompletePatternsRecUpd
, Opt_WarnOverlappingPatterns
+ , Opt_WarnIncompleteRecordSelectors
]
-- | Check whether the redundancy checker should run (redundancy only)
diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs
index 1d6c49b6b2a18ee13228ba211bfb9736718fc39a..8924cc90fc587380e5c2b11d116c857b8eba6207 100644
--- a/compiler/GHC/IfaceToCore.hs
+++ b/compiler/GHC/IfaceToCore.hs
@@ -1688,7 +1688,16 @@ 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, sel_fieldLabel = fl { flSelector = nm } }) }
+ ; let all_cons = recSelParentCons tc'
+ cons_partitioned
+ = conLikesWithFields all_cons [flLabel fl]
+ ; return (RecSelId
+ { sel_tycon = tc'
+ , sel_naughty = naughty
+ , sel_fieldLabel = fl { flSelector = nm }
+ , sel_cons = cons_partitioned }
+ -- Reconstructed here since we don't want Uniques in the Iface file
+ ) }
where
tyThingPatSyn (AConLike (PatSynCon ps)) = ps
tyThingPatSyn _ = panic "tcIdDetails: expecting patsyn"
diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs
index a698af9dff4b8ea8bf202e3f4fcba2d9bac5a982..72080273b2becf34630fa45f4c28f80417b1c348 100644
--- a/compiler/GHC/Tc/Errors/Ppr.hs
+++ b/compiler/GHC/Tc/Errors/Ppr.hs
@@ -1479,6 +1479,9 @@ instance Diagnostic TcRnMessage where
TcRnPartialFieldSelector fld -> mkSimpleDecorated $
sep [text "Use of partial record field selector" <> colon,
nest 2 $ quotes (ppr (occName fld))]
+ TcRnHasFieldResolvedIncomplete name -> mkSimpleDecorated $
+ text "The invocation of `getField` on the record field" <+> quotes (ppr name)
+ <+> text "may produce an error since it is not defined for all data constructors"
TcRnBadFieldAnnotation n con reason -> mkSimpleDecorated $
hang (pprBadFieldAnnotationReason reason)
2 (text "on the" <+> speakNth n
@@ -2291,6 +2294,8 @@ instance Diagnostic TcRnMessage where
-> ErrorWithoutFlag
TcRnPartialFieldSelector{}
-> WarningWithFlag Opt_WarnPartialFields
+ TcRnHasFieldResolvedIncomplete{}
+ -> WarningWithFlag Opt_WarnIncompleteRecordSelectors
TcRnBadFieldAnnotation _ _ LazyFieldsDisabled
-> ErrorWithoutFlag
TcRnBadFieldAnnotation{}
@@ -2928,6 +2933,8 @@ instance Diagnostic TcRnMessage where
-> noHints
TcRnPartialFieldSelector{}
-> noHints
+ TcRnHasFieldResolvedIncomplete{}
+ -> noHints
TcRnBadFieldAnnotation _ _ LazyFieldsDisabled
-> [suggestExtension LangExt.StrictData]
TcRnBadFieldAnnotation{}
diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs
index 2d9e197d69f631df0bca8e2c51f680d76b361558..044070578f0b71f38c3e638426e98d157e3a89d5 100644
--- a/compiler/GHC/Tc/Errors/Types.hs
+++ b/compiler/GHC/Tc/Errors/Types.hs
@@ -3416,6 +3416,24 @@ data TcRnMessage where
TcRnPartialFieldSelector :: !FieldLabel -- ^ The selector
-> TcRnMessage
+ {-| TcRnHasFieldResolvedIncomplete is a warning triggered when a HasField constraint
+ is resolved for a record field for which a `getField @"field"` application
+ might not be successful. Currently, this means that the warning is triggered when
+ the parent data type of that record field does not have that field in all
+ its constructors.
+
+ Example(s):
+ data T = T1 | T2 {x :: Bool}
+ f :: HasField t "x" Bool => t -> Bool
+ f = getField @"x"
+ g :: T -> Bool
+ g = f
+
+ Test cases:
+ TcIncompleteRecSel
+ -}
+ TcRnHasFieldResolvedIncomplete :: !Name -> TcRnMessage
+
{-| TcRnBadFieldAnnotation is an error/warning group indicating that a
strictness/unpack related data type field annotation is invalid.
-}
diff --git a/compiler/GHC/Tc/Instance/Class.hs b/compiler/GHC/Tc/Instance/Class.hs
index a22ff699d16ca245e9127488aa929f0eda2f2a16..bb2182817a9d1ad645e6de934370636f7595d25b 100644
--- a/compiler/GHC/Tc/Instance/Class.hs
+++ b/compiler/GHC/Tc/Instance/Class.hs
@@ -54,6 +54,9 @@ import GHC.Utils.Misc( splitAtList, fstOf3 )
import GHC.Data.FastString
import Language.Haskell.Syntax.Basic (FieldLabelString(..))
+import GHC.Types.Id.Info
+import GHC.Tc.Errors.Types
+import Control.Monad
{- *******************************************************************
* *
@@ -913,7 +916,8 @@ matchHasField dflags short_cut clas tys
-- the field selector should be in scope
, Just gre <- lookupGRE_FieldLabel rdr_env fl
- -> do { sel_id <- tcLookupId (flSelector fl)
+ -> do { let name = flSelector fl
+ ; sel_id <- tcLookupId name
; (tv_prs, preds, sel_ty) <- tcInstType newMetaTyVars sel_id
-- The first new wanted constraint equates the actual
@@ -943,7 +947,11 @@ matchHasField dflags short_cut clas tys
; if not (isNaughtyRecordSelector sel_id) && isTauTy sel_ty
then do { -- See Note [Unused name reporting and HasField]
addUsedGRE AllDeprecationWarnings gre
- ; keepAlive (greName gre)
+ ; keepAlive name
+ ; unless (null $ snd $ sel_cons $ idDetails sel_id)
+ $ addDiagnostic $ TcRnHasFieldResolvedIncomplete name
+ -- Only emit an incomplete selector warning if it's an implicit instance
+ -- See Note [Detecting incomplete record selectors] in GHC.HsToCore.Pmc
; return OneInst { cir_new_theta = theta
, cir_mk_ev = mk_ev
, cir_coherence = IsCoherent
diff --git a/compiler/GHC/Tc/Solver/Dict.hs b/compiler/GHC/Tc/Solver/Dict.hs
index 8c85d9e06df5da0adc610d5d558a076414f5ebc4..8e5b0cac9615aa8588293d98fc93c820be550654 100644
--- a/compiler/GHC/Tc/Solver/Dict.hs
+++ b/compiler/GHC/Tc/Solver/Dict.hs
@@ -780,7 +780,7 @@ shortCutSolver dflags ev_w ev_i
try_solve_from_instance (ev_binds, solved_dicts) ev
| let pred = ctEvPred ev
, ClassPred cls tys <- classifyPredType pred
- = do { inst_res <- lift $ matchGlobalInst dflags True cls tys
+ = do { inst_res <- lift $ matchGlobalInst dflags True cls tys loc_w
; case inst_res of
OneInst { cir_new_theta = preds
, cir_mk_ev = mk_ev
@@ -939,7 +939,7 @@ matchClassInst dflags inerts clas tys loc
; return local_res }
NoInstance -- No local instances, so try global ones
- -> do { global_res <- matchGlobalInst dflags False clas tys
+ -> do { global_res <- matchGlobalInst dflags False clas tys loc
; traceTcS "} matchClassInst global result" $ ppr global_res
; return global_res } }
where
diff --git a/compiler/GHC/Tc/Solver/Monad.hs b/compiler/GHC/Tc/Solver/Monad.hs
index 71a473f1ae25177f9a091666cf467189e8c860dc..52d6d113ec5bd64ddb940245720f6a9f31b1f7f3 100644
--- a/compiler/GHC/Tc/Solver/Monad.hs
+++ b/compiler/GHC/Tc/Solver/Monad.hs
@@ -1641,9 +1641,9 @@ instFlexiXTcM subst (tv:tvs)
matchGlobalInst :: DynFlags
-> Bool -- True <=> caller is the short-cut solver
-- See Note [Shortcut solving: overlap]
- -> Class -> [Type] -> TcS TcM.ClsInstResult
-matchGlobalInst dflags short_cut cls tys
- = wrapTcS (TcM.matchGlobalInst dflags short_cut cls tys)
+ -> Class -> [Type] -> CtLoc -> TcS TcM.ClsInstResult
+matchGlobalInst dflags short_cut cls tys loc
+ = wrapTcS $ TcM.setCtLocM loc $ TcM.matchGlobalInst dflags short_cut cls tys
tcInstSkolTyVarsX :: SkolemInfo -> Subst -> [TyVar] -> TcS (Subst, [TcTyVar])
tcInstSkolTyVarsX skol_info subst tvs = wrapTcS $ TcM.tcInstSkolTyVarsX skol_info subst tvs
diff --git a/compiler/GHC/Tc/TyCl/Utils.hs b/compiler/GHC/Tc/TyCl/Utils.hs
index 767db8a7f7040dce4ce7749d8b7fd7bbd43ecfeb..6bcba860aaf145873fdc3e822d709544dd47ef07 100644
--- a/compiler/GHC/Tc/TyCl/Utils.hs
+++ b/compiler/GHC/Tc/TyCl/Utils.hs
@@ -885,14 +885,19 @@ 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
- , sel_fieldLabel = fl }
-- Find a representative constructor, con1
- cons_w_field = conLikesWithFields all_cons [lbl]
+ cons_partitioned@(cons_w_field, _) = conLikesWithFields all_cons [lbl]
con1 = assert (not (null cons_w_field)) $ head cons_w_field
+ -- Construct the IdDetails
+ rec_details = RecSelId { sel_tycon = idDetails
+ , sel_naughty = is_naughty
+ , sel_fieldLabel = fl
+ , sel_cons = cons_partitioned }
+ -- See Note [Detecting incomplete record selectors] in GHC.HsToCore.Pmc
+
+
-- Selector type; Note [Polymorphic selectors]
(univ_tvs, _, _, _, req_theta, _, data_ty) = conLikeFullSig con1
diff --git a/compiler/GHC/Types/Error.hs b/compiler/GHC/Types/Error.hs
index c51d9ba59156ae4c2ecc59eda315f71dbc14efc6..c011e85d52e7b2f8a398a6342ca4f7dad37e963b 100644
--- a/compiler/GHC/Types/Error.hs
+++ b/compiler/GHC/Types/Error.hs
@@ -21,6 +21,7 @@ module GHC.Types.Error
, addMessage
, unionMessages
, unionManyMessages
+ , filterMessages
, MsgEnvelope (..)
-- * Classifying Messages
@@ -194,6 +195,10 @@ unionMessages (Messages msgs1) (Messages msgs2) =
unionManyMessages :: Foldable f => f (Messages e) -> Messages e
unionManyMessages = fold
+filterMessages :: (MsgEnvelope e -> Bool) -> Messages e -> Messages e
+filterMessages f (Messages msgs) =
+ Messages (filterBag f msgs)
+
-- | A 'DecoratedSDoc' is isomorphic to a '[SDoc]' but it carries the
-- invariant that the input '[SDoc]' needs to be rendered /decorated/ into its
-- final form, where the typical case would be adding bullets between each
diff --git a/compiler/GHC/Types/Error/Codes.hs b/compiler/GHC/Types/Error/Codes.hs
index 90a918c8f0206e4882078cabafe1e30647694a53..087b17054e5de7b36c65a894fbd1e4bda4a52d72 100644
--- a/compiler/GHC/Types/Error/Codes.hs
+++ b/compiler/GHC/Types/Error/Codes.hs
@@ -148,6 +148,7 @@ type family GhcDiagnosticCode c = n | n -> c where
GhcDiagnosticCode "DsRecBindsNotAllowedForUnliftedTys" = 20185
GhcDiagnosticCode "DsRuleMightInlineFirst" = 95396
GhcDiagnosticCode "DsAnotherRuleMightFireFirst" = 87502
+ GhcDiagnosticCode "DsIncompleteRecordSelector" = 17335
-- Parser diagnostic codes
@@ -528,6 +529,7 @@ type family GhcDiagnosticCode c = n | n -> c where
GhcDiagnosticCode "TcRnTyFamDepsDisabled" = 43991
GhcDiagnosticCode "TcRnAbstractClosedTyFamDecl" = 60012
GhcDiagnosticCode "TcRnPartialFieldSelector" = 82712
+ GhcDiagnosticCode "TcRnHasFieldResolvedIncomplete" = 86894
GhcDiagnosticCode "TcRnSuperclassCycle" = 29210
GhcDiagnosticCode "TcRnDefaultSigMismatch" = 72771
GhcDiagnosticCode "TcRnTyFamResultDisabled" = 44012
diff --git a/compiler/GHC/Types/Id/Info.hs b/compiler/GHC/Types/Id/Info.hs
index 281ac8657f9c757232c2b89393b0543a830555d7..798994a10b8688447731592022ec76e60b528d61 100644
--- a/compiler/GHC/Types/Id/Info.hs
+++ b/compiler/GHC/Types/Id/Info.hs
@@ -22,7 +22,7 @@ module GHC.Types.Id.Info (
IdDetails(..), pprIdDetails, coVarDetails, isCoVarDetails,
JoinArity, isJoinIdDetails_maybe,
RecSelParent(..), recSelParentName, recSelFirstConName,
- idDetailsConcreteTvs,
+ recSelParentCons, idDetailsConcreteTvs,
-- * The IdInfo type
IdInfo, -- Abstract
@@ -101,6 +101,7 @@ import GHC.Core.DataCon
import GHC.Core.TyCon
import GHC.Core.Type (mkTyConApp)
import GHC.Core.PatSyn
+import GHC.Core.ConLike
import GHC.Types.ForeignCall
import GHC.Unit.Module
import GHC.Types.Demand
@@ -149,7 +150,13 @@ data IdDetails
, 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
+ -- See Note [Naughty record selectors] in GHC.Tc.TyCl
+ , sel_cons :: ([ConLike], [ConLike])
+ -- If record selector is not defined for all constructors
+ -- of a parent type, this is the pair of lists of constructors that
+ -- it is and is not defined for. Otherwise, it's Nothing.
+ -- Cached here based on the RecSelParent.
+ } -- See Note [Detecting incomplete record selectors] in GHC.HsToCore.Pmc
| DataConWorkId DataCon -- ^ The 'Id' is for a data constructor /worker/
| DataConWrapId DataCon -- ^ The 'Id' is for a data constructor /wrapper/
@@ -332,6 +339,15 @@ recSelFirstConName :: RecSelParent -> Name
recSelFirstConName (RecSelData tc) = dataConName $ head $ tyConDataCons tc
recSelFirstConName (RecSelPatSyn ps) = patSynName ps
+recSelParentCons :: RecSelParent -> [ConLike]
+recSelParentCons (RecSelData tc)
+ | isAlgTyCon tc
+ = map RealDataCon $ visibleDataCons
+ $ algTyConRhs tc
+ | otherwise
+ = []
+recSelParentCons (RecSelPatSyn ps) = [PatSynCon ps]
+
instance Outputable RecSelParent where
ppr p = case p of
RecSelData tc
diff --git a/compiler/GHC/Types/TyThing.hs b/compiler/GHC/Types/TyThing.hs
index 83daf1576ee4f26e9e7d3c0b61da9c2746829e97..1be2095bfcae8f2fa9a07ea5ae12a5baeb4b9c3a 100644
--- a/compiler/GHC/Types/TyThing.hs
+++ b/compiler/GHC/Types/TyThing.hs
@@ -356,11 +356,11 @@ tyThingGREInfo = \case
RecSelData tc ->
let dcs = map RealDataCon $ tyConDataCons tc in
case conLikesWithFields dcs [flLabel fl] of
- [] -> pprPanic "tyThingGREInfo: no DataCons with this FieldLabel" $
+ ([], _) -> 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
+ (cons, _) -> mkUniqSet $ map conLikeConLikeName cons
in IAmRecField $
RecFieldInfo
{ recFieldLabel = fl
diff --git a/docs/users_guide/9.10.1-notes.rst b/docs/users_guide/9.10.1-notes.rst
index 57fbd5177bd5602b4f79c0f21039382e5b9136dd..2021a2e14d429ea0c76d781bb70e62533a4ef1bf 100644
--- a/docs/users_guide/9.10.1-notes.rst
+++ b/docs/users_guide/9.10.1-notes.rst
@@ -21,6 +21,21 @@ Language
Compiler
~~~~~~~~
+- GHC Proposal `#516
+ <https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0516-incomplete-record-selectors.rst>`_
+ has been implemented. It introduces a warning :ghc-flag:`-Wincomplete-record-selectors` which warns about when
+ an invocation of a record selector may fail due to being applied to a constructor for which it is not defined.
+
+ For example ::
+
+ data T = T1 | T2 { x :: Int }
+ f :: T -> Int
+ f a = x a + 1 -- emit a warning here, since `f T1` will fail
+
+ Unlike :ghc-flag:`-Wpartial-fields` this produces a warning about incomplete selectors at use sites instead of
+ definition sites, so it is useful in cases when the library does intend for incomplete record selectors to be
+ used but only in specific circumstances (e.g. when other cases are handled by previous pattern matches).
+
GHCi
~~~~
diff --git a/docs/users_guide/9.8.1-notes.rst b/docs/users_guide/9.8.1-notes.rst
index a7c2ad4eed68de339ff0637e23d61da698f37726..9f3cddb200c7aa9c8e4a64f2826a0bff2ac78393 100644
--- a/docs/users_guide/9.8.1-notes.rst
+++ b/docs/users_guide/9.8.1-notes.rst
@@ -177,7 +177,7 @@ Compiler
{-# WARNING "do not use that constructor" D(D1),
D(D2)
)
- D = D1 | D2
+ data D = D1 | D2
This allows for changing the structure of a library without immediately breaking user code,
but instead being able to warn the user that a change in the library interface
diff --git a/docs/users_guide/using-warnings.rst b/docs/users_guide/using-warnings.rst
index 37ae36ae50a551b4cad78d17fefeb26763228e34..ec005d7a91e049afe56816254348089ac514fb4f 100644
--- a/docs/users_guide/using-warnings.rst
+++ b/docs/users_guide/using-warnings.rst
@@ -120,6 +120,7 @@ as ``-Wno-...`` for every individual warning in the group.
* :ghc-flag:`-Whi-shadowing`
* :ghc-flag:`-Wincomplete-record-updates`
+ * :ghc-flag:`-Wincomplete-record-selectors`
* :ghc-flag:`-Wincomplete-uni-patterns`
* :ghc-flag:`-Wmissing-pattern-synonym-signatures`
* :ghc-flag:`-Wmissing-signatures`
@@ -1079,6 +1080,39 @@ of ``-W(no-)*``.
This option isn't enabled by default because it can be very noisy,
and it often doesn't indicate a bug in the program.
+.. ghc-flag:: -Wincomplete-record-selectors
+ :shortdesc: warn when a record selector application could fail
+ :type: dynamic
+ :reverse: -Wno-incomplete-record-selectors
+ :category:
+
+ :since: 9.10
+
+ .. index::
+ single: incomplete record selectors, warning
+ single: record selectors, incomplete
+
+ When a record selector is applied to a constructor that does not
+ contain that field, it will produce an error. For example ::
+
+ data T = T1 | T2 { x :: Int }
+
+ f :: T -> Int
+ f a = x a -- `f T1` will fail
+
+ g1 :: HasField "x" t Int => t -> Int
+ g1 a = 1 + getField @"x" a
+
+ g2 :: T -> Int
+ g2 a = g1 a + 2 -- `g2 T1` will fail as well
+
+ The warning warns about cases like that. It also takes into account
+ previously pattern-matched cases, for example ::
+
+ d :: T -> Int
+ d T1 = 0
+ d a = x a -- would not warn
+
.. ghc-flag:: -Wmissing-deriving-strategies
:shortdesc: warn when a deriving clause is missing a deriving strategy
:type: dynamic
@@ -2480,13 +2514,13 @@ sanity, not yours.)
<https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0134-deprecating-exports-proposal.rst>`__,
it is now possible to deprecate certain exports of a name without deprecating the name itself.
- As explained in :ref:`warning-deprecated-pragma`, when a name is exported in several ways in the same module,
+ As explained in :ref:`warning-deprecated-pragma`, when a name is exported in several ways in the same module,
but only some of those ways have a warning, it will not end up deprecated when imported in another module.
For example: ::
-
+
module A (x) where
-
+
x :: Int
x = 2
@@ -2496,5 +2530,5 @@ sanity, not yours.)
)
import A
- When :ghc-flag:`-Wincomplete-export-warnings` is enabled, GHC warns about exports
+ When :ghc-flag:`-Wincomplete-export-warnings` is enabled, GHC warns about exports
that are not deprecating a name that is deprecated with another export in that module.
\ No newline at end of file
diff --git a/testsuite/tests/plugins/all.T b/testsuite/tests/plugins/all.T
index 326fe9b31fe8cf4ae68847f8b909352d5c88a129..98c55bfc607b1f79a238a2f28af86c0a03c0e482 100644
--- a/testsuite/tests/plugins/all.T
+++ b/testsuite/tests/plugins/all.T
@@ -11,6 +11,21 @@ setTestOpts([
when(opsys('mingw32'), multi_cpu_race),
])
+import itertools
+
+# Check the simple-plugin tests without
+# caring about the order of loading of interfaces
+def normalizeIfaces(unnormalized_str):
+ iface_plugin_prefix = "interfacePlugin: "
+ grouped_plugins = itertools.groupby(
+ unnormalized_str.split('\n'),
+ lambda l: l.startswith(iface_plugin_prefix)
+ )
+ return "\n".join([
+ line
+ for k, lines in grouped_plugins
+ for line in (sorted(lines) if k else lines)
+ ])
test('plugins01',
[extra_files(['simple-plugin/']),
@@ -175,9 +190,11 @@ test('static-plugins',
[extra_files(['simple-plugin/']),
unless(config.have_RTS_linker, skip),
expect_broken_for(16803, prof_ways),
- extra_run_opts('"' + config.libdir + '"')],
+ extra_run_opts('"' + config.libdir + '"'),
+ normalise_fun(normalizeIfaces)
+ ],
compile_and_run,
- ['-package ghc -isimple-plugin/'])
+ ['-package ghc -isimple-plugin/ -j1'])
test('T15858',
[extra_files(['plugin-recomp/', 'plugin-recomp-test.hs']),
diff --git a/testsuite/tests/pmcheck/should_compile/DsIncompleteRecSel1.hs b/testsuite/tests/pmcheck/should_compile/DsIncompleteRecSel1.hs
new file mode 100644
index 0000000000000000000000000000000000000000..9c080702facac3d7422a51358f49d2c46611ff30
--- /dev/null
+++ b/testsuite/tests/pmcheck/should_compile/DsIncompleteRecSel1.hs
@@ -0,0 +1,25 @@
+-- Case for general occurences of selectors
+{-# LANGUAGE PatternSynonyms #-}
+module DsIncompleteRecSel1 where
+
+data T = T1 { x :: Bool } | T2
+
+f :: T -> Bool
+f = x
+
+f2 :: T -> Bool
+f2 T2 = True
+f2 a = d
+ where
+ d = x a
+
+f3 :: T -> Bool
+f3 T2 = False
+f3 a = x (let b = a in b)
+
+
+pattern N{n} = (n :: Int)
+
+nat :: Int -> Int
+nat 0 = 1
+nat a@N{} = n a
\ No newline at end of file
diff --git a/testsuite/tests/pmcheck/should_compile/DsIncompleteRecSel1.stderr b/testsuite/tests/pmcheck/should_compile/DsIncompleteRecSel1.stderr
new file mode 100644
index 0000000000000000000000000000000000000000..48cbf7e07b6b0f7b7c2d3149a079fc926cec310f
--- /dev/null
+++ b/testsuite/tests/pmcheck/should_compile/DsIncompleteRecSel1.stderr
@@ -0,0 +1,3 @@
+
+DsIncompleteRecSel1.hs:8:5: warning: [GHC-17335] [-Wincomplete-record-selectors]
+ The application of the record field ‘x’ may fail for the following constructors: T2
diff --git a/testsuite/tests/pmcheck/should_compile/DsIncompleteRecSel2.hs b/testsuite/tests/pmcheck/should_compile/DsIncompleteRecSel2.hs
new file mode 100644
index 0000000000000000000000000000000000000000..b18b6c2d64e9699be1a62d627966e22991dd8d9a
--- /dev/null
+++ b/testsuite/tests/pmcheck/should_compile/DsIncompleteRecSel2.hs
@@ -0,0 +1,29 @@
+-- Case for long-range info and GADTs caught with PMC
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE PatternSynonyms #-}
+module DsIncompleteRecSel2 where
+
+data T a where
+ T1 :: { x :: Bool } -> T a
+ T2 :: T Bool
+ T3 :: T Int
+ T4 :: Int -> T Bool
+
+f :: T Char -> Bool
+f a = x a
+
+f2 :: T Int -> Bool
+f2 T3 = True
+f2 a = x a
+
+f3 :: T Bool -> Bool
+f3 T2 = True
+f3 (T4 1) = False
+f3 a = x a
+
+
+pattern G <- _
+pattern P <- T1 _
+f4 :: T Int -> Bool
+f4 a@G | P <- a = x a
+f4 _ = True
\ No newline at end of file
diff --git a/testsuite/tests/pmcheck/should_compile/DsIncompleteRecSel2.stderr b/testsuite/tests/pmcheck/should_compile/DsIncompleteRecSel2.stderr
new file mode 100644
index 0000000000000000000000000000000000000000..b9522d273c18d93e7f0ef8e9fe15a681eaf557dc
--- /dev/null
+++ b/testsuite/tests/pmcheck/should_compile/DsIncompleteRecSel2.stderr
@@ -0,0 +1,6 @@
+
+DsIncompleteRecSel2.hs:22:8: warning: [GHC-17335] [-Wincomplete-record-selectors]
+ The application of the record field ‘x’ may fail for the following constructors: T4
+
+DsIncompleteRecSel2.hs:28:19: warning: [GHC-17335] [-Wincomplete-record-selectors]
+ The application of the record field ‘x’ may fail for the following constructors: P
diff --git a/testsuite/tests/pmcheck/should_compile/DsIncompleteRecSel3.hs b/testsuite/tests/pmcheck/should_compile/DsIncompleteRecSel3.hs
new file mode 100644
index 0000000000000000000000000000000000000000..2cc4142f8da1721258ca7b95b8db96f9a6eeb9ef
--- /dev/null
+++ b/testsuite/tests/pmcheck/should_compile/DsIncompleteRecSel3.hs
@@ -0,0 +1,37 @@
+module DsIncompleteRecSel3 where
+
+-- For exponentially specified nablas (with all combinations of True/False)
+data T = T1{ x :: Bool }
+ | T2
+ { a1 :: Bool
+ , a2 :: Bool
+ , a3 :: Bool
+ , a4 :: Bool
+ , a5 :: Bool
+ , a6 :: Bool
+ , a7 :: Bool
+ , a8 :: Bool
+ , a9 :: Bool
+ , a10 :: Bool
+ , a11 :: Bool
+ , a12 :: Bool
+ , a13 :: Bool
+ , a14 :: Bool
+ , a15 :: Bool
+ , a16 :: Bool
+ , a17 :: Bool
+ , a18 :: Bool
+ , a19 :: Bool
+ , a20 :: Bool }
+
+d :: T -> Bool
+d T2{a2=True} = True
+d t = x t
+
+data G = G1{ y :: Int } | G2 | G3 | G4 | G5 | G6 | G7 | G8 | G9 | G10 | G11 | G12 | G13 | G14 | G15 | G16 | G17 | G18 | G19 | G20 | G21 | G22 | G23 | G24 | G25 | G26 | G27 | G28 | G29 | G30 | G31 | G32 | G33 | G34 | G35 | G36 | G37 | G38 | G39 | G40 | G41 | G42 | G43 | G44 | G45 | G46 | G47 | G48 | G49 | G50 | G51 | G52 | G53 | G54 | G55 | G56 | G57 | G58 | G59 | G60 | G61 | G62 | G63 | G64 | G65 | G66 | G67 | G68 | G69 | G70 | G71 | G72 | G73 | G74 | G75 | G76 | G77 | G78 | G79 | G80 | G81 | G82 | G83 | G84 | G85 | G86 | G87 | G88 | G89 | G90 | G91 | G92 | G93 | G94 | G95 | G96 | G97 | G98 | G99 | G100 | G101 | G102 | G103 | G104 | G105 | G106 | G107 | G108 | G109 | G110 | G111 | G112 | G113 | G114 | G115 | G116 | G117 | G118 | G119 | G120 | G121 | G122 | G123 | G124 | G125 | G126 | G127 | G128 | G129 | G130 | G131 | G132 | G133 | G134 | G135 | G136 | G137 | G138 | G139 | G140 | G141 | G142 | G143 | G144 | G145 | G146 | G147 | G148 | G149 | G150 | G151 | G152 | G153 | G154 | G155 | G156 | G157 | G158 | G159 | G160 | G161 | G162 | G163 | G164 | G165 | G166 | G167 | G168 | G169 | G170 | G171 | G172 | G173 | G174 | G175 | G176 | G177 | G178 | G179 | G180 | G181 | G182 | G183 | G184 | G185 | G186 | G187 | G188 | G189 | G190 | G191 | G192 | G193 | G194 | G195 | G196 | G197 | G198 | G199 | G200 | G201 | G202 | G203 | G204 | G205 | G206 | G207 | G208 | G209 | G210 | G211 | G212 | G213 | G214 | G215 | G216 | G217 | G218 | G219 | G220 | G221 | G222 | G223 | G224 | G225 | G226 | G227 | G228 | G229 | G230 | G231 | G232 | G233 | G234 | G235 | G236 | G237 | G238 | G239 | G240 | G241 | G242 | G243 | G244 | G245 | G246 | G247 | G248 | G249 | G250 | G251 | G252 | G253 | G254 | G255 | G256 | G257 | G258 | G259 | G260 | G261 | G262 | G263 | G264 | G265 | G266 | G267 | G268 | G269 | G270 | G271 | G272 | G273 | G274 | G275 | G276 | G277 | G278 | G279 | G280 | G281 | G282 | G283 | G284 | G285 | G286 | G287 | G288 | G289 | G290 | G291 | G292 | G293 | G294 | G295 | G296 | G297 | G298 | G299 | G300 | G301 | G302 | G303 | G304 | G305 | G306 | G307 | G308 | G309 | G310 | G311 | G312 | G313 | G314 | G315 | G316 | G317 | G318 | G319 | G320 | G321 | G322 | G323 | G324 | G325 | G326 | G327 | G328 | G329 | G330 | G331 | G332 | G333 | G334 | G335 | G336 | G337 | G338 | G339 | G340 | G341 | G342 | G343 | G344 | G345 | G346 | G347 | G348 | G349 | G350 | G351 | G352 | G353 | G354 | G355 | G356 | G357 | G358 | G359 | G360 | G361 | G362 | G363 | G364 | G365 | G366 | G367 | G368 | G369 | G370 | G371 | G372 | G373 | G374 | G375 | G376 | G377 | G378 | G379 | G380 | G381 | G382 | G383 | G384 | G385 | G386 | G387 | G388 | G389 | G390 | G391 | G392 | G393 | G394 | G395 | G396 | G397 | G398 | G399 | G400 | G401 | G402 | G403 | G404 | G405 | G406 | G407 | G408 | G409 | G410 | G411 | G412 | G413 | G414 | G415 | G416 | G417 | G418 | G419 | G420 | G421 | G422 | G423 | G424 | G425 | G426 | G427 | G428 | G429 | G430 | G431 | G432 | G433 | G434 | G435 | G436 | G437 | G438 | G439 | G440 | G441 | G442 | G443 | G444 | G445 | G446 | G447 | G448 | G449 | G450 | G451 | G452 | G453 | G454 | G455 | G456 | G457 | G458 | G459 | G460 | G461 | G462 | G463 | G464 | G465 | G466 | G467 | G468 | G469 | G470 | G471 | G472 | G473 | G474 | G475 | G476 | G477 | G478 | G479 | G480 | G481 | G482 | G483 | G484 | G485 | G486 | G487 | G488 | G489 | G490 | G491 | G492 | G493 | G494 | G495 | G496 | G497 | G498 | G499 | G500 | G501 | G502 | G503 | G504 | G505 | G506 | G507 | G508 | G509 | G510 | G511 | G512 | G513 | G514 | G515 | G516 | G517 | G518 | G519 | G520 | G521 | G522 | G523 | G524 | G525 | G526 | G527 | G528 | G529 | G530 | G531 | G532 | G533 | G534 | G535 | G536 | G537 | G538 | G539 | G540 | G541 | G542 | G543 | G544 | G545 | G546 | G547 | G548 | G549 | G550 | G551 | G552 | G553 | G554 | G555 | G556 | G557 | G558 | G559 | G560 | G561 | G562 | G563 | G564 | G565 | G566 | G567 | G568 | G569 | G570 | G571 | G572 | G573 | G574 | G575 | G576 | G577 | G578 | G579 | G580 | G581 | G582 | G583 | G584 | G585 | G586 | G587 | G588 | G589 | G590 | G591 | G592 | G593 | G594 | G595 | G596 | G597 | G598 | G599 | G600 | G601 | G602 | G603 | G604 | G605 | G606 | G607 | G608 | G609 | G610 | G611 | G612 | G613 | G614 | G615 | G616 | G617 | G618 | G619 | G620 | G621 | G622 | G623 | G624 | G625 | G626 | G627 | G628 | G629 | G630 | G631 | G632 | G633 | G634 | G635 | G636 | G637 | G638 | G639 | G640 | G641 | G642 | G643 | G644 | G645 | G646 | G647 | G648 | G649 | G650 | G651 | G652 | G653 | G654 | G655 | G656 | G657 | G658 | G659 | G660 | G661 | G662 | G663 | G664 | G665 | G666 | G667 | G668 | G669 | G670 | G671 | G672 | G673 | G674 | G675 | G676 | G677 | G678 | G679 | G680 | G681 | G682 | G683 | G684 | G685 | G686 | G687 | G688 | G689 | G690 | G691 | G692 | G693 | G694 | G695 | G696 | G697 | G698 | G699 | G700 | G701 | G702 | G703 | G704 | G705 | G706 | G707 | G708 | G709 | G710 | G711 | G712 | G713 | G714 | G715 | G716 | G717 | G718 | G719 | G720 | G721 | G722 | G723 | G724 | G725 | G726 | G727 | G728 | G729 | G730 | G731 | G732 | G733 | G734 | G735 | G736 | G737 | G738 | G739 | G740 | G741 | G742 | G743 | G744 | G745 | G746 | G747 | G748 | G749 | G750 | G751 | G752 | G753 | G754 | G755 | G756 | G757 | G758 | G759 | G760 | G761 | G762 | G763 | G764 | G765 | G766 | G767 | G768 | G769 | G770 | G771 | G772 | G773 | G774 | G775 | G776 | G777 | G778 | G779 | G780 | G781 | G782 | G783 | G784 | G785 | G786 | G787 | G788 | G789 | G790 | G791 | G792 | G793 | G794 | G795 | G796 | G797 | G798 | G799 | G800 | G801 | G802 | G803 | G804 | G805 | G806 | G807 | G808 | G809 | G810 | G811 | G812 | G813 | G814 | G815 | G816 | G817 | G818 | G819 | G820 | G821 | G822 | G823 | G824 | G825 | G826 | G827 | G828 | G829 | G830 | G831 | G832 | G833 | G834 | G835 | G836 | G837 | G838 | G839 | G840 | G841 | G842 | G843 | G844 | G845 | G846 | G847 | G848 | G849 | G850 | G851 | G852 | G853 | G854 | G855 | G856 | G857 | G858 | G859 | G860 | G861 | G862 | G863 | G864 | G865 | G866 | G867 | G868 | G869 | G870 | G871 | G872 | G873 | G874 | G875 | G876 | G877 | G878 | G879 | G880 | G881 | G882 | G883 | G884 | G885 | G886 | G887 | G888 | G889 | G890 | G891 | G892 | G893 | G894 | G895 | G896 | G897 | G898 | G899 | G900 | G901 | G902 | G903 | G904 | G905 | G906 | G907 | G908 | G909 | G910 | G911 | G912 | G913 | G914 | G915 | G916 | G917 | G918 | G919 | G920 | G921 | G922 | G923 | G924 | G925 | G926 | G927 | G928 | G929 | G930 | G931 | G932 | G933 | G934 | G935 | G936 | G937 | G938 | G939 | G940 | G941 | G942 | G943 | G944 | G945 | G946 | G947 | G948 | G949 | G950 | G951 | G952 | G953 | G954 | G955 | G956 | G957 | G958 | G959 | G960 | G961 | G962 | G963 | G964 | G965 | G966 | G967 | G968 | G969 | G970 | G971 | G972 | G973 | G974 | G975 | G976 | G977 | G978 | G979 | G980 | G981 | G982 | G983 | G984 | G985 | G986 | G987 | G988 | G989 | G990 | G991 | G992 | G993 | G994 | G995 | G996 | G997 | G998 | G999 | G1000
+
+g :: G -> Int
+g a = y a + y a + y a + y a + y a + y a + y a + y a + y a + y a
+
+z :: G -> Int
+z = y
\ No newline at end of file
diff --git a/testsuite/tests/pmcheck/should_compile/DsIncompleteRecSel3.stderr b/testsuite/tests/pmcheck/should_compile/DsIncompleteRecSel3.stderr
new file mode 100644
index 0000000000000000000000000000000000000000..62637730c2bce1087b15ef0d8d61f4995f313e80
--- /dev/null
+++ b/testsuite/tests/pmcheck/should_compile/DsIncompleteRecSel3.stderr
@@ -0,0 +1,80 @@
+
+DsIncompleteRecSel3.hs:29:7: warning: [GHC-17335] [-Wincomplete-record-selectors]
+ The application of the record field ‘x’ may fail for the following constructors: T2
+
+DsIncompleteRecSel3.hs:34:7: warning: [GHC-17335] [-Wincomplete-record-selectors]
+ The application of the record field ‘y’ may fail for the following constructors: G2
+ G3
+ G4
+ G5
+ ...
+
+DsIncompleteRecSel3.hs:34:13: warning: [GHC-17335] [-Wincomplete-record-selectors]
+ The application of the record field ‘y’ may fail for the following constructors: G2
+ G3
+ G4
+ G5
+ ...
+
+DsIncompleteRecSel3.hs:34:19: warning: [GHC-17335] [-Wincomplete-record-selectors]
+ The application of the record field ‘y’ may fail for the following constructors: G2
+ G3
+ G4
+ G5
+ ...
+
+DsIncompleteRecSel3.hs:34:25: warning: [GHC-17335] [-Wincomplete-record-selectors]
+ The application of the record field ‘y’ may fail for the following constructors: G2
+ G3
+ G4
+ G5
+ ...
+
+DsIncompleteRecSel3.hs:34:31: warning: [GHC-17335] [-Wincomplete-record-selectors]
+ The application of the record field ‘y’ may fail for the following constructors: G2
+ G3
+ G4
+ G5
+ ...
+
+DsIncompleteRecSel3.hs:34:37: warning: [GHC-17335] [-Wincomplete-record-selectors]
+ The application of the record field ‘y’ may fail for the following constructors: G2
+ G3
+ G4
+ G5
+ ...
+
+DsIncompleteRecSel3.hs:34:43: warning: [GHC-17335] [-Wincomplete-record-selectors]
+ The application of the record field ‘y’ may fail for the following constructors: G2
+ G3
+ G4
+ G5
+ ...
+
+DsIncompleteRecSel3.hs:34:49: warning: [GHC-17335] [-Wincomplete-record-selectors]
+ The application of the record field ‘y’ may fail for the following constructors: G2
+ G3
+ G4
+ G5
+ ...
+
+DsIncompleteRecSel3.hs:34:55: warning: [GHC-17335] [-Wincomplete-record-selectors]
+ The application of the record field ‘y’ may fail for the following constructors: G2
+ G3
+ G4
+ G5
+ ...
+
+DsIncompleteRecSel3.hs:34:61: warning: [GHC-17335] [-Wincomplete-record-selectors]
+ The application of the record field ‘y’ may fail for the following constructors: G2
+ G3
+ G4
+ G5
+ ...
+
+DsIncompleteRecSel3.hs:37:5: warning: [GHC-17335] [-Wincomplete-record-selectors]
+ The application of the record field ‘y’ may fail for the following constructors: G2
+ G3
+ G4
+ G5
+ ...
diff --git a/testsuite/tests/pmcheck/should_compile/all.T b/testsuite/tests/pmcheck/should_compile/all.T
index 0030a9f2d74b39c9bbb5be634ea0b18010d67a80..75d11e1641ac8d1ca95cc9dac013fbcea41f37d6 100644
--- a/testsuite/tests/pmcheck/should_compile/all.T
+++ b/testsuite/tests/pmcheck/should_compile/all.T
@@ -164,4 +164,6 @@ test('EmptyCase007', [], compile, [overlapping_incomplete])
test('EmptyCase008', [], compile, [overlapping_incomplete])
test('EmptyCase009', [], compile, [overlapping_incomplete])
test('EmptyCase010', [], compile, [overlapping_incomplete])
-
+test('DsIncompleteRecSel1', normal, compile, ['-Wincomplete-record-selectors'])
+test('DsIncompleteRecSel2', normal, compile, ['-Wincomplete-record-selectors'])
+test('DsIncompleteRecSel3', [collect_compiler_stats('bytes allocated', 10)], compile, ['-Wincomplete-record-selectors'])
\ No newline at end of file
diff --git a/testsuite/tests/typecheck/should_compile/TcIncompleteRecSel.hs b/testsuite/tests/typecheck/should_compile/TcIncompleteRecSel.hs
new file mode 100644
index 0000000000000000000000000000000000000000..d7d26dda02df54406ea5c6d22f6944a3cb2ea966
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/TcIncompleteRecSel.hs
@@ -0,0 +1,16 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeApplications #-}
+module TcIncompleteRecSel where
+
+import GHC.Records
+
+data T where
+ T1 :: { x :: Bool } -> T
+ T2 :: T
+
+f :: HasField "x" t Bool => t -> Bool
+f = getField @"x"
+
+g :: T -> Bool
+g = f
\ No newline at end of file
diff --git a/testsuite/tests/typecheck/should_compile/TcIncompleteRecSel.stderr b/testsuite/tests/typecheck/should_compile/TcIncompleteRecSel.stderr
new file mode 100644
index 0000000000000000000000000000000000000000..1fe36df6f987c5d42aba142943fe8b2ca995c8fe
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/TcIncompleteRecSel.stderr
@@ -0,0 +1,3 @@
+
+TcIncompleteRecSel.hs:16:5: warning: [GHC-86894] [-Wincomplete-record-selectors]
+ The invocation of `getField` on the record field ‘x’ may produce an error since it is not defined for all data constructors
diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T
index 468de12a39371c6b1e37fbf259aa8687312f59e8..dbc9b6da60e8c816ccc4959aceb00a232245e017 100644
--- a/testsuite/tests/typecheck/should_compile/all.T
+++ b/testsuite/tests/typecheck/should_compile/all.T
@@ -889,3 +889,4 @@ test('T22537', normal, compile, [''])
test('T18986a', normal, compile, [''])
test('T18986b', normal, compile, [''])
test('T23413', normal, compile, [''])
+test('TcIncompleteRecSel', normal, compile, ['-Wincomplete-record-selectors'])