GitLab

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

Commits:

fbdc623a

by sheaf at 2025-10-26T18:23:52-04:00

Add hints for unsolved HasField constraints

This commit adds hints and explanations for unsolved 'HasField'
constraints.

GHC will now provide additional explanations for an unsolved constraint
of the form 'HasField fld_name rec_ty fld_ty'; the details are laid out in
Note [Error messages for unsolved HasField constraints], but briefly:

  1. Provide similar name suggestions (e.g. mis-spelled field name)
     and import suggestions (record field not in scope).
     These result in actionable 'GhcHints', which is helpful to provide
     code actions in HLS.

  2. Explain why GHC did not solve the constraint, e.g.:

    - 'fld_name' is not a string literal (e.g. a type variable)
    - 'rec_ty' is a TyCon without any fields, e.g. 'Int' or 'Bool'.
    - 'fld_ty' contains existentials variables or foralls.
    - The record field is a pattern synonym field (GHC does not generate
      HasField instances for those).
    - 'HasField' is a custom 'TyCon', not actually the built-in
      'HasField' typeclass from 'GHC.Records'.

On the way, we slightly refactor the mechanisms for import suggestions
in GHC.Rename.Unbound. This is to account for the fact that, for
'HasField', we don't care whether the field is imported qualified or
unqualified. 'importSuggestions' was refactored, we now have
'sameQualImportSuggestions' and 'anyQualImportSuggestions'.

Fixes #18776 #22382 #26480

99d5707f

by sheaf at 2025-10-26T18:23:52-04:00

Rename PatSyn MatchContext to PatSynCtx to avoid punning

29 changed files:

compiler/GHC/Core/ConLike.hs
compiler/GHC/Hs/Expr.hs
compiler/GHC/HsToCore/Pmc/Utils.hs
compiler/GHC/Rename/Bind.hs
compiler/GHC/Rename/Names.hs
compiler/GHC/Rename/Unbound.hs
compiler/GHC/Tc/Errors.hs
compiler/GHC/Tc/Errors/Ppr.hs
compiler/GHC/Tc/Errors/Types.hs
compiler/GHC/Tc/Instance/Class.hs
compiler/GHC/Tc/TyCl/PatSyn.hs
compiler/GHC/Tc/TyCl/Utils.hs
compiler/GHC/Tc/Types/Origin.hs
compiler/GHC/Types/Hint.hs
compiler/GHC/Types/Hint/Ppr.hs
compiler/Language/Haskell/Syntax/Expr.hs
+ testsuite/tests/overloadedrecflds/should_fail/T26480.hs
+ testsuite/tests/overloadedrecflds/should_fail/T26480.stderr
+ testsuite/tests/overloadedrecflds/should_fail/T26480_aux1.hs
+ testsuite/tests/overloadedrecflds/should_fail/T26480_aux2.hs
+ testsuite/tests/overloadedrecflds/should_fail/T26480b.hs
+ testsuite/tests/overloadedrecflds/should_fail/T26480b.stderr
testsuite/tests/overloadedrecflds/should_fail/all.T
testsuite/tests/overloadedrecflds/should_fail/hasfieldfail01.stderr
testsuite/tests/overloadedrecflds/should_fail/hasfieldfail02.stderr
testsuite/tests/parser/should_fail/RecordDotSyntaxFail11.stderr
testsuite/tests/parser/should_fail/RecordDotSyntaxFail8.hs
testsuite/tests/parser/should_fail/RecordDotSyntaxFail8.stderr
testsuite/tests/rename/should_fail/T19843h.stderr

Changes:

compiler/GHC/Core/ConLike.hs

@@ -26,6 +26,8 @@ module GHC.Core.ConLike (
          , conLikeFieldType
          , conLikeIsInfix
          , conLikeHasBuilder
++
 +        , isExistentialRecordField
      ) where
  import GHC.Prelude
@@ -35,7 +37,7 @@ import GHC.Core.Multiplicity
  import GHC.Core.PatSyn
  import GHC.Core.TyCo.Rep (Type, ThetaType)
  import GHC.Core.TyCon (tyConDataCons)
 -import GHC.Core.Type(mkTyConApp)
 +import GHC.Core.Type(mkTyConApp, tyCoVarsOfType)
  import GHC.Types.Unique
  import GHC.Types.Name
  import GHC.Types.Name.Reader
@@ -43,6 +45,7 @@ import GHC.Types.Basic
  import GHC.Types.GREInfo
  import GHC.Types.Var
 +import GHC.Types.Var.Set
  import GHC.Utils.Misc
  import GHC.Utils.Outputable
@@ -239,3 +242,23 @@ conLikeFieldType (RealDataCon dc) label = dataConFieldType dc label
  conLikeIsInfix :: ConLike -> Bool
  conLikeIsInfix (RealDataCon dc) = dataConIsInfix dc
  conLikeIsInfix (PatSynCon ps)   = patSynIsInfix  ps
++
 +-- | Is this record field a naughty record field due to the presence of
 +-- existential type variables?
 +--
 +-- Different from 'isNaughtyRecordSelector' because the latter is also true
 +-- in the presence of @-XNoFieldSelectors@.
 +--
 +-- See Note [Naughty record selectors] in GHC.Tc.TyCl.Utils.
 +isExistentialRecordField :: Type -> ConLike -> Bool
 +isExistentialRecordField field_ty con =
 +  case con of
 +    RealDataCon {} -> not $ field_ty_tvs `subVarSet` res_ty_tvs
 +    PatSynCon {}   -> not $ field_ty_tvs `subVarSet` mkVarSet univ_tvs
 +       -- In the PatSynCon case, the selector type is (data_ty -> field_ty), but
 +       -- fvs(data_ty) are all universals (see Note [Pattern synonym result type] in
 +       -- GHC.Core.PatSyn, so no need to check them.
 +  where
 +    field_ty_tvs = tyCoVarsOfType field_ty
 +    res_ty_tvs   = tyCoVarsOfType data_ty
 +    (univ_tvs, _, _, _, _, _, data_ty) = conLikeFullSig con

compiler/GHC/Hs/Expr.hs

@@ -1898,7 +1898,7 @@ matchSeparator PatBindRhs       = text "="
  matchSeparator PatBindGuards    = text "="
  matchSeparator StmtCtxt{}       = text "<-"
  matchSeparator RecUpd           = text "="  -- This can be printed by the pattern
 -matchSeparator PatSyn           = text "<-" -- match checker trace
 +matchSeparator PatSynCtx        = text "<-" -- match checker trace
  matchSeparator LazyPatCtx       = panic "unused"
  matchSeparator ThPatSplice      = panic "unused"
  matchSeparator ThPatQuote       = panic "unused"
@@ -2494,7 +2494,7 @@ instance Outputable fn => Outputable (HsMatchContext fn) where
    ppr (StmtCtxt _)            = text "StmtCtxt _"
    ppr ThPatSplice             = text "ThPatSplice"
    ppr ThPatQuote              = text "ThPatQuote"
 -  ppr PatSyn                  = text "PatSyn"
 +  ppr PatSynCtx               = text "PatSynCtx"
    ppr LazyPatCtx              = text "LazyPatCtx"
  instance Outputable HsLamVariant where
@@ -2538,7 +2538,7 @@ matchContextErrString RecUpd                        = text "record update"
  matchContextErrString (ArrowMatchCtxt c)            = matchArrowContextErrString c
  matchContextErrString ThPatSplice                   = panic "matchContextErrString"  -- Not used at runtime
  matchContextErrString ThPatQuote                    = panic "matchContextErrString"  -- Not used at runtime
 -matchContextErrString PatSyn                        = text "pattern synonym"
 +matchContextErrString PatSynCtx                     = text "pattern synonym"
  matchContextErrString (StmtCtxt (ParStmtCtxt c))    = matchContextErrString (StmtCtxt c)
  matchContextErrString (StmtCtxt (TransStmtCtxt c))  = matchContextErrString (StmtCtxt c)
  matchContextErrString (StmtCtxt (PatGuard _))       = text "pattern guard"
@@ -2613,7 +2613,7 @@ pprMatchContextNoun PatBindGuards           = text "pattern binding guards"
  pprMatchContextNoun (ArrowMatchCtxt c)      = pprArrowMatchContextNoun c
  pprMatchContextNoun (StmtCtxt ctxt)         = text "pattern binding in"
                                                $$ pprAStmtContext ctxt
 -pprMatchContextNoun PatSyn                  = text "pattern synonym declaration"
 +pprMatchContextNoun PatSynCtx               = text "pattern synonym declaration"
  pprMatchContextNoun LazyPatCtx              = text "irrefutable pattern"
  pprMatchContextNouns :: Outputable fn => HsMatchContext fn -> SDoc

compiler/GHC/HsToCore/Pmc/Utils.hs

@@ -93,7 +93,7 @@ exhaustiveWarningFlag (ArrowMatchCtxt c) = arrowMatchContextExhaustiveWarningFla
  exhaustiveWarningFlag RecUpd             = Just Opt_WarnIncompletePatternsRecUpd
  exhaustiveWarningFlag LazyPatCtx         = Just Opt_WarnIncompleteUniPatterns
  exhaustiveWarningFlag ThPatSplice        = Nothing
 -exhaustiveWarningFlag PatSyn             = Nothing
 +exhaustiveWarningFlag PatSynCtx          = Nothing
  exhaustiveWarningFlag ThPatQuote         = Nothing
  -- Don't warn about incomplete patterns in list comprehensions, pattern guards
  -- etc. They are often *supposed* to be incomplete

compiler/GHC/Rename/Bind.hs

@@ -763,7 +763,7 @@ rnPatSynBind sig_fn bind@(PSB { psb_id = L l name
          ; let scoped_tvs = sig_fn name
          ; ((pat', details'), fvs1) <- bindSigTyVarsFV scoped_tvs $
 -                                      rnPat PatSyn pat $ \pat' ->
 +                                      rnPat PatSynCtx pat $ \pat' ->
           -- We check the 'RdrName's instead of the 'Name's
           -- so that the binding locations are reported
           -- from the left-hand side

compiler/GHC/Rename/Names.hs

@@ -2453,8 +2453,8 @@ badImportItemErr iface decl_spec ie sub avails = do
            -- Only keep imported items, and set the "HowInScope" to
            -- "Nothing" to avoid printing "imported from..." in the suggestion
            -- error message.
 -          imported_item (SimilarRdrName rdr_name (Just (ImportedBy {})))
 -            = Just (SimilarRdrName rdr_name Nothing)
 +          imported_item (SimilarRdrName rdr_name gre (Just (ImportedBy {})))
 +            = Just (SimilarRdrName rdr_name gre Nothing)
            imported_item _ = Nothing
      checkIfDataCon = checkIfAvailMatches isDataConName

compiler/GHC/Rename/Unbound.hs

@@ -18,6 +18,7 @@ module GHC.Rename.Unbound
     , unknownNameSuggestionsMessage
     , similarNameSuggestions
     , fieldSelectorSuggestions
 +   , anyQualImportSuggestions
     , WhatLooking(..)
     , WhereLooking(..)
     , LookingFor(..)
@@ -215,7 +216,7 @@ unknownNameSuggestions_ looking_for dflags hpt curr_mod global_env local_env
        , map (ImportSuggestion $ rdrNameOcc tried_rdr_name) imp_suggs
        , extensionSuggestions tried_rdr_name
        , fieldSelectorSuggestions global_env tried_rdr_name ]
 -    (imp_errs, imp_suggs) = importSuggestions looking_for hpt curr_mod imports tried_rdr_name
 +    (imp_errs, imp_suggs) = sameQualImportSuggestions looking_for hpt curr_mod imports tried_rdr_name
      if_ne :: (NonEmpty a -> b) -> [a] -> [b]
      if_ne _ []       = []
@@ -242,7 +243,7 @@ similarNameSuggestions looking_for@(LF what_look where_look) dflags global_env
      all_possibilities :: [(String, SimilarName)]
      all_possibilities = case what_look of
        WL_None -> []
 -      _ -> [ (showPpr dflags r, SimilarRdrName r (Just $ LocallyBoundAt loc))
 +      _ -> [ (showPpr dflags r, SimilarRdrName r Nothing (Just $ LocallyBoundAt loc))
             | (r,loc) <- local_possibilities local_env ]
          ++ [ (showPpr dflags r, rp) | (r, rp) <- global_possibilities global_env ]
@@ -273,7 +274,7 @@ similarNameSuggestions looking_for@(LF what_look where_look) dflags global_env
      global_possibilities :: GlobalRdrEnv -> [(RdrName, SimilarName)]
      global_possibilities global_env
 -      | tried_is_qual = [ (rdr_qual, SimilarRdrName rdr_qual (Just how))
 +      | tried_is_qual = [ (rdr_qual, SimilarRdrName rdr_qual (Just gre) (Just how))
                          | gre <- globalRdrEnvElts global_env
                          , isGreOk looking_for gre
                          , let occ = greOccName gre
@@ -288,7 +289,7 @@ similarNameSuggestions looking_for@(LF what_look where_look) dflags global_env
                            rdr_unqual = mkRdrUnqual occ
                      , is_relevant occ
                      , sim <- case (unquals_in_scope gre, quals_only gre) of
 -                                (how:_, _)    -> [ SimilarRdrName rdr_unqual (Just how) ]
 +                                (how:_, _)    -> [ SimilarRdrName rdr_unqual (Just gre) (Just how) ]
                                  ([],    pr:_) -> [ pr ]  -- See Note [Only-quals]
                                  ([],    [])   -> [] ]
@@ -316,45 +317,74 @@ similarNameSuggestions looking_for@(LF what_look where_look) dflags global_env
      quals_only :: GlobalRdrElt -> [SimilarName]
      -- Ones for which *only* the qualified version is in scope
      quals_only (gre@GRE { gre_imp = is })
 -      = [ (SimilarRdrName (mkRdrQual (is_as ispec) (greOccName gre)) (Just $ ImportedBy ispec))
 +      = [ (SimilarRdrName (mkRdrQual (is_as ispec) (greOccName gre)) (Just gre) (Just $ ImportedBy ispec))
          | i <- bagToList is, let ispec = is_decl i, is_qual ispec ]
 +-- | Provide import suggestions, without filtering by module qualification.
 +-- Used to suggest imports for 'HasField', which doesn't care about whether a
 +-- name is imported qualified or unqualified.
 +--
 +-- For example:
 +--
 +--  > import M1 () -- M1 exports fld1
 +--  > import qualified M2 hiding ( fld2 )
 +--  > x r = r.fld1              -- suggest adding 'fld1' to M1 import
 +--  > y r = getField @"fld2" r  -- suggest unhiding 'fld' from M2 import
 +anyQualImportSuggestions :: LookingFor -> LookupGRE GREInfo -> TcM [ImportSuggestion]
 +anyQualImportSuggestions looking_for lookup_gre =
 +  do { imp_info <- getImports
 +     ; let interesting_imports = interestingImports imp_info (const True)
 +     ; return $
 +          importSuggestions_ looking_for interesting_imports lookup_gre
 +     }
 --- | Generate errors and helpful suggestions if a qualified name Mod.foo is not in scope.
 -importSuggestions :: LookingFor
 -                  -> InteractiveContext -> Module
 -                  -> ImportAvails -> RdrName -> ([ImportError], [ImportSuggestion])
 -importSuggestions looking_for ic currMod imports rdr_name
 -  | WL_LocalOnly <- lf_where looking_for       = ([], [])
 -  | WL_LocalTop  <- lf_where looking_for       = ([], [])
 +-- | The given 'RdrName' is not in scope. Try to find out why that is by looking
 +-- at the import list, to suggest e.g. changing the import list somehow.
 +--
 +-- For example:
 +--
 +-- > import qualified M1 hiding ( blah1 )
 +-- > x = M1.blah -- suggest unhiding blah1
 +-- > y = XX.blah1 -- import error: no imports provide the XX qualification prefix
 +sameQualImportSuggestions
 +  :: LookingFor
 +  -> InteractiveContext
 +  -> Module
 +  -> ImportAvails
 +  -> RdrName
 +  -> ([ImportError], [ImportSuggestion])
 +sameQualImportSuggestions looking_for ic currMod imports rdr_name
    | not (isQual rdr_name || isUnqual rdr_name) = ([], [])
 -  | Just name <- mod_name
 -  , show_not_imported_line name
 -  = ([MissingModule name], [])
 +  | Just rdr_mod_name <- mb_rdr_mod_name
 +  , show_not_imported_line rdr_mod_name
 +  = ([MissingModule rdr_mod_name], [])
    | is_qualified
 -  , null helpful_imports
 +  , null import_suggs
    , (mod : mods) <- map fst interesting_imports
    = ([ModulesDoNotExport (mod :| mods) (lf_which looking_for) occ_name], [])
 -  | mod : mods <- helpful_imports_non_hiding
 -  = ([], [CouldImportFrom (mod :| mods)])
 -  | mod : mods <- helpful_imports_hiding
 -  = ([], [CouldUnhideFrom (mod :| mods)])
    | otherwise
 -  = ([], [])
 - where
 +  = ([], import_suggs)
 +  where
++
 +  interesting_imports = interestingImports imports right_qual_import
++
 +  import_suggs =
 +    importSuggestions_ looking_for interesting_imports $
 +      (LookupOccName (rdrNameOcc rdr_name) $ RelevantGREsFOS WantNormal)
++
    is_qualified = isQual rdr_name
 -  (mod_name, occ_name) = case rdr_name of
 +  (mb_rdr_mod_name, occ_name) = case rdr_name of
      Unqual occ_name        -> (Nothing, occ_name)
      Qual mod_name occ_name -> (Just mod_name, occ_name)
 -    _                      -> panic "importSuggestions: dead code"
+-
 +    _                      -> panic "sameQualImportSuggestions: dead code"
 -  -- What import statements provide "Mod" at all
 -  -- or, if this is an unqualified name, are not qualified imports
 -  interesting_imports = [ (mod, imp)
 -    | (mod, mod_imports) <- M.toList (imp_mods imports)
 -    , Just imp <- return $ pick (importedByUser mod_imports)
 -    ]
 +  -- See Note [When to show/hide the module-not-imported line]
 +  show_not_imported_line :: ModuleName -> Bool                    -- #15611
 +  show_not_imported_line modnam
 +      | not (null interactive_imports)        = False -- 1 (interactive context)
 +      | not (null interesting_imports)        = False -- 1 (normal module import)
 +      | moduleName currMod == modnam          = False -- 2
 +      | otherwise                             = True
    -- Choose the imports from the interactive context which might have provided
    -- a module.
@@ -362,18 +392,52 @@ importSuggestions looking_for ic currMod imports rdr_name
      filter pick_interactive (ic_imports ic)
    pick_interactive :: InteractiveImport -> Bool
 -  pick_interactive (IIDecl d)   | mod_name == Just (unLoc (ideclName d)) = True
 -                                | mod_name == fmap unLoc (ideclAs d) = True
 -  pick_interactive (IIModule m) | mod_name == Just (moduleName m) = True
 +  pick_interactive (IIDecl d)   | mb_rdr_mod_name == Just (unLoc (ideclName d)) = True
 +                                | mb_rdr_mod_name == fmap unLoc (ideclAs d) = True
 +  pick_interactive (IIModule m) | mb_rdr_mod_name == Just (moduleName m) = True
    pick_interactive _ = False
 +  right_qual_import imv =
 +    case mb_rdr_mod_name of
 +      -- Qual RdrName: only want qualified imports with the same module name
 +      Just rdr_mod_name -> imv_name imv == rdr_mod_name
 +      -- UnQual RdrName: import must be unqualified
 +      Nothing           -> not (imv_qualified imv)
++
 +-- | What import statements are relevant?
 +--
 +--   - If we are looking for a qualified name @Mod.blah@, which imports provide @Mod@ at all,
 +--   - If we are looking for an unqualified name, which imports are themselves unqualified.
 +interestingImports :: ImportAvails -> (ImportedModsVal -> Bool) -> [(Module, ImportedModsVal)]
 +interestingImports imports ok_mod_name =
 +  [ (mod, imp)
 +    | (mod, mod_imports) <- M.toList (imp_mods imports)
 +    , Just imp <- return $ pick (importedByUser mod_imports)
 +    ]
++
 +  where
    -- We want to keep only one for each original module; preferably one with an
    -- explicit import list (for no particularly good reason)
    pick :: [ImportedModsVal] -> Maybe ImportedModsVal
 -  pick = listToMaybe . sortBy cmp . filter select
 -    where select imv = case mod_name of Just name -> imv_name imv == name
 -                                        Nothing   -> not (imv_qualified imv)
 -          cmp = on compare imv_is_hiding S.<> on SrcLoc.leftmost_smallest imv_span
 +  pick = listToMaybe . sortBy cmp . filter ok_mod_name
 +    where
 +      cmp = on compare imv_is_hiding S.<> on SrcLoc.leftmost_smallest imv_span
++
 +importSuggestions_
 +  :: LookingFor
 +  -> [(Module, ImportedModsVal)]
 +  -> LookupGRE GREInfo
 +  -> [ImportSuggestion]
 +importSuggestions_ looking_for interesting_imports lookup_gre
 +  | WL_LocalOnly <- lf_where looking_for       = []
 +  | WL_LocalTop  <- lf_where looking_for       = []
 +  | mod : mods <- helpful_imports_non_hiding
 +  = [CouldImportFrom (mod :| mods)]
 +  | mod : mods <- helpful_imports_hiding
 +  = [CouldUnhideFrom (mod :| mods)]
 +  | otherwise
 +  = []
 + where
    -- Which of these would export a 'foo'
    -- (all of these are restricted imports, because if they were not, we
@@ -382,21 +446,13 @@ importSuggestions looking_for ic currMod imports rdr_name
      where helpful (_,imv)
              = any (isGreOk looking_for) $
                lookupGRE (imv_all_exports imv)
 -                (LookupOccName occ_name $ RelevantGREsFOS WantNormal)
 +                lookup_gre
    -- Which of these do that because of an explicit hiding list resp. an
    -- explicit import list
    (helpful_imports_hiding, helpful_imports_non_hiding)
      = partition (imv_is_hiding . snd) helpful_imports
 -  -- See Note [When to show/hide the module-not-imported line]
 -  show_not_imported_line :: ModuleName -> Bool                    -- #15611
 -  show_not_imported_line modnam
 -      | not (null interactive_imports)        = False -- 1 (interactive context)
 -      | not (null interesting_imports)        = False -- 1 (normal module import)
 -      | moduleName currMod == modnam          = False -- 2
 -      | otherwise                             = True
+-
  extensionSuggestions :: RdrName -> [GhcHint]
  extensionSuggestions rdrName
    | rdrName == mkUnqual varName (fsLit "mdo") ||

compiler/GHC/Tc/Errors.hs

@@ -17,6 +17,8 @@ module GHC.Tc.Errors(
  import GHC.Prelude
 +import GHC.Builtin.Names (hasFieldClassName)
++
  import GHC.Driver.Env (hsc_units)
  import GHC.Driver.DynFlags
  import GHC.Driver.Ppr
@@ -31,6 +33,7 @@ import GHC.Tc.Errors.Ppr
  import GHC.Tc.Types.Constraint
  import GHC.Tc.Types.CtLoc
  import GHC.Tc.Utils.TcMType
 +import GHC.Tc.Utils.Env (tcLookupId, tcLookupDataCon)
  import GHC.Tc.Zonk.Type
  import GHC.Tc.Utils.TcType
  import GHC.Tc.Zonk.TcType
@@ -43,6 +46,7 @@ import {-# SOURCE #-} GHC.Tc.Errors.Hole ( findValidHoleFits, getHoleFitDispConf
  import GHC.Types.Name
  import GHC.Types.Name.Reader
  import GHC.Types.Id
 +import GHC.Types.Id.Info (IdDetails(..), RecSelParent (..))
  import GHC.Types.Var
  import GHC.Types.Var.Set
  import GHC.Types.Var.Env
@@ -50,13 +54,18 @@ import GHC.Types.Name.Env
  import GHC.Types.SrcLoc
  import GHC.Types.Basic
  import GHC.Types.Error
 +import GHC.Types.Hint (SimilarName (..))
  import qualified GHC.Types.Unique.Map as UM
 +import GHC.Types.Unique.Set (nonDetEltsUniqSet)
  import GHC.Unit.Module
  import qualified GHC.LanguageExtensions as LangExt
 +import GHC.Core.PatSyn (PatSyn)
  import GHC.Core.Predicate
  import GHC.Core.Type
 +import GHC.Core.Class (className)
 +import GHC.Core.ConLike (isExistentialRecordField, ConLike (..))
  import GHC.Core.Coercion
  import GHC.Core.TyCo.Ppr     ( pprTyVars )
  import GHC.Core.TyCo.Tidy
@@ -75,13 +84,18 @@ import GHC.Data.List.SetOps ( equivClasses, nubOrdBy )
  import GHC.Data.Maybe
  import qualified GHC.Data.Strict as Strict
++
 +import Language.Haskell.Syntax.Basic (FieldLabelString(..))
++
  import Control.Monad      ( unless, when, foldM, forM_ )
 +import Data.Bifunctor     ( bimap )
  import Data.Foldable      ( toList )
  import Data.Function      ( on )
  import Data.List          ( partition, union, sort, sortBy )
  import Data.List.NonEmpty ( NonEmpty(..), nonEmpty )
  import qualified Data.List.NonEmpty as NE
  import Data.Ord         ( comparing )
 +import Data.Either (partitionEithers)
  {-
  ************************************************************************
@@ -1470,8 +1484,8 @@ coercion.
  mkIrredErr :: SolverReportErrCtxt -> NonEmpty ErrorItem -> TcM SolverReport
  mkIrredErr ctxt items
    = do { (ctxt, binds, item1) <- relevantBindings True ctxt item1
 -       ; let msg = important ctxt $ mkPlainMismatchMsg $
 -                   CouldNotDeduce (getUserGivens ctxt) (item1 :| others) Nothing
 +       ; couldNotDeduceErr <- mkCouldNotDeduceErr (getUserGivens ctxt) (item1 :| others) Nothing
 +       ; let msg = important ctxt $ mkPlainMismatchMsg couldNotDeduceErr
         ; return $ add_relevant_bindings binds msg  }
    where
      item1:|others = tryFilter (not . ei_suppress) items
@@ -1851,6 +1865,7 @@ reportEqErr :: SolverReportErrCtxt
              -> TcM TcSolverReportMsg
  reportEqErr ctxt item ty1 ty2
    = do
 +    mismatch <- misMatchOrCND ctxt item ty1 ty2
      mb_coercible_info <- if errorItemEqRel item == ReprEq
                           then coercible_msg ty1 ty2
                           else return Nothing
@@ -1862,7 +1877,6 @@ reportEqErr ctxt item ty1 ty2
                        , mismatchAmbiguityInfo = eqInfos
                        , mismatchCoercibleInfo = mb_coercible_info }
    where
 -    mismatch = misMatchOrCND ctxt item ty1 ty2
      eqInfos  = eqInfoMsgs ty1 ty2
  coercible_msg :: TcType -> TcType -> TcM (Maybe CoercibleMsg)
@@ -1894,6 +1908,7 @@ mkTyVarEqErr' ctxt item tv1 ty2
    -- try it before anything more complicated.
    | check_eq_result `cterHasProblem` cteImpredicative
    = do
 +    headline_msg <- misMatchOrCND ctxt item ty1 ty2
      tyvar_eq_info <- extraTyVarEqInfo (tv1, Nothing) ty2
      let
          poly_msg = CannotUnifyWithPolytype item tv1 ty2 mb_tv_info
@@ -1917,6 +1932,7 @@ mkTyVarEqErr' ctxt item tv1 ty2
      || errorItemEqRel item == ReprEq
       -- The cases below don't really apply to ReprEq (except occurs check)
    = do
 +    headline_msg <- misMatchOrCND ctxt item ty1 ty2
      tv_extra <- extraTyVarEqInfo (tv1, Nothing) ty2
      reason <- if errorItemEqRel item == ReprEq
                then RepresentationalEq tv_extra <$> coercible_msg ty1 ty2
@@ -1933,23 +1949,24 @@ mkTyVarEqErr' ctxt item tv1 ty2
      --
      -- Use tyCoVarsOfType because it might have begun as the canonical
      -- constraint (Dual (Dual a)) ~ a, and been swizzled by mkEqnErr_help
 -  = let ambiguity_infos = eqInfoMsgs ty1 ty2
 +  = do headline_msg <- misMatchOrCND ctxt item ty1 ty2
 +       let ambiguity_infos = eqInfoMsgs ty1 ty2
 -        interesting_tyvars = filter (not . noFreeVarsOfType . tyVarKind) $
 -                             filter isTyVar $
 -                             fvVarList $
 -                             tyCoFVsOfType ty1 `unionFV` tyCoFVsOfType ty2
 +           interesting_tyvars = filter (not . noFreeVarsOfType . tyVarKind) $
 +                                filter isTyVar $
 +                                fvVarList $
 +                                tyCoFVsOfType ty1 `unionFV` tyCoFVsOfType ty2
 -        occurs_err =
 -          OccursCheck
 -            { occursCheckInterestingTyVars = interesting_tyvars
 -            , occursCheckAmbiguityInfos    = ambiguity_infos }
 -        main_msg =
 -          CannotUnifyVariable
 -            { mismatchMsg       = headline_msg
 -            , cannotUnifyReason = occurs_err }
 +           occurs_err =
 +             OccursCheck
 +               { occursCheckInterestingTyVars = interesting_tyvars
 +               , occursCheckAmbiguityInfos    = ambiguity_infos }
 +           main_msg =
 +             CannotUnifyVariable
 +               { mismatchMsg       = headline_msg
 +               , cannotUnifyReason = occurs_err }
 -    in return main_msg
 +       return main_msg
    -- If the immediately-enclosing implication has 'tv' a skolem, and
    -- we know by now its an InferSkol kind of skolem, then presumably
@@ -2005,7 +2022,6 @@ mkTyVarEqErr' ctxt item tv1 ty2
          -- Consider an ambiguous top-level constraint (a ~ F a)
          -- Not an occurs check, because F is a type function.
    where
 -    headline_msg = misMatchOrCND ctxt item ty1 ty2
      mismatch_msg = mkMismatchMsg item ty1 ty2
      -- The following doesn't use the cterHasProblem mechanism because
@@ -2073,7 +2089,7 @@ eqInfoMsgs ty1 ty2
                = Nothing
  misMatchOrCND :: SolverReportErrCtxt -> ErrorItem
 -              -> TcType -> TcType -> MismatchMsg
 +              -> TcType -> TcType -> TcM MismatchMsg
  -- If oriented then ty1 is actual, ty2 is expected
  misMatchOrCND ctxt item ty1 ty2
    | insoluble_item   -- See Note [Insoluble mis-match]
@@ -2082,10 +2098,10 @@ misMatchOrCND ctxt item ty1 ty2
      || null givens
    = -- If the equality is unconditionally insoluble
      -- or there is no context, don't report the context
 -    mkMismatchMsg item ty1 ty2
 +    return $ mkMismatchMsg item ty1 ty2
    | otherwise
 -  = CouldNotDeduce givens (item :| []) (Just $ CND_Extra level ty1 ty2)
 +  = mkCouldNotDeduceErr givens (item :| []) (Just $ CND_ExpectedActual level ty1 ty2)
    where
      insoluble_item = case ei_m_reason item of
@@ -2275,9 +2291,8 @@ mkQCErr :: HasDebugCallStack => SolverReportErrCtxt -> NonEmpty ErrorItem -> TcM
  mkQCErr ctxt items
    | item1 :| _ <- tryFilter (not . ei_suppress) items
      -- Ignore multiple qc-errors on the same line
 -  = do { let msg = mkPlainMismatchMsg $
 -                   CouldNotDeduce (getUserGivens ctxt) (item1 :| []) Nothing
 -       ; return $ important ctxt msg }
 +  = do { couldNotDeduceErr <- mkCouldNotDeduceErr (getUserGivens ctxt) (item1 :| []) Nothing
 +       ; return $ important ctxt $ mkPlainMismatchMsg couldNotDeduceErr }
  mkDictErr :: HasDebugCallStack => SolverReportErrCtxt -> NonEmpty ErrorItem -> TcM SolverReport
@@ -2292,16 +2307,9 @@ mkDictErr ctxt orig_items
         -- But we report only one of them (hence 'head') because they all
         -- have the same source-location origin, to try avoid a cascade
         -- of error from one location
 -       ; ( err, (imp_errs, hints) ) <-
 -           mk_dict_err ctxt (head (no_inst_items ++ overlap_items))
 -       ; return $
 -           SolverReport
 -             { sr_important_msg = SolverReportWithCtxt ctxt err
 -             , sr_supplementary = [ SupplementaryImportErrors imps
 -                                  | imps <- maybeToList (NE.nonEmpty imp_errs) ]
 -             , sr_hints = hints
 -             }
 -        }
 +       ; err <- mk_dict_err ctxt (head (no_inst_items ++ overlap_items))
 +       ; return $ important ctxt err
 +       }
    where
      items = tryFilter (not . ei_suppress) orig_items
@@ -2335,28 +2343,29 @@ mkDictErr ctxt orig_items
  --     matching and unifying instances, and say "The choice depends on the instantion of ...,
  --     and the result of evaluating ...".
  mk_dict_err :: HasCallStack => SolverReportErrCtxt -> (ErrorItem, ClsInstLookupResult)
 -            -> TcM ( TcSolverReportMsg, ([ImportError], [GhcHint]) )
 +            -> TcM TcSolverReportMsg
  mk_dict_err ctxt (item, (matches, pot_unifiers, unsafe_overlapped))
    = case (NE.nonEmpty matches, NE.nonEmpty unsafe_overlapped) of
    (Nothing, _)  -> do -- No matches but perhaps several unifiers
      { (_, rel_binds, item) <- relevantBindings True ctxt item
      ; candidate_insts <- get_candidate_instances
 -    ; (imp_errs, field_suggestions) <- record_field_suggestions item
 -    ; return (CannotResolveInstance item unifiers candidate_insts rel_binds, (imp_errs, field_suggestions)) }
 +    ; mb_noBuiltinInst_msg <- getNoBuiltinInstMsg item
 +    ; return $
 +        CannotResolveInstance item unifiers candidate_insts rel_binds mb_noBuiltinInst_msg
 +    }
    -- Some matches => overlap errors
    (Just matchesNE, Nothing) -> return $
 -    ( OverlappingInstances item (NE.map fst matchesNE) unifiers, ([], []))
 +    OverlappingInstances item (NE.map fst matchesNE) unifiers
    (Just (match :| []), Just unsafe_overlappedNE) -> return $
 -    ( UnsafeOverlap item (fst match) (NE.map fst unsafe_overlappedNE), ([], []))
 +    UnsafeOverlap item (fst match) (NE.map fst unsafe_overlappedNE)
    (Just matches@(_ :| _), Just overlaps) ->
      pprPanic "mk_dict_err: multiple matches with overlap" $
        vcat [ text "matches:" <+> ppr matches
             , text "overlaps:" <+> ppr overlaps
+            ]
    where
 -    orig        = errorItemOrigin item
      pred        = errorItemPred item
      (clas, tys) = getClassPredTys pred
      unifiers    = getCoherentUnifiers pot_unifiers
@@ -2381,43 +2390,6 @@ mk_dict_err ctxt (item, (matches, pot_unifiers, unsafe_overlapped))
          in different_names && same_occ_names
        | otherwise = False
 -    -- See Note [Out-of-scope fields with -XOverloadedRecordDot]
 -    record_field_suggestions :: ErrorItem -> TcM ([ImportError], [GhcHint])
 -    record_field_suggestions item = flip (maybe $ return ([], noHints)) record_field $ \name ->
 -       do { glb_env <- getGlobalRdrEnv
 -          ; lcl_env <- getLocalRdrEnv
 -          ; let field_name_hints = report_no_fieldnames item
 -          ; (errs, hints) <- if occ_name_in_scope glb_env lcl_env name
 -              then return ([], noHints)
 -              else unknownNameSuggestions emptyLocalRdrEnv WL_RecField (mkRdrUnqual name)
 -          ; pure (errs, hints ++ field_name_hints)
 -          }
+-
 -    -- get type names from instance
 -    -- resolve the type - if it's in scope is it a record?
 -    -- if it's a record, report an error - the record name + the field that could not be found
 -    report_no_fieldnames :: ErrorItem -> [GhcHint]
 -    report_no_fieldnames item
 -       | Just (EvVarDest evvar) <- ei_evdest item
 -       -- we can assume that here we have a `HasField @Symbol x r a` instance
 -       -- because of GetFieldOrigin in record_field
 -       , Just (_, [_symbol, x, r, a]) <- tcSplitTyConApp_maybe (varType evvar)
 -       , Just (r_tycon, _) <- tcSplitTyConApp_maybe r
 -       , Just x_name <- isStrLitTy x
 -       -- we check that this is a record type by checking whether it has any
 -       -- fields (in scope)
 -       , not . null $ tyConFieldLabels r_tycon
 -       = [RemindRecordMissingField x_name r a]
 -       | otherwise = []
+-
 -    occ_name_in_scope glb_env lcl_env occ_name = not $
 -      null (lookupGRE glb_env (LookupOccName occ_name (RelevantGREsFOS WantNormal))) &&
 -      isNothing (lookupLocalRdrOcc lcl_env occ_name)
+-
 -    record_field = case orig of
 -      GetFieldOrigin name -> Just (mkVarOccFS name)
 -      _                   -> Nothing
+-
  {- Note [Report candidate instances]
  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  If we have an unsolved (Num Int), where `Int` is not the Prelude Int,
@@ -2475,6 +2447,245 @@ results in
        in the import of ‘Data.Monoid’
  -}
 +mkCouldNotDeduceErr
 +  :: [UserGiven]
 +  -> NonEmpty ErrorItem
 +  -> Maybe CND_ExpectedActual
 +  -> TcM MismatchMsg
 +mkCouldNotDeduceErr user_givens items@(item :| _) mb_ea
 +  = do { mb_noBuiltinInst_info <- getNoBuiltinInstMsg item
 +       ; return $ CouldNotDeduce user_givens items mb_ea mb_noBuiltinInst_info }
++
 +getNoBuiltinInstMsg :: ErrorItem -> TcM (Maybe NoBuiltinInstanceMsg)
 +getNoBuiltinInstMsg item =
 +  do { rdr_env <- getGlobalRdrEnv
 +     ; fam_envs <- tcGetFamInstEnvs
 +     ; mbNoHasFieldMsg <- hasFieldInfo_maybe rdr_env fam_envs item
 +     ; return $ fmap NoBuiltinHasFieldMsg mbNoHasFieldMsg
 +     }
++
 +{- Note [Error messages for unsolved HasField constraints]
 +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 +The HasField type-class has special instance solving logic, implemented in
 +'GHC.Tc.Instance.Class.{matchHasField,lookupHasFieldLabel}'. This logic is a
 +bit complex, so it's useful to explain to the user why GHC might have failed to
 +solve a 'HasField' constraint. GHC will emit the following error messages for
 +an unsolved constraint of the form 'HasField fld_name rec_ty fld_ty'.
 +These come in two flavours
++
 +  HF1.
 +    Actionable hints: suggest similarly named fields (in case of mis-spelling)
 +    or provide import suggestions (e.g. out of scope field).
 +    See 'GHC.Tc.Errors.Ppr.hasFieldMsgHints' which takes the returned
 +    'HasFieldMsg' and produces the hints we display to the user.
++
 +    This depends on whether 'rec_ty' is a known fixed TyCon or not.
++
 +    HF1a. If 'rec_ty' is a known record TyCon:
 +          - If 'fld_name' is a record field of that TyCon, but it's not in scope,
 +            then suggest importing it.
 +          - Otherwise, we suggest similarly named fields, prioritising similar
 +            name suggestions for record fields from that same TyCon.
++
 +    HF1b. If 'rec_ty' is not a fixed TyCon (e.g. it's a metavariable):
 +          - If 'fld_name' is an in-scope record field, don't suggest anything.
 +          - Otherwise, suggest similar names.
++
 +  HF2. Observations. GHC points out a fact to the user which might help them
 +       understand the problem:
++
 +    HF2a. 'fld_name' is not a string literal.
 +          This is useful when the user has forgotten the quotes, e.g. they
 +          have written 'getField @myFieldName' instead of 'getField @"myFieldName"'.
++
 +    HF2b. 'rec_ty' is a TyCon without any fields, e.g. 'Int' or 'Bool'.
++
 +    HF2c. The record field type 'fld_ty' contains existentials variables
 +          or foralls. In the former case GHC doesn't generate a field selector
 +          at all (it's a naughty record selector), while in the latter GHC
 +          doesn't solve the constraint, because class instance arguments
 +          can't contain foralls.
++
 +    HF2d. The record field is a pattern synonym record field.
 +          GHC does not generate 'HasField' instances for pattern synonym fields.
++
 +    HF2e. The user is using -XRebindableSyntax, and this is not actually the
 +          built-in HasField which GHC has special solving logic for.
++
 +          This can happen rather easily, because the current usage of
 +          -XOverloadedRecordUpdate requires enabling -XRebindableSyntax and
 +          defining a custom 'setField' function.
 +-}
++
 +-- | Try to produce an explanatory message for why GHC was not able to use
 +-- a built-in instance to solve a 'HasField' constraint.
 +--
 +-- See Note [Error messages for unsolved HasField constraints]
 +hasFieldInfo_maybe :: GlobalRdrEnv -> FamInstEnvs -> ErrorItem -> TcM (Maybe HasFieldMsg)
 +hasFieldInfo_maybe rdr_env fam_inst_envs item
 +  | Just (x_ty, rec_ty, _wanted_field_ty) <- hasField_maybe (errorItemPred item)
++
 +  -- This function largely replicates the logic
 +  -- of 'GHC.Tc.Instance.Class.{matchHasField,lookupHasFieldLabel}'.
 +  --
 +  -- When that function fails to return a built-in HasField instance,
 +  -- this function should generate an appropriate message which can be
 +  -- displayed to the user as a hint.
++
 +  = case isStrLitTy x_ty of
 +    { Nothing ->
 +        -- (HF2a) Field label is not a literal string.
 +        return $ Just $ NotALiteralFieldName x_ty
 +    ; Just x ->
 + do { dflags <- getDynFlags
 +    ; let x_fl = FieldLabelString x
 +          looking_for_field = LF WL_RecField WL_Global
 +          fld_var_occ = mkVarOccFS x
 +          lkup_fld_occ = LookupOccName fld_var_occ (RelevantGREsFOS WantField)
 +          similar_names =
 +            similarNameSuggestions looking_for_field
 +              dflags rdr_env emptyLocalRdrEnv (mkRdrUnqual fld_var_occ)
 +    ; (patsyns, suggs) <- partitionEithers <$> mapMaybeM with_parent similar_names
 +    ; imp_suggs <- anyQualImportSuggestions looking_for_field lkup_fld_occ
 +    ; case splitTyConApp_maybe rec_ty of
 +    { Nothing -> do
 +        -- (HF1b) Similar name and import suggestions with unknown TyCon.
 +        --
 +        -- Don't say 'rec is not a record type' if 'rec' is e.g. a type variable.
 +        -- That's not really helpful, especially if 'rec' is a metavariable,
 +        -- in which case this is most likely an ambiguity issue.
 +        let gres = lookupGRE rdr_env lkup_fld_occ
 +        case gres of
 +          _:_ ->
 +            -- If the name was in scope, don't give "similar name" suggestions.
 +            return Nothing
 +          [] -> do
 +            return $ Just $
 +              SuggestSimilarFields Nothing x_fl suggs patsyns imp_suggs
 +    ; Just (rec_tc, rec_args)
 +        | let rec_rep_tc = fstOf3 (tcLookupDataFamInst fam_inst_envs rec_tc rec_args)
 +        ->
 +      if null $ tyConFieldLabels rec_rep_tc
 +      then
 +        -- (HF2b) Not a record TyCon
 +        return $ Just $ NotARecordType rec_ty
 +      else
 +      case lookupTyConFieldLabel x_fl rec_rep_tc of
 +    { Nothing -> do
 +        -- (HF1a) Similar name and import suggestions with known TyCon.
 +        return $ Just $
 +          SuggestSimilarFields (Just (rec_tc, rec_rep_tc)) x_fl suggs patsyns imp_suggs
 +    ; Just fl ->
 +        -- The TyCon does have the field, so the issue might be that
 +        -- it's not in scope or that the field is existential or higher-rank.
 +      case lookupGRE_FieldLabel rdr_env fl of
 +    { Nothing -> do
 +        -- (HF1a) Not in scope. Try to suggest importing the field.
 +        let lookup_gre =
 +              LookupExactName
 +                { lookupExactName = flSelector fl
 +                , lookInAllNameSpaces = False }
 +        imp_suggs <- anyQualImportSuggestions looking_for_field lookup_gre
 +        return $ Just $ OutOfScopeField rec_tc fl imp_suggs
 +    ; Just gre ->
 +      let con1_nm =
 +            case nonDetEltsUniqSet $ recFieldCons $ fieldGREInfo gre of
 +                   n : _ -> n
 +                   [] -> pprPanic "record field with no constructors" (ppr fl)
 +      in case con1_nm of
 +    { PatSynName {} ->
 +      -- 'lookupTyConFieldLabel' always returns a DataCon field
 +      pprPanic "hasFieldInfo_maybe: PatSyn" $
 +        vcat [ text "tc:" <+> ppr rec_tc
 +             , text "rep_tc:" <+> ppr rec_rep_tc
 +             , text "con1_nm:" <+> ppr con1_nm
 +             ]
 +    ; DataConName dc1_nm -> do
 +      dc1 <- tcLookupDataCon dc1_nm
 +      let orig_field_ty = dataConFieldType dc1 (flLabel fl)
 +      return $
 +        -- (HF2c) Existential or higher-rank field.
 +        -- See 'GHC.Tc.Instance.Class.matchHasField', which
 +        -- has these same two conditions.
 +        if |  isExistentialRecordField orig_field_ty (RealDataCon dc1)
 +              -- NB: use 'orig_field_ty' and not 'idType sel_id',
 +              -- because the latter is 'unitTy' when there are existentials.
 +           -> Just $ FieldTooFancy rec_tc x_fl FieldHasExistential
 +           | not $ isTauTy orig_field_ty
 +           -> Just $ FieldTooFancy rec_tc x_fl FieldHasForAlls
 +           | otherwise
 +           -> Nothing
 +             -- Not sure what went wrong. Usually not a type error
 +             -- in the field type, because the functional dependency
 +             -- would cause a genuine equality error.
 +  }}}}}}
++
 +  -- (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
++
 +  | otherwise
 +  = return Nothing
++
 +  where
++
 +    get_parent_nm :: Name -> TcM (Maybe (Either PatSyn TyCon))
 +    get_parent_nm nm =
 +      do { fld_id <- tcLookupId nm
 +         ; return $
 +             case idDetails fld_id of
 +               RecSelId { sel_tycon = parent } ->
 +                 case parent of
 +                  RecSelData tc ->
 +                     Just $ Right tc
 +                  RecSelPatSyn ps ->
 +                    -- (HF2d) PatSyn record fields don't contribute 'HasField'
 +                    --        instances, so tell the user about that.
 +                    Just $ Left ps
 +               _ -> Nothing
 +         }
++
 +    get_parent :: SimilarName -> TcM (Maybe (Either PatSyn TyCon))
 +    get_parent (SimilarName nm) = get_parent_nm nm
 +    get_parent (SimilarRdrName _ mb_gre _) =
 +      case mb_gre of
 +        Nothing -> return Nothing
 +        Just gre -> get_parent_nm $ greName gre
++
 +    with_parent :: SimilarName
 +                -> TcM (Maybe (Either (PatSyn, SimilarName) (TyCon, SimilarName)))
 +    with_parent n = fmap (bimap (,n) (,n)) <$> get_parent n
++
 +-- | Is this constraint definitely 'HasField'?
 +hasField_maybe :: PredType -> Maybe (Type, Type, Type)
 +hasField_maybe pred =
 +  case classifyPredType pred of
 +    ClassPred cls tys
 +      | className cls == hasFieldClassName
 +      , [ _k, _rec_rep, _fld_rep, x_ty, rec_ty, fld_ty ] <- tys
 +      -> Just (x_ty, rec_ty, fld_ty)
 +    _ -> Nothing
 +  -- 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/Errors/Ppr.hs

@@ -63,7 +63,7 @@ import GHC.Core.InstEnv
  import GHC.Core.TyCo.Rep (Type(..))
  import GHC.Core.TyCo.Ppr (pprWithInvisibleBitsWhen, pprSourceTyCon,
                            pprTyVars, pprWithTYPE, pprTyVar, pprTidiedType, pprForAll)
 -import GHC.Core.PatSyn ( patSynName, pprPatSynType )
 +import GHC.Core.PatSyn ( patSynName, pprPatSynType, PatSyn )
  import GHC.Core.TyCo.Tidy
  import GHC.Core.Predicate
  import GHC.Core.Type
@@ -90,7 +90,7 @@ import GHC.Types.DefaultEnv (ClassDefaults(ClassDefaults, cd_types, cd_provenanc
  import GHC.Types.Error
  import GHC.Types.Error.Codes
  import GHC.Types.Hint
 -import GHC.Types.Hint.Ppr ( pprSigLike ) -- & Outputable GhcHint
 +import GHC.Types.Hint.Ppr ( pprSigLike )
  import GHC.Types.Basic
  import GHC.Types.Id
  import GHC.Types.Id.Info ( RecSelParent(..) )
@@ -129,6 +129,9 @@ import qualified GHC.LanguageExtensions as LangExt
  import GHC.Data.BooleanFormula (pprBooleanFormulaNice)
 +import Language.Haskell.Syntax.Basic (field_label, FieldLabelString (..))
++
 +import Control.Monad (guard)
  import qualified Data.Semigroup as S
  import Data.List.NonEmpty (NonEmpty(..))
  import qualified Data.List.NonEmpty as NE
@@ -4114,7 +4117,13 @@ pprTcSolverReportMsg ctxt (UnboundImplicitParams (item :| items)) =
              sep [ text "Unbound implicit parameter" <> plural preds
                  , nest 2 (pprParendTheta preds) ]
       else
 -        let mismatch = CouldNotDeduce givens (item :| items) Nothing
 +        let mismatch =
 +              CouldNotDeduce
 +                { cnd_user_givens   = givens
 +                , cnd_wanted        = item :| items
 +                , cnd_ea            = Nothing
 +                , cnd_noBuiltin_msg = Nothing
 +                }
              invis_bits = mismatchInvisibleBits mismatch
              ppr_msg = pprMismatchMsg ctxt mismatch
          in
@@ -4127,7 +4136,7 @@ pprTcSolverReportMsg _ (AmbiguityPreventsSolvingCt item ambigs) =
    text "prevents the constraint" <+> quotes (pprParendType $ errorItemPred item)
    <+> text "from being solved."
  pprTcSolverReportMsg ctxt@(CEC {cec_encl = implics})
 -  (CannotResolveInstance item unifiers candidates rel_binds)
 +  (CannotResolveInstance item unifiers candidates rel_binds mb_HasField_msg)
    = pprWithInvisibleBits invis_bits $
      vcat
        [ no_inst_msg
@@ -4171,10 +4180,10 @@ pprTcSolverReportMsg ctxt@(CEC {cec_encl = implics})
        | lead_with_ambig
        = (Set.empty, pprTcSolverReportMsg ctxt $ AmbiguityPreventsSolvingCt item (ambig_kvs, ambig_tvs))
        | otherwise
 -      = let mismatch = CouldNotDeduce useful_givens (item :| []) Nothing
 +      = let mismatch = CouldNotDeduce useful_givens (item :| []) Nothing mb_HasField_msg
          in
            ( mismatchInvisibleBits mismatch
 -          , pprMismatchMsg ctxt $ CouldNotDeduce useful_givens (item :| []) Nothing
 +          , pprMismatchMsg ctxt mismatch
+           )
      -- Report "potential instances" only when the constraint arises
@@ -4202,6 +4211,9 @@ pprTcSolverReportMsg ctxt@(CEC {cec_encl = implics})
        | otherwise = Nothing
      extra_note
 +      | Just {} <- mb_HasField_msg
 +      = empty
++
        -- Flag up partially applied uses of (->)
        | any isFunTy (filterOutInvisibleTypes (classTyCon clas) tys)
        = text "(maybe you haven't applied a function to enough arguments?)"
@@ -4417,10 +4429,10 @@ mismatchInvisibleBits
                    , teq_mismatch_ty1      = ty1
                    , teq_mismatch_ty2      = ty2 })
    = shouldPprWithInvisibleBits ty1 ty2 (errorItemOrigin item)
 -mismatchInvisibleBits (CouldNotDeduce { cnd_extra = mb_extra })
 -  = case mb_extra of
 +mismatchInvisibleBits (CouldNotDeduce { cnd_ea = mb_ea })
 +  = case mb_ea of
        Nothing -> Set.empty
 -      Just (CND_Extra _ ty1 ty2) ->
 +      Just (CND_ExpectedActual _ ty1 ty2) ->
          mayLookIdentical ty1 ty2
  -- | Turn a 'MismatchMsg' into an 'SDoc'.
@@ -4612,9 +4624,14 @@ pprMismatchMsg ctxt
      starts_with_vowel (c:_) = c `elem` ("AEIOU" :: String)
      starts_with_vowel []    = False
+-
 -pprMismatchMsg ctxt (CouldNotDeduce useful_givens (item :| others) mb_extra)
 +pprMismatchMsg ctxt
 +  (CouldNotDeduce { cnd_user_givens = useful_givens
 +                  , cnd_wanted = item :| others
 +                  , cnd_ea = mb_ea
 +                  , cnd_noBuiltin_msg = mb_NoBuiltin_msg
 +                  })
    = vcat [ main_msg
 +         , maybe empty pprNoBuiltinInstanceMsg mb_NoBuiltin_msg
           , pprQCOriginExtra item
           , ea_supplementary ]
    where
@@ -4623,9 +4640,10 @@ pprMismatchMsg ctxt (CouldNotDeduce useful_givens (item :| others) mb_extra)
        | otherwise          = vcat ( addArising ct_loc no_deduce_msg
                                    : pp_from_givens useful_givens)
 -    ea_supplementary = case mb_extra of
 -      Nothing                        -> empty
 -      Just (CND_Extra level ty1 ty2) -> mk_supplementary_ea_msg ctxt level ty1 ty2 orig
 +    ea_supplementary = case mb_ea of
 +      Nothing -> empty
 +      Just (CND_ExpectedActual level ty1 ty2) ->
 +        mk_supplementary_ea_msg ctxt level ty1 ty2 orig
      ct_loc = errorItemCtLoc item
      orig   = ctLocOrigin ct_loc
@@ -5022,6 +5040,87 @@ pprCoercibleMsg (OutOfScopeNewtypeConstructor tc dc) =
 (sep [ text "of newtype" <+> quotes (pprSourceTyCon tc)
             , text "is not in scope" ])
 +pprNoBuiltinInstanceMsg :: NoBuiltinInstanceMsg -> SDoc
 +pprNoBuiltinInstanceMsg = \case
 +  NoBuiltinHasFieldMsg msg -> pprHasFieldMsg msg
++
 +pprHasFieldMsg :: HasFieldMsg -> SDoc
 +pprHasFieldMsg = \case
 +  NotALiteralFieldName ty ->
 +    text "NB:" <+> quotes (ppr ty) <+> what
 +      where
 +        what
 +          | Just {} <- getCastedTyVar_maybe ty
 +          = text "is a type variable, not a string literal."
 +          | otherwise
 +          = text "is not a string literal."
 +  NotARecordType ty ->
 +    text "NB:" <+> quotes (ppr ty) <+> text "is not a record type."
 +  OutOfScopeField tc fld _import_suggs ->
 +    text "NB: the record field" <+> quotes (ppr fld) <+> text "of" <+> quotes (ppr tc) <+> text "is out of scope."
 +  FieldTooFancy tc fld rea ->
 +    case rea of
 +      FieldHasExistential ->
 +        text "NB: the record field" <+> quotes (ppr fld) <+> text "of" <+> quotes (ppr tc) <+> text "contains existential variables."
 +      FieldHasForAlls ->
 +        text "NB: the field type of the record field" <+> quotes (ppr fld) <+> text "of" <+> quotes (ppr tc) <+> text "is not a mono-type."
 +  CustomHasField custom_hasField ->
 +    text "NB:" <+> quotes (ppr custom_hasField) <+> text "is not the built-in"
 +      <+> quotes (ppr hasFieldClassName) <+> text "class."
 +  SuggestSimilarFields (Just (tc, rep_tc)) fld suggs pat_syns _imp_suggs ->
 +    vcat
 +      [   text "NB:" <+> quotes (ppr tc)
 +      <+> text "does not have a record field named"
 +      <+> quotes (ppr fld) <> dot
 +      , pprHasFieldPatSynMsg fld pat_syns
 +      , pprSameNameOtherTyCons (mapMaybe same_name_diff_tc suggs)
 +        -- NB: The actual suggestions are dealt with by
 +        -- GHC.Tc.Errors.hasFieldMsgHints. The logic here just covers
 +        -- information for which there is no actionable hint.
 +      ]
 +    where
 +      same_name_diff_tc (rep_tc', fld') = do
 +        let occ = case fld' of
 +                     SimilarName n -> getOccFS n
 +                     SimilarRdrName n _ _ -> occNameFS $ rdrNameOcc n
 +        guard $
 +          rep_tc' /= rep_tc
 +            &&
 +          (fld == FieldLabelString occ)
 +        return rep_tc'
 +  SuggestSimilarFields Nothing fld _suggs pat_syns _imp_suggs ->
 +    pprHasFieldPatSynMsg fld pat_syns
 +    -- Most of the error message only makes sense when we know the TyCon.
 +    -- In this "unknown TyCon" case, we only have:
 +    --   - the "PatSyns don't give HasField instances" message
 +    --   - the hints, which are handled separately (see 'hasFieldMsgHints').
++
 +pprSameNameOtherTyCons :: [TyCon] -> SDoc
 +pprSameNameOtherTyCons [] = empty
 +pprSameNameOtherTyCons tcs =
 +  other_types_have <+> text "a field of this name:"
 +    <+> pprWithCommas (quotes . ppr) tcs <> dot
 +  where
 +    other_types_have :: SDoc
 +    other_types_have = case tcs of
 +      _:_:_ -> "Other types have"
 +      _     -> "Another type has"
++
 +pprHasFieldPatSynMsg :: FieldLabelString -> [(PatSyn, SimilarName)] -> SDoc
 +pprHasFieldPatSynMsg fld pat_syns =
 +  if any same_name pat_syns
 +  then
 +    text "Pattern synonym record fields do not contribute"
 +      <+> quotes (ppr hasFieldClassName) <+> text "instances."
 +  else empty
 +  where
 +    same_name (_,nm) =
 +      let occ = case nm of
 +                  SimilarName n -> getOccFS n
 +                  SimilarRdrName n _ _ -> occNameFS $ rdrNameOcc n
 +      in
 +        occ == field_label fld
++
  pprWhenMatching :: SolverReportErrCtxt -> WhenMatching -> SDoc
  pprWhenMatching ctxt (WhenMatching cty1 cty2 sub_o mb_sub_t_or_k) =
    sdocOption sdocPrintExplicitCoercions $ \printExplicitCoercions ->
@@ -5247,8 +5346,8 @@ tcSolverReportMsgHints ctxt = \case
      -> noHints
    AmbiguityPreventsSolvingCt {}
      -> noHints
 -  CannotResolveInstance {}
 -    -> noHints
 +  CannotResolveInstance { cannotResolve_noBuiltinMsg = mb_noBuiltin }
 +    -> maybe noHints noBuiltinInstanceHints mb_noBuiltin
    OverlappingInstances {}
      -> noHints
    UnsafeOverlap {}
@@ -5256,22 +5355,66 @@ tcSolverReportMsgHints ctxt = \case
    MultiplicityCoercionsNotSupported {}
     -> noHints
 +noBuiltinInstanceHints :: NoBuiltinInstanceMsg -> [GhcHint]
 +noBuiltinInstanceHints = \case
 +  NoBuiltinHasFieldMsg noHasFieldMsg -> hasFieldMsgHints noHasFieldMsg
++
 +hasFieldMsgHints :: HasFieldMsg -> [GhcHint]
 +hasFieldMsgHints = \case
 +  NotALiteralFieldName {} -> noHints
 +  NotARecordType {}       -> noHints
 +  FieldTooFancy {}        -> noHints
 +  SuggestSimilarFields mb_orig_tc orig_fld suggs _patsyns imp_suggs ->
 +    map (ImportSuggestion fld_occ) imp_suggs ++ similar_suggs
 +    where
 +      fld_occ = mkVarOccFS $ field_label orig_fld
 +      similar_suggs =
 +        case NE.nonEmpty $ filter different_name suggs of
 +          Nothing -> noHints
 +          Just neSuggs ->
 +            case mb_orig_tc of
 +              Just (orig_tc, orig_rep_tc) ->
 +                -- We know the parent TyCon
 +                [SuggestSimilarSelectors orig_tc orig_rep_tc orig_fld neSuggs]
 +              Nothing ->
 +                -- We don't know the parent TyCon
 +                [ SuggestSimilarNames
 +                    (mkRdrUnqual fld_occ)
 +                    (fmap snd neSuggs)
 +                ]
 +      different_name ( _, nm ) =
 +        let occ = case nm of
 +                    SimilarName n -> getOccFS n
 +                    SimilarRdrName n _ _ -> occNameFS $ rdrNameOcc n
 +        in
 +          orig_fld /= FieldLabelString occ
 +  OutOfScopeField _tc fld import_suggs ->
 +    map (ImportSuggestion (nameOccName $ flSelector fld)) import_suggs
 +  CustomHasField {} -> noHints
++
  mismatchMsgHints :: SolverReportErrCtxt -> MismatchMsg -> [GhcHint]
  mismatchMsgHints ctxt msg =
 +  mismatchMsgHasFieldHints msg ++
    maybeToList [ hint | (exp,act) <- mismatchMsg_ExpectedActuals msg
                       , hint <- suggestAddSig ctxt exp act ]
 +mismatchMsgHasFieldHints :: MismatchMsg -> [GhcHint]
 +mismatchMsgHasFieldHints
 +  (CouldNotDeduce { cnd_noBuiltin_msg = mb_noBuiltin }) =
 +    maybe noHints noBuiltinInstanceHints mb_noBuiltin
 +mismatchMsgHasFieldHints (BasicMismatch{}) = []
 +mismatchMsgHasFieldHints (TypeEqMismatch{}) = []
++
  mismatchMsg_ExpectedActuals :: MismatchMsg -> Maybe (Type, Type)
  mismatchMsg_ExpectedActuals = \case
    BasicMismatch { mismatch_ty1 = exp, mismatch_ty2 = act } ->
      Just (exp, act)
    TypeEqMismatch { teq_mismatch_expected = exp, teq_mismatch_actual = act } ->
      Just (exp,act)
 -  CouldNotDeduce { cnd_extra = cnd_extra }
 -    | Just (CND_Extra _ exp act) <- cnd_extra
 -    -> Just (exp, act)
 -    | otherwise
 -    -> Nothing
 +  CouldNotDeduce { cnd_ea = mb_ea } ->
 +    case mb_ea of
 +      Just (CND_ExpectedActual _ exp act) -> Just (exp, act)
 +      Nothing -> Nothing
  cannotUnifyVariableHints :: CannotUnifyVariableReason -> [GhcHint]
  cannotUnifyVariableHints = \case

compiler/GHC/Tc/Errors/Types.hs

@@ -72,7 +72,7 @@ module GHC.Tc.Errors.Types (
    , ExpectedActualInfo(..)
    , TyVarInfo(..), SameOccInfo(..)
    , AmbiguityInfo(..)
 -  , CND_Extra(..)
 +  , CND_ExpectedActual(..)
    , FitsMbSuppressed(..)
    , ValidHoleFits(..), noValidHoleFits
    , HoleFitDispConfig(..)
@@ -86,6 +86,9 @@ module GHC.Tc.Errors.Types (
    , lookingForSubordinate
    , HoleError(..)
    , CoercibleMsg(..)
 +  , NoBuiltinInstanceMsg(..)
 +  , HasFieldMsg(..)
 +  , TooFancyField(..)
    , PotentialInstances(..)
    , UnsupportedCallConvention(..)
    , ExpectedBackends
@@ -200,7 +203,7 @@ import GHC.Tc.Utils.TcType (TcType, TcSigmaType, TcPredType,
  import GHC.Types.Basic
  import GHC.Types.Error
  import GHC.Types.Avail
 -import GHC.Types.Hint (UntickedPromotedThing(..), AssumedDerivingStrategy(..), SigLike)
 +import GHC.Types.Hint
  import GHC.Types.ForeignCall (CLabelString)
  import GHC.Types.Id.Info ( RecSelParent(..) )
  import GHC.Types.Name (NamedThing(..), Name, OccName, getSrcLoc, getSrcSpan)
@@ -5615,6 +5618,7 @@ data TcSolverReportMsg
      , cannotResolve_unifiers     :: [ClsInst]
      , cannotResolve_candidates   :: [ClsInst]
      , cannotResolve_relBinds     :: RelevantBindings
 +    , cannotResolve_noBuiltinMsg :: Maybe NoBuiltinInstanceMsg
+     }
    -- | Could not solve a constraint using available instances
@@ -5675,15 +5679,20 @@ data MismatchMsg
    -- Used for messages such as @"No instance for ..."@ and
    -- @"Could not deduce ... from"@.
    | CouldNotDeduce
 -     { cnd_user_givens :: [Implication]
 +     { cnd_user_givens   :: [Implication]
          -- | The Wanted constraints we couldn't solve.
          --
          -- N.B.: the 'ErrorItem' at the head of the list has been tidied,
          -- perhaps not the others.
 -     , cnd_wanted      :: NE.NonEmpty ErrorItem
 +     , cnd_wanted        :: NE.NonEmpty ErrorItem
 -       -- | Some additional info consumed by 'mk_supplementary_ea_msg'.
 -     , cnd_extra       :: Maybe CND_Extra
 +       -- | Additional "expected/actual" information
 +       -- consumed by 'mk_supplementary_ea_msg'.
 +     , cnd_ea            :: Maybe CND_ExpectedActual
++
 +       -- | Additional message relating to unsolved constraints for
 +       -- typeclasses which have built-in instances.
 +     , cnd_noBuiltin_msg :: Maybe NoBuiltinInstanceMsg
+      }
    deriving Generic
@@ -5753,7 +5762,7 @@ mkPlainMismatchMsg msg
  -- | Additional information to be given in a 'CouldNotDeduce' message,
  -- which is then passed on to 'mk_supplementary_ea_msg'.
 -data CND_Extra = CND_Extra TypeOrKind Type Type
 +data CND_ExpectedActual = CND_ExpectedActual TypeOrKind Type Type
  -- | A cue to print out information about type variables,
  -- e.g. where they were bound, when there is a mismatch @tv1 ~ ty2@.
@@ -5967,6 +5976,48 @@ data CoercibleMsg
    -- Test cases: TcCoercibleFail.
    | OutOfScopeNewtypeConstructor TyCon DataCon
 +-- | Explains why GHC wasn't able to provide a built-in instance for
 +-- a particular class.
 +data NoBuiltinInstanceMsg
 +  = NoBuiltinHasFieldMsg HasFieldMsg
++
 +  -- Other useful constructors might be:
 +  -- NoBuiltinTypeableMsg  -- explains polykinded Typeable restrictions
 +  -- NoBuiltinDataToTagMsg -- see conditions in Note [DataToTag overview]
 +  -- NoBuiltinWithDictMsg  -- see Note [withDict]
++
 +-- | Explains why GHC wasn't able to provide a built-in 'HasField' instance
 +-- for the given types.
 +data HasFieldMsg
 +  -- | The field is not a literal field name, e.g. @HasField x u v@ where @x@
 +  -- is a type variable.
 +  = NotALiteralFieldName Type
 +  -- | The type we are selecting from is not a record type,
 +  -- e.g. @HasField "fld" Int fld@.
 +  | NotARecordType Type
 +  -- | The field is out of scope.
 +  | OutOfScopeField TyCon FieldLabel [ImportSuggestion]
 +  -- | The field has a type which means that GHC cannot solve
 +  -- a 'HasField' constraint for it.
 +  | FieldTooFancy TyCon FieldLabelString TooFancyField
 +  -- | No such field, but the field is perhaps mis-spelled;
 +  -- here are some suggestions.
 +  | SuggestSimilarFields
 +      (Maybe (TyCon, TyCon)) -- ^ (optional) desired parent (tc and rep_tc)
 +      FieldLabelString       -- ^ field name
 +      [(TyCon, SimilarName)]         -- ^ suggestions (for this 'TyCon' or other 'TyCon's)
 +      [(PatSyn, SimilarName)]       -- ^ pattern synonyms with similarly named fields
 +      [ImportSuggestion]     -- ^ import suggestions
++
 +  -- | Using -XRebindableSyntax and a different 'HasField'.
 +  | CustomHasField TyCon -- ^ the custom HasField TyCon
++
 +-- | Why is a record field "too fancy" for GHC to be able to properly
 +-- solve a 'HasField' constraint?
 +data TooFancyField
 +  = FieldHasExistential
 +  | FieldHasForAlls
++
  -- | Explain a problem with an import.
  data ImportError
    -- | Couldn't find a module with the requested name.

compiler/GHC/Tc/Instance/Class.hs

@@ -1247,6 +1247,11 @@ matchHasField dflags short_cut clas tys mb_ct_loc
                       -- The selector must not be "naughty" (i.e. the field
                       -- cannot have an existentially quantified type),
                       -- and it must not be higher-rank.
 +                     --
 +                     -- See also 'GHC.Tc.Errors.hasFieldInfo_maybe', which is
 +                     -- responsible for the error messages in cases of unsolved
 +                     -- HasField constraints when the field type runs afoul
 +                     -- of these conditions.
                     ; if (isNaughtyRecordSelector sel_id) || not (isTauTy sel_ty)
                       then try_user_instances
                       else
@@ -1306,6 +1311,11 @@ lookupHasFieldLabel
  -- A complication is that `T` might be a data family, so we need to
  -- look it up in the `fam_envs` to find its representation tycon.
  lookupHasFieldLabel fam_inst_envs rdr_env arg_tys
++
 +  -- NB: if you edit this function, you might also want to update
 +  -- GHC.Tc.Errors.hasfieldInfo_maybe which is responsible for error messages
 +  -- when GHC /does not/ solve a 'HasField' constraint.
++
    |  -- We are matching HasField {k} {r_rep} {a_rep} x r a...
      (_k : _rec_rep : _fld_rep : x_ty : rec_ty : fld_ty : _) <- arg_tys
      -- x should be a literal string

compiler/GHC/Tc/TyCl/PatSyn.hs

@@ -136,7 +136,7 @@ tcInferPatSynDecl (PSB { psb_id = lname@(L _ name), psb_args = details
         ; let (arg_names, is_infix) = collectPatSynArgInfo details
         ; (tclvl, wanted, ((lpat', args), pat_ty))
              <- pushLevelAndCaptureConstraints      $
 -               tcInferPat FRRPatSynArg PatSyn lpat $
 +               tcInferPat FRRPatSynArg PatSynCtx lpat $
                 mapM tcLookupId arg_names
         ; let (ex_tvs, prov_dicts) = tcCollectEx lpat'
@@ -421,7 +421,7 @@ tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details
             assertPpr (equalLength arg_names arg_tys) (ppr name $$ ppr arg_names $$ ppr arg_tys) $
             pushLevelAndCaptureConstraints   $
             tcExtendNameTyVarEnv univ_tv_prs $
 -           tcCheckPat PatSyn lpat (unrestricted skol_pat_ty)   $
 +           tcCheckPat PatSynCtx lpat (unrestricted skol_pat_ty)   $
             do { let in_scope    = mkInScopeSetList skol_univ_tvs
                      empty_subst = mkEmptySubst in_scope
                ; (inst_subst, ex_tvs') <- mapAccumLM newMetaTyVarX empty_subst skol_ex_tvs
@@ -843,7 +843,7 @@ tcPatSynMatcher (L loc ps_name) lpat prag_fn
               gen = Generated OtherExpansion SkipPmc
               body = mkLHsWrap (mkWpLet req_ev_binds) $
                      L (getLoc lpat) $
 -                    HsCase PatSyn (nlHsVar scrutinee) $
 +                    HsCase PatSynCtx (nlHsVar scrutinee) $
                      MG{ mg_alts = L (l2l $ getLoc lpat) cases
                        , mg_ext = MatchGroupTc [unrestricted pat_ty] res_ty gen
+                       }

compiler/GHC/Tc/TyCl/Utils.hs

@@ -21,7 +21,7 @@ module GHC.Tc.TyCl.Utils(
          addTyConsToGblEnv, mkDefaultMethodType,
          -- * Record selectors
 -        tcRecSelBinds, mkRecSelBinds, mkOneRecordSelector
 +        tcRecSelBinds, mkRecSelBinds, mkOneRecordSelector,
      ) where
  import GHC.Prelude
@@ -899,7 +899,7 @@ mkOneRecordSelector all_cons idDetails fl has_sel
      -- Selector type; Note [Polymorphic selectors]
 -    (univ_tvs, _, _, _, req_theta, _, data_ty) = conLikeFullSig con1
 +    (_, _, _, _, req_theta, _, data_ty) = conLikeFullSig con1
      field_ty     = conLikeFieldType con1 lbl
      field_ty_tvs = tyCoVarsOfType field_ty
@@ -909,17 +909,13 @@ mkOneRecordSelector all_cons idDetails fl has_sel
                     conLikeUserTyVarBinders con1
      -- is_naughty: see Note [Naughty record selectors]
 -    is_naughty = not ok_scoping || no_selectors
 -    ok_scoping = case con1 of
 -                   RealDataCon {} -> field_ty_tvs `subVarSet` data_ty_tvs
 -                   PatSynCon {}   -> field_ty_tvs `subVarSet` mkVarSet univ_tvs
 -       -- In the PatSynCon case, the selector type is (data_ty -> field_ty), but
 -       -- fvs(data_ty) are all universals (see Note [Pattern synonym result type] in
 -       -- GHC.Core.PatSyn, so no need to check them.
+-
 -    no_selectors   = has_sel == NoFieldSelectors  -- No field selectors => all are naughty
 -                                                  -- thus suppressing making a binding
 -                                                  -- A slight hack!
 +    is_naughty = isExistentialRecordField field_ty con1 || no_selectors
++
 +    no_selectors   = has_sel == NoFieldSelectors
 +      -- For PatternSynonyms with -XNoFieldSelectors, pretend the fields
 +      -- are naughty record selectors to suppress making a binding.
 +      --
 +      -- See Note [NoFieldSelectors and naughty record selectors]
      sel_ty | is_naughty = unitTy  -- See Note [Naughty record selectors]
             | otherwise  = mkForAllTys sel_tvbs $

compiler/GHC/Tc/Types/Origin.hs

@@ -524,7 +524,7 @@ data CtOrigin
    ----------- Below here, all are Origins for Wanted constraints ------------
    | OccurrenceOf Name          -- ^ Occurrence of an overloaded identifier
 -  | OccurrenceOfRecSel RdrName -- ^ Occurrence of a record selector
 +  | OccurrenceOfRecSel (LocatedN RdrName) -- ^ Occurrence of a record selector
    | AppOrigin                  -- ^ An application of some kind
    | SpecPragOrigin UserTypeCtxt    -- ^ Specialisation pragma for
@@ -558,7 +558,10 @@ data CtOrigin
                          -- IMPORTANT: These constraints will never cause errors;
                          -- See Note [Constraints to ignore] in GHC.Tc.Errors
    | SectionOrigin
 -  | GetFieldOrigin FastString
 +  | GetFieldOrigin (LocatedN FastString)
++
 +  -- | A overloaded record field projection like @.fld@ or @.fld1.fld2.fld@.
 +  | RecordFieldProjectionOrigin (FieldLabelStrings GhcRn)
    | TupleOrigin         -- (..,..)
    | ExprSigOrigin       -- e :: ty
    | PatSigOrigin        -- p :: ty
@@ -566,7 +569,7 @@ data CtOrigin
    | ProvCtxtOrigin      -- The "provided" context of a pattern synonym signature
          (PatSynBind GhcRn GhcRn) -- Information about the pattern synonym, in
                                   -- particular the name and the right-hand side
 -  | RecordUpdOrigin
 +  | RecordUpdOrigin (LHsRecUpdFields GhcRn)
    | ViewPatOrigin
    -- | 'ScOrigin' is used only for the Wanted constraints for the
@@ -737,7 +740,7 @@ lexprCtOrigin (L _ e) = exprCtOrigin e
  exprCtOrigin :: HsExpr GhcRn -> CtOrigin
  exprCtOrigin (HsVar _ (L _ (WithUserRdr _ name))) = OccurrenceOf name
 -exprCtOrigin (HsGetField _ _ (L _ f)) = GetFieldOrigin (field_label $ unLoc $ dfoLabel f)
 +exprCtOrigin (HsGetField _ _ (L _ f)) = GetFieldOrigin (fmap field_label $ dfoLabel f)
  exprCtOrigin (HsOverLabel _ l)  = OverLabelOrigin l
  exprCtOrigin (ExplicitList {})    = ListOrigin
  exprCtOrigin (HsIPVar _ ip)       = IPOccOrigin ip
@@ -749,9 +752,9 @@ exprCtOrigin (HsAppType _ e1 _)   = lexprCtOrigin e1
  exprCtOrigin (OpApp _ _ op _)     = lexprCtOrigin op
  exprCtOrigin (NegApp _ e _)       = lexprCtOrigin e
  exprCtOrigin (HsPar _ e)          = lexprCtOrigin e
 -exprCtOrigin (HsProjection _ _)   = SectionOrigin
 -exprCtOrigin (SectionL _ _ _)     = SectionOrigin
 -exprCtOrigin (SectionR _ _ _)     = SectionOrigin
 +exprCtOrigin (HsProjection _ p)   = RecordFieldProjectionOrigin (FieldLabelStrings $ fmap noLocA p)
 +exprCtOrigin (SectionL {})        = SectionOrigin
 +exprCtOrigin (SectionR {})        = SectionOrigin
  exprCtOrigin (ExplicitTuple {})   = Shouldn'tHappenOrigin "explicit tuple"
  exprCtOrigin ExplicitSum{}        = Shouldn'tHappenOrigin "explicit sum"
  exprCtOrigin (HsCase _ _ matches) = matchesCtOrigin matches
@@ -760,7 +763,7 @@ exprCtOrigin (HsMultiIf _ rhs)   = lGRHSCtOrigin rhs
  exprCtOrigin (HsLet _ _ e)       = lexprCtOrigin e
  exprCtOrigin (HsDo {})           = DoOrigin
  exprCtOrigin (RecordCon {})      = Shouldn'tHappenOrigin "record construction"
 -exprCtOrigin (RecordUpd {})      = RecordUpdOrigin
 +exprCtOrigin (RecordUpd _ _ flds)= RecordUpdOrigin flds
  exprCtOrigin (ExprWithTySig {})  = ExprSigOrigin
  exprCtOrigin (ArithSeq {})       = Shouldn'tHappenOrigin "arithmetic sequence"
  exprCtOrigin (HsPragE _ _ e)     = lexprCtOrigin e
@@ -779,7 +782,7 @@ exprCtOrigin (XExpr (ExpandedThingRn thing _)) | OrigExpr a <- thing = exprCtOri
                                                 | OrigStmt _ <- thing = DoOrigin
                                                 | OrigPat p  <- thing = DoPatOrigin p
  exprCtOrigin (XExpr (PopErrCtxt {})) = Shouldn'tHappenOrigin "PopErrCtxt"
 -exprCtOrigin (XExpr (HsRecSelRn f))  = OccurrenceOfRecSel (foExt f)
 +exprCtOrigin (XExpr (HsRecSelRn f))  = OccurrenceOfRecSel $ L (getLoc $ foLabel f) (foExt f)
  -- | Extract a suitable CtOrigin from a MatchGroup
  matchesCtOrigin :: MatchGroup GhcRn (LHsExpr GhcRn) -> CtOrigin
@@ -937,7 +940,7 @@ ppr_br AppOrigin             = text "an application"
  ppr_br (IPOccOrigin name)    = hsep [text "a use of implicit parameter", quotes (ppr name)]
  ppr_br (OverLabelOrigin l)   = hsep [text "the overloaded label"
                                      ,quotes (char '#' <> ppr l)]
 -ppr_br RecordUpdOrigin       = text "a record update"
 +ppr_br (RecordUpdOrigin {})  = text "a record update"
  ppr_br ExprSigOrigin         = text "an expression type signature"
  ppr_br PatSigOrigin          = text "a pattern type signature"
  ppr_br PatOrigin             = text "a pattern"
@@ -945,6 +948,7 @@ ppr_br ViewPatOrigin         = text "a view pattern"
  ppr_br (LiteralOrigin lit)   = hsep [text "the literal", quotes (ppr lit)]
  ppr_br (ArithSeqOrigin seq)  = hsep [text "the arithmetic sequence", quotes (ppr seq)]
  ppr_br SectionOrigin         = text "an operator section"
 +ppr_br (RecordFieldProjectionOrigin p) = text "the record selector" <+> quotes (ppr p)
  ppr_br (GetFieldOrigin f)    = hsep [text "selecting the field", quotes (ppr f)]
  ppr_br AssocFamPatOrigin     = text "the LHS of a family instance"
  ppr_br TupleOrigin           = text "a tuple"

compiler/GHC/Types/Hint.hs

@@ -42,12 +42,14 @@ import GHC.Core.TyCon (TyCon)
  import GHC.Core.Type (Type)
  import GHC.Types.Fixity (LexicalFixity(..))
  import GHC.Types.Name (Name, NameSpace, OccName (occNameFS), isSymOcc, nameOccName)
 -import GHC.Types.Name.Reader (RdrName (Unqual), ImpDeclSpec)
 +import GHC.Types.Name.Reader (RdrName (Unqual), ImpDeclSpec, GlobalRdrElt)
  import GHC.Types.SrcLoc (SrcSpan)
  import GHC.Types.Basic (Activation, RuleName)
  import GHC.Parser.Errors.Basic
  import GHC.Utils.Outputable
 -import GHC.Data.FastString (fsLit, FastString)
 +import GHC.Data.FastString (fsLit)
++
 +import Language.Haskell.Syntax.Basic (FieldLabelString)
  import Data.Typeable ( Typeable )
  import Data.Map.Strict (Map)
@@ -394,6 +396,12 @@ data GhcHint
    -}
    | SuggestSimilarNames RdrName (NE.NonEmpty SimilarName)
 +  {-| Suggest a similar record selector that the user might have meant.
++
 +      Test case: T26480b.
 +  -}
 +  | SuggestSimilarSelectors TyCon TyCon FieldLabelString (NE.NonEmpty (TyCon, SimilarName))
++
    {-| Remind the user that the field selector has been suppressed
        because of -XNoFieldSelectors.
@@ -464,9 +472,6 @@ data GhcHint
    {-| Suggest eta-reducing a type synonym used in the implementation
        of abstract data. -}
    | SuggestEtaReduceAbsDataTySyn TyCon
 -  {-| Remind the user that there is no field of a type and name in the record,
 -      constructors are in the usual order $x$, $r$, $a$ -}
 -  | RemindRecordMissingField FastString Type Type
    {-| Suggest binding the type variable on the LHS of the type declaration
    -}
    | SuggestBindTyVarOnLhs RdrName
@@ -579,7 +584,7 @@ data HowInScope
  data SimilarName
    = SimilarName Name
 -  | SimilarRdrName RdrName (Maybe HowInScope)
 +  | SimilarRdrName RdrName (Maybe GlobalRdrElt) (Maybe HowInScope)
  -- | Some kind of signature, such as a fixity signature, standalone
  -- kind signature, COMPLETE pragma, role annotation, etc.

compiler/GHC/Types/Hint/Ppr.hs

@@ -15,7 +15,7 @@ import GHC.Types.Hint
  import GHC.Core.FamInstEnv (FamFlavor(..))
  import GHC.Core.TyCon
 -import GHC.Core.TyCo.Rep     ( mkVisFunTyMany )
 +import GHC.Hs.Binds (hsSigDoc)
  import GHC.Hs.Expr ()   -- instance Outputable
  import GHC.Types.Id
  import GHC.Types.Name
@@ -25,14 +25,16 @@ import GHC.Unit.Module.Imported (ImportedModsVal(..))
  import GHC.Unit.Types
  import GHC.Utils.Outputable
 +import qualified GHC.LanguageExtensions as LangExt
++
  import GHC.Driver.Flags
 +import Language.Haskell.Syntax.Basic (FieldLabelString)
++
 +import Data.List (partition)
  import qualified Data.List.NonEmpty as NE
  import qualified Data.Map.Strict as Map
 -import qualified GHC.LanguageExtensions as LangExt
 -import GHC.Hs.Binds (hsSigDoc)
+-
  instance Outputable GhcHint where
    ppr = \case
      UnknownHint m
@@ -198,7 +200,9 @@ instance Outputable GhcHint where
                                , nest 2 (pprWithCommas pp_item $ NE.toList similar_names) ]
          where
            tried_ns = occNameSpace $ rdrNameOcc tried_rdr_name
 -          pp_item = pprSimilarName tried_ns
 +          pp_item = pprSimilarName (Just tried_ns)
 +    SuggestSimilarSelectors tc rep_tc fld suggs ->
 +      pprSimilarFields tc rep_tc fld (NE.toList suggs)
      RemindFieldSelectorSuppressed rdr_name parents
        -> text "Notice that" <+> quotes (ppr rdr_name)
           <+> text "is a field selector" <+> whose
@@ -255,12 +259,6 @@ instance Outputable GhcHint where
      SuggestEtaReduceAbsDataTySyn tc
        -> text "If possible, eta-reduce the type synonym" <+> ppr_tc <+> text "so that it is nullary."
          where ppr_tc = quotes (ppr $ tyConName tc)
 -    RemindRecordMissingField x r a ->
 -      text "NB: There is no field selector" <+> ppr_sel
 -        <+> text "in scope for record type" <+> ppr_r
 -      where ppr_sel = quotes (ftext x <+> dcolon <+> ppr_arr_r_a)
 -            ppr_arr_r_a = ppr $ mkVisFunTyMany r a
 -            ppr_r = quotes $ ppr r
      SuggestBindTyVarOnLhs tv
        -> text "Bind" <+> quotes (ppr tv) <+> text "on the LHS of the type declaration"
      SuggestAnonymousWildcard
@@ -405,10 +403,10 @@ pprImportSuggestion dc_occ (ImportDataCon { ies_suggest_import_from = Just mod
      parens_sp d = parens (space <> d <> space)
  -- | Pretty-print a 'SimilarName'.
 -pprSimilarName :: NameSpace -> SimilarName -> SDoc
 +pprSimilarName :: Maybe NameSpace -> SimilarName -> SDoc
  pprSimilarName _ (SimilarName name)
    = quotes (ppr name) <+> parens (pprDefinedAt name)
 -pprSimilarName tried_ns (SimilarRdrName rdr_name how_in_scope)
 +pprSimilarName mb_tried_ns (SimilarRdrName rdr_name _gre_info how_in_scope)
    = pp_ns rdr_name <+> quotes (ppr rdr_name) <+> loc
    where
      loc = case how_in_scope of
@@ -421,8 +419,12 @@ pprSimilarName tried_ns (SimilarRdrName rdr_name how_in_scope)
          ImportedBy is ->
            parens (text "imported from" <+> ppr (moduleName $ is_mod is))
      pp_ns :: RdrName -> SDoc
 -    pp_ns rdr | ns /= tried_ns = pprNameSpace ns
 -              | otherwise      = empty
 +    pp_ns rdr
 +      | Just tried_ns <- mb_tried_ns
 +      , ns /= tried_ns
 +      = pprNameSpace ns
 +      | otherwise
 +      = empty
        where ns = rdrNameSpace rdr
  pprImpliedExtensions :: LangExt.Extension -> SDoc
@@ -437,6 +439,34 @@ pprPrefixUnqual :: Name -> SDoc
  pprPrefixUnqual name =
    pprPrefixOcc (getOccName name)
 +pprSimilarFields :: TyCon -> TyCon -> FieldLabelString -> [(TyCon, SimilarName)] -> SDoc
 +pprSimilarFields _tc rep_tc _fld suggs
 +  | null suggs
 +  = empty
 +  -- There are similarly named fields for the right TyCon: report those first.
 +  | same_tc_sugg1 : same_tc_rest <- same_tc
 +  = case same_tc_rest of
 +      [] ->
 +        text "Perhaps use" <+> ppr_same_tc same_tc_sugg1 <> dot
 +      _ ->
 +        vcat [ text "Perhaps use one of"
 +             , nest 2 $ pprWithCommas ppr_same_tc same_tc
 +             ]
 +  -- Otherwise, report the similarly named fields for other TyCons.
 +  | otherwise
 +  = vcat [ text "Perhaps use" <+> similar_field <+> text "of another type" <> colon
 +         , nest 2 $ pprWithCommas ppr_other_tc others
 +         ]
 +  where
 +    (same_tc, others) = partition ((== rep_tc) . fst) suggs
 +    similar_field =
 +      case others of
 +        _:_:_ -> "one of the similarly named fields"
 +        _     -> "the similarly named field"
 +    ppr_same_tc (_, nm) = pprSimilarName Nothing nm
 +    ppr_other_tc (other_tc, nm) =
 +      quotes (ppr other_tc) <> colon <+> pprSimilarName Nothing nm
++
  pprSigLike :: SigLike -> SDoc
  pprSigLike = \case
    SigLikeSig sig ->

compiler/Language/Haskell/Syntax/Expr.hs

@@ -1403,7 +1403,7 @@ data HsMatchContext fn
    | ThPatSplice            -- ^A Template Haskell pattern splice
    | ThPatQuote             -- ^A Template Haskell pattern quotation [p| (a,b) |]
 -  | PatSyn                 -- ^A pattern synonym declaration
 +  | PatSynCtx              -- ^A pattern synonym declaration
    | LazyPatCtx             -- ^An irrefutable pattern
  {- Note [mc_fun field of FunRhs]
@@ -1467,8 +1467,8 @@ qualifiedDoModuleName_maybe ctxt = case ctxt of
  isPatSynCtxt :: HsMatchContext fn -> Bool
  isPatSynCtxt ctxt =
    case ctxt of
 -    PatSyn -> True
 -    _      -> False
 +    PatSynCtx -> True
 +    _         -> False
  isComprehensionContext :: HsStmtContext fn -> Bool
  -- Uses comprehension syntax [ e | quals ]

testsuite/tests/overloadedrecflds/should_fail/T26480.hs

 +{-# LANGUAGE DataKinds #-}
 +{-# LANGUAGE PatternSynonyms #-}
++
 +module T26480 where
++
 +import Data.Proxy
 +import GHC.TypeLits
 +import GHC.Records
++
 +import T26480_aux1 (R1)
 +import qualified T26480_aux2 as XXX (R2)
++
 +data S = MkS { fld_s :: Int }
++
 +data E where
 +  MkE :: { fld_e :: e } -> E
++
 +data Q = MkQ { fld_q :: forall a. a -> a }
++
 +data T = MkT { specificFieldName :: Int }
++
 +data G = MkG { xyzzywyzzydyzzy :: Int }
++
 +pattern P :: Int -> S
 +pattern P { patSynField } = MkS patSynField
++
 +-- Not a literal string
 +test1 :: forall (fld_s :: Symbol). Proxy fld_s -> S -> Int
 +test1 _ = getField @fld_s
++
 +-- Not a record type
 +test2 :: Int -> Int
 +test2 = getField @"int_fld"
++
 +-- Field out of scope: unqualified import
 +test3a :: R1 -> Int
 +test3a = getField @"f1"
++
 +-- Field out of scope: qualified import
 +test3b :: XXX.R2 -> Int
 +test3b = getField @"f2"
++
 +-- Existential record field
 +test4 :: E -> Int
 +test4 = getField @"fld_e"
++
 +-- Record field contains forall
 +test5 :: Q -> Bool -> Bool
 +test5 = getField @"fld_q"
++
 +-- Record field is misspelled
 +test6 :: T -> Int
 +test6 = getField @"specificFieldTame"
++
 +-- Record field is for a different type
 +test7 :: T -> Int
 +test7 = getField @"xyzzywyzzydyzzy"
++
 +-- Record field is misspelled and is for a different type
 +test8 :: T -> Int
 +test8 = getField @"xyzzywyzzyzyzzy"
++
 +-- Pattern synonym field
 +test9 :: S -> Int
 +test9 = getField @"patSynField"

testsuite/tests/overloadedrecflds/should_fail/T26480.stderr

 +T26480.hs:29:11: error: [GHC-39999]
 +    • No instance for ‘HasField fld_s S Int’
 +        arising from a use of ‘getField’
 +      NB: ‘fld_s’ is a type variable, not a string literal.
 +    • In the expression: getField @fld_s
 +      In an equation for ‘test1’: test1 _ = getField @fld_s
++
 +T26480.hs:33:9: error: [GHC-39999]
 +    • No instance for ‘HasField "int_fld" Int Int’
 +        arising from a use of ‘getField’
 +      NB: ‘Int’ is not a record type.
 +    • In the expression: getField @"int_fld"
 +      In an equation for ‘test2’: test2 = getField @"int_fld"
++
 +T26480.hs:37:10: error: [GHC-39999]
 +    • No instance for ‘HasField "f1" R1 Int’
 +        arising from a use of ‘getField’
 +      NB: the record field ‘f1’ of ‘R1’ is out of scope.
 +    • In the expression: getField @"f1"
 +      In an equation for ‘test3a’: test3a = getField @"f1"
 +    Suggested fix:
 +      Add ‘f1’ to the import list in the import of ‘T26480_aux1’
 +      (at T26480.hs:10:1-23).
++
 +T26480.hs:41:10: error: [GHC-39999]
 +    • No instance for ‘HasField "f2" XXX.R2 Int’
 +        arising from a use of ‘getField’
 +      NB: the record field ‘f2’ of ‘XXX.R2’ is out of scope.
 +    • In the expression: getField @"f2"
 +      In an equation for ‘test3b’: test3b = getField @"f2"
 +    Suggested fix:
 +      Add ‘f2’ to the import list in the import of ‘T26480_aux2’
 +      (at T26480.hs:11:1-40).
++
 +T26480.hs:45:9: error: [GHC-39999]
 +    • No instance for ‘HasField "fld_e" E Int’
 +        arising from a use of ‘getField’
 +      NB: the record field ‘fld_e’ of ‘E’ contains existential variables.
 +    • In the expression: getField @"fld_e"
 +      In an equation for ‘test4’: test4 = getField @"fld_e"
++
 +T26480.hs:49:9: error: [GHC-39999]
 +    • No instance for ‘HasField "fld_q" Q (Bool -> Bool)’
 +        arising from a use of ‘getField’
 +      NB: the field type of the record field ‘fld_q’ of ‘Q’ is not a mono-type.
 +    • In the expression: getField @"fld_q"
 +      In an equation for ‘test5’: test5 = getField @"fld_q"
++
 +T26480.hs:53:9: error: [GHC-39999]
 +    • No instance for ‘HasField "specificFieldTame" T Int’
 +        arising from a use of ‘getField’
 +      NB: ‘T’ does not have a record field named ‘specificFieldTame’.
 +    • In the expression: getField @"specificFieldTame"
 +      In an equation for ‘test6’: test6 = getField @"specificFieldTame"
 +    Suggested fix: Perhaps use ‘specificFieldName’ (line 20).
++
 +T26480.hs:57:9: error: [GHC-39999]
 +    • No instance for ‘HasField "xyzzywyzzydyzzy" T Int’
 +        arising from a use of ‘getField’
 +      NB: ‘T’ does not have a record field named ‘xyzzywyzzydyzzy’.
 +      Another type has a field of this name: ‘G’.
 +    • In the expression: getField @"xyzzywyzzydyzzy"
 +      In an equation for ‘test7’: test7 = getField @"xyzzywyzzydyzzy"
++
 +T26480.hs:61:9: error: [GHC-39999]
 +    • No instance for ‘HasField "xyzzywyzzyzyzzy" T Int’
 +        arising from a use of ‘getField’
 +      NB: ‘T’ does not have a record field named ‘xyzzywyzzyzyzzy’.
 +    • In the expression: getField @"xyzzywyzzyzyzzy"
 +      In an equation for ‘test8’: test8 = getField @"xyzzywyzzyzyzzy"
 +    Suggested fix:
 +      Perhaps use the similarly named field of another type:
 +        ‘G’: ‘xyzzywyzzydyzzy’ (line 22)
++
 +T26480.hs:65:9: error: [GHC-39999]
 +    • No instance for ‘HasField "patSynField" S Int’
 +        arising from a use of ‘getField’
 +      NB: ‘S’ does not have a record field named ‘patSynField’.
 +      Pattern synonym record fields do not contribute ‘HasField’ instances.
 +    • In the expression: getField @"patSynField"
 +      In an equation for ‘test9’: test9 = getField @"patSynField"
++

testsuite/tests/overloadedrecflds/should_fail/T26480_aux1.hs

 +module T26480_aux1 where
++
 +data R1 = MkR1 { f1 :: Int }
 +data R2 = MkR2 { f2 :: Int }

testsuite/tests/overloadedrecflds/should_fail/T26480_aux2.hs

 +module T26480_aux2 where
++
 +data R2 = MkR2 { f2 :: Int }

testsuite/tests/overloadedrecflds/should_fail/T26480b.hs

 +{-# LANGUAGE AllowAmbiguousTypes #-}
 +{-# LANGUAGE DataKinds #-}
 +{-# LANGUAGE RebindableSyntax #-}
 +{-# LANGUAGE OverloadedRecordDot #-}
 +{-# LANGUAGE OverloadedRecordUpdate #-}
++
 +module T26480b where
++
 +import Prelude
 +import Data.Proxy
 +import GHC.TypeLits
 +import GHC.Records
++
++
 +setField
 +  :: forall (fld :: Symbol) rec ty
 +  .  HasField fld rec ty => ty -> rec -> rec
 +setField _ r = r
++
 +data N = N { no :: H }
++
 +data D = MkD{ field1 :: G }
++
 +data G = MkG { xyzzywyzzydyzzy :: H }
++
 +data H = MkH { field2 :: Int }
++
 +-- Direct usage of 'getField'
 +test1 :: G -> H
 +test1 = getField @"xyzzywyzzydyzza"
++
 +test1' :: N -> H
 +test1' = getField @"xyzzywyzzydyzzy"
++
 +test1'' :: N -> H
 +test1'' = getField @"ayzzywyzzydyzzy"
++
 +-- Record dot, applied
 +test2a :: G -> H
 +test2a g = g.xyzzywyzzydyzzb
++
 +test2b :: D -> H
 +test2b g = g.field1.xyzzywyzzydyzzc
++
 +-- Record dot, bare selector
 +test3a :: G -> H
 +test3a = (.xyzzywyzzydyzzd)
++
 +test3b :: D ->H
 +test3b = (.field1.xyzzywyzzydyzze)
++
 +-- Overloaded record update
 +test4a :: G -> G
 +test4a d = d { xyzzywyzzydyzzf = MkG ( MkH 3 ) }
++
 +test4b :: D -> D
 +test4b d = d { field1.xyzzywyzzydyzzg = MkH 3 }

testsuite/tests/overloadedrecflds/should_fail/T26480b.stderr

 +T26480b.hs:30:9: error: [GHC-39999]
 +    • No instance for ‘HasField "xyzzywyzzydyzza" G H’
 +        arising from a use of ‘getField’
 +      NB: ‘G’ does not have a record field named ‘xyzzywyzzydyzza’.
 +    • In the expression: getField @"xyzzywyzzydyzza"
 +      In an equation for ‘test1’: test1 = getField @"xyzzywyzzydyzza"
 +    Suggested fix: Perhaps use ‘xyzzywyzzydyzzy’ (line 24).
++
 +T26480b.hs:33:10: error: [GHC-39999]
 +    • No instance for ‘HasField "xyzzywyzzydyzzy" N H’
 +        arising from a use of ‘getField’
 +      NB: ‘N’ does not have a record field named ‘xyzzywyzzydyzzy’.
 +      Another type has a field of this name: ‘G’.
 +    • In the expression: getField @"xyzzywyzzydyzzy"
 +      In an equation for ‘test1'’: test1' = getField @"xyzzywyzzydyzzy"
++
 +T26480b.hs:36:11: error: [GHC-39999]
 +    • No instance for ‘HasField "ayzzywyzzydyzzy" N H’
 +        arising from a use of ‘getField’
 +      NB: ‘N’ does not have a record field named ‘ayzzywyzzydyzzy’.
 +    • In the expression: getField @"ayzzywyzzydyzzy"
 +      In an equation for ‘test1''’: test1'' = getField @"ayzzywyzzydyzzy"
 +    Suggested fix:
 +      Perhaps use the similarly named field of another type:
 +        ‘G’: ‘xyzzywyzzydyzzy’ (line 24)
++
 +T26480b.hs:40:12: error: [GHC-39999]
 +    • No instance for ‘HasField "xyzzywyzzydyzzb" G H’
 +        arising from selecting the field ‘xyzzywyzzydyzzb’
 +      NB: ‘G’ does not have a record field named ‘xyzzywyzzydyzzb’.
 +    • In the expression: g.xyzzywyzzydyzzb
 +      In an equation for ‘test2a’: test2a g = g.xyzzywyzzydyzzb
 +    Suggested fix: Perhaps use ‘xyzzywyzzydyzzy’ (line 24).
++
 +T26480b.hs:43:12: error: [GHC-39999]
 +    • No instance for ‘HasField "xyzzywyzzydyzzc" G H’
 +        arising from selecting the field ‘xyzzywyzzydyzzc’
 +      NB: ‘G’ does not have a record field named ‘xyzzywyzzydyzzc’.
 +    • In the expression: g.field1.xyzzywyzzydyzzc
 +      In an equation for ‘test2b’: test2b g = g.field1.xyzzywyzzydyzzc
 +    Suggested fix: Perhaps use ‘xyzzywyzzydyzzy’ (line 24).
++
 +T26480b.hs:47:10: error: [GHC-39999]
 +    • No instance for ‘HasField "xyzzywyzzydyzzd" G H’
 +        arising from the record selector ‘xyzzywyzzydyzzd’
 +      NB: ‘G’ does not have a record field named ‘xyzzywyzzydyzzd’.
 +    • In the expression: (.xyzzywyzzydyzzd)
 +      In an equation for ‘test3a’: test3a = (.xyzzywyzzydyzzd)
 +    Suggested fix: Perhaps use ‘xyzzywyzzydyzzy’ (line 24).
++
 +T26480b.hs:50:10: error: [GHC-39999]
 +    • No instance for ‘HasField "xyzzywyzzydyzze" G H’
 +      NB: ‘G’ does not have a record field named ‘xyzzywyzzydyzze’.
 +    • In the expression: (.field1.xyzzywyzzydyzze)
 +      In an equation for ‘test3b’: test3b = (.field1.xyzzywyzzydyzze)
 +    Suggested fix: Perhaps use ‘xyzzywyzzydyzzy’ (line 24).
++
 +T26480b.hs:54:12: error: [GHC-39999]
 +    • No instance for ‘HasField "xyzzywyzzydyzzf" G G’
 +        arising from a record update
 +      NB: ‘G’ does not have a record field named ‘xyzzywyzzydyzzf’.
 +    • In the expression: d {xyzzywyzzydyzzf = MkG (MkH 3)}
 +      In an equation for ‘test4a’:
 +          test4a d = d {xyzzywyzzydyzzf = MkG (MkH 3)}
 +    Suggested fix: Perhaps use ‘xyzzywyzzydyzzy’ (line 24).
++
 +T26480b.hs:57:12: error: [GHC-39999]
 +    • No instance for ‘HasField "xyzzywyzzydyzzg" G H’
 +      NB: ‘G’ does not have a record field named ‘xyzzywyzzydyzzg’.
 +    • In the expression: d {field1.xyzzywyzzydyzzg = MkH 3}
 +      In an equation for ‘test4b’:
 +          test4b d = d {field1.xyzzywyzzydyzzg = MkH 3}
 +    Suggested fix: Perhaps use ‘xyzzywyzzydyzzy’ (line 24).
++

testsuite/tests/overloadedrecflds/should_fail/all.T

@@ -33,6 +33,8 @@ test('hasfieldfail03', normal, compile_fail, [''])
  test('hasfieldfail04', normal, compile_fail, [''])
  test('T14953', [extra_files(['T14953_A.hs', 'T14953_B.hs'])],
       multimod_compile_fail, ['T14953', ''])
 +test('T26480', extra_files(['T26480_aux1.hs', 'T26480_aux2.hs']), multimod_compile_fail, ['T26480', '-v0'])
 +test('T26480b', normal, compile_fail, [''])
  test('DuplicateExports', normal, compile_fail, [''])
  test('T17420', [extra_files(['T17420A.hs'])], multimod_compile_fail,
       ['T17420', ''])

testsuite/tests/overloadedrecflds/should_fail/hasfieldfail01.stderr

  [1 of 3] Compiling HasFieldFail01_A ( HasFieldFail01_A.hs, HasFieldFail01_A.o )
  [2 of 3] Compiling Main             ( hasfieldfail01.hs, hasfieldfail01.o )
+-
  hasfieldfail01.hs:9:15: error: [GHC-39999]
      • No instance for ‘HasField "foo" T Int’
          arising from a use of ‘getField’
 +      NB: the record field ‘foo’ of ‘T’ is out of scope.
      • In the first argument of ‘print’, namely
          ‘(getField @"foo" (MkT 42) :: Int)’
        In the expression: print (getField @"foo" (MkT 42) :: Int)
        In an equation for ‘main’:
            main = print (getField @"foo" (MkT 42) :: Int)
 +    Suggested fix:
 +      Add ‘foo’ to the import list in the import of ‘HasFieldFail01_A’
 +      (at hasfieldfail01.hs:3:1-32).
++

testsuite/tests/overloadedrecflds/should_fail/hasfieldfail02.stderr

+-
  hasfieldfail02.hs:11:5: error: [GHC-39999]
      • No instance for ‘HasField "foo" T a1’
          arising from a use of ‘getField’
 +      NB: the field type of the record field ‘foo’ of ‘T’ is not a mono-type.
      • In the expression: getField @"foo" (MkT id)
        In an equation for ‘x’: x = getField @"foo" (MkT id)
  hasfieldfail02.hs:17:5: error: [GHC-39999]
      • No instance for ‘HasField "bar" U a0’
          arising from a use of ‘getField’
 +      NB: the record field ‘bar’ of ‘U’ contains existential variables.
      • In the expression: getField @"bar" (MkU True)
        In an equation for ‘y’: y = getField @"bar" (MkU True)
++

testsuite/tests/parser/should_fail/RecordDotSyntaxFail11.stderr

@@ -16,6 +16,7 @@ RecordDotSyntaxFail11.hs:8:3: error: [GHC-39999]
  RecordDotSyntaxFail11.hs:8:11: error: [GHC-39999]
      • No instance for ‘GHC.Internal.Records.HasField "baz" Int a0’
 +      NB: ‘Int’ is not a record type.
      • In the second argument of ‘($)’, namely ‘(.foo.bar.baz) a’
        In a stmt of a 'do' block: print $ (.foo.bar.baz) a
        In the expression:

testsuite/tests/parser/should_fail/RecordDotSyntaxFail8.hs

@@ -28,10 +28,26 @@ data Baz = Baz { baz :: Quux } deriving (Show, Eq)
  instance HasField "baz" Baz Quux where
      hasField r = (\x -> case r of Baz { .. } -> Baz { baz = x, .. }, baz r)
 --- 'Quux' has a 'quux' field of type 'Int'
 -data Quux = Quux { quux :: Int } deriving (Show, Eq)
 +-- 'Quux' has 'quux' fields of type 'Wob'
 +data Quux = Quux { quux1, quux2, quux3 :: Wob } deriving (Show, Eq)
  -- Forget to write this type's 'HasField' instance
 +-- 'Wob' has a field of type 'Bool'
 +data Wob = Wob { wob :: Bool } deriving (Show, Eq)
 +instance HasField "wob" Wob Bool where
 +    hasField r = (\x -> case r of Wob { .. } -> Wob { wob = x, .. }, wob r)
++
 +myQuux :: Quux
 +myQuux = Quux w w w
 +  where w = Wob { wob = True }
++
  main = do
 -  let a = Foo { foo = Bar{ bar = Baz { baz = Quux { quux = 42 } } } }
 -  print $ a.foo.bar.baz.quux
 +  let
 +    a = Foo { foo = Bar{ bar = Baz { baz = myQuux } } }
 +  print @Quux $ a.foo.bar.baz.quux1
++
 +  let b = myQuux
 +  print @Quux $ b.quux2
++
 +  let c = Foo { foo = Bar{ bar = Baz { baz = myQuux } } }
 +  print @Bool $ a.foo.bar.baz.quux3.wob

testsuite/tests/parser/should_fail/RecordDotSyntaxFail8.stderr

 -RecordDotSyntaxFail8.hs:37:3: error: [GHC-39999]
 -    • Ambiguous type variable ‘a0’ arising from a use of ‘print’
 -      prevents the constraint ‘(Show a0)’ from being solved.
 -      Probable fix: use a type annotation to specify what ‘a0’ should be.
 -      Potentially matching instances:
 -        instance Show Ordering -- Defined in ‘GHC.Internal.Show’
 -        instance Show Bar -- Defined at RecordDotSyntaxFail8.hs:22:41
 -        ...plus 29 others
 -        ...plus 13 instances involving out-of-scope types
 -        (use -fprint-potential-instances to see them all)
 -    • In the first argument of ‘($)’, namely ‘print’
 -      In a stmt of a 'do' block: print $ ....baz.quux
 +RecordDotSyntaxFail8.hs:47:17: error: [GHC-39999]
 +    • No instance for ‘HasField "quux1" Quux Quux’
 +        arising from selecting the field ‘quux1’
 +      NB: ‘HasField’ is not the built-in ‘GHC.Internal.Records.HasField’ class.
 +    • In the second argument of ‘($)’, namely ‘....bar.baz.quux1’
 +      In a stmt of a 'do' block: print @Quux $ ....baz.quux1
        In the expression:
          do let a = Foo {foo = ...}
 -           print $ ....quux
 +           print @Quux $ ....quux1
 +           let b = myQuux
 +           print @Quux $ b.quux2
 +           let c = Foo {foo = ...}
 +           ...
 -RecordDotSyntaxFail8.hs:37:11: error: [GHC-39999]
 -    • No instance for ‘HasField "quux" Quux a0’
 -        arising from selecting the field ‘quux’
 -    • In the second argument of ‘($)’, namely ‘....bar.baz.quux’
 -      In a stmt of a 'do' block: print $ ....baz.quux
 +RecordDotSyntaxFail8.hs:50:17: error: [GHC-39999]
 +    • No instance for ‘HasField "quux2" Quux Quux’
 +        arising from selecting the field ‘quux2’
 +      NB: ‘HasField’ is not the built-in ‘GHC.Internal.Records.HasField’ class.
 +    • In the second argument of ‘($)’, namely ‘b.quux2’
 +      In a stmt of a 'do' block: print @Quux $ b.quux2
        In the expression:
          do let a = Foo {foo = ...}
 -           print $ ....quux
 -    Suggested fix:
 -      NB: There is no field selector ‘quux :: Quux
 -                                              -> a0’ in scope for record type ‘Quux’
 +           print @Quux $ ....quux1
 +           let b = myQuux
 +           print @Quux $ b.quux2
 +           let c = Foo {foo = ...}
 +           ...
++
 +RecordDotSyntaxFail8.hs:53:17: error: [GHC-39999]
 +    • No instance for ‘HasField "quux3" Quux r0’
 +        arising from selecting the field ‘quux3’
 +      NB: ‘HasField’ is not the built-in ‘GHC.Internal.Records.HasField’ class.
 +    • In the expression: ....bar.baz.quux3
 +      In the second argument of ‘($)’, namely ‘....baz.quux3.wob’
 +      In a stmt of a 'do' block: print @Bool $ ....quux3.wob

testsuite/tests/rename/should_fail/T19843h.stderr

@@ -29,7 +29,7 @@ T19843h.hs:24:8: error: [GHC-39999]
      • In the expression: undefined.getAll
        In an equation for ‘quur’: quur = undefined.getAll
      Suggested fixes:
 -      • Perhaps use record field of Alt ‘getAlt’ (imported from Data.Monoid)
        • Add ‘getAll’ to the import list in the import of ‘Data.Monoid’
 -        (at T19843h.hs:9:1-28).
 +        (at T19843h.hs:8:1-46).
 +      • Perhaps use record field of Alt ‘getAlt’ (imported from Data.Monoid)