diff options
Diffstat (limited to 'compiler/GHC/Tc/Errors.hs')
| -rw-r--r-- | compiler/GHC/Tc/Errors.hs | 1950 |
1 files changed, 386 insertions, 1564 deletions
diff --git a/compiler/GHC/Tc/Errors.hs b/compiler/GHC/Tc/Errors.hs index 0d84dddb1e..b08fd6b3a8 100644 --- a/compiler/GHC/Tc/Errors.hs +++ b/compiler/GHC/Tc/Errors.hs @@ -1,6 +1,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -20,6 +21,8 @@ import GHC.Driver.Session import GHC.Driver.Ppr import GHC.Driver.Config.Diagnostic +import GHC.Rename.Unbound + import GHC.Tc.Types import GHC.Tc.Utils.Monad import GHC.Tc.Errors.Types @@ -33,7 +36,7 @@ import GHC.Tc.Types.Evidence import GHC.Tc.Types.EvTerm import GHC.Tc.Instance.Family import GHC.Tc.Utils.Instantiate -import {-# SOURCE #-} GHC.Tc.Errors.Hole ( findValidHoleFits ) +import {-# SOURCE #-} GHC.Tc.Errors.Hole ( findValidHoleFits, getHoleFitDispConfig, pprHoleFit ) import GHC.Types.Name import GHC.Types.Name.Reader ( lookupGRE_Name, GlobalRdrEnv, mkRdrUnqual @@ -43,30 +46,22 @@ import GHC.Types.Var import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Types.Name.Env -import GHC.Types.Name.Set import GHC.Types.SrcLoc import GHC.Types.Basic import GHC.Types.Error -import GHC.Types.Unique.Set ( nonDetEltsUniqSet ) -import GHC.Rename.Unbound ( unknownNameSuggestions, WhatLooking(..) ) +--import GHC.Rename.Unbound ( unknownNameSuggestions, WhatLooking(..) ) import GHC.Unit.Module -import GHC.Hs.Binds ( PatSynBind(..) ) -import GHC.Builtin.Names ( typeableClassName, pretendNameIsInScope ) import qualified GHC.LanguageExtensions as LangExt import GHC.Core.Predicate import GHC.Core.Type import GHC.Core.Coercion -import GHC.Core.TyCo.Rep -import GHC.Core.TyCo.Ppr ( pprTyVars, pprWithExplicitKindsWhen, pprSourceTyCon - , pprWithTYPE ) -import GHC.Core.Unify ( tcMatchTys ) +import GHC.Core.TyCo.Ppr ( pprTyVars + ) import GHC.Core.InstEnv import GHC.Core.TyCon -import GHC.Core.Class import GHC.Core.DataCon -import GHC.Core.ConLike ( ConLike(..)) import GHC.Utils.Error (diagReasonSeverity, pprLocMsgEnvelope ) import GHC.Utils.Misc @@ -76,8 +71,6 @@ import GHC.Utils.Panic.Plain import GHC.Utils.FV ( fvVarList, unionFV ) import GHC.Data.Bag -import GHC.Data.FastString -import GHC.Utils.Trace (pprTraceUserWarning) import GHC.Data.List.SetOps ( equivClasses, nubOrdBy ) import GHC.Data.Maybe import qualified GHC.Data.Strict as Strict @@ -86,12 +79,9 @@ import Control.Monad ( unless, when, foldM, forM_ ) import Data.Foldable ( toList ) import Data.Functor ( (<&>) ) import Data.Function ( on ) -import Data.List ( groupBy, partition, mapAccumL - , sortBy, tails, unfoldr ) -import Data.Ord ( comparing ) --- import Data.Semigroup ( Semigroup ) -import qualified Data.Semigroup as Semigroup - +import Data.List ( partition, mapAccumL ) +import Data.List.NonEmpty ( NonEmpty(..), (<|) ) +import qualified Data.List.NonEmpty as NE ( map, reverse ) {- ************************************************************************ @@ -265,102 +255,15 @@ report_unsolved type_errors expr_holes -- Internal functions -------------------------------------------- --- | An error Report collects messages categorised by their importance. --- See Note [Error report] for details. -data Report - = Report { report_important :: [SDoc] - , report_relevant_bindings :: [SDoc] - , report_valid_hole_fits :: [SDoc] - } - -instance Outputable Report where -- Debugging only - ppr (Report { report_important = imp - , report_relevant_bindings = rel - , report_valid_hole_fits = val }) - = vcat [ text "important:" <+> vcat imp - , text "relevant:" <+> vcat rel - , text "valid:" <+> vcat val ] - -{- Note [Error report] -~~~~~~~~~~~~~~~~~~~~~~ -The idea is that error msgs are divided into three parts: the main msg, the -context block ("In the second argument of ..."), and the relevant bindings -block, which are displayed in that order, with a mark to divide them. The -the main msg ('report_important') varies depending on the error -in question, but context and relevant bindings are always the same, which -should simplify visual parsing. - -The context is added when the Report is passed off to 'mkErrorReport'. -Unfortunately, unlike the context, the relevant bindings are added in -multiple places so they have to be in the Report. --} +-- | Make a report from a single 'TcReportMsg'. +important :: ReportErrCtxt -> TcReportMsg -> SolverReport +important ctxt doc = mempty { sr_important_msgs = [ReportWithCtxt ctxt doc] } + +mk_relevant_bindings :: RelevantBindings -> SolverReport +mk_relevant_bindings binds = mempty { sr_supplementary = [SupplementaryBindings binds] } -instance Semigroup Report where - Report a1 b1 c1 <> Report a2 b2 c2 = Report (a1 ++ a2) (b1 ++ b2) (c1 ++ c2) - -instance Monoid Report where - mempty = Report [] [] [] - mappend = (Semigroup.<>) - --- | Put a doc into the important msgs block. -important :: SDoc -> Report -important doc = mempty { report_important = [doc] } - --- | Put a doc into the relevant bindings block. -mk_relevant_bindings :: SDoc -> Report -mk_relevant_bindings doc = mempty { report_relevant_bindings = [doc] } - --- | Put a doc into the valid hole fits block. -valid_hole_fits :: SDoc -> Report -valid_hole_fits docs = mempty { report_valid_hole_fits = [docs] } - -data ReportErrCtxt - = CEC { cec_encl :: [Implication] -- Enclosing implications - -- (innermost first) - -- ic_skols and givens are tidied, rest are not - , cec_tidy :: TidyEnv - - , cec_binds :: EvBindsVar -- Make some errors (depending on cec_defer) - -- into warnings, and emit evidence bindings - -- into 'cec_binds' for unsolved constraints - - , cec_defer_type_errors :: DiagnosticReason -- Defer type errors until runtime - - -- cec_expr_holes is a union of: - -- cec_type_holes - a set of typed holes: '_', '_a', '_foo' - -- cec_out_of_scope_holes - a set of variables which are - -- out of scope: 'x', 'y', 'bar' - , cec_expr_holes :: DiagnosticReason -- Holes in expressions. - , cec_type_holes :: DiagnosticReason -- Holes in types. - , cec_out_of_scope_holes :: DiagnosticReason -- Out of scope holes. - - , cec_warn_redundant :: Bool -- True <=> -Wredundant-constraints - , cec_expand_syns :: Bool -- True <=> -fprint-expanded-synonyms - - , cec_suppress :: Bool -- True <=> More important errors have occurred, - -- so create bindings if need be, but - -- don't issue any more errors/warnings - -- See Note [Suppressing error messages] - } - -instance Outputable ReportErrCtxt where - ppr (CEC { cec_binds = bvar - , cec_defer_type_errors = dte - , cec_expr_holes = eh - , cec_type_holes = th - , cec_out_of_scope_holes = osh - , cec_warn_redundant = wr - , cec_expand_syns = es - , cec_suppress = sup }) - = text "CEC" <+> braces (vcat - [ text "cec_binds" <+> equals <+> ppr bvar - , text "cec_defer_type_errors" <+> equals <+> ppr dte - , text "cec_expr_holes" <+> equals <+> ppr eh - , text "cec_type_holes" <+> equals <+> ppr th - , text "cec_out_of_scope_holes" <+> equals <+> ppr osh - , text "cec_warn_redundant" <+> equals <+> ppr wr - , text "cec_expand_syns" <+> equals <+> ppr es - , text "cec_suppress" <+> equals <+> ppr sup ]) +mk_report_hints :: [GhcHint] -> SolverReport +mk_report_hints hints = mempty { sr_hints = hints } -- | Returns True <=> the ReportErrCtxt indicates that something is deferred deferringAnyBindings :: ReportErrCtxt -> Bool @@ -479,23 +382,28 @@ warnRedundantConstraints ctxt env info ev_vars | null redundant_evs = return () - | SigSkol user_ctxt _ _ <- info + | SigSkol user_ctxt _ _ <- info = setLclEnv env $ -- We want to add "In the type signature for f" -- to the error context, which is a bit tiresome setSrcSpan (redundantConstraintsSpan user_ctxt) $ - addErrCtxt (text "In" <+> ppr info) $ - do { env <- getLclEnv - ; msg <- mkErrorReport (WarningWithFlag Opt_WarnRedundantConstraints) ctxt env (important doc) - ; reportDiagnostic msg } + report_redundant_msg True | otherwise -- But for InstSkol there already *is* a surrounding -- "In the instance declaration for Eq [a]" context -- and we don't want to say it twice. Seems a bit ad-hoc - = do { msg <- mkErrorReport (WarningWithFlag Opt_WarnRedundantConstraints) ctxt env (important doc) - ; reportDiagnostic msg } + = report_redundant_msg False where - doc = text "Redundant constraint" <> plural redundant_evs <> colon - <+> pprEvVarTheta redundant_evs + report_redundant_msg :: Bool -- ^ whether to add "In ..." to the diagnostic + -> TcRn () + report_redundant_msg show_info + = do { lcl_env <- getLclEnv + ; msg <- + mkErrorReport + lcl_env + (TcRnRedundantConstraints redundant_evs (info, show_info)) + (Just ctxt) + [] + ; reportDiagnostic msg } redundant_evs = filterOut is_type_error $ @@ -511,14 +419,14 @@ warnRedundantConstraints ctxt env info ev_vars reportBadTelescope :: ReportErrCtxt -> TcLclEnv -> SkolemInfo -> [TcTyVar] -> TcM () reportBadTelescope ctxt env (ForAllSkol telescope) skols - = do { msg <- mkErrorReport ErrorWithoutFlag ctxt env (important doc) + = do { msg <- mkErrorReport + env + (TcRnSolverReport [report] ErrorWithoutFlag noHints) + (Just ctxt) + [] ; reportDiagnostic msg } where - doc = hang (text "These kind and type variables:" <+> telescope $$ - text "are out of dependency order. Perhaps try this ordering:") - 2 (pprTyVars sorted_tvs) - - sorted_tvs = scopedSort skols + report = ReportWithCtxt ctxt $ BadTelescope telescope skols reportBadTelescope _ _ skol_info skols = pprPanic "reportBadTelescope" (ppr skol_info $$ ppr skols) @@ -810,21 +718,20 @@ machinery, in cases where it is definitely going to be a no-op. mkUserTypeErrorReporter :: Reporter mkUserTypeErrorReporter ctxt - = mapM_ $ \ct -> do { let err = mkUserTypeError ct + = mapM_ $ \ct -> do { let err = important ctxt $ mkUserTypeError ct ; maybeReportError ctxt ct err ; addDeferredBinding ctxt err ct } -mkUserTypeError :: Ct -> Report -mkUserTypeError ct = important - $ pprUserTypeErrorTy - $ case getUserTypeErrorMsg ct of - Just msg -> msg - Nothing -> pprPanic "mkUserTypeError" (ppr ct) +mkUserTypeError :: Ct -> TcReportMsg +mkUserTypeError ct = + case getUserTypeErrorMsg ct of + Just msg -> UserTypeError msg + Nothing -> pprPanic "mkUserTypeError" (ppr ct) mkGivenErrorReporter :: Reporter -- See Note [Given errors] mkGivenErrorReporter ctxt cts - = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct + = do { (ctxt, relevant_binds, ct) <- relevantBindings True ctxt ct ; let (implic:_) = cec_encl ctxt -- Always non-empty when mkGivenErrorReporter is called ct' = setCtLoc ct (setCtLocEnv (ctLoc ct) (ic_env implic)) @@ -832,17 +739,12 @@ mkGivenErrorReporter ctxt cts -- with one from the immediately-enclosing implication. -- See Note [Inaccessible code] - inaccessible_msg = hang (text "Inaccessible code in") - 2 (ppr (ic_info implic)) - report = important inaccessible_msg `mappend` - mk_relevant_bindings binds_msg - - ; report <- mkEqErr_help ctxt report ct' ty1 ty2 - ; err <- mkErrorReport (WarningWithFlag Opt_WarnInaccessibleCode) ctxt - (ctLocEnv (ctLoc ct')) report - - ; traceTc "mkGivenErrorReporter" (ppr ct) - ; reportDiagnostic err } + ; (eq_err_msgs, _hints) <- mkEqErr_help ctxt ct' ty1 ty2 + -- The hints wouldn't help in this situation, so we discard them. + ; let supplementary = [ SupplementaryBindings relevant_binds ] + msg = TcRnInaccessibleCode implic (NE.reverse . NE.map (ReportWithCtxt ctxt) $ eq_err_msgs) + ; msg <- mkErrorReport (ctLocEnv (ctLoc ct')) msg (Just ctxt) supplementary + ; reportDiagnostic msg } where (ct : _ ) = cts -- Never empty (ty1, ty2) = getEqPredTys (ctPred ct) @@ -889,7 +791,7 @@ pattern match which binds some equality constraints. If we find one, we report the insoluble Given. -} -mkGroupReporter :: (ReportErrCtxt -> [Ct] -> TcM Report) +mkGroupReporter :: (ReportErrCtxt -> [Ct] -> TcM SolverReport) -- Make error message for a group -> Reporter -- Deal with lots of constraints -- Group together errors from same location, @@ -898,7 +800,7 @@ mkGroupReporter mk_err ctxt cts = mapM_ (reportGroup mk_err ctxt . toList) (equivClasses cmp_loc cts) -- Like mkGroupReporter, but doesn't actually print error messages -mkSuppressReporter :: (ReportErrCtxt -> [Ct] -> TcM Report) +mkSuppressReporter :: (ReportErrCtxt -> [Ct] -> TcM SolverReport) -> Reporter mkSuppressReporter mk_err ctxt cts = mapM_ (suppressGroup mk_err ctxt . toList) (equivClasses cmp_loc cts) @@ -917,7 +819,7 @@ cmp_loc ct1 ct2 = get ct1 `compare` get ct2 -- Reduce duplication by reporting only one error from each -- /starting/ location even if the end location differs -reportGroup :: (ReportErrCtxt -> [Ct] -> TcM Report) -> Reporter +reportGroup :: (ReportErrCtxt -> [Ct] -> TcM SolverReport) -> Reporter reportGroup mk_err ctxt cts | ct1 : _ <- cts = do { err <- mk_err ctxt cts @@ -937,7 +839,7 @@ reportGroup mk_err ctxt cts -- like reportGroup, but does not actually report messages. It still adds -- -fdefer-type-errors bindings, though. -suppressGroup :: (ReportErrCtxt -> [Ct] -> TcM Report) -> Reporter +suppressGroup :: (ReportErrCtxt -> [Ct] -> TcM SolverReport) -> Reporter suppressGroup mk_err ctxt cts = do { err <- mk_err ctxt cts ; traceTc "Suppressing errors for" (ppr cts) @@ -950,16 +852,17 @@ nonDeferrableOrigin (UsageEnvironmentOf {}) = True nonDeferrableOrigin (FixedRuntimeRepOrigin {}) = True nonDeferrableOrigin _ = False -maybeReportError :: ReportErrCtxt -> Ct -> Report -> TcM () -maybeReportError ctxt ct report +maybeReportError :: ReportErrCtxt -> Ct -> SolverReport -> TcM () +maybeReportError ctxt ct (SolverReport { sr_important_msgs = important, sr_supplementary = supp, sr_hints = hints }) = unless (cec_suppress ctxt) $ -- Some worse error has occurred, so suppress this diagnostic do let reason | nonDeferrableOrigin (ctOrigin ct) = ErrorWithoutFlag | otherwise = cec_defer_type_errors ctxt -- See Note [No deferring for multiplicity errors] - msg <- mkErrorReport reason ctxt (ctLocEnv (ctLoc ct)) report + diag = TcRnSolverReport important reason hints + msg <- mkErrorReport (ctLocEnv (ctLoc ct)) diag (Just ctxt) supp reportDiagnostic msg -addDeferredBinding :: ReportErrCtxt -> Report -> Ct -> TcM () +addDeferredBinding :: ReportErrCtxt -> SolverReport -> Ct -> TcM () -- See Note [Deferring coercion errors to runtime] addDeferredBinding ctxt err ct | deferringAnyBindings ctxt @@ -981,9 +884,11 @@ addDeferredBinding ctxt err ct = return () mkErrorTerm :: ReportErrCtxt -> CtLoc -> Type -- of the error term - -> Report -> TcM EvTerm -mkErrorTerm ctxt ct_loc ty report - = do { msg <- mkErrorReport ErrorWithoutFlag ctxt (ctLocEnv ct_loc) report + -> SolverReport -> TcM EvTerm +mkErrorTerm ctxt ct_loc ty (SolverReport { sr_important_msgs = important, sr_supplementary = supp }) + = do { msg <- mkErrorReport + (ctLocEnv ct_loc) + (TcRnSolverReport important ErrorWithoutFlag noHints) (Just ctxt) supp -- This will be reported at runtime, so we always want "error:" in the report, never "warning:" ; dflags <- getDynFlags ; let err_msg = pprLocMsgEnvelope msg @@ -1029,75 +934,79 @@ tryReporter ctxt (str, keep_me, suppress_after, reporter) cts where (yeses, nos) = partition (\ct -> keep_me ct (classifyPredType (ctPred ct))) cts -pprArising :: CtOrigin -> SDoc --- Used for the main, top-level error message --- We've done special processing for TypeEq, KindEq, givens -pprArising (TypeEqOrigin {}) = empty -pprArising (KindEqOrigin {}) = empty -pprArising orig | isGivenOrigin orig = empty - | otherwise = pprCtOrigin orig - --- Add the "arising from..." part to a message about bunch of dicts -addArising :: CtOrigin -> SDoc -> SDoc -addArising orig msg = hang msg 2 (pprArising orig) - -pprWithArising :: [Ct] -> (CtLoc, SDoc) --- Print something like --- (Eq a) arising from a use of x at y --- (Show a) arising from a use of p at q --- Also return a location for the error message --- Works for Wanted/Derived only -pprWithArising [] - = panic "pprWithArising" -pprWithArising (ct:cts) - | null cts - = (loc, addArising (ctLocOrigin loc) - (pprTheta [ctPred ct])) - | otherwise - = (loc, vcat (map ppr_one (ct:cts))) - where - loc = ctLoc ct - ppr_one ct' = hang (parens (pprType (ctPred ct'))) - 2 (pprCtLoc (ctLoc ct')) - -mkErrorReport :: DiagnosticReason - -> ReportErrCtxt - -> TcLclEnv - -> Report +-- | Wrap an input 'TcRnMessage' with additional contextual information, +-- such as relevant bindings or valid hole fits. +mkErrorReport :: TcLclEnv + -> TcRnMessage + -- ^ The main payload of the message. + -> Maybe ReportErrCtxt + -- ^ The context to add, after the main diagnostic + -- but before the supplementary information. + -- Nothing <=> don't add any context. + -> [SolverReportSupplementary] + -- ^ Supplementary information, to be added at the end of the message. -> TcM (MsgEnvelope TcRnMessage) -mkErrorReport rea ctxt tcl_env (Report important relevant_bindings valid_subs) - = do { context <- mkErrInfo (cec_tidy ctxt) (tcl_ctxt tcl_env) - ; unit_state <- hsc_units <$> getTopEnv ; - ; let err_info = ErrInfo context (vcat $ relevant_bindings ++ valid_subs) - ; let msg = TcRnUnknownMessage $ mkPlainDiagnostic rea noHints (vcat important) +mkErrorReport tcl_env msg mb_ctxt supplementary + = do { mb_context <- traverse (\ ctxt -> mkErrInfo (cec_tidy ctxt) (tcl_ctxt tcl_env)) mb_ctxt + ; unit_state <- hsc_units <$> getTopEnv + ; hfdc <- getHoleFitDispConfig + ; let + err_info = + ErrInfo + (fromMaybe empty mb_context) + (vcat $ map (pprSolverReportSupplementary hfdc) supplementary) ; mkTcRnMessage (RealSrcSpan (tcl_loc tcl_env) Strict.Nothing) - (TcRnMessageWithInfo unit_state $ TcRnMessageDetailed err_info msg) - } - --- This version does not include the context -mkErrorReportNC :: DiagnosticReason - -> TcLclEnv - -> Report - -> TcM (MsgEnvelope TcRnMessage) -mkErrorReportNC rea tcl_env (Report important relevant_bindings valid_subs) - = do { unit_state <- hsc_units <$> getTopEnv ; - ; let err_info = ErrInfo O.empty (vcat $ relevant_bindings ++ valid_subs) - ; let msg = TcRnUnknownMessage $ mkPlainDiagnostic rea noHints (vcat important) - ; mkTcRnMessage - (RealSrcSpan (tcl_loc tcl_env) Strict.Nothing) - (TcRnMessageWithInfo unit_state $ TcRnMessageDetailed err_info msg) - } - -type UserGiven = Implication + (TcRnMessageWithInfo unit_state $ TcRnMessageDetailed err_info msg) } + +-- | Pretty-print supplementary information, to add to an error report. +pprSolverReportSupplementary :: HoleFitDispConfig -> SolverReportSupplementary -> SDoc +-- This function should be in "GHC.Tc.Errors.Ppr", +-- but we need it here because 'TcRnMessageDetails' needs an 'SDoc'. +pprSolverReportSupplementary hfdc = \case + SupplementaryBindings binds -> pprRelevantBindings binds + SupplementaryHoleFits fits -> pprValidHoleFits hfdc fits + SupplementaryCts cts -> pprConstraintsInclude cts + +-- | Display a collection of valid hole fits. +pprValidHoleFits :: HoleFitDispConfig -> ValidHoleFits -> SDoc +-- This function should be in "GHC.Tc.Errors.Ppr", +-- but we need it here because 'TcRnMessageDetails' needs an 'SDoc'. +pprValidHoleFits hfdc (ValidHoleFits (Fits fits discarded_fits) (Fits refs discarded_refs)) + = fits_msg $$ refs_msg -getUserGivens :: ReportErrCtxt -> [UserGiven] --- One item for each enclosing implication -getUserGivens (CEC {cec_encl = implics}) = getUserGivensFromImplics implics - -getUserGivensFromImplics :: [Implication] -> [UserGiven] -getUserGivensFromImplics implics - = reverse (filterOut (null . ic_given) implics) + where + fits_msg, refs_msg, fits_discard_msg, refs_discard_msg :: SDoc + fits_msg = ppUnless (null fits) $ + hang (text "Valid hole fits include") 2 $ + vcat (map (pprHoleFit hfdc) fits) + $$ ppWhen discarded_fits fits_discard_msg + refs_msg = ppUnless (null refs) $ + hang (text "Valid refinement hole fits include") 2 $ + vcat (map (pprHoleFit hfdc) refs) + $$ ppWhen discarded_refs refs_discard_msg + fits_discard_msg = + text "(Some hole fits suppressed;" <+> + text "use -fmax-valid-hole-fits=N" <+> + text "or -fno-max-valid-hole-fits)" + refs_discard_msg = + text "(Some refinement hole fits suppressed;" <+> + text "use -fmax-refinement-hole-fits=N" <+> + text "or -fno-max-refinement-hole-fits)" + +-- | Add a "Constraints include..." message. +-- +-- See Note [Constraints include ...] +pprConstraintsInclude :: [(PredType, RealSrcSpan)] -> SDoc +-- This function should be in "GHC.Tc.Errors.Ppr", +-- but we need it here because 'TcRnMessageDetails' needs an 'SDoc'. +pprConstraintsInclude cts + = ppUnless (null cts) $ + hang (text "Constraints include") + 2 (vcat $ map pprConstraint cts) + where + pprConstraint (constraint, loc) = + ppr constraint <+> nest 2 (parens (text "from" <+> ppr loc)) {- Note [Always warn with -fdefer-type-errors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1201,14 +1110,14 @@ solve it. ************************************************************************ -} -mkIrredErr :: ReportErrCtxt -> [Ct] -> TcM Report +mkIrredErr :: ReportErrCtxt -> [Ct] -> TcM SolverReport mkIrredErr ctxt cts = do { (ctxt, binds_msg, ct1) <- relevantBindings True ctxt ct1 - ; let orig = ctOrigin ct1 - msg = couldNotDeduce (getUserGivens ctxt) (map ctPred cts, orig) + ; let msg = important ctxt $ + CouldNotDeduce (getUserGivens ctxt) (ct1 :| others) Nothing ; return $ msg `mappend` mk_relevant_bindings binds_msg } where - (ct1:_) = cts + ct1:others = cts {- Note [Constructing Hole Errors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1247,122 +1156,63 @@ See also 'reportUnsolved'. ---------------- -- | Constructs a new hole error, unless this is deferred. See Note [Constructing Hole Errors]. mkHoleError :: NameEnv Type -> [Ct] -> ReportErrCtxt -> Hole -> TcM (MsgEnvelope TcRnMessage) -mkHoleError _ _tidy_simples ctxt hole@(Hole { hole_occ = occ - , hole_ty = hole_ty - , hole_loc = ct_loc }) +mkHoleError _ _tidy_simples ctxt hole@(Hole { hole_occ = occ, hole_loc = ct_loc }) | isOutOfScopeHole hole = do { dflags <- getDynFlags ; rdr_env <- getGlobalRdrEnv ; imp_info <- getImports ; curr_mod <- getModule ; hpt <- getHpt - ; let err = important out_of_scope_msg `mappend` - (mk_relevant_bindings $ - unknownNameSuggestions WL_Anything dflags hpt curr_mod rdr_env - (tcl_rdr lcl_env) imp_info (mkRdrUnqual occ)) - - ; maybeAddDeferredBindings ctxt hole err - ; mkErrorReportNC (cec_out_of_scope_holes ctxt) lcl_env err - -- Use NC variant: the context is generally not helpful here + ; let (imp_errs, hints) + = unknownNameSuggestions WL_Anything + dflags hpt curr_mod rdr_env + (tcl_rdr lcl_env) imp_info (mkRdrUnqual occ) + errs = [ReportWithCtxt ctxt (ReportHoleError hole $ OutOfScopeHole imp_errs)] + report = SolverReport errs [] hints + + ; maybeAddDeferredBindings ctxt hole report + ; mkErrorReport lcl_env (TcRnSolverReport errs (cec_out_of_scope_holes ctxt) hints) Nothing [] + -- Pass the value 'Nothing' for the context, as it's generally not helpful + -- to include the context here. } where - herald | isDataOcc occ = text "Data constructor not in scope:" - | otherwise = text "Variable not in scope:" - - out_of_scope_msg -- Print v :: ty only if the type has structure - | boring_type = hang herald 2 (ppr occ) - | otherwise = hang herald 2 (pp_occ_with_type occ hole_ty) - - lcl_env = ctLocEnv ct_loc - boring_type = isTyVarTy hole_ty + lcl_env = ctLocEnv ct_loc -- general case: not an out-of-scope error -mkHoleError lcl_name_cache tidy_simples ctxt hole@(Hole { hole_occ = occ - , hole_ty = hole_ty - , hole_sort = sort - , hole_loc = ct_loc }) - = do { binds_msg +mkHoleError lcl_name_cache tidy_simples ctxt + hole@(Hole { hole_ty = hole_ty + , hole_sort = sort + , hole_loc = ct_loc }) + = do { rel_binds <- relevant_bindings False lcl_env lcl_name_cache (tyCoVarsOfType hole_ty) -- The 'False' means "don't filter the bindings"; see Trac #8191 ; show_hole_constraints <- goptM Opt_ShowHoleConstraints - ; let constraints_msg + ; let relevant_cts | ExprHole _ <- sort, show_hole_constraints - = givenConstraintsMsg ctxt + = givenConstraints ctxt | otherwise - = empty + = [] ; show_valid_hole_fits <- goptM Opt_ShowValidHoleFits - ; (ctxt, sub_msg) <- if show_valid_hole_fits - then validHoleFits ctxt tidy_simples hole - else return (ctxt, empty) + ; (ctxt, hole_fits) <- if show_valid_hole_fits + then validHoleFits ctxt tidy_simples hole + else return (ctxt, noValidHoleFits) - ; let err = important hole_msg `mappend` - mk_relevant_bindings (binds_msg $$ constraints_msg) `mappend` - valid_hole_fits sub_msg + ; let reason | ExprHole _ <- sort = cec_expr_holes ctxt + | otherwise = cec_type_holes ctxt + errs = [ReportWithCtxt ctxt $ ReportHoleError hole $ HoleError sort] + supp = [ SupplementaryBindings rel_binds + , SupplementaryCts relevant_cts + , SupplementaryHoleFits hole_fits ] - ; maybeAddDeferredBindings ctxt hole err + ; maybeAddDeferredBindings ctxt hole (SolverReport errs supp []) - ; let holes | ExprHole _ <- sort = cec_expr_holes ctxt - | otherwise = cec_type_holes ctxt - ; mkErrorReport holes ctxt lcl_env err + ; mkErrorReport lcl_env (TcRnSolverReport errs reason noHints) (Just ctxt) supp } where - lcl_env = ctLocEnv ct_loc - hole_kind = tcTypeKind hole_ty - tyvars = tyCoVarsOfTypeList hole_ty - - hole_msg = case sort of - ExprHole _ -> vcat [ hang (text "Found hole:") - 2 (pp_occ_with_type occ hole_ty) - , tyvars_msg, expr_hole_hint ] - TypeHole -> vcat [ hang (text "Found type wildcard" <+> quotes (ppr occ)) - 2 (text "standing for" <+> quotes pp_hole_type_with_kind) - , tyvars_msg, type_hole_hint ] - ConstraintHole -> vcat [ hang (text "Found extra-constraints wildcard standing for") - 2 (quotes $ pprType hole_ty) -- always kind constraint - , tyvars_msg, type_hole_hint ] - - pp_hole_type_with_kind - | isLiftedTypeKind hole_kind - || isCoVarType hole_ty -- Don't print the kind of unlifted - -- equalities (#15039) - = pprType hole_ty - | otherwise - = pprType hole_ty <+> dcolon <+> pprKind hole_kind - - tyvars_msg = ppUnless (null tyvars) $ - text "Where:" <+> (vcat (map loc_msg other_tvs) - $$ pprSkols ctxt skol_tvs) - where - (skol_tvs, other_tvs) = partition is_skol tyvars - is_skol tv = isTcTyVar tv && isSkolemTyVar tv - -- Coercion variables can be free in the - -- hole, via kind casts - - type_hole_hint - | ErrorWithoutFlag <- cec_type_holes ctxt - = text "To use the inferred type, enable PartialTypeSignatures" - | otherwise - = empty - - expr_hole_hint -- Give hint for, say, f x = _x - | lengthFS (occNameFS occ) > 1 -- Don't give this hint for plain "_" - = text "Or perhaps" <+> quotes (ppr occ) - <+> text "is mis-spelled, or not in scope" - | otherwise - = empty - - loc_msg tv - | isTyVar tv - = case tcTyVarDetails tv of - MetaTv {} -> quotes (ppr tv) <+> text "is an ambiguous type variable" - _ -> empty -- Skolems dealt with already - | otherwise -- A coercion variable can be free in the hole type - = ppWhenOption sdocPrintExplicitCoercions $ - quotes (ppr tv) <+> text "is a coercion variable" - + lcl_env = ctLocEnv ct_loc {- Note [Adding deferred bindings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1379,7 +1229,7 @@ so that the correct 'Severity' can be computed out of that later on. -- See Note [Adding deferred bindings]. maybeAddDeferredBindings :: ReportErrCtxt -> Hole - -> Report + -> SolverReport -> TcM () maybeAddDeferredBindings ctxt hole report = do case hole_sort hole of @@ -1394,57 +1244,38 @@ maybeAddDeferredBindings ctxt hole report = do writeMutVar ref err_tm _ -> pure () -pp_occ_with_type :: OccName -> Type -> SDoc -pp_occ_with_type occ hole_ty = hang (pprPrefixOcc occ) 2 (dcolon <+> pprType hole_ty) - -- We unwrap the ReportErrCtxt here, to avoid introducing a loop in module -- imports -validHoleFits :: ReportErrCtxt -- The context we're in, i.e. the - -- implications and the tidy environment - -> [Ct] -- Unsolved simple constraints - -> Hole -- The hole - -> TcM (ReportErrCtxt, SDoc) -- We return the new context - -- with a possibly updated - -- tidy environment, and - -- the message. +validHoleFits :: ReportErrCtxt -- ^ The context we're in, i.e. the + -- implications and the tidy environment + -> [Ct] -- ^ Unsolved simple constraints + -> Hole -- ^ The hole + -> TcM (ReportErrCtxt, ValidHoleFits) + -- ^ We return the new context + -- with a possibly updated + -- tidy environment, and + -- the valid hole fits. validHoleFits ctxt@(CEC {cec_encl = implics , cec_tidy = lcl_env}) simps hole - = do { (tidy_env, msg) <- findValidHoleFits lcl_env implics simps hole - ; return (ctxt {cec_tidy = tidy_env}, msg) } + = do { (tidy_env, fits) <- findValidHoleFits lcl_env implics simps hole + ; return (ctxt {cec_tidy = tidy_env}, fits) } -- See Note [Constraints include ...] -givenConstraintsMsg :: ReportErrCtxt -> SDoc -givenConstraintsMsg ctxt = - let constraints :: [(Type, RealSrcSpan)] - constraints = - do { implic@Implic{ ic_given = given } <- cec_encl ctxt - ; constraint <- given - ; return (varType constraint, tcl_loc (ic_env implic)) } - - pprConstraint (constraint, loc) = - ppr constraint <+> nest 2 (parens (text "from" <+> ppr loc)) - - in ppUnless (null constraints) $ - hang (text "Constraints include") - 2 (vcat $ map pprConstraint constraints) +givenConstraints :: ReportErrCtxt -> [(Type, RealSrcSpan)] +givenConstraints ctxt + = do { implic@Implic{ ic_given = given } <- cec_encl ctxt + ; constraint <- given + ; return (varType constraint, tcl_loc (ic_env implic)) } ---------------- -mkIPErr :: ReportErrCtxt -> [Ct] -> TcM Report + +mkIPErr :: ReportErrCtxt -> [Ct] -> TcM SolverReport mkIPErr ctxt cts = do { (ctxt, binds_msg, ct1) <- relevantBindings True ctxt ct1 - ; let orig = ctOrigin ct1 - preds = map ctPred cts - givens = getUserGivens ctxt - msg | null givens - = important $ addArising orig $ - sep [ text "Unbound implicit parameter" <> plural cts - , nest 2 (pprParendTheta preds) ] - | otherwise - = couldNotDeduce givens (preds, orig) - + ; let msg = important ctxt $ UnboundImplicitParams (ct1 :| others) ; return $ msg `mappend` mk_relevant_bindings binds_msg } where - (ct1:_) = cts + ct1:others = cts ---------------- @@ -1452,7 +1283,7 @@ mkIPErr ctxt cts -- Wanted constraints arising from representation-polymorphism checks. -- -- See Note [Reporting representation-polymorphism errors] in GHC.Tc.Types.Origin. -mkFRRErr :: ReportErrCtxt -> [Ct] -> TcM Report +mkFRRErr :: ReportErrCtxt -> [Ct] -> TcM SolverReport mkFRRErr ctxt cts = do { -- Zonking/tidying. ; origs <- @@ -1460,36 +1291,18 @@ mkFRRErr ctxt cts zonkTidyOrigins (cec_tidy ctxt) (map ctOrigin cts) <&> -- Then remove duplicates: only retain one 'CtOrigin' per representation-polymorphic type. - (nubOrdBy (nonDetCmpType `on` frr_type) . snd) - + (nubOrdBy (nonDetCmpType `on` (snd . frr_orig_and_type)) . snd) -- Obtain all the errors we want to report (constraints with FixedRuntimeRep origin), -- with the corresponding types: -- ty1 :: TYPE rep1, ty2 :: TYPE rep2, ... - ; let tys = map frr_type origs - kis = map typeKind tys - - -- Assemble the error message: pair up each origin with the corresponding type, e.g. - -- • FixedRuntimeRep origin msg 1 ... - -- a :: TYPE r1 - -- • FixedRuntimeRep origin msg 2 ... - -- b :: TYPE r2 - - combine_origin_ty_ki :: CtOrigin -> Type -> Kind -> SDoc - combine_origin_ty_ki orig ty ki = - -- Add bullet points if there is more than one error. - (if length tys > 1 then (bullet <+>) else id) $ - vcat [pprArising orig <> colon - ,nest 2 $ ppr ty <+> dcolon <+> pprWithTYPE ki] - - msg :: SDoc - msg = vcat $ zipWith3 combine_origin_ty_ki origs tys kis - - ; return $ important msg } + ; let origs_and_tys = map frr_orig_and_type origs + + ; return $ important ctxt $ FixedRuntimeRepError origs_and_tys } where - frr_type :: CtOrigin -> Type - frr_type (FixedRuntimeRepOrigin ty _) = ty - frr_type orig + frr_orig_and_type :: CtOrigin -> (FRROrigin, Type) + frr_orig_and_type (FixedRuntimeRepOrigin ty frr_orig) = (frr_orig, ty) + frr_orig_and_type orig = pprPanic "mkFRRErr: not a FixedRuntimeRep origin" (text "origin =" <+> ppr orig) @@ -1552,61 +1365,59 @@ any more. So we don't assert that it is. -- Don't have multiple equality errors from the same location -- E.g. (Int,Bool) ~ (Bool,Int) one error will do! -mkEqErr :: ReportErrCtxt -> [Ct] -> TcM Report +mkEqErr :: ReportErrCtxt -> [Ct] -> TcM SolverReport mkEqErr ctxt (ct:_) = mkEqErr1 ctxt ct mkEqErr _ [] = panic "mkEqErr" -mkEqErr1 :: ReportErrCtxt -> Ct -> TcM Report +mkEqErr1 :: ReportErrCtxt -> Ct -> TcM SolverReport mkEqErr1 ctxt ct -- Wanted or derived; -- givens handled in mkGivenErrorReporter = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct ; rdr_env <- getGlobalRdrEnv ; fam_envs <- tcGetFamInstEnvs - ; let coercible_msg = case ctEqRel ct of - NomEq -> empty - ReprEq -> mkCoercibleExplanation rdr_env fam_envs ty1 ty2 + ; let mb_coercible_msg = case ctEqRel ct of + NomEq -> Nothing + ReprEq -> ReportCoercibleMsg <$> mkCoercibleExplanation rdr_env fam_envs ty1 ty2 ; traceTc "mkEqErr1" (ppr ct $$ pprCtOrigin (ctOrigin ct)) - ; let report = mconcat [ important coercible_msg - , mk_relevant_bindings binds_msg] - ; mkEqErr_help ctxt report ct ty1 ty2 } + ; (last_msg :| prev_msgs, hints) <- mkEqErr_help ctxt ct ty1 ty2 + ; let + report = foldMap (important ctxt) (reverse prev_msgs) + `mappend` (important ctxt $ mkTcReportWithInfo last_msg $ maybeToList mb_coercible_msg) + `mappend` (mk_relevant_bindings binds_msg) + `mappend` (mk_report_hints hints) + ; return report } where (ty1, ty2) = getEqPredTys (ctPred ct) -- | This function tries to reconstruct why a "Coercible ty1 ty2" constraint -- is left over. mkCoercibleExplanation :: GlobalRdrEnv -> FamInstEnvs - -> TcType -> TcType -> SDoc + -> TcType -> TcType -> Maybe CoercibleMsg mkCoercibleExplanation rdr_env fam_envs ty1 ty2 | Just (tc, tys) <- tcSplitTyConApp_maybe ty1 , (rep_tc, _, _) <- tcLookupDataFamInst fam_envs tc tys , Just msg <- coercible_msg_for_tycon rep_tc - = msg + = Just msg | Just (tc, tys) <- splitTyConApp_maybe ty2 , (rep_tc, _, _) <- tcLookupDataFamInst fam_envs tc tys , Just msg <- coercible_msg_for_tycon rep_tc - = msg + = Just msg | Just (s1, _) <- tcSplitAppTy_maybe ty1 , Just (s2, _) <- tcSplitAppTy_maybe ty2 , s1 `eqType` s2 , has_unknown_roles s1 - = hang (text "NB: We cannot know what roles the parameters to" <+> - quotes (ppr s1) <+> text "have;") - 2 (text "we must assume that the role is nominal") + = Just $ UnknownRoles s1 | otherwise - = empty + = Nothing where coercible_msg_for_tycon tc | isAbstractTyCon tc - = Just $ hsep [ text "NB: The type constructor" - , quotes (pprSourceTyCon tc) - , text "is abstract" ] + = Just $ TyConIsAbstract tc | isNewTyCon tc , [data_con] <- tyConDataCons tc , let dc_name = dataConName data_con , isNothing (lookupGRE_Name rdr_env dc_name) - = Just $ hang (text "The data constructor" <+> quotes (ppr dc_name)) - 2 (sep [ text "of newtype" <+> quotes (pprSourceTyCon tc) - , text "is not in scope" ]) + = Just $ OutOfScopeNewtypeConstructor tc data_con | otherwise = Nothing has_unknown_roles ty @@ -1619,83 +1430,78 @@ mkCoercibleExplanation rdr_env fam_envs ty1 ty2 | otherwise = False -mkEqErr_help :: ReportErrCtxt -> Report +-- | Accumulated messages in reverse order. +type AccReportMsgs = NonEmpty TcReportMsg + +mkEqErr_help :: ReportErrCtxt -> Ct - -> TcType -> TcType -> TcM Report -mkEqErr_help ctxt report ct ty1 ty2 + -> TcType -> TcType -> TcM (AccReportMsgs, [GhcHint]) +mkEqErr_help ctxt ct ty1 ty2 | Just (tv1, _) <- tcGetCastedTyVar_maybe ty1 - = mkTyVarEqErr ctxt report ct tv1 ty2 + = mkTyVarEqErr ctxt ct tv1 ty2 | Just (tv2, _) <- tcGetCastedTyVar_maybe ty2 - = mkTyVarEqErr ctxt report ct tv2 ty1 + = mkTyVarEqErr ctxt ct tv2 ty1 | otherwise - = return $ reportEqErr ctxt report ct ty1 ty2 + = return (reportEqErr ctxt ct ty1 ty2 :| [], []) -reportEqErr :: ReportErrCtxt -> Report +reportEqErr :: ReportErrCtxt -> Ct - -> TcType -> TcType -> Report -reportEqErr ctxt report ct ty1 ty2 - = mconcat [misMatch, report, eqInfo] + -> TcType -> TcType -> TcReportMsg +reportEqErr ctxt ct ty1 ty2 + = mkTcReportWithInfo mismatch eqInfos where - misMatch = misMatchOrCND False ctxt ct ty1 ty2 - eqInfo = mkEqInfoMsg ct ty1 ty2 + mismatch = misMatchOrCND False ctxt ct ty1 ty2 + eqInfos = eqInfoMsgs ct ty1 ty2 -mkTyVarEqErr :: ReportErrCtxt -> Report -> Ct - -> TcTyVar -> TcType -> TcM Report +mkTyVarEqErr :: ReportErrCtxt -> Ct + -> TcTyVar -> TcType -> TcM (AccReportMsgs, [GhcHint]) -- tv1 and ty2 are already tidied -mkTyVarEqErr ctxt report ct tv1 ty2 +mkTyVarEqErr ctxt ct tv1 ty2 = do { traceTc "mkTyVarEqErr" (ppr ct $$ ppr tv1 $$ ppr ty2) ; dflags <- getDynFlags - ; return $ mkTyVarEqErr' dflags ctxt report ct tv1 ty2 } + ; return $ mkTyVarEqErr' dflags ctxt ct tv1 ty2 } -mkTyVarEqErr' :: DynFlags -> ReportErrCtxt -> Report -> Ct - -> TcTyVar -> TcType -> Report -mkTyVarEqErr' dflags ctxt report ct tv1 ty2 +mkTyVarEqErr' :: DynFlags -> ReportErrCtxt -> Ct + -> TcTyVar -> TcType -> (AccReportMsgs, [GhcHint]) +mkTyVarEqErr' dflags ctxt ct tv1 ty2 -- impredicativity is a simple error to understand; try it first | check_eq_result `cterHasProblem` cteImpredicative - = let msg = vcat [ (if isSkolemTyVar tv1 - then text "Cannot equate type variable" - else text "Cannot instantiate unification variable") - <+> quotes (ppr tv1) - , hang (text "with a" <+> what <+> text "involving polytypes:") 2 (ppr ty2) ] - in - -- Unlike the other reports, this discards the old 'report_important' + , let + poly_msg = CannotUnifyWithPolytype ct tv1 ty2 + tyvar_eq_info = extraTyVarEqInfo tv1 ty2 + poly_msg_with_info + | isSkolemTyVar tv1 + = mkTcReportWithInfo poly_msg tyvar_eq_info + | otherwise + = poly_msg + = -- Unlike the other reports, this discards the old 'report_important' -- instead of augmenting it. This is because the details are not likely -- to be helpful since this is just an unimplemented feature. - mconcat [ headline_msg - , important msg - , if isSkolemTyVar tv1 then extraTyVarEqInfo ctxt tv1 ty2 else mempty - , report ] + (poly_msg_with_info <| headline_msg :| [], []) | isSkolemTyVar tv1 -- ty2 won't be a meta-tyvar; we would have -- swapped in Solver.Canonical.canEqTyVarHomo || isTyVarTyVar tv1 && not (isTyVarTy ty2) || ctEqRel ct == ReprEq -- The cases below don't really apply to ReprEq (except occurs check) - = mconcat [ headline_msg - , extraTyVarEqInfo ctxt tv1 ty2 - , suggestAddSig ctxt ty1 ty2 - , report - ] + = (mkTcReportWithInfo headline_msg tv_extra :| [], add_sig) | cterHasOccursCheck check_eq_result -- We report an "occurs check" even for a ~ F t a, where F is a type -- function; it's not insoluble (because in principle F could reduce) -- but we have certainly been unable to solve it - = let extra2 = mkEqInfoMsg ct ty1 ty2 + = let extras2 = eqInfoMsgs ct ty1 ty2 interesting_tyvars = filter (not . noFreeVarsOfType . tyVarKind) $ filter isTyVar $ fvVarList $ tyCoFVsOfType ty1 `unionFV` tyCoFVsOfType ty2 - extra3 = mk_relevant_bindings $ - ppWhen (not (null interesting_tyvars)) $ - hang (text "Type variable kinds:") 2 $ - vcat (map (tyvar_binding . tidyTyCoVarOcc (cec_tidy ctxt)) - interesting_tyvars) - tyvar_binding tv = ppr tv <+> dcolon <+> ppr (tyVarKind tv) - in - mconcat [headline_msg, extra2, extra3, report] + extras3 = case interesting_tyvars of + [] -> [] + (tv : tvs) -> [OccursCheckInterestingTyVars (tv :| tvs)] + + in (mkTcReportWithInfo headline_msg (extras2 ++ extras3) :| [], []) -- If the immediately-enclosing implication has 'tv' a skolem, and -- we know by now its an InferSkol kind of skolem, then presumably @@ -1704,35 +1510,14 @@ mkTyVarEqErr' dflags ctxt report ct tv1 ty2 | (implic:_) <- cec_encl ctxt , Implic { ic_skols = skols } <- implic , tv1 `elem` skols - = mconcat [ misMatchMsg ctxt ct ty1 ty2 - , extraTyVarEqInfo ctxt tv1 ty2 - , report - ] + = (mkTcReportWithInfo mismatch_msg tv_extra :| [], []) -- Check for skolem escape | (implic:_) <- cec_encl ctxt -- Get the innermost context - , Implic { ic_skols = skols, ic_info = skol_info } <- implic + , Implic { ic_skols = skols } <- implic , let esc_skols = filter (`elemVarSet` (tyCoVarsOfType ty2)) skols , not (null esc_skols) - = let msg = misMatchMsg ctxt ct ty1 ty2 - esc_doc = sep [ text "because" <+> what <+> text "variable" <> plural esc_skols - <+> pprQuotedList esc_skols - , text "would escape" <+> - if isSingleton esc_skols then text "its scope" - else text "their scope" ] - tv_extra = important $ - vcat [ nest 2 $ esc_doc - , sep [ (if isSingleton esc_skols - then text "This (rigid, skolem)" <+> - what <+> text "variable is" - else text "These (rigid, skolem)" <+> - what <+> text "variables are") - <+> text "bound by" - , nest 2 $ ppr skol_info - , nest 2 $ text "at" <+> - ppr (tcl_loc (ic_env implic)) ] ] - in - mconcat [msg, tv_extra, report] + = (SkolemEscape ct implic esc_skols :| [mismatch_msg], []) -- Nastiest case: attempt to unify an untouchable variable -- So tv is a meta tyvar (or started that way before we @@ -1740,29 +1525,23 @@ mkTyVarEqErr' dflags ctxt report ct tv1 ty2 -- meta tyvar or a TyVarTv, else it'd have been unified -- See Note [Error messages for untouchables] | (implic:_) <- cec_encl ctxt -- Get the innermost context - , Implic { ic_given = given, ic_tclvl = lvl, ic_info = skol_info } <- implic + , Implic { ic_tclvl = lvl } <- implic = assertPpr (not (isTouchableMetaTyVar lvl tv1)) (ppr tv1 $$ ppr lvl) $ -- See Note [Error messages for untouchables] - let msg = misMatchMsg ctxt ct ty1 ty2 - tclvl_extra = important $ - nest 2 $ - sep [ quotes (ppr tv1) <+> text "is untouchable" - , nest 2 $ text "inside the constraints:" <+> pprEvVarTheta given - , nest 2 $ text "bound by" <+> ppr skol_info - , nest 2 $ text "at" <+> - ppr (tcl_loc (ic_env implic)) ] - tv_extra = extraTyVarEqInfo ctxt tv1 ty2 - add_sig = suggestAddSig ctxt ty1 ty2 + let tclvl_extra = UntouchableVariable tv1 implic in - mconcat [msg, tclvl_extra, tv_extra, add_sig, report] + (mkTcReportWithInfo tclvl_extra tv_extra :| [mismatch_msg], add_sig) | otherwise - = reportEqErr ctxt report ct (mkTyVarTy tv1) ty2 + = (reportEqErr ctxt ct (mkTyVarTy tv1) ty2 :| [], []) -- This *can* happen (#6123) -- Consider an ambiguous top-level constraint (a ~ F a) -- Not an occurs check, because F is a type function. where headline_msg = misMatchOrCND insoluble_occurs_check ctxt ct ty1 ty2 + mismatch_msg = mkMismatchMsg ct ty1 ty2 + tv_extra = extraTyVarEqInfo tv1 ty2 + add_sig = maybeToList $ suggestAddSig ctxt ty1 ty2 ty1 = mkTyVarTy tv1 @@ -1774,42 +1553,37 @@ mkTyVarEqErr' dflags ctxt report ct tv1 ty2 -- variable is on the right, so we don't get useful info for the CIrredCan, -- and have to compute the result of checkTyVarEq here. - insoluble_occurs_check = check_eq_result `cterHasProblem` cteInsolubleOccurs - what = text $ levelString $ - ctLocTypeOrKind_maybe (ctLoc ct) `orElse` TypeLevel - -levelString :: TypeOrKind -> String -levelString TypeLevel = "type" -levelString KindLevel = "kind" - -mkEqInfoMsg :: Ct -> TcType -> TcType -> Report +eqInfoMsgs :: Ct -> TcType -> TcType -> [TcReportInfo] -- Report (a) ambiguity if either side is a type function application -- e.g. F a0 ~ Int -- (b) warning about injectivity if both sides are the same -- type function application F a ~ F b -- See Note [Non-injective type functions] -mkEqInfoMsg ct ty1 ty2 - = important (tyfun_msg $$ ambig_msg) +eqInfoMsgs ct ty1 ty2 + = catMaybes [tyfun_msg, ambig_msg] where mb_fun1 = isTyFun_maybe ty1 mb_fun2 = isTyFun_maybe ty2 + (ambig_kvs, ambig_tvs) = getAmbigTkvs ct ambig_msg | isJust mb_fun1 || isJust mb_fun2 - = snd (mkAmbigMsg False ct) - | otherwise = empty + , not (null ambig_kvs && null ambig_tvs) + = Just $ Ambiguity False (ambig_kvs, ambig_tvs) + | otherwise + = Nothing tyfun_msg | Just tc1 <- mb_fun1 , Just tc2 <- mb_fun2 , tc1 == tc2 , not (isInjectiveTyCon tc1 Nominal) - = text "NB:" <+> quotes (ppr tc1) - <+> text "is a non-injective type family" - | otherwise = empty + = Just $ NonInjectiveTyFam tc1 + | otherwise + = Nothing misMatchOrCND :: Bool -> ReportErrCtxt -> Ct - -> TcType -> TcType -> Report + -> TcType -> TcType -> TcReportMsg -- If oriented then ty1 is actual, ty2 is expected misMatchOrCND insoluble_occurs_check ctxt ct ty1 ty2 | insoluble_occurs_check -- See Note [Insoluble occurs check] @@ -1818,56 +1592,26 @@ misMatchOrCND insoluble_occurs_check ctxt ct ty1 ty2 || null givens = -- If the equality is unconditionally insoluble -- or there is no context, don't report the context - misMatchMsg ctxt ct ty1 ty2 + mkMismatchMsg ct ty1 ty2 | otherwise - = mconcat [ couldNotDeduce givens ([eq_pred], orig) - , important $ mk_supplementary_ea_msg ctxt level ty1 ty2 orig ] + = CouldNotDeduce givens (ct :| []) (Just $ CND_Extra level ty1 ty2) + where ev = ctEvidence ct - eq_pred = ctEvPred ev - orig = ctEvOrigin ev level = ctLocTypeOrKind_maybe (ctEvLoc ev) `orElse` TypeLevel givens = [ given | given <- getUserGivens ctxt, ic_given_eqs given /= NoGivenEqs ] -- Keep only UserGivens that have some equalities. -- See Note [Suppress redundant givens during error reporting] -couldNotDeduce :: [UserGiven] -> (ThetaType, CtOrigin) -> Report -couldNotDeduce givens (wanteds, orig) - = important $ - vcat [ addArising orig (text "Could not deduce:" <+> pprTheta wanteds) - , vcat (pp_givens givens)] - -pp_givens :: [UserGiven] -> [SDoc] -pp_givens givens - = case givens of - [] -> [] - (g:gs) -> ppr_given (text "from the context:") g - : map (ppr_given (text "or from:")) gs - where - ppr_given herald implic@(Implic { ic_given = gs, ic_info = skol_info }) - = hang (herald <+> pprEvVarTheta (mkMinimalBySCs evVarPred gs)) - -- See Note [Suppress redundant givens during error reporting] - -- for why we use mkMinimalBySCs above. - 2 (sep [ text "bound by" <+> ppr skol_info - , text "at" <+> ppr (tcl_loc (ic_env implic)) ]) - -- These are for the "blocked" equalities, as described in TcCanonical -- Note [Equalities with incompatible kinds], wrinkle (2). There should -- always be another unsolved wanted around, which will ordinarily suppress -- this message. But this can still be printed out with -fdefer-type-errors -- (sigh), so we must produce a message. -mkBlockedEqErr :: ReportErrCtxt -> [Ct] -> TcM Report -mkBlockedEqErr _ (ct:_) = return $ important msg - where - msg = vcat [ hang (text "Cannot use equality for substitution:") - 2 (ppr (ctPred ct)) - , text "Doing so would be ill-kinded." ] - -- This is a terrible message. Perhaps worse, if the user - -- has -fprint-explicit-kinds on, they will see that the two - -- sides have the same kind, as there is an invisible cast. - -- I really don't know how to do better. -mkBlockedEqErr _ [] = panic "mkBlockedEqErr no constraints" +mkBlockedEqErr :: ReportErrCtxt -> [Ct] -> TcM SolverReport +mkBlockedEqErr ctxt (ct:_) = return $ important ctxt (BlockedEquality ct) +mkBlockedEqErr _ [] = panic "mkBlockedEqErr no constraints" {- Note [Suppress redundant givens during error reporting] @@ -1909,37 +1653,31 @@ addition to superclasses (see Note [Remove redundant provided dicts] in GHC.Tc.TyCl.PatSyn). -} -extraTyVarEqInfo :: ReportErrCtxt -> TcTyVar -> TcType -> Report +extraTyVarEqInfo :: TcTyVar -> TcType -> [TcReportInfo] -- Add on extra info about skolem constants -- NB: The types themselves are already tidied -extraTyVarEqInfo ctxt tv1 ty2 - = important (extraTyVarInfo ctxt tv1 $$ ty_extra ty2) +extraTyVarEqInfo tv1 ty2 + = extraTyVarInfo tv1 : ty_extra ty2 where ty_extra ty = case tcGetCastedTyVar_maybe ty of - Just (tv, _) -> extraTyVarInfo ctxt tv - Nothing -> empty - -extraTyVarInfo :: ReportErrCtxt -> TcTyVar -> SDoc -extraTyVarInfo ctxt tv - = assertPpr (isTyVar tv) (ppr tv) $ - case tcTyVarDetails tv of - SkolemTv {} -> pprSkols ctxt [tv] - RuntimeUnk {} -> quotes (ppr tv) <+> text "is an interactive-debugger skolem" - MetaTv {} -> empty - -suggestAddSig :: ReportErrCtxt -> TcType -> TcType -> Report + Just (tv, _) -> [extraTyVarInfo tv] + Nothing -> [] + +extraTyVarInfo :: TcTyVar -> TcReportInfo +extraTyVarInfo tv = assertPpr (isTyVar tv) (ppr tv) $ TyVarInfo tv + +suggestAddSig :: ReportErrCtxt -> TcType -> TcType -> Maybe GhcHint -- See Note [Suggest adding a type signature] suggestAddSig ctxt ty1 _ty2 - | null inferred_bndrs -- No let-bound inferred binders in context - = mempty - | [bndr] <- inferred_bndrs - = important $ text "Possible fix: add a type signature for" <+> quotes (ppr bndr) + | bndr : bndrs <- inferred_bndrs + = Just $ SuggestAddTypeSignatures $ NamedBindings (bndr :| bndrs) | otherwise - = important $ text "Possible fix: add type signatures for some or all of" <+> (ppr inferred_bndrs) + = Nothing where - inferred_bndrs = case tcGetTyVar_maybe ty1 of - Just tv | isSkolemTyVar tv -> find (cec_encl ctxt) False tv - _ -> [] + inferred_bndrs = + case tcGetTyVar_maybe ty1 of + Just tv | isSkolemTyVar tv -> find (cec_encl ctxt) False tv + _ -> [] -- 'find' returns the binders of an InferSkol for 'tv', -- provided there is an intervening implication with @@ -1954,224 +1692,35 @@ suggestAddSig ctxt ty1 _ty2 = find implics (seen_eqs || ic_given_eqs implic /= NoGivenEqs) tv -------------------- -misMatchMsg :: ReportErrCtxt -> Ct -> TcType -> TcType -> Report --- Types are already tidy --- If oriented then ty1 is actual, ty2 is expected -misMatchMsg ctxt ct ty1 ty2 - = important $ - addArising orig $ - pprWithExplicitKindsWhenMismatch ty1 ty2 orig $ - sep [ case orig of - TypeEqOrigin {} -> tk_eq_msg ctxt ct ty1 ty2 orig - KindEqOrigin {} -> tk_eq_msg ctxt ct ty1 ty2 orig - _ -> headline_eq_msg False ct ty1 ty2 - , sameOccExtra ty2 ty1 ] - where - orig = ctOrigin ct - -headline_eq_msg :: Bool -> Ct -> Type -> Type -> SDoc --- Generates the main "Could't match 't1' against 't2' --- headline message -headline_eq_msg add_ea ct ty1 ty2 - - | (isLiftedRuntimeRep ty1 && isUnliftedRuntimeRep ty2) || - (isLiftedRuntimeRep ty2 && isUnliftedRuntimeRep ty1) || - (isLiftedLevity ty1 && isUnliftedLevity ty2) || - (isLiftedLevity ty2 && isUnliftedLevity ty1) - = text "Couldn't match a lifted type with an unlifted type" - - | isAtomicTy ty1 || isAtomicTy ty2 - = -- Print with quotes - sep [ text herald1 <+> quotes (ppr ty1) - , nest padding $ - text herald2 <+> quotes (ppr ty2) ] - - | otherwise - = -- Print with vertical layout - vcat [ text herald1 <> colon <+> ppr ty1 - , nest padding $ - text herald2 <> colon <+> ppr ty2 ] - where - herald1 = conc [ "Couldn't match" - , if is_repr then "representation of" else "" - , if add_ea then "expected" else "" - , what ] - herald2 = conc [ "with" - , if is_repr then "that of" else "" - , if add_ea then ("actual " ++ what) else "" ] - - padding = length herald1 - length herald2 - - is_repr = case ctEqRel ct of { ReprEq -> True; NomEq -> False } - - what = levelString (ctLocTypeOrKind_maybe (ctLoc ct) `orElse` TypeLevel) - - conc :: [String] -> String - conc = foldr1 add_space - - add_space :: String -> String -> String - add_space s1 s2 | null s1 = s2 - | null s2 = s1 - | otherwise = s1 ++ (' ' : s2) - - -tk_eq_msg :: ReportErrCtxt - -> Ct -> Type -> Type -> CtOrigin -> SDoc -tk_eq_msg ctxt ct ty1 ty2 orig@(TypeEqOrigin { uo_actual = act - , uo_expected = exp - , uo_thing = mb_thing }) - -- We can use the TypeEqOrigin to - -- improve the error message quite a lot - - | isUnliftedTypeKind act, isLiftedTypeKind exp - = sep [ text "Expecting a lifted type, but" - , thing_msg mb_thing (text "an") (text "unlifted") ] - - | isLiftedTypeKind act, isUnliftedTypeKind exp - = sep [ text "Expecting an unlifted type, but" - , thing_msg mb_thing (text "a") (text "lifted") ] - - | tcIsLiftedTypeKind exp - = maybe_num_args_msg $$ - sep [ text "Expected a type, but" - , case mb_thing of - Nothing -> text "found something with kind" - Just thing -> quotes thing <+> text "has kind" - , quotes (pprWithTYPE act) ] - - | Just nargs_msg <- num_args_msg - = nargs_msg $$ - mk_ea_msg ctxt (Just ct) level orig - - | -- pprTrace "check" (ppr ea_looks_same $$ ppr exp $$ ppr act $$ ppr ty1 $$ ppr ty2) $ - ea_looks_same ty1 ty2 exp act - = mk_ea_msg ctxt (Just ct) level orig - | otherwise -- The mismatched types are /inside/ exp and act - = vcat [ headline_eq_msg False ct ty1 ty2 - , mk_ea_msg ctxt Nothing level orig ] - - where - ct_loc = ctLoc ct - level = ctLocTypeOrKind_maybe ct_loc `orElse` TypeLevel - - thing_msg (Just thing) _ levity = quotes thing <+> text "is" <+> levity - thing_msg Nothing an levity = text "got" <+> an <+> levity <+> text "type" - - num_args_msg = case level of - KindLevel - | not (isMetaTyVarTy exp) && not (isMetaTyVarTy act) - -- if one is a meta-tyvar, then it's possible that the user - -- has asked for something impredicative, and we couldn't unify. - -- Don't bother with counting arguments. - -> let n_act = count_args act - n_exp = count_args exp in - case n_act - n_exp of - n | n > 0 -- we don't know how many args there are, so don't - -- recommend removing args that aren't - , Just thing <- mb_thing - -> Just $ text "Expecting" <+> speakN (abs n) <+> - more <+> quotes thing - where - more - | n == 1 = text "more argument to" - | otherwise = text "more arguments to" -- n > 1 - _ -> Nothing - - _ -> Nothing - - maybe_num_args_msg = num_args_msg `orElse` empty - - count_args ty = count isVisibleBinder $ fst $ splitPiTys ty - -tk_eq_msg ctxt ct ty1 ty2 - (KindEqOrigin cty1 cty2 sub_o mb_sub_t_or_k) - = vcat [ headline_eq_msg False ct ty1 ty2 - , supplementary_msg ] - where - sub_t_or_k = mb_sub_t_or_k `orElse` TypeLevel - sub_whats = text (levelString sub_t_or_k) <> char 's' - -- "types" or "kinds" - - supplementary_msg - = sdocOption sdocPrintExplicitCoercions $ \printExplicitCoercions -> - if printExplicitCoercions - || not (cty1 `pickyEqType` cty2) - then vcat [ hang (text "When matching" <+> sub_whats) - 2 (vcat [ ppr cty1 <+> dcolon <+> - ppr (tcTypeKind cty1) - , ppr cty2 <+> dcolon <+> - ppr (tcTypeKind cty2) ]) - , mk_supplementary_ea_msg ctxt sub_t_or_k cty1 cty2 sub_o ] - else text "When matching the kind of" <+> quotes (ppr cty1) - -tk_eq_msg _ _ _ _ _ = panic "typeeq_mismatch_msg" - -ea_looks_same :: Type -> Type -> Type -> Type -> Bool --- True if the faulting types (ty1, ty2) look the same as --- the expected/actual types (exp, act). --- If so, we don't want to redundantly report the latter -ea_looks_same ty1 ty2 exp act - = (act `looks_same` ty1 && exp `looks_same` ty2) || - (exp `looks_same` ty1 && act `looks_same` ty2) +mkMismatchMsg :: Ct -> Type -> Type -> TcReportMsg +mkMismatchMsg ct ty1 ty2 = + case ctOrigin ct of + TypeEqOrigin { uo_actual, uo_expected, uo_thing = mb_thing } -> + mkTcReportWithInfo + (TypeEqMismatch + { teq_mismatch_ppr_explicit_kinds = ppr_explicit_kinds + , teq_mismatch_ct = ct + , teq_mismatch_ty1 = ty1 + , teq_mismatch_ty2 = ty2 + , teq_mismatch_actual = uo_actual + , teq_mismatch_expected = uo_expected + , teq_mismatch_what = mb_thing}) + extras + KindEqOrigin cty1 cty2 sub_o mb_sub_t_or_k -> + mkTcReportWithInfo (Mismatch False ct ty1 ty2) + (WhenMatching cty1 cty2 sub_o mb_sub_t_or_k : extras) + _ -> + mkTcReportWithInfo + (Mismatch False ct ty1 ty2) + extras where - looks_same t1 t2 = t1 `pickyEqType` t2 - || t1 `eqType` liftedTypeKind && t2 `eqType` liftedTypeKind - -- pickyEqType is sensitive to synonyms, so only replies True - -- when the types really look the same. However, - -- (TYPE 'LiftedRep) and Type both print the same way. - -mk_supplementary_ea_msg :: ReportErrCtxt -> TypeOrKind - -> Type -> Type -> CtOrigin -> SDoc -mk_supplementary_ea_msg ctxt level ty1 ty2 orig - | TypeEqOrigin { uo_expected = exp, uo_actual = act } <- orig - , not (ea_looks_same ty1 ty2 exp act) - = mk_ea_msg ctxt Nothing level orig - | otherwise - = empty - -mk_ea_msg :: ReportErrCtxt -> Maybe Ct -> TypeOrKind -> CtOrigin -> SDoc --- Constructs a "Couldn't match" message --- The (Maybe Ct) says whether this is the main top-level message (Just) --- or a supplementary message (Nothing) -mk_ea_msg ctxt at_top level - (TypeEqOrigin { uo_actual = act, uo_expected = exp, uo_thing = mb_thing }) - | Just thing <- mb_thing - , KindLevel <- level - = hang (text "Expected" <+> kind_desc <> comma) - 2 (text "but" <+> quotes thing <+> text "has kind" <+> - quotes (ppr act)) - - | otherwise - = vcat [ case at_top of - Just ct -> headline_eq_msg True ct exp act - Nothing -> supplementary_ea_msg - , ppWhen expand_syns expandedTys ] - - where - supplementary_ea_msg = vcat [ text "Expected:" <+> ppr exp - , text " Actual:" <+> ppr act ] - - kind_desc | tcIsConstraintKind exp = text "a constraint" - | Just arg <- kindRep_maybe exp -- TYPE t0 - , tcIsTyVarTy arg = sdocOption sdocPrintExplicitRuntimeReps $ \case - True -> text "kind" <+> quotes (ppr exp) - False -> text "a type" - | otherwise = text "kind" <+> quotes (ppr exp) - - expand_syns = cec_expand_syns ctxt - - expandedTys = ppUnless (expTy1 `pickyEqType` exp && expTy2 `pickyEqType` act) $ vcat - [ text "Type synonyms expanded:" - , text "Expected type:" <+> ppr expTy1 - , text " Actual type:" <+> ppr expTy2 ] - - (expTy1, expTy2) = expandSynonymsToMatch exp act - -mk_ea_msg _ _ _ _ = empty + orig = ctOrigin ct + extras = sameOccExtras ty2 ty1 + ppr_explicit_kinds = shouldPprWithExplicitKinds ty1 ty2 orig --- | Prints explicit kinds (with @-fprint-explicit-kinds@) in an 'SDoc' when a --- type mismatch occurs to due invisible kind arguments. +-- | Whether to prints explicit kinds (with @-fprint-explicit-kinds@) +-- in an 'SDoc' when a type mismatch occurs to due invisible kind arguments. -- -- This function first checks to see if the 'CtOrigin' argument is a -- 'TypeEqOrigin', and if so, uses the expected/actual types from that to @@ -2180,18 +1729,16 @@ mk_ea_msg _ _ _ _ = empty -- mismatch occurred in an invisible argument position or not). If the -- 'CtOrigin' is not a 'TypeEqOrigin', fall back on the actual mismatched types -- themselves. -pprWithExplicitKindsWhenMismatch :: Type -> Type -> CtOrigin - -> SDoc -> SDoc -pprWithExplicitKindsWhenMismatch ty1 ty2 ct - = pprWithExplicitKindsWhen show_kinds +shouldPprWithExplicitKinds :: Type -> Type -> CtOrigin -> Bool +shouldPprWithExplicitKinds ty1 ty2 ct + = tcEqTypeVis act_ty exp_ty + -- True when the visible bit of the types look the same, + -- so we want to show the kinds in the displayed type. where (act_ty, exp_ty) = case ct of TypeEqOrigin { uo_actual = act , uo_expected = exp } -> (act, exp) _ -> (ty1, ty2) - show_kinds = tcEqTypeVis act_ty exp_ty - -- True when the visible bit of the types look the same, - -- so we want to show the kinds in the displayed type {- Note [Insoluble occurs check] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2209,165 +1756,11 @@ This is done in misMatchOrCND (via the insoluble_occurs_check arg) (NB: there are potentially-soluble ones, like (a ~ F a b), and we don't want to be as draconian with them.) - -Note [Expanding type synonyms to make types similar] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -In type error messages, if -fprint-expanded-types is used, we want to expand -type synonyms to make expected and found types as similar as possible, but we -shouldn't expand types too much to make type messages even more verbose and -harder to understand. The whole point here is to make the difference in expected -and found types clearer. - -`expandSynonymsToMatch` does this, it takes two types, and expands type synonyms -only as much as necessary. Given two types t1 and t2: - - * If they're already same, it just returns the types. - - * If they're in form `C1 t1_1 .. t1_n` and `C2 t2_1 .. t2_m` (C1 and C2 are - type constructors), it expands C1 and C2 if they're different type synonyms. - Then it recursively does the same thing on expanded types. If C1 and C2 are - same, then it applies the same procedure to arguments of C1 and arguments of - C2 to make them as similar as possible. - - Most important thing here is to keep number of synonym expansions at - minimum. For example, if t1 is `T (T3, T5, Int)` and t2 is `T (T5, T3, - Bool)` where T5 = T4, T4 = T3, ..., T1 = X, it returns `T (T3, T3, Int)` and - `T (T3, T3, Bool)`. - - * Otherwise types don't have same shapes and so the difference is clearly - visible. It doesn't do any expansions and show these types. - -Note that we only expand top-layer type synonyms. Only when top-layer -constructors are the same we start expanding inner type synonyms. - -Suppose top-layer type synonyms of t1 and t2 can expand N and M times, -respectively. If their type-synonym-expanded forms will meet at some point (i.e. -will have same shapes according to `sameShapes` function), it's possible to find -where they meet in O(N+M) top-layer type synonym expansions and O(min(N,M)) -comparisons. We first collect all the top-layer expansions of t1 and t2 in two -lists, then drop the prefix of the longer list so that they have same lengths. -Then we search through both lists in parallel, and return the first pair of -types that have same shapes. Inner types of these two types with same shapes -are then expanded using the same algorithm. - -In case they don't meet, we return the last pair of types in the lists, which -has top-layer type synonyms completely expanded. (in this case the inner types -are not expanded at all, as the current form already shows the type error) -} --- | Expand type synonyms in given types only enough to make them as similar as --- possible. Returned types are the same in terms of used type synonyms. --- --- To expand all synonyms, see 'Type.expandTypeSynonyms'. --- --- See `ExpandSynsFail` tests in tests testsuite/tests/typecheck/should_fail for --- some examples of how this should work. -expandSynonymsToMatch :: Type -> Type -> (Type, Type) -expandSynonymsToMatch ty1 ty2 = (ty1_ret, ty2_ret) - where - (ty1_ret, ty2_ret) = go ty1 ty2 - - -- | Returns (type synonym expanded version of first type, - -- type synonym expanded version of second type) - go :: Type -> Type -> (Type, Type) - go t1 t2 - | t1 `pickyEqType` t2 = - -- Types are same, nothing to do - (t1, t2) - - go (TyConApp tc1 tys1) (TyConApp tc2 tys2) - | tc1 == tc2 - , tys1 `equalLength` tys2 = - -- Type constructors are same. They may be synonyms, but we don't - -- expand further. The lengths of tys1 and tys2 must be equal; - -- for example, with type S a = a, we don't want - -- to zip (S Monad Int) and (S Bool). - let (tys1', tys2') = - unzip (zipWithEqual "expandSynonymsToMatch" go tys1 tys2) - in (TyConApp tc1 tys1', TyConApp tc2 tys2') - - go (AppTy t1_1 t1_2) (AppTy t2_1 t2_2) = - let (t1_1', t2_1') = go t1_1 t2_1 - (t1_2', t2_2') = go t1_2 t2_2 - in (mkAppTy t1_1' t1_2', mkAppTy t2_1' t2_2') - - go ty1@(FunTy _ w1 t1_1 t1_2) ty2@(FunTy _ w2 t2_1 t2_2) | w1 `eqType` w2 = - let (t1_1', t2_1') = go t1_1 t2_1 - (t1_2', t2_2') = go t1_2 t2_2 - in ( ty1 { ft_arg = t1_1', ft_res = t1_2' } - , ty2 { ft_arg = t2_1', ft_res = t2_2' }) - - go (ForAllTy b1 t1) (ForAllTy b2 t2) = - -- NOTE: We may have a bug here, but we just can't reproduce it easily. - -- See D1016 comments for details and our attempts at producing a test - -- case. Short version: We probably need RnEnv2 to really get this right. - let (t1', t2') = go t1 t2 - in (ForAllTy b1 t1', ForAllTy b2 t2') - - go (CastTy ty1 _) ty2 = go ty1 ty2 - go ty1 (CastTy ty2 _) = go ty1 ty2 - - go t1 t2 = - -- See Note [Expanding type synonyms to make types similar] for how this - -- works - let - t1_exp_tys = t1 : tyExpansions t1 - t2_exp_tys = t2 : tyExpansions t2 - t1_exps = length t1_exp_tys - t2_exps = length t2_exp_tys - dif = abs (t1_exps - t2_exps) - in - followExpansions $ - zipEqual "expandSynonymsToMatch.go" - (if t1_exps > t2_exps then drop dif t1_exp_tys else t1_exp_tys) - (if t2_exps > t1_exps then drop dif t2_exp_tys else t2_exp_tys) - - -- | Expand the top layer type synonyms repeatedly, collect expansions in a - -- list. The list does not include the original type. - -- - -- Example, if you have: - -- - -- type T10 = T9 - -- type T9 = T8 - -- ... - -- type T0 = Int - -- - -- `tyExpansions T10` returns [T9, T8, T7, ... Int] - -- - -- This only expands the top layer, so if you have: - -- - -- type M a = Maybe a - -- - -- `tyExpansions (M T10)` returns [Maybe T10] (T10 is not expanded) - tyExpansions :: Type -> [Type] - tyExpansions = unfoldr (\t -> (\x -> (x, x)) `fmap` tcView t) - - -- | Drop the type pairs until types in a pair look alike (i.e. the outer - -- constructors are the same). - followExpansions :: [(Type, Type)] -> (Type, Type) - followExpansions [] = pprPanic "followExpansions" empty - followExpansions [(t1, t2)] - | sameShapes t1 t2 = go t1 t2 -- expand subtrees - | otherwise = (t1, t2) -- the difference is already visible - followExpansions ((t1, t2) : tss) - -- Traverse subtrees when the outer shapes are the same - | sameShapes t1 t2 = go t1 t2 - -- Otherwise follow the expansions until they look alike - | otherwise = followExpansions tss - - sameShapes :: Type -> Type -> Bool - sameShapes AppTy{} AppTy{} = True - sameShapes (TyConApp tc1 _) (TyConApp tc2 _) = tc1 == tc2 - sameShapes (FunTy {}) (FunTy {}) = True - sameShapes (ForAllTy {}) (ForAllTy {}) = True - sameShapes (CastTy ty1 _) ty2 = sameShapes ty1 ty2 - sameShapes ty1 (CastTy ty2 _) = sameShapes ty1 ty2 - sameShapes _ _ = False - -sameOccExtra :: TcType -> TcType -> SDoc +sameOccExtras :: TcType -> TcType -> [TcReportInfo] -- See Note [Disambiguating (X ~ X) errors] -sameOccExtra ty1 ty2 +sameOccExtras ty1 ty2 | Just (tc1, _) <- tcSplitTyConApp_maybe ty1 , Just (tc2, _) <- tcSplitTyConApp_maybe ty2 , let n1 = tyConName tc1 @@ -2376,23 +1769,9 @@ sameOccExtra ty1 ty2 same_pkg = moduleUnit (nameModule n1) == moduleUnit (nameModule n2) , n1 /= n2 -- Different Names , same_occ -- but same OccName - = text "NB:" <+> (ppr_from same_pkg n1 $$ ppr_from same_pkg n2) + = [SameOcc same_pkg n1 n2] | otherwise - = empty - where - ppr_from same_pkg nm - | isGoodSrcSpan loc - = hang (quotes (ppr nm) <+> text "is defined at") - 2 (ppr loc) - | otherwise -- Imported things have an UnhelpfulSrcSpan - = hang (quotes (ppr nm)) - 2 (sep [ text "is defined in" <+> quotes (ppr (moduleName mod)) - , ppUnless (same_pkg || pkg == mainUnit) $ - nest 4 $ text "in package" <+> quotes (ppr pkg) ]) - where - pkg = moduleUnit mod - mod = nameModule nm - loc = nameSrcSpan nm + = [] {- Note [Suggest adding a type signature] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2461,7 +1840,7 @@ Warn of loopy local equalities that were dropped. ************************************************************************ -} -mkDictErr :: HasDebugCallStack => ReportErrCtxt -> [Ct] -> TcM Report +mkDictErr :: HasDebugCallStack => ReportErrCtxt -> [Ct] -> TcM SolverReport mkDictErr ctxt cts = assert (not (null cts)) $ do { inst_envs <- tcGetInstEnvs @@ -2475,7 +1854,7 @@ mkDictErr ctxt cts -- have the same source-location origin, to try avoid a cascade -- of error from one location ; err <- mk_dict_err ctxt (head (no_inst_cts ++ overlap_cts)) - ; return $ important err } + ; return $ important ctxt err } where no_givens = null (getUserGivens ctxt) @@ -2507,30 +1886,27 @@ mkDictErr ctxt cts -- matching and unifying instances, and say "The choice depends on the instantion of ..., -- and the result of evaluating ...". mk_dict_err :: HasCallStack => ReportErrCtxt -> (Ct, ClsInstLookupResult) - -> TcM SDoc + -> TcM TcReportMsg -- Report an overlap error if this class constraint results -- from an overlap (returning Left clas), otherwise return (Right pred) -mk_dict_err ctxt@(CEC {cec_encl = implics}) (ct, (matches, unifiers, unsafe_overlapped)) +mk_dict_err ctxt (ct, (matches, unifiers, unsafe_overlapped)) | null matches -- No matches but perhaps several unifiers - = do { (_, binds_msg, ct) <- relevantBindings True ctxt ct + = do { (_, rel_binds, ct) <- relevantBindings True ctxt ct ; candidate_insts <- get_candidate_instances - ; field_suggestions <- record_field_suggestions - ; return (cannot_resolve_msg ct candidate_insts binds_msg field_suggestions) } + ; (imp_errs, field_suggestions) <- record_field_suggestions + ; return (cannot_resolve_msg ct candidate_insts rel_binds imp_errs field_suggestions) } | null unsafe_overlapped -- Some matches => overlap errors - = return overlap_msg + = return $ overlap_msg | otherwise - = return safe_haskell_msg + = return $ safe_haskell_msg where orig = ctOrigin ct pred = ctPred ct (clas, tys) = getClassPredTys pred ispecs = [ispec | (ispec, _) <- matches] unsafe_ispecs = [ispec | (ispec, _) <- unsafe_overlapped] - useful_givens = discardProvCtxtGivens orig (getUserGivensFromImplics implics) - -- useful_givens are the enclosing implications with non-empty givens, - -- modulo the horrid discardProvCtxtGivens get_candidate_instances :: TcM [ClsInst] -- See Note [Report candidate instances] @@ -2553,18 +1929,18 @@ mk_dict_err ctxt@(CEC {cec_encl = implics}) (ct, (matches, unifiers, unsafe_over | otherwise = False -- See Note [Out-of-scope fields with -XOverloadedRecordDot] - record_field_suggestions :: TcM SDoc - record_field_suggestions = flip (maybe $ return empty) record_field $ \name -> + record_field_suggestions :: TcM ([ImportError], [GhcHint]) + record_field_suggestions = flip (maybe $ return ([], noHints)) record_field $ \name -> do { glb_env <- getGlobalRdrEnv ; lcl_env <- getLocalRdrEnv ; if occ_name_in_scope glb_env lcl_env name - then return empty - else do { dflags <- getDynFlags - ; imp_info <- getImports - ; curr_mod <- getModule - ; hpt <- getHpt - ; return (unknownNameSuggestions WL_RecField dflags hpt curr_mod - glb_env emptyLocalRdrEnv imp_info (mkRdrUnqual name)) } } + then return ([], noHints) + else do { dflags <- getDynFlags + ; imp_info <- getImports + ; curr_mod <- getModule + ; hpt <- getHpt + ; return (unknownNameSuggestions WL_RecField dflags hpt curr_mod + glb_env emptyLocalRdrEnv imp_info (mkRdrUnqual name)) } } occ_name_in_scope glb_env lcl_env occ_name = not $ null (lookupGlobalRdrEnv glb_env occ_name) && @@ -2574,232 +1950,22 @@ mk_dict_err ctxt@(CEC {cec_encl = implics}) (ct, (matches, unifiers, unsafe_over HasFieldOrigin name -> Just (mkVarOccFS name) _ -> Nothing - cannot_resolve_msg :: Ct -> [ClsInst] -> SDoc -> SDoc -> SDoc - cannot_resolve_msg ct candidate_insts binds_msg field_suggestions - = vcat [ no_inst_msg - , nest 2 extra_note - , vcat (pp_givens useful_givens) - , mb_patsyn_prov `orElse` empty - , ppWhen (has_ambig_tvs && not (null unifiers && null useful_givens)) - (vcat [ ppUnless lead_with_ambig ambig_msg, binds_msg, potential_msg ]) - - , ppWhen (isNothing mb_patsyn_prov) $ - -- Don't suggest fixes for the provided context of a pattern - -- synonym; the right fix is to bind more in the pattern - show_fixes (ctxtFixes has_ambig_tvs pred implics - ++ drv_fixes) - , ppWhen (not (null candidate_insts)) - (hang (text "There are instances for similar types:") - 2 (vcat (map ppr candidate_insts))) - -- See Note [Report candidate instances] - , field_suggestions ] - where - orig = ctOrigin ct - -- See Note [Highlighting ambiguous type variables] - lead_with_ambig = has_ambig_tvs && not (any isRuntimeUnkSkol ambig_tvs) - && not (null unifiers) && null useful_givens - - (has_ambig_tvs, ambig_msg) = mkAmbigMsg lead_with_ambig ct - ambig_tvs = uncurry (++) (getAmbigTkvs ct) - - no_inst_msg - | lead_with_ambig - = ambig_msg <+> pprArising orig - $$ text "prevents the constraint" <+> quotes (pprParendType pred) - <+> text "from being solved." - - | null useful_givens - = addArising orig $ text "No instance for" - <+> pprParendType pred - - | otherwise - = addArising orig $ text "Could not deduce" - <+> pprParendType pred - - potential_msg - = ppWhen (not (null unifiers) && want_potential orig) $ - potential_hdr $$ - potentialInstancesErrMsg (PotentialInstances { matches = [], unifiers }) - - potential_hdr - = ppWhen lead_with_ambig $ - text "Probable fix: use a type annotation to specify what" - <+> pprQuotedList ambig_tvs <+> text "should be." - - mb_patsyn_prov :: Maybe SDoc - mb_patsyn_prov - | not lead_with_ambig - , ProvCtxtOrigin PSB{ psb_def = L _ pat } <- orig - = Just (vcat [ text "In other words, a successful match on the pattern" - , nest 2 $ ppr pat - , text "does not provide the constraint" <+> pprParendType pred ]) - | otherwise = Nothing - - -- Report "potential instances" only when the constraint arises - -- directly from the user's use of an overloaded function - want_potential (TypeEqOrigin {}) = False - want_potential _ = True - - extra_note | any isFunTy (filterOutInvisibleTypes (classTyCon clas) tys) - = text "(maybe you haven't applied a function to enough arguments?)" - | className clas == typeableClassName -- Avoid mysterious "No instance for (Typeable T) - , [_,ty] <- tys -- Look for (Typeable (k->*) (T k)) - , Just (tc,_) <- tcSplitTyConApp_maybe ty - , not (isTypeFamilyTyCon tc) - = hang (text "GHC can't yet do polykinded") - 2 (text "Typeable" <+> - parens (ppr ty <+> dcolon <+> ppr (tcTypeKind ty))) - | otherwise - = empty - - drv_fixes = case orig of - DerivClauseOrigin -> [drv_fix False] - StandAloneDerivOrigin -> [drv_fix True] - DerivOriginDC _ _ standalone -> [drv_fix standalone] - DerivOriginCoerce _ _ _ standalone -> [drv_fix standalone] - _ -> [] - - drv_fix standalone_wildcard - | standalone_wildcard - = text "fill in the wildcard constraint yourself" - | otherwise - = hang (text "use a standalone 'deriving instance' declaration,") - 2 (text "so you can specify the instance context yourself") + cannot_resolve_msg :: Ct -> [ClsInst] -> RelevantBindings -> [ImportError] -> [GhcHint] -> TcReportMsg + cannot_resolve_msg ct candidate_insts binds imp_errs field_suggestions + = CannotResolveInstance ct unifiers candidate_insts imp_errs field_suggestions binds + -- Overlap errors. + overlap_msg, safe_haskell_msg :: TcReportMsg -- Normal overlap error overlap_msg - = assert (not (null matches)) $ - vcat [ addArising orig (text "Overlapping instances for" - <+> pprType (mkClassPred clas tys)) - - , ppUnless (null matching_givens) $ - sep [text "Matching givens (or their superclasses):" - , nest 2 (vcat matching_givens)] - - , potentialInstancesErrMsg - (PotentialInstances { matches = map fst matches, unifiers }) - - , ppWhen (null matching_givens && isSingleton matches && null unifiers) $ - -- Intuitively, some given matched the wanted in their - -- flattened or rewritten (from given equalities) form - -- but the matcher can't figure that out because the - -- constraints are non-flat and non-rewritten so we - -- simply report back the whole given - -- context. Accelerate Smart.hs showed this problem. - sep [ text "There exists a (perhaps superclass) match:" - , nest 2 (vcat (pp_givens useful_givens))] - - , ppWhen (isSingleton matches) $ - parens (vcat [ ppUnless (null tyCoVars) $ - text "The choice depends on the instantiation of" <+> - quotes (pprWithCommas ppr tyCoVars) - , ppUnless (null famTyCons) $ - if (null tyCoVars) - then - text "The choice depends on the result of evaluating" <+> - quotes (pprWithCommas ppr famTyCons) - else - text "and the result of evaluating" <+> - quotes (pprWithCommas ppr famTyCons) - , ppWhen (null (matching_givens)) $ - vcat [ text "To pick the first instance above, use IncoherentInstances" - , text "when compiling the other instance declarations"] - ])] - where - tyCoVars = tyCoVarsOfTypesList tys - famTyCons = filter isFamilyTyCon $ concatMap (nonDetEltsUniqSet . tyConsOfType) tys - - matching_givens = mapMaybe matchable useful_givens - - matchable implic@(Implic { ic_given = evvars, ic_info = skol_info }) - = case ev_vars_matching of - [] -> Nothing - _ -> Just $ hang (pprTheta ev_vars_matching) - 2 (sep [ text "bound by" <+> ppr skol_info - , text "at" <+> - ppr (tcl_loc (ic_env implic)) ]) - where ev_vars_matching = [ pred - | ev_var <- evvars - , let pred = evVarPred ev_var - , any can_match (pred : transSuperClasses pred) ] - can_match pred - = case getClassPredTys_maybe pred of - Just (clas', tys') -> clas' == clas - && isJust (tcMatchTys tys tys') - Nothing -> False + = assert (not (null matches)) $ OverlappingInstances ct ispecs unifiers -- Overlap error because of Safe Haskell (first -- match should be the most specific match) safe_haskell_msg = assert (matches `lengthIs` 1 && not (null unsafe_ispecs)) $ - vcat [ addArising orig (text "Unsafe overlapping instances for" - <+> pprType (mkClassPred clas tys)) - , sep [text "The matching instance is:", - nest 2 (pprInstance $ head ispecs)] - , vcat [ text "It is compiled in a Safe module and as such can only" - , text "overlap instances from the same module, however it" - , text "overlaps the following instances from different" <+> - text "modules:" - , nest 2 (vcat [pprInstances $ unsafe_ispecs]) - ] - ] - - -ctxtFixes :: Bool -> PredType -> [Implication] -> [SDoc] -ctxtFixes has_ambig_tvs pred implics - | not has_ambig_tvs - , isTyVarClassPred pred - , (skol:skols) <- usefulContext implics pred - , let what | null skols - , SigSkol (PatSynCtxt {}) _ _ <- skol - = text "\"required\"" - | otherwise - = empty - = [sep [ text "add" <+> pprParendType pred - <+> text "to the" <+> what <+> text "context of" - , nest 2 $ ppr_skol skol $$ - vcat [ text "or" <+> ppr_skol skol - | skol <- skols ] ] ] - | otherwise = [] - where - ppr_skol (PatSkol (RealDataCon dc) _) = text "the data constructor" <+> quotes (ppr dc) - ppr_skol (PatSkol (PatSynCon ps) _) = text "the pattern synonym" <+> quotes (ppr ps) - ppr_skol skol_info = ppr skol_info - -discardProvCtxtGivens :: CtOrigin -> [UserGiven] -> [UserGiven] -discardProvCtxtGivens orig givens -- See Note [discardProvCtxtGivens] - | ProvCtxtOrigin (PSB {psb_id = L _ name}) <- orig - = filterOut (discard name) givens - | otherwise - = givens - where - discard n (Implic { ic_info = SigSkol (PatSynCtxt n') _ _ }) = n == n' - discard _ _ = False - -usefulContext :: [Implication] -> PredType -> [SkolemInfo] --- usefulContext picks out the implications whose context --- the programmer might plausibly augment to solve 'pred' -usefulContext implics pred - = go implics - where - pred_tvs = tyCoVarsOfType pred - go [] = [] - go (ic : ics) - | implausible ic = rest - | otherwise = ic_info ic : rest - where - -- Stop when the context binds a variable free in the predicate - rest | any (`elemVarSet` pred_tvs) (ic_skols ic) = [] - | otherwise = go ics - - implausible ic - | null (ic_skols ic) = True - | implausible_info (ic_info ic) = True - | otherwise = False - - implausible_info (SigSkol (InfSigCtxt {}) _ _) = True - implausible_info _ = False - -- Do not suggest adding constraints to an *inferred* type signature + UnsafeOverlap ct ispecs unsafe_ispecs + {- Note [Report candidate instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2829,47 +1995,6 @@ from being solved: Once these conditions are satisfied, we can safely say that ambiguity prevents the constraint from being solved. -Note [discardProvCtxtGivens] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In most situations we call all enclosing implications "useful". There is one -exception, and that is when the constraint that causes the error is from the -"provided" context of a pattern synonym declaration: - - pattern Pat :: (Num a, Eq a) => Show a => a -> Maybe a - -- required => provided => type - pattern Pat x <- (Just x, 4) - -When checking the pattern RHS we must check that it does actually bind all -the claimed "provided" constraints; in this case, does the pattern (Just x, 4) -bind the (Show a) constraint. Answer: no! - -But the implication we generate for this will look like - forall a. (Num a, Eq a) => [W] Show a -because when checking the pattern we must make the required -constraints available, since they are needed to match the pattern (in -this case the literal '4' needs (Num a, Eq a)). - -BUT we don't want to suggest adding (Show a) to the "required" constraints -of the pattern synonym, thus: - pattern Pat :: (Num a, Eq a, Show a) => Show a => a -> Maybe a -It would then typecheck but it's silly. We want the /pattern/ to bind -the alleged "provided" constraints, Show a. - -So we suppress that Implication in discardProvCtxtGivens. It's -painfully ad-hoc but the truth is that adding it to the "required" -constraints would work. Suppressing it solves two problems. First, -we never tell the user that we could not deduce a "provided" -constraint from the "required" context. Second, we never give a -possible fix that suggests to add a "provided" constraint to the -"required" context. - -For example, without this distinction the above code gives a bad error -message (showing both problems): - - error: Could not deduce (Show a) ... from the context: (Eq a) - ... Possible fix: add (Show a) to the context of - the signature for pattern synonym `Pat' ... - Note [Out-of-scope fields with -XOverloadedRecordDot] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ With -XOverloadedRecordDot, when a field isn't in scope, the error that appears @@ -2899,202 +2024,6 @@ results in in the import of ‘Data.Monoid’ -} -show_fixes :: [SDoc] -> SDoc -show_fixes [] = empty -show_fixes (f:fs) = sep [ text "Possible fix:" - , nest 2 (vcat (f : map (text "or" <+>) fs))] - - --- | This datatype collates instances that match or unifier, --- in order to report an error message for an unsolved typeclass constraint. -data PotentialInstances - = PotentialInstances - { matches :: [ClsInst] - , unifiers :: [ClsInst] - } - --- | Directly display the given matching and unifying instances, --- with a header for each: `Matching instances`/`Potentially matching instances`. -pprPotentialInstances :: (ClsInst -> SDoc) -> PotentialInstances -> SDoc -pprPotentialInstances ppr_inst (PotentialInstances { matches, unifiers }) = - vcat - [ ppWhen (not $ null matches) $ - text "Matching instance" <> plural matches <> colon $$ - nest 2 (vcat (map ppr_inst matches)) - , ppWhen (not $ null unifiers) $ - (text "Potentially matching instance" <> plural unifiers <> colon) $$ - nest 2 (vcat (map ppr_inst unifiers)) - ] - --- | Display a summary of available instances, omitting those involving --- out-of-scope types, in order to explain why we couldn't solve a particular --- constraint, e.g. due to instance overlap or out-of-scope types. --- --- To directly display a collection of matching/unifying instances, --- use 'pprPotentialInstances'. -potentialInstancesErrMsg :: PotentialInstances -> SDoc --- See Note [Displaying potential instances] -potentialInstancesErrMsg potentials = - sdocOption sdocPrintPotentialInstances $ \print_insts -> - getPprStyle $ \sty -> - potentials_msg_with_options potentials print_insts sty - --- | Display a summary of available instances, omitting out-of-scope ones. --- --- Use 'potentialInstancesErrMsg' to automatically set the pretty-printing --- options. -potentials_msg_with_options :: PotentialInstances - -> Bool -- ^ Whether to print /all/ potential instances - -> PprStyle - -> SDoc -potentials_msg_with_options - (PotentialInstances { matches, unifiers }) - show_all_potentials sty - | null matches && null unifiers - = empty - - | null show_these_matches && null show_these_unifiers - = vcat [ not_in_scope_msg empty - , flag_hint ] - - | otherwise - = vcat [ pprPotentialInstances - pprInstance -- print instance + location info - (PotentialInstances - { matches = show_these_matches - , unifiers = show_these_unifiers }) - , overlapping_but_not_more_specific_msg sorted_matches - , nest 2 $ vcat - [ ppWhen (n_in_scope_hidden > 0) $ - text "...plus" - <+> speakNOf n_in_scope_hidden (text "other") - , ppWhen (not_in_scopes > 0) $ - not_in_scope_msg (text "...plus") - , flag_hint ] ] - where - n_show_matches, n_show_unifiers :: Int - n_show_matches = 3 - n_show_unifiers = 2 - - (in_scope_matches, not_in_scope_matches) = partition inst_in_scope matches - (in_scope_unifiers, not_in_scope_unifiers) = partition inst_in_scope unifiers - sorted_matches = sortBy fuzzyClsInstCmp in_scope_matches - sorted_unifiers = sortBy fuzzyClsInstCmp in_scope_unifiers - (show_these_matches, show_these_unifiers) - | show_all_potentials = (sorted_matches, sorted_unifiers) - | otherwise = (take n_show_matches sorted_matches - ,take n_show_unifiers sorted_unifiers) - n_in_scope_hidden - = length sorted_matches + length sorted_unifiers - - length show_these_matches - length show_these_unifiers - - -- "in scope" means that all the type constructors - -- are lexically in scope; these instances are likely - -- to be more useful - inst_in_scope :: ClsInst -> Bool - inst_in_scope cls_inst = nameSetAll name_in_scope $ - orphNamesOfTypes (is_tys cls_inst) - - name_in_scope name - | pretendNameIsInScope name - = True -- E.g. (->); see Note [pretendNameIsInScope] in GHC.Builtin.Names - | Just mod <- nameModule_maybe name - = qual_in_scope (qualName sty mod (nameOccName name)) - | otherwise - = True - - qual_in_scope :: QualifyName -> Bool - qual_in_scope NameUnqual = True - qual_in_scope (NameQual {}) = True - qual_in_scope _ = False - - not_in_scopes :: Int - not_in_scopes = length not_in_scope_matches + length not_in_scope_unifiers - - not_in_scope_msg herald = - hang (herald <+> speakNOf not_in_scopes (text "instance") - <+> text "involving out-of-scope types") - 2 (ppWhen show_all_potentials $ - pprPotentialInstances - pprInstanceHdr -- only print the header, not the instance location info - (PotentialInstances - { matches = not_in_scope_matches - , unifiers = not_in_scope_unifiers - })) - - flag_hint = ppUnless (show_all_potentials - || (equalLength show_these_matches matches - && equalLength show_these_unifiers unifiers)) $ - text "(use -fprint-potential-instances to see them all)" - --- | Compute a message informing the user of any instances that are overlapped --- but were not discarded because the instance overlapping them wasn't --- strictly more specific. -overlapping_but_not_more_specific_msg :: [ClsInst] -> SDoc -overlapping_but_not_more_specific_msg insts - -- Only print one example of "overlapping but not strictly more specific", - -- to avoid information overload. - | overlap : _ <- overlapping_but_not_more_specific - = overlap_header $$ ppr_overlapping overlap - | otherwise - = empty - where - overlap_header :: SDoc - overlap_header - | [_] <- overlapping_but_not_more_specific - = text "An overlapping instance can only be chosen when it is strictly more specific." - | otherwise - = text "Overlapping instances can only be chosen when they are strictly more specific." - overlapping_but_not_more_specific :: [(ClsInst, ClsInst)] - overlapping_but_not_more_specific - = nubOrdBy (comparing (is_dfun . fst)) - [ (overlapper, overlappee) - | these <- groupBy ((==) `on` is_cls_nm) insts - -- Take all pairs of distinct instances... - , one:others <- tails these -- if `these = [inst_1, inst_2, ...]` - , other <- others -- then we get pairs `(one, other) = (inst_i, inst_j)` with `i < j` - -- ... such that one instance in the pair overlaps the other... - , let mb_overlapping - | hasOverlappingFlag (overlapMode $ is_flag one) - || hasOverlappableFlag (overlapMode $ is_flag other) - = [(one, other)] - | hasOverlappingFlag (overlapMode $ is_flag other) - || hasOverlappableFlag (overlapMode $ is_flag one) - = [(other, one)] - | otherwise - = [] - , (overlapper, overlappee) <- mb_overlapping - -- ... but the overlapper is not more specific than the overlappee. - , not (overlapper `more_specific_than` overlappee) - ] - more_specific_than :: ClsInst -> ClsInst -> Bool - is1 `more_specific_than` is2 - = isJust (tcMatchTys (is_tys is1) (is_tys is2)) - ppr_overlapping :: (ClsInst, ClsInst) -> SDoc - ppr_overlapping (overlapper, overlappee) - = text "The first instance that follows overlaps the second, but is not more specific than it:" - $$ nest 2 (vcat $ map pprInstanceHdr [overlapper, overlappee]) - -{- Note [Displaying potential instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When showing a list of instances for - - overlapping instances (show ones that match) - - no such instance (show ones that could match) -we want to give it a bit of structure. Here's the plan - -* Say that an instance is "in scope" if all of the - type constructors it mentions are lexically in scope. - These are the ones most likely to be useful to the programmer. - -* Show at most n_show in-scope instances, - and summarise the rest ("plus N others") - -* Summarise the not-in-scope instances ("plus 4 not in scope") - -* Add the flag -fshow-potential-instances which replaces the - summary with the full list --} - {- Note [Kind arguments in error messages] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -3118,59 +2047,6 @@ the above error message would instead be displayed as: Which makes it clearer that the culprit is the mismatch between `k2` and `k20`. -} -mkAmbigMsg :: Bool -- True when message has to be at beginning of sentence - -> Ct -> (Bool, SDoc) -mkAmbigMsg prepend_msg ct - | null ambig_kvs && null ambig_tvs = (False, empty) - | otherwise = (True, msg) - where - (ambig_kvs, ambig_tvs) = getAmbigTkvs ct - - msg | any isRuntimeUnkSkol ambig_kvs -- See Note [Runtime skolems] - || any isRuntimeUnkSkol ambig_tvs - = vcat [ text "Cannot resolve unknown runtime type" - <> plural ambig_tvs <+> pprQuotedList ambig_tvs - , text "Use :print or :force to determine these types"] - - | not (null ambig_tvs) - = pp_ambig (text "type") ambig_tvs - - | otherwise - = pp_ambig (text "kind") ambig_kvs - - pp_ambig what tkvs - | prepend_msg -- "Ambiguous type variable 't0'" - = text "Ambiguous" <+> what <+> text "variable" - <> plural tkvs <+> pprQuotedList tkvs - - | otherwise -- "The type variable 't0' is ambiguous" - = text "The" <+> what <+> text "variable" <> plural tkvs - <+> pprQuotedList tkvs <+> isOrAre tkvs <+> text "ambiguous" - -pprSkols :: ReportErrCtxt -> [TcTyVar] -> SDoc -pprSkols ctxt tvs - = vcat (map pp_one (getSkolemInfo (cec_encl ctxt) tvs)) - where - pp_one (UnkSkol, tvs) - = vcat [ hang (pprQuotedList tvs) - 2 (is_or_are tvs "a" "(rigid, skolem)") - , nest 2 (text "of unknown origin") - , nest 2 (text "bound at" <+> ppr (foldr1 combineSrcSpans (map getSrcSpan tvs))) - ] - pp_one (RuntimeUnkSkol, tvs) - = hang (pprQuotedList tvs) - 2 (is_or_are tvs "an" "unknown runtime") - pp_one (skol_info, tvs) - = vcat [ hang (pprQuotedList tvs) - 2 (is_or_are tvs "a" "rigid" <+> text "bound by") - , nest 2 (pprSkolInfo skol_info) - , nest 2 (text "at" <+> ppr (foldr1 combineSrcSpans (map getSrcSpan tvs))) ] - - is_or_are [_] article adjective = text "is" <+> text article <+> text adjective - <+> text "type variable" - is_or_are _ _ adjective = text "are" <+> text adjective - <+> text "type variables" - getAmbigTkvs :: Ct -> ([Var],[Var]) getAmbigTkvs ct = partition (`elemVarSet` dep_tkv_set) ambig_tkvs @@ -3178,32 +2054,6 @@ getAmbigTkvs ct tkvs = tyCoVarsOfCtList ct ambig_tkvs = filter isAmbiguousTyVar tkvs dep_tkv_set = tyCoVarsOfTypes (map tyVarKind tkvs) - -getSkolemInfo :: [Implication] -> [TcTyVar] - -> [(SkolemInfo, [TcTyVar])] -- #14628 --- Get the skolem info for some type variables --- from the implication constraints that bind them. --- --- In the returned (skolem, tvs) pairs, the 'tvs' part is non-empty -getSkolemInfo _ [] - = [] - -getSkolemInfo [] tvs - | all isRuntimeUnkSkol tvs = [(RuntimeUnkSkol, tvs)] -- #14628 - | otherwise = -- See https://gitlab.haskell.org/ghc/ghc/-/issues?label_name[]=No%20skolem%20info - pprTraceUserWarning msg [(UnkSkol,tvs)] - where - msg = text "No skolem info - we could not find the origin of the following variables" <+> ppr tvs - $$ text "This should not happen, please report it as a bug following the instructions at:" - $$ text "https://gitlab.haskell.org/ghc/ghc/wikis/report-a-bug" - - -getSkolemInfo (implic:implics) tvs - | null tvs_here = getSkolemInfo implics tvs - | otherwise = (ic_info implic, tvs_here) : getSkolemInfo implics tvs_other - where - (tvs_here, tvs_other) = partition (`elem` ic_skols implic) tvs - ----------------------- -- relevantBindings looks at the value environment and finds values whose -- types mention any of the offending type variables. It has to be @@ -3216,7 +2066,7 @@ getSkolemInfo (implic:implics) tvs relevantBindings :: Bool -- True <=> filter by tyvar; False <=> no filtering -- See #8191 -> ReportErrCtxt -> Ct - -> TcM (ReportErrCtxt, SDoc, Ct) + -> TcM (ReportErrCtxt, RelevantBindings, Ct) -- Also returns the zonked and tidied CtOrigin of the constraint relevantBindings want_filtering ctxt ct = do { traceTc "relevantBindings" (ppr ct) @@ -3235,9 +2085,9 @@ relevantBindings want_filtering ctxt ct ; (env2, lcl_name_cache) <- zonkTidyTcLclEnvs env1 [lcl_env] - ; doc <- relevant_bindings want_filtering lcl_env lcl_name_cache ct_fvs + ; relev_bds <- relevant_bindings want_filtering lcl_env lcl_name_cache ct_fvs ; let ctxt' = ctxt { cec_tidy = env2 } - ; return (ctxt', doc, ct') } + ; return (ctxt', relev_bds, ct') } where loc = ctLoc ct lcl_env = ctLocEnv loc @@ -3247,7 +2097,7 @@ relevant_bindings :: Bool -> TcLclEnv -> NameEnv Type -- Cache of already zonked and tidied types -> TyCoVarSet - -> TcM SDoc + -> TcM RelevantBindings relevant_bindings want_filtering lcl_env lcl_name_env ct_tvs = do { dflags <- getDynFlags ; traceTc "relevant_bindings" $ @@ -3257,18 +2107,12 @@ relevant_bindings want_filtering lcl_env lcl_name_env ct_tvs , pprWithCommas id [ ppr id | TcIdBndr_ExpType id _ _ <- tcl_bndrs lcl_env ] ] - ; (docs, discards) - <- go dflags (maxRelevantBinds dflags) - emptyVarSet [] False + ; go dflags (maxRelevantBinds dflags) + emptyVarSet (RelevantBindings [] False) (removeBindingShadowing $ tcl_bndrs lcl_env) -- tcl_bndrs has the innermost bindings first, -- which are probably the most relevant ones - - ; let doc = ppUnless (null docs) $ - hang (text "Relevant bindings include") - 2 (vcat docs $$ ppWhen discards discardMsg) - - ; return doc } + } where run_out :: Maybe Int -> Bool run_out Nothing = False @@ -3278,14 +2122,13 @@ relevant_bindings want_filtering lcl_env lcl_name_env ct_tvs dec_max = fmap (\n -> n - 1) - go :: DynFlags -> Maybe Int -> TcTyVarSet -> [SDoc] - -> Bool -- True <=> some filtered out due to lack of fuel + go :: DynFlags -> Maybe Int -> TcTyVarSet + -> RelevantBindings -> [TcBinder] - -> TcM ([SDoc], Bool) -- The bool says if we filtered any out - -- because of lack of fuel - go _ _ _ docs discards [] - = return (reverse docs, discards) - go dflags n_left tvs_seen docs discards (tc_bndr : tc_bndrs) + -> TcM RelevantBindings + go _ _ _ (RelevantBindings bds discards) [] + = return $ RelevantBindings (reverse bds) discards + go dflags n_left tvs_seen rels@(RelevantBindings bds discards) (tc_bndr : tc_bndrs) = case tc_bndr of TcTvBndr {} -> discard_it TcIdBndr id top_lvl -> go2 (idName id) top_lvl @@ -3301,17 +2144,14 @@ relevant_bindings want_filtering lcl_env lcl_name_env ct_tvs Nothing -> discard_it -- No info; discard } where - discard_it = go dflags n_left tvs_seen docs - discards tc_bndrs + discard_it = go dflags n_left tvs_seen rels tc_bndrs go2 id_name top_lvl = do { let tidy_ty = case lookupNameEnv lcl_name_env id_name of Just tty -> tty Nothing -> pprPanic "relevant_bindings" (ppr id_name) ; traceTc "relevantBindings 1" (ppr id_name <+> dcolon <+> ppr tidy_ty) ; let id_tvs = tyCoVarsOfType tidy_ty - doc = sep [ pprPrefixOcc id_name <+> dcolon <+> ppr tidy_ty - , nest 2 (parens (text "bound at" - <+> ppr (getSrcLoc id_name)))] + bd = (id_name, tidy_ty) new_seen = tvs_seen `unionVarSet` id_tvs ; if (want_filtering && not (hasPprDebug dflags) @@ -3328,44 +2168,26 @@ relevant_bindings want_filtering lcl_env lcl_name_env ct_tvs else if run_out n_left && id_tvs `subVarSet` tvs_seen -- We've run out of n_left fuel and this binding only -- mentions already-seen type variables, so discard it - then go dflags n_left tvs_seen docs - True -- Record that we have now discarded something + then go dflags n_left tvs_seen (RelevantBindings bds True) -- Record that we have now discarded something tc_bndrs -- Keep this binding, decrement fuel else go dflags (dec_max n_left) new_seen - (doc:docs) discards tc_bndrs } - - -discardMsg :: SDoc -discardMsg = text "(Some bindings suppressed;" <+> - text "use -fmax-relevant-binds=N or -fno-max-relevant-binds)" + (RelevantBindings (bd:bds) discards) tc_bndrs } ----------------------- warnDefaulting :: TcTyVar -> [Ct] -> Type -> TcM () -warnDefaulting the_tv wanteds default_ty +warnDefaulting _ [] _ + = panic "warnDefaulting: empty Wanteds" +warnDefaulting the_tv wanteds@(ct:_) default_ty = do { warn_default <- woptM Opt_WarnTypeDefaults ; env0 <- tcInitTidyEnv ; let tidy_env = tidyFreeTyCoVars env0 $ tyCoVarsOfCtsList (listToBag wanteds) tidy_wanteds = map (tidyCt tidy_env) wanteds tidy_tv = lookupVarEnv (snd tidy_env) the_tv - (loc, ppr_wanteds) = pprWithArising tidy_wanteds - warn_msg = - hang (hsep $ [ text "Defaulting" ] - ++ - (case tidy_tv of - Nothing -> [] - Just tv -> [text "the type variable" - , quotes (ppr tv)]) - ++ - [ text "to type" - , quotes (ppr default_ty) - , text "in the following constraint" <> plural tidy_wanteds ]) - 2 - ppr_wanteds - ; let diag = TcRnUnknownMessage $ - mkPlainDiagnostic (WarningWithFlag Opt_WarnTypeDefaults) noHints warn_msg + diag = TcRnWarnDefaulting tidy_wanteds tidy_tv default_ty + loc = ctLoc ct ; setCtLocM loc $ diagnosticTc warn_default diag } {- |