This MR is an implementation of the proposal #516.

It adds a warning -Wincomplete-record-selectors for usages of a record
field access function (either a record selector or getField @"rec"),
while trying to silence the warning whenever it can be sure that a constructor
without the record field would not be invoked (which would otherwise cause
the program to fail). For example:

    data T = T1 | T2 {x :: Bool}

    f a = x a -- this would throw an error

    g T1 = True
    g a = x a -- this would not throw an error

    h :: HasField "x" r Bool => r -> Bool
    h = getField @"x"

    j :: T -> Bool
    j = h -- this would throw an error because of the `HasField`
          -- constraint being solved

See the tests DsIncompleteRecSel* and TcIncompleteRecSel for more examples of the warning.
See Note [Detecting incomplete record selectors] in GHC.HsToCore.Expr for implementation details

Author: barci2

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)
 

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

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)]

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
 

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)

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
 

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
 

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,29 +52,28 @@ 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
 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