[Git][ghc/ghc][master] 2 commits: Add hints for unsolved HasField constraints

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) = 2 (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 ===================================== @@ -0,0 +1,65 @@ +{-# 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 ===================================== @@ -0,0 +1,82 @@ +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 ===================================== @@ -0,0 +1,4 @@ +module T26480_aux1 where + +data R1 = MkR1 { f1 :: Int } +data R2 = MkR2 { f2 :: Int } ===================================== testsuite/tests/overloadedrecflds/should_fail/T26480_aux2.hs ===================================== @@ -0,0 +1,3 @@ +module T26480_aux2 where + +data R2 = MkR2 { f2 :: Int } ===================================== testsuite/tests/overloadedrecflds/should_fail/T26480b.hs ===================================== @@ -0,0 +1,57 @@ +{-# 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 ===================================== @@ -0,0 +1,74 @@ +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,11 +1,15 @@ [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 ===================================== @@ -1,12 +1,14 @@ - 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 ===================================== @@ -1,28 +1,36 @@ -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) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6ef22fa0ba7c0a9284176e40fdc3135... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6ef22fa0ba7c0a9284176e40fdc3135... You're receiving this email because of your account on gitlab.haskell.org.