GitLab

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC

Commits:

52c3e6ba

by sheaf at 2026-03-20T12:21:09-04:00

Improve incomplete record selector warnings

This commit stops GHC from emitting spurious incomplete record selector
warnings for bare selectors/projections such as .fld

There are two places we currently emit incomplete record selector
warnings:

  1. In the desugarer, when we see a record selector or an occurrence
     of 'getField'. Here, we can use pattern matching information to
     ensure we don't give false positives.
  2. In the typechecker, which might sometimes give false positives but
     can emit warnings in cases that the pattern match checker would
     otherwise miss.

This is explained in Note [Detecting incomplete record selectors]
in GHC.HsToCore.Pmc.

Now, we obviously don't want to emit the same error twice, and generally
we prefer (1), as those messages contain fewer false positives. So we
suppress (2) when we are sure we are going to emit (1); the logic for
doing so is in GHC.Tc.Instance.Class.warnIncompleteRecSel,
and works by looking at the CtOrigin.

Now, the issue was that this logic handled explicit record selectors as
well as overloaded record field selectors such as "x.r" (which turns
into a simple GetFieldOrigin CtOrigin), but it didn't properly handle
record projectors like ".fld" or ".fld1.fld2" (which result in other
CtOrigins such as 'RecordFieldProjectionOrigin').

To solve this problem, we re-use the 'isHasFieldOrigin' introduced in
fbdc623a (slightly adjusted).

On the way, we also had to update the desugarer with special handling
for the 'ExpandedThingTc' case in 'ds_app', to make sure that
'ds_app_var' sees all the type arguments to 'getField' in order for it
to indeed emit warnings like in (1).

Fixes #26686

8 changed files:

compiler/GHC/HsToCore/Expr.hs
compiler/GHC/HsToCore/Pmc.hs
compiler/GHC/Tc/Errors.hs
compiler/GHC/Tc/Instance/Class.hs
compiler/GHC/Tc/Types/Origin.hs
+ testsuite/tests/overloadedrecflds/should_compile/T26686.hs
+ testsuite/tests/overloadedrecflds/should_compile/T26686.stderr
testsuite/tests/overloadedrecflds/should_compile/all.T

Changes:

compiler/GHC/HsToCore/Expr.hs

@@ -721,6 +721,15 @@ ds_app (XExpr (ConLikeTc con)) _hs_args core_args
  ds_app (XExpr (HsRecSelTc (FieldOcc { foLabel = L _ sel_id }))) _hs_args core_args
    = ds_app_rec_sel sel_id sel_id core_args
 +ds_app (XExpr (ExpandedThingTc _orig e)) hs_args core_args
 +  = ds_app e hs_args core_args
 +  -- NB: this is important for the 'getField' case of 'ds_app_var', which needs
 +  -- to see all type arguments to 'getField' at once, while for record field
 +  -- projections such as (.fld) we may get:
 +  --
 +  --   XExpr (ExpandedThingTc (.fld) (getField @Symbol @LiftedRep @LiftedRep "fld"))
 +  --     `HsAppType` rec_ty `HsAppType` fld
++
  ds_app (HsVar _ lfun) hs_args core_args
    = ds_app_var lfun hs_args core_args
@@ -736,8 +745,10 @@ ds_app_var (L loc fun_id) hs_args core_args
    -----------------------
    -- Deal with getField applications. General form:
    --   getField
 -  --     @GHC.Types.Symbol                        {k}
 -  --     @"sel"                                   x_ty
 +  --     @Symbol                                  {k}
 +  --     @LiftedRep                               {r_rep}
 +  --     @LiftedRep                               {a_rep}
 +  --     @"sel"                                   fld
    --     @T                                       r_ty
    --     @Int                                     a_ty
    --     ($dHasField :: HasField "sel" T Int)     dict

compiler/GHC/HsToCore/Pmc.hs

@@ -375,6 +375,10 @@ Finally, there are two more items addressing -XOverloadedRecordDot:
    the (IRS6) warning in the typechecker for a `HasField` constraint that
    arises from a record-dot HsGetField occurrence.  Happily, this is easy to do
    by looking at its `CtOrigin`. Tested in T24891.
++
 +  The same applies for record field projection operators such as (.fld) and
 +  (.fld1.fld2), which have different 'CtOrigin's. The 'isHasFieldOrigin'
 +  function catches those as well. Tested in T26686.
  -}
  pmcRecSel :: Id       -- ^ Id of the selector

compiler/GHC/Tc/Errors.hs

@@ -97,6 +97,7 @@ import Data.Ord           ( comparing )
  import Data.Either        ( partitionEithers )
  import Data.Map.Strict (Map)
  import qualified Data.Map.Strict as Map
 +import qualified Data.Semigroup as Semi
  {-
  ************************************************************************
@@ -2714,15 +2715,34 @@ hasFieldInfo_maybe rdr_env fam_inst_envs item
    -- (HF2e) It's a custom HasField constraint, not the one from GHC.Records.
    | Just (tc, _) <- splitTyConApp_maybe (errorItemPred item)
 -  , getOccString tc == "HasField"
 -  , isHasFieldOrigin (errorItemOrigin item)
 -  = return $ Just $ CustomHasField tc
 +  = do { rebindable_syntax <- xoptM LangExt.RebindableSyntax
 +       ; return $
 +           if want_custom_hasfield_msg tc rebindable_syntax
 +           then Just $ CustomHasField tc
 +           else Nothing
 +       }
    | otherwise
    = return Nothing
    where
 +    orig = errorItemOrigin item
++
 +    want_custom_hasfield_msg tc rebindable_syntax
 +      | getOccString tc == "HasField"
 +      = Semi.getAny $ foldMapCtOrigin (Semi.Any . is_has_field) orig
 +      | otherwise
 +      = False
 +      where
 +        -- Handle custom 'getField'/'setField' with RebindableSyntax.
 +        is_has_field (OccurrenceOf n)
 +          | rebindable_syntax
 +          , getOccString n `elem` ["getField", "setField"]
 +          = True
 +        is_has_field o
 +          = isHasFieldOrigin o
++
      get_parent_nm :: Name -> TcM (Maybe (Either PatSyn TyCon))
      get_parent_nm nm =
        do { fld_id <- tcLookupId nm
@@ -2762,22 +2782,6 @@ hasField_maybe pred =
    -- NB: we deliberately don't handle rebound 'HasField' (with -XRebindableSyntax),
    -- as GHC only has built-in instances for the built-in 'HasField' class.
 --- | Does this constraint arise from GHC internal mechanisms that desugar to
 --- usage of the 'HasField' typeclass (e.g. OverloadedRecordDot, etc)?
 ---
 --- Just used heuristically to decide whether to print an informative message to
 --- the user (see (H2e) in Note [Error messages for unsolved HasField constraints]).
 -isHasFieldOrigin :: CtOrigin -> Bool
 -isHasFieldOrigin = \case
 -  OccurrenceOf n ->
 -    -- A heuristic...
 -    getOccString n `elem` ["getField", "setField"]
 -  OccurrenceOfRecSel {} -> True
 -  RecordUpdOrigin {} -> True
 -  RecordFieldProjectionOrigin {} -> True
 -  GetFieldOrigin {} -> True
 -  _ -> False
+-
  -----------------------
  -- relevantBindings looks at the value environment and finds values whose
  -- types mention any of the offending type variables.  It has to be

compiler/GHC/Tc/Instance/Class.hs

@@ -20,7 +20,7 @@ import GHC.Tc.Instance.Typeable
  import GHC.Tc.Utils.TcMType
  import GHC.Tc.Types.Evidence
  import GHC.Tc.Types.CtLoc
 -import GHC.Tc.Types.Origin ( InstanceWhat (..), SafeOverlapping, CtOrigin(GetFieldOrigin) )
 +import GHC.Tc.Types.Origin ( InstanceWhat (..), SafeOverlapping, isHasFieldOrigin )
  import GHC.Tc.Instance.Family( tcGetFamInstEnvs, tcLookupDataFamInst, FamInstEnvs )
  import GHC.Rename.Env( addUsedGRE, addUsedDataCons, DeprecationWarnings (..) )
@@ -1275,8 +1275,8 @@ warnIncompleteRecSel :: DynFlags -> Id -> CtLoc -> TcM ()
  -- Warn about incomplete record selectors
  -- See (IRS6) in Note [Detecting incomplete record selectors] in GHC.HsToCore.Pmc
  warnIncompleteRecSel dflags sel_id ct_loc
 -  | not (isGetFieldOrigin (ctLocOrigin ct_loc))
 -      -- isGetFieldOrigin: see (IRS7) in
 +  | not $ isHasFieldOrigin (ctLocOrigin ct_loc)
 +      -- isHasFieldOrigin: see (IRS7) in
        -- Note [Detecting incomplete record selectors] in GHC.HsToCore.Pmc
    , RecSelId { sel_cons = RSI { rsi_undef = fallible_cons } } <- idDetails sel_id
    , not (null fallible_cons)
@@ -1288,11 +1288,6 @@ warnIncompleteRecSel dflags sel_id ct_loc
    where
      maxCons = maxUncoveredPatterns dflags
 -    -- GHC.Tc.Gen.App.tcInstFun arranges that the CtOrigin of (r.x) is GetFieldOrigin,
 -    -- despite the expansion to (getField @"x" r)
 -    isGetFieldOrigin (GetFieldOrigin {}) = True
 -    isGetFieldOrigin _                   = False
+-
  lookupHasFieldLabel
    :: FamInstEnvs -> GlobalRdrEnv -> [Type]
    -> Maybe ( Name          -- Name of the record selector

compiler/GHC/Tc/Types/Origin.hs

@@ -16,7 +16,8 @@ module GHC.Tc.Types.Origin (
    CtOrigin(..), exprCtOrigin, lexprCtOrigin, matchesCtOrigin, grhssCtOrigin,
    invisibleOrigin_maybe, isVisibleOrigin, toInvisibleOrigin,
    pprCtOrigin, pprCtOriginBriefly, isGivenOrigin,
 -  defaultReprEqOrigins, isWantedSuperclassOrigin,
 +  foldMapCtOrigin,
 +  defaultReprEqOrigins, isWantedSuperclassOrigin, isHasFieldOrigin,
    ClsInstOrQC(..), NakedScFlag(..), NonLinearPatternReason(..),
    HsImplicitLiftSplice(..),
    StandaloneDeriv,
@@ -52,6 +53,8 @@ import GHC.Tc.Utils.TcType
  import GHC.Hs
 +import GHC.Builtin.Names (getFieldName)
++
  import GHC.Core.DataCon
  import GHC.Core.ConLike
  import GHC.Core.TyCon
@@ -79,6 +82,8 @@ import GHC.Types.Unique.Supply
  import qualified Data.Kind as Hs
  import Data.List.NonEmpty (NonEmpty (..))
  import Data.Maybe (isNothing)
 +import qualified Data.Semigroup as Semi
 +import GHC.Generics
  {- *********************************************************************
  *                                                                      *
@@ -993,6 +998,95 @@ pprNonLinearPatternReason PatternSynonymReason = parens (text "pattern synonyms
  pprNonLinearPatternReason ViewPatternReason = parens (text "view patterns aren't linear")
  pprNonLinearPatternReason OtherPatternReason = empty
++
 +{- *********************************************************************
 +*                                                                      *
 +                     Recursing through CtOrigin
 +*                                                                      *
 +********************************************************************* -}
++
 +-- | Fold over a 'CtOrigin', looking through all recursive
 +-- occurrences of 'CtOrigin' within 'CtOrigin'.
 +foldMapCtOrigin :: forall m. Semigroup m => (CtOrigin -> m) -> CtOrigin -> m
 +foldMapCtOrigin f = go
 +  where
 +    go :: CtOrigin -> m
 +    go orig =
 +      case orig of
 +        KindEqOrigin _ _ o _ -> recur o
 +        CycleBreakerOrigin o -> recur o
 +        WantedSuperclassOrigin _ o -> recur o
 +        DefaultReprEqOrigin _ _ o -> recur o
 +        ScOrigin cls_or_qc _sc_flag ->
 +          case cls_or_qc of
 +            IsQC _ o -> recur o
 +            IsClsInst -> f orig
++
 +        -- Explicit pattern match on remaining constructors, in order to get
 +        -- better pattern-match warnings when constructors are changed or
 +        -- added/removed. This isn't entirely fool-proof, as someone may still
 +        -- change the type of one of the fields and hide a 'CtOrigin' inside.
 +        --
 +        -- This approach was chosen instead of using 'syb'/'GHC.Generics',
 +        -- because those would require deriving 'Data.Data'/'Generic' on
 +        -- a huge number of datatypes.
 +        GivenOrigin {} -> f orig
 +        GivenSCOrigin {} -> f orig
 +        OccurrenceOf {} -> f orig
 +        OccurrenceOfRecSel {} -> f orig
 +        AppOrigin {} -> f orig
 +        SpecPragOrigin {} -> f orig
 +        TypeEqOrigin {}-> f orig
 +        IPOccOrigin {} -> f orig
 +        OverLabelOrigin {} -> f orig
 +        LiteralOrigin {} -> f orig
 +        QualLiteralOrigin {} -> f orig
 +        NegateOrigin {} -> f orig
 +        ArithSeqOrigin {} -> f orig
 +        AssocFamPatOrigin {} -> f orig
 +        SectionOrigin {} -> f orig
 +        GetFieldOrigin {} -> f orig
 +        RecordFieldProjectionOrigin {} -> f orig
 +        TupleOrigin {} -> f orig
 +        ExprSigOrigin {} -> f orig
 +        PatSigOrigin {} -> f orig
 +        PatOrigin {} -> f orig
 +        ProvCtxtOrigin {} -> f orig
 +        RecordUpdOrigin {} -> f orig
 +        ViewPatOrigin {} -> f orig
 +        DerivOrigin {} -> f orig
 +        DerivOriginDC {} -> f orig
 +        DerivOriginCoerce {}  -> f orig
 +        DefaultOrigin {} -> f orig
 +        DoOrigin {} -> f orig
 +        DoPatOrigin {} -> f orig
 +        MCompOrigin {} -> f orig
 +        MCompPatOrigin {} -> f orig
 +        ProcOrigin {} -> f orig
 +        ArrowCmdOrigin {} -> f orig
 +        AnnOrigin {} -> f orig
 +        FunDepOrigin {} -> f orig
 +        ExprHoleOrigin {} -> f orig
 +        TypeHoleOrigin {} -> f orig
 +        PatCheckOrigin {} -> f orig
 +        ListOrigin {} -> f orig
 +        IfThenElseOrigin {} -> f orig
 +        BracketOrigin {} -> f orig
 +        StaticOrigin {} -> f orig
 +        ImpedanceMatching {} -> f orig
 +        Shouldn'tHappenOrigin {} -> f orig
 +        InstProvidedOrigin {} -> f orig
 +        NonLinearPatternOrigin {} -> f orig
 +        OmittedFieldOrigin {} -> f orig
 +        UsageEnvironmentOf {} -> f orig
 +        FRROrigin {} -> f orig
 +        InstanceSigOrigin {} -> f orig
 +        AmbiguityCheckOrigin {} -> f orig
 +        ImplicitLiftOrigin {} -> f orig
++
 +      where
 +        recur o = f orig Semi.<> go o
++
  {- *********************************************************************
  *                                                                      *
                 Defaulting of representational equalities
@@ -1004,21 +1098,10 @@ pprNonLinearPatternReason OtherPatternReason = empty
  -- That is, this function extracts all occurrences of the 'DefaultReprEqOrigin'
  -- constructor from within a 'CtOrigin'.
  defaultReprEqOrigins :: CtOrigin -> [(CtOrigin, (TcType, TcType))]
 -defaultReprEqOrigins = go
 +defaultReprEqOrigins = foldMapCtOrigin go
    where
      go = \case
 -      DefaultReprEqOrigin l r o -> (o, (l, r)) : go o
+-
 -      -- Handle recursive occurrences of 'CtOrigin' within 'CtOrigin'.
 -      -- TODO: use syb to derive this, so that the following never goes out of date.
 -      ScOrigin cls_or_qc _ ->
 -        case cls_or_qc of
 -          IsClsInst -> []
 -          IsQC _ o -> go o
 -      KindEqOrigin _ _ o _ -> go o
 -      CycleBreakerOrigin o -> go o
 -      WantedSuperclassOrigin _ o -> go o
+-
 +      DefaultReprEqOrigin l r o -> [(o, (l, r))]
        _ -> []
  {- *********************************************************************
@@ -1046,6 +1129,37 @@ isPushCallStackOrigin_maybe orig               = Just orig_fs
    where
      orig_fs = mkFastString (showSDocUnsafe (pprCtOriginBriefly orig))
 +{- *********************************************************************
 +*                                                                      *
 +                       HasField and CtOrigin
 +*                                                                      *
 +********************************************************************* -}
++
 +-- | Does this constraint arise from GHC internal mechanisms that desugar to
 +-- usage of the 'HasField' typeclass (e.g. OverloadedRecordDot, etc)?
 +--
 +-- Used in two places:
 +--
 +--  - When reporting an unsolved 'HasField' constraint, to decide whether to
 +--    print an informative message to the user.
 +--    See (H2e) in Note [Error messages for unsolved HasField constraints]
 +--    in GHC.Tc.Errors.
 +--  - To avoid emitting a poor "incomplete record selector" warning directly
 +--    in typechecker, in cases when the desugarer will be able to emit a better
 +--    error message, due to having better pattern match checking information.
 +--    See (IRS7) in Note [Detecting incomplete record selectors]
 +--    in GHC.HsToCore.Pmc
 +isHasFieldOrigin :: CtOrigin -> Bool
 +isHasFieldOrigin = Semi.getAny . foldMapCtOrigin (Semi.Any . go)
 +  where
 +    go = \case
 +      OccurrenceOf n -> n == getFieldName
 +      OccurrenceOfRecSel {} -> True
 +      RecordFieldProjectionOrigin {} -> True
 +      GetFieldOrigin {} -> True
 +      RecordUpdOrigin {} -> True
 +      _ -> False
++
  {-
  ************************************************************************
  *                                                                      *

testsuite/tests/overloadedrecflds/should_compile/T26686.hs

 +{-# LANGUAGE OverloadedRecordDot #-}
 +{-# LANGUAGE GADTs #-}
++
 +{-# OPTIONS_GHC -Wincomplete-record-selectors #-}
++
 +module T26686 where
++
 +import Data.Kind
++
 +data A
 +data B
++
 +data G = G { f2 :: Int }
++
 +data T x where
 +  TA :: { ta :: G } -> T x
 +  TB :: { tb :: G } -> T B
++
 +data H a = H { f1 :: T a }
++
 +test1_ok :: T A -> G
 +test1_ok = (.ta)
 +test2_ok :: T A -> Int
 +test2_ok = (.ta.f2)
 +test3_ok :: H A -> G
 +test3_ok = (.f1.ta)
 +test4_ok :: H A -> Int
 +test4_ok = (.f1.ta.f2)
++
 +test1_bad :: T x -> G
 +test1_bad = (.ta)
 +test2_bad :: T x -> Int
 +test2_bad = (.ta.f2)
 +test3_bad :: H x -> G
 +test3_bad = (.f1.ta)
 +test4_bad :: H x -> Int
 +test4_bad = (.f1.ta.f2)

testsuite/tests/overloadedrecflds/should_compile/T26686.stderr

 +T26686.hs:31:13: warning: [GHC-17335] [-Wincomplete-record-selectors (in -Wall)]
 +    Selecting the record field ‘ta’ may fail for the following constructors:
 +      TB
++
 +T26686.hs:33:13: warning: [GHC-17335] [-Wincomplete-record-selectors (in -Wall)]
 +    Selecting the record field ‘ta’ may fail for the following constructors:
 +      TB
++
 +T26686.hs:35:13: warning: [GHC-17335] [-Wincomplete-record-selectors (in -Wall)]
 +    Selecting the record field ‘ta’ may fail for the following constructors:
 +      TB
++
 +T26686.hs:37:13: warning: [GHC-17335] [-Wincomplete-record-selectors (in -Wall)]
 +    Selecting the record field ‘ta’ may fail for the following constructors:
 +      TB
++

testsuite/tests/overloadedrecflds/should_compile/all.T

@@ -30,6 +30,7 @@ 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('T26686', normal, compile, [''])
  test('DupFldFixity3', normal, compile, [''])
  test('overloadedrecflds10'
      , [extra_files(['OverloadedRecFlds10_A.hs', 'OverloadedRecFlds10_B.hs', 'OverloadedRecFlds10_C.hs'])]