diff options
| -rw-r--r-- | compiler/GHC/Rename/Names.hs | 120 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Errors.hs | 170 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Errors/Ppr.hs | 168 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Errors/Types.hs | 93 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Types/Origin.hs | 2 | ||||
| -rw-r--r-- | testsuite/tests/driver/werror.stderr | 2 | ||||
| -rw-r--r-- | testsuite/tests/warnings/should_compile/Werror01.stderr | 1 | ||||
| -rw-r--r-- | testsuite/tests/warnings/should_fail/WerrorFail2.stderr | 2 |
8 files changed, 337 insertions, 221 deletions
diff --git a/compiler/GHC/Rename/Names.hs b/compiler/GHC/Rename/Names.hs index b3360ad73b..d2573b2b25 100644 --- a/compiler/GHC/Rename/Names.hs +++ b/compiler/GHC/Rename/Names.hs @@ -50,8 +50,7 @@ import GHC.Builtin.Names import GHC.Parser.PostProcess ( setRdrNameSpace ) import GHC.Core.Type import GHC.Core.PatSyn -import GHC.Core.TyCo.Ppr -import GHC.Core.TyCon ( TyCon, tyConName, tyConKind ) +import GHC.Core.TyCon ( TyCon, tyConName ) import qualified GHC.LanguageExtensions as LangExt import GHC.Utils.Outputable as Outputable @@ -1606,95 +1605,76 @@ There are four warning flags in play: -- inferred type of the function warnMissingSignatures :: TcGblEnv -> RnM () warnMissingSignatures gbl_env - = do { let exports = availsToNameSet (tcg_exports gbl_env) + = do { warn_binds <- woptM Opt_WarnMissingSignatures + ; warn_pat_syns <- woptM Opt_WarnMissingPatternSynonymSignatures + ; let exports = availsToNameSet (tcg_exports gbl_env) sig_ns = tcg_sigs gbl_env -- We use sig_ns to exclude top-level bindings that are generated by GHC binds = collectHsBindsBinders CollNoDictBinders $ tcg_binds gbl_env pat_syns = tcg_patsyns gbl_env - -- Warn about missing signatures - -- Do this only when we have a type to offer - ; warn_binds <- woptM Opt_WarnMissingSignatures - ; warn_exported_binds <- woptM Opt_WarnMissingExportedSignatures - ; warn_pat_syns <- woptM Opt_WarnMissingPatternSynonymSignatures - ; warn_exported_pat_syns <- woptM Opt_WarnMissingExportedPatternSynonymSignatures - - -- See Note [Missing signatures] - ; let add_sig_warns - = when (warn_pat_syns || warn_exported_pat_syns) - (mapM_ add_pat_syn_warn pat_syns) >> - when (warn_binds || warn_exported_binds) - (mapM_ add_bind_warn binds) - - add_pat_syn_warn p - = when export_check $ - add_warn name flag $ - hang (text "Pattern synonym with no type signature:") - 2 (text "pattern" <+> pprPrefixName name <+> dcolon <+> pp_ty) - where - name = patSynName p - pp_ty = pprPatSynType p - export_check = warn_pat_syns || name `elemNameSet` exports - flag | warn_pat_syns - = Opt_WarnMissingPatternSynonymSignatures - | otherwise - = Opt_WarnMissingExportedPatternSynonymSignatures - - add_bind_warn :: Id -> IOEnv (Env TcGblEnv TcLclEnv) () - add_bind_warn id - = do { env <- tcInitTidyEnv -- Why not use emptyTidyEnv? - ; let (_, ty) = tidyOpenType env (idType id) - ty_msg = pprSigmaType ty - - ; when export_check $ - add_warn name flag $ - hang (text "Top-level binding with no type signature:") - 2 (pprPrefixName name <+> dcolon <+> ty_msg) } + not_ghc_generated :: Name -> Bool + not_ghc_generated name = name `elemNameSet` sig_ns + + add_binding_warn :: Id -> RnM () + add_binding_warn id = + when (not_ghc_generated name) $ + do { env <- tcInitTidyEnv -- Why not use emptyTidyEnv? + ; let (_, ty) = tidyOpenType env (idType id) + missing = MissingTopLevelBindingSig name ty + diag = TcRnMissingSignature missing exported warn_binds + ; addDiagnosticAt (getSrcSpan name) diag } where name = idName id - export_check = warn_binds || name `elemNameSet` exports - flag | warn_binds - = Opt_WarnMissingSignatures - | otherwise - = Opt_WarnMissingExportedSignatures - - add_warn name flag msg - = when not_ghc_generated $ do - let dia = TcRnUnknownMessage $ - mkPlainDiagnostic (WarningWithFlag flag) noHints msg - addDiagnosticAt (getSrcSpan name) dia + exported = if name `elemNameSet` exports + then IsExported + else IsNotExported + + add_patsyn_warn :: PatSyn -> RnM () + add_patsyn_warn ps = + when (not_ghc_generated name) $ + addDiagnosticAt (getSrcSpan name) + (TcRnMissingSignature missing exported warn_pat_syns) where - not_ghc_generated - = name `elemNameSet` sig_ns + name = patSynName ps + missing = MissingPatSynSig ps + exported = if name `elemNameSet` exports + then IsExported + else IsNotExported - ; add_sig_warns } + -- Warn about missing signatures + -- Do this only when we have a type to offer + -- See Note [Missing signatures] + ; mapM_ add_binding_warn binds + ; mapM_ add_patsyn_warn pat_syns + } -- | Warn the user about tycons that lack kind signatures. -- Called /after/ type (and kind) inference, so that we can report the -- inferred kinds. warnMissingKindSignatures :: TcGblEnv -> RnM () warnMissingKindSignatures gbl_env - = do { warn_missing_kind_sigs <- woptM Opt_WarnMissingKindSignatures - ; cusks_enabled <- xoptM LangExt.CUSKs - ; when (warn_missing_kind_sigs) (mapM_ (add_ty_warn cusks_enabled) tcs) + = do { cusks_enabled <- xoptM LangExt.CUSKs + ; mapM_ (add_ty_warn cusks_enabled) tcs } where tcs = tcg_tcs gbl_env ksig_ns = tcg_ksigs gbl_env - - add_ty_warn :: Bool -> TyCon -> IOEnv (Env TcGblEnv TcLclEnv) () - add_ty_warn cusks_enabled tyCon = when (name `elemNameSet` ksig_ns) $ do - let dia = TcRnUnknownMessage $ - mkPlainDiagnostic (WarningWithFlag Opt_WarnMissingKindSignatures) noHints $ - hang msg 2 (text "type" <+> pprPrefixName name <+> dcolon <+> ki_msg) - addDiagnosticAt (getSrcSpan name) dia + exports = availsToNameSet (tcg_exports gbl_env) + not_ghc_generated :: Name -> Bool + not_ghc_generated name = name `elemNameSet` ksig_ns + + add_ty_warn :: Bool -> TyCon -> RnM () + add_ty_warn cusks_enabled tyCon = + when (not_ghc_generated name) $ + addDiagnosticAt (getSrcSpan name) diag where - msg | cusks_enabled = text "Top-level type constructor with no standalone kind signature or CUSK:" - | otherwise = text "Top-level type constructor with no standalone kind signature:" name = tyConName tyCon - ki = tyConKind tyCon - ki_msg :: SDoc - ki_msg = pprKind ki + diag = TcRnMissingSignature missing exported False + missing = MissingTyConKindSig tyCon cusks_enabled + exported = if name `elemNameSet` exports + then IsExported + else IsNotExported {- ********************************************************* diff --git a/compiler/GHC/Tc/Errors.hs b/compiler/GHC/Tc/Errors.hs index 3474626289..a833e76661 100644 --- a/compiler/GHC/Tc/Errors.hs +++ b/compiler/GHC/Tc/Errors.hs @@ -13,7 +13,11 @@ module GHC.Tc.Errors( reportUnsolved, reportAllUnsolved, warnAllUnsolved, warnDefaulting, - solverDepthErrorTcS + solverDepthErrorTcS, + + -- * GHC API helper functions + solverReportMsg_ExpectedActuals, + solverReportInfo_ExpectedActuals ) where import GHC.Prelude @@ -28,6 +32,7 @@ import GHC.Rename.Unbound import GHC.Tc.Types import GHC.Tc.Utils.Monad import GHC.Tc.Errors.Types +import GHC.Tc.Errors.Ppr import GHC.Tc.Types.Constraint import GHC.Tc.Utils.TcMType import GHC.Tc.Utils.Env( tcInitTidyEnv ) @@ -87,7 +92,6 @@ import Data.List.NonEmpty ( NonEmpty(..), (<|) ) import qualified Data.List.NonEmpty as NE ( map, reverse ) import Data.List ( sortBy ) import Data.Ord ( comparing ) -import GHC.Tc.Errors.Ppr {- @@ -263,9 +267,9 @@ report_unsolved type_errors expr_holes -- Internal functions -------------------------------------------- --- | Make a report from a single 'TcReportMsg'. -important :: ReportErrCtxt -> TcReportMsg -> SolverReport -important ctxt doc = mempty { sr_important_msgs = [ReportWithCtxt ctxt doc] } +-- | Make a report from a single 'TcSolverReportMsg'. +important :: SolverReportErrCtxt -> TcSolverReportMsg -> SolverReport +important ctxt doc = mempty { sr_important_msgs = [SolverReportWithCtxt ctxt doc] } mk_relevant_bindings :: RelevantBindings -> SolverReport mk_relevant_bindings binds = mempty { sr_supplementary = [SupplementaryBindings binds] } @@ -273,15 +277,15 @@ mk_relevant_bindings binds = mempty { sr_supplementary = [SupplementaryBindings 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 +-- | Returns True <=> the SolverReportErrCtxt indicates that something is deferred +deferringAnyBindings :: SolverReportErrCtxt -> Bool -- Don't check cec_type_holes, as these don't cause bindings to be deferred deferringAnyBindings (CEC { cec_defer_type_errors = ErrorWithoutFlag , cec_expr_holes = ErrorWithoutFlag , cec_out_of_scope_holes = ErrorWithoutFlag }) = False deferringAnyBindings _ = True -maybeSwitchOffDefer :: EvBindsVar -> ReportErrCtxt -> ReportErrCtxt +maybeSwitchOffDefer :: EvBindsVar -> SolverReportErrCtxt -> SolverReportErrCtxt -- Switch off defer-type-errors inside CoEvBindsVar -- See Note [Failing equalities with no evidence bindings] maybeSwitchOffDefer evb ctxt @@ -329,7 +333,7 @@ error into a warning may allow subsequent warnings to appear that were previously suppressed. (e.g. partial-sigs/should_fail/T14584) -} -reportImplic :: ReportErrCtxt -> Implication -> TcM () +reportImplic :: SolverReportErrCtxt -> Implication -> TcM () reportImplic ctxt implic@(Implic { ic_skols = tvs , ic_given = given , ic_wanted = wanted, ic_binds = evb @@ -388,7 +392,7 @@ reportImplic ctxt implic@(Implic { ic_skols = tvs IC_BadTelescope -> True _ -> False -warnRedundantConstraints :: ReportErrCtxt -> TcLclEnv -> SkolemInfoAnon -> [EvVar] -> TcM () +warnRedundantConstraints :: SolverReportErrCtxt -> TcLclEnv -> SkolemInfoAnon -> [EvVar] -> TcM () -- See Note [Tracking redundant constraints] in GHC.Tc.Solver warnRedundantConstraints ctxt env info ev_vars | null redundant_evs @@ -429,7 +433,7 @@ warnRedundantConstraints ctxt env info ev_vars improving pred -- (transSuperClasses p) does not include p = any isImprovementPred (pred : transSuperClasses pred) -reportBadTelescope :: ReportErrCtxt -> TcLclEnv -> SkolemInfoAnon -> [TcTyVar] -> TcM () +reportBadTelescope :: SolverReportErrCtxt -> TcLclEnv -> SkolemInfoAnon -> [TcTyVar] -> TcM () reportBadTelescope ctxt env (ForAllSkol telescope) skols = do { msg <- mkErrorReport env @@ -438,7 +442,7 @@ reportBadTelescope ctxt env (ForAllSkol telescope) skols [] ; reportDiagnostic msg } where - report = ReportWithCtxt ctxt $ BadTelescope telescope skols + report = SolverReportWithCtxt ctxt $ BadTelescope telescope skols reportBadTelescope _ _ skol_info skols = pprPanic "reportBadTelescope" (ppr skol_info $$ ppr skols) @@ -460,7 +464,7 @@ But without the context we won't find beta := Zero. This only matters in instance declarations.. -} -reportWanteds :: ReportErrCtxt -> TcLevel -> WantedConstraints -> TcM () +reportWanteds :: SolverReportErrCtxt -> TcLevel -> WantedConstraints -> TcM () reportWanteds ctxt tc_lvl (WC { wc_simple = simples, wc_impl = implics , wc_holes = holes }) = do { traceTc "reportWanteds" (vcat [ text "Simples =" <+> ppr simples @@ -638,7 +642,7 @@ isTyFun_maybe ty = case tcSplitTyConApp_maybe ty of -------------------------------------------- type Reporter - = ReportErrCtxt -> [Ct] -> TcM () + = SolverReportErrCtxt -> [Ct] -> TcM () type ReporterSpec = ( String -- Name , Ct -> Pred -> Bool -- Pick these ones @@ -661,7 +665,7 @@ mkSkolReporter ctxt cts | otherwise = False reportHoles :: [Ct] -- other (tidied) constraints - -> ReportErrCtxt -> [Hole] -> TcM () + -> SolverReportErrCtxt -> [Hole] -> TcM () reportHoles tidy_cts ctxt holes = do diag_opts <- initDiagOpts <$> getDynFlags @@ -734,7 +738,7 @@ mkUserTypeErrorReporter ctxt ; maybeReportError ctxt ct err ; addDeferredBinding ctxt err ct } -mkUserTypeError :: Ct -> TcReportMsg +mkUserTypeError :: Ct -> TcSolverReportMsg mkUserTypeError ct = case getUserTypeErrorMsg ct of Just msg -> UserTypeError msg @@ -754,7 +758,7 @@ mkGivenErrorReporter ctxt cts ; (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 = TcRnInaccessibleCode implic (NE.reverse . NE.map (SolverReportWithCtxt ctxt) $ eq_err_msgs) ; msg <- mkErrorReport (ctLocEnv (ctLoc ct')) msg (Just ctxt) supplementary ; reportDiagnostic msg } where @@ -803,7 +807,7 @@ pattern match which binds some equality constraints. If we find one, we report the insoluble Given. -} -mkGroupReporter :: (ReportErrCtxt -> [Ct] -> TcM SolverReport) +mkGroupReporter :: (SolverReportErrCtxt -> [Ct] -> TcM SolverReport) -- Make error message for a group -> Reporter -- Deal with lots of constraints -- Group together errors from same location, @@ -812,7 +816,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 SolverReport) +mkSuppressReporter :: (SolverReportErrCtxt -> [Ct] -> TcM SolverReport) -> Reporter mkSuppressReporter mk_err ctxt cts = mapM_ (suppressGroup mk_err ctxt . toList) (equivClasses cmp_loc cts) @@ -831,7 +835,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 SolverReport) -> Reporter +reportGroup :: (SolverReportErrCtxt -> [Ct] -> TcM SolverReport) -> Reporter reportGroup mk_err ctxt cts | ct1 : _ <- cts = do { err <- mk_err ctxt cts @@ -851,7 +855,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 SolverReport) -> Reporter +suppressGroup :: (SolverReportErrCtxt -> [Ct] -> TcM SolverReport) -> Reporter suppressGroup mk_err ctxt cts = do { err <- mk_err ctxt cts ; traceTc "Suppressing errors for" (ppr cts) @@ -864,7 +868,7 @@ nonDeferrableOrigin (UsageEnvironmentOf {}) = True nonDeferrableOrigin (FixedRuntimeRepOrigin {}) = True nonDeferrableOrigin _ = False -maybeReportError :: ReportErrCtxt -> Ct -> SolverReport -> TcM () +maybeReportError :: SolverReportErrCtxt -> 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 @@ -874,7 +878,7 @@ maybeReportError ctxt ct (SolverReport { sr_important_msgs = important, sr_suppl msg <- mkErrorReport (ctLocEnv (ctLoc ct)) diag (Just ctxt) supp reportDiagnostic msg -addDeferredBinding :: ReportErrCtxt -> SolverReport -> Ct -> TcM () +addDeferredBinding :: SolverReportErrCtxt -> SolverReport -> Ct -> TcM () -- See Note [Deferring coercion errors to runtime] addDeferredBinding ctxt err ct | deferringAnyBindings ctxt @@ -895,7 +899,7 @@ addDeferredBinding ctxt err ct | otherwise -- Do not set any evidence for Given/Derived = return () -mkErrorTerm :: ReportErrCtxt -> CtLoc -> Type -- of the error term +mkErrorTerm :: SolverReportErrCtxt -> CtLoc -> Type -- of the error term -> SolverReport -> TcM EvTerm mkErrorTerm ctxt ct_loc ty (SolverReport { sr_important_msgs = important, sr_supplementary = supp }) = do { msg <- mkErrorReport @@ -909,7 +913,7 @@ mkErrorTerm ctxt ct_loc ty (SolverReport { sr_important_msgs = important, sr_sup ; return $ evDelayedError ty err_str } -tryReporters :: ReportErrCtxt -> [ReporterSpec] -> [Ct] -> TcM (ReportErrCtxt, [Ct]) +tryReporters :: SolverReportErrCtxt -> [ReporterSpec] -> [Ct] -> TcM (SolverReportErrCtxt, [Ct]) -- Use the first reporter in the list whose predicate says True tryReporters ctxt reporters cts = do { let (vis_cts, invis_cts) = partition (isVisibleOrigin . ctOrigin) cts @@ -931,7 +935,7 @@ tryReporters ctxt reporters cts -- deferred bindings for them if we have -fdefer-type-errors -- But suppress their error messages -tryReporter :: ReportErrCtxt -> ReporterSpec -> [Ct] -> TcM (ReportErrCtxt, [Ct]) +tryReporter :: SolverReportErrCtxt -> ReporterSpec -> [Ct] -> TcM (SolverReportErrCtxt, [Ct]) tryReporter ctxt (str, keep_me, suppress_after, reporter) cts | null yeses = return (ctxt, cts) @@ -951,7 +955,7 @@ tryReporter ctxt (str, keep_me, suppress_after, reporter) cts mkErrorReport :: TcLclEnv -> TcRnMessage -- ^ The main payload of the message. - -> Maybe ReportErrCtxt + -> Maybe SolverReportErrCtxt -- ^ The context to add, after the main diagnostic -- but before the supplementary information. -- Nothing <=> don't add any context. @@ -1122,7 +1126,7 @@ solve it. ************************************************************************ -} -mkIrredErr :: ReportErrCtxt -> [Ct] -> TcM SolverReport +mkIrredErr :: SolverReportErrCtxt -> [Ct] -> TcM SolverReport mkIrredErr ctxt cts = do { (ctxt, binds_msg, ct1) <- relevantBindings True ctxt ct1 ; let msg = important ctxt $ @@ -1167,7 +1171,7 @@ 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 :: NameEnv Type -> [Ct] -> SolverReportErrCtxt -> Hole -> TcM (MsgEnvelope TcRnMessage) mkHoleError _ _tidy_simples ctxt hole@(Hole { hole_occ = occ, hole_loc = ct_loc }) | isOutOfScopeHole hole = do { dflags <- getDynFlags @@ -1179,7 +1183,7 @@ mkHoleError _ _tidy_simples ctxt hole@(Hole { hole_occ = occ, hole_loc = ct_loc = 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)] + errs = [SolverReportWithCtxt ctxt (ReportHoleError hole $ OutOfScopeHole imp_errs)] report = SolverReport errs [] hints ; maybeAddDeferredBindings ctxt hole report @@ -1213,7 +1217,7 @@ mkHoleError lcl_name_cache tidy_simples ctxt ; (grouped_skvs, other_tvs) <- zonkAndGroupSkolTvs hole_ty ; let reason | ExprHole _ <- sort = cec_expr_holes ctxt | otherwise = cec_type_holes ctxt - errs = [ReportWithCtxt ctxt $ ReportHoleError hole $ HoleError sort other_tvs grouped_skvs] + errs = [SolverReportWithCtxt ctxt $ ReportHoleError hole $ HoleError sort other_tvs grouped_skvs] supp = [ SupplementaryBindings rel_binds , SupplementaryCts relevant_cts , SupplementaryHoleFits hole_fits ] @@ -1254,7 +1258,7 @@ so that the correct 'Severity' can be computed out of that later on. -- | Adds deferred bindings (as errors). -- See Note [Adding deferred bindings]. -maybeAddDeferredBindings :: ReportErrCtxt +maybeAddDeferredBindings :: SolverReportErrCtxt -> Hole -> SolverReport -> TcM () @@ -1271,13 +1275,13 @@ maybeAddDeferredBindings ctxt hole report = do writeMutVar ref err_tm _ -> pure () --- We unwrap the ReportErrCtxt here, to avoid introducing a loop in module +-- We unwrap the SolverReportErrCtxt here, to avoid introducing a loop in module -- imports -validHoleFits :: ReportErrCtxt -- ^ The context we're in, i.e. the +validHoleFits :: SolverReportErrCtxt -- ^ The context we're in, i.e. the -- implications and the tidy environment -> [Ct] -- ^ Unsolved simple constraints -> Hole -- ^ The hole - -> TcM (ReportErrCtxt, ValidHoleFits) + -> TcM (SolverReportErrCtxt, ValidHoleFits) -- ^ We return the new context -- with a possibly updated -- tidy environment, and @@ -1288,7 +1292,7 @@ validHoleFits ctxt@(CEC {cec_encl = implics ; return (ctxt {cec_tidy = tidy_env}, fits) } -- See Note [Constraints include ...] -givenConstraints :: ReportErrCtxt -> [(Type, RealSrcSpan)] +givenConstraints :: SolverReportErrCtxt -> [(Type, RealSrcSpan)] givenConstraints ctxt = do { implic@Implic{ ic_given = given } <- cec_encl ctxt ; constraint <- given @@ -1296,7 +1300,7 @@ givenConstraints ctxt ---------------- -mkIPErr :: ReportErrCtxt -> [Ct] -> TcM SolverReport +mkIPErr :: SolverReportErrCtxt -> [Ct] -> TcM SolverReport mkIPErr ctxt cts = do { (ctxt, binds_msg, ct1) <- relevantBindings True ctxt ct1 ; let msg = important ctxt $ UnboundImplicitParams (ct1 :| others) @@ -1310,7 +1314,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 SolverReport +mkFRRErr :: SolverReportErrCtxt -> [Ct] -> TcM SolverReport mkFRRErr ctxt cts = do { -- Zonking/tidying. ; origs <- @@ -1392,11 +1396,11 @@ 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 SolverReport +mkEqErr :: SolverReportErrCtxt -> [Ct] -> TcM SolverReport mkEqErr ctxt (ct:_) = mkEqErr1 ctxt ct mkEqErr _ [] = panic "mkEqErr" -mkEqErr1 :: ReportErrCtxt -> Ct -> TcM SolverReport +mkEqErr1 :: SolverReportErrCtxt -> Ct -> TcM SolverReport mkEqErr1 ctxt ct -- Wanted or derived; -- givens handled in mkGivenErrorReporter = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct @@ -1458,9 +1462,9 @@ mkCoercibleExplanation rdr_env fam_envs ty1 ty2 = False -- | Accumulated messages in reverse order. -type AccReportMsgs = NonEmpty TcReportMsg +type AccReportMsgs = NonEmpty TcSolverReportMsg -mkEqErr_help :: ReportErrCtxt +mkEqErr_help :: SolverReportErrCtxt -> Ct -> TcType -> TcType -> TcM (AccReportMsgs, [GhcHint]) mkEqErr_help ctxt ct ty1 ty2 @@ -1471,16 +1475,16 @@ mkEqErr_help ctxt ct ty1 ty2 | otherwise = return (reportEqErr ctxt ct ty1 ty2 :| [], []) -reportEqErr :: ReportErrCtxt +reportEqErr :: SolverReportErrCtxt -> Ct - -> TcType -> TcType -> TcReportMsg + -> TcType -> TcType -> TcSolverReportMsg reportEqErr ctxt ct ty1 ty2 = mkTcReportWithInfo mismatch eqInfos where mismatch = misMatchOrCND False ctxt ct ty1 ty2 eqInfos = eqInfoMsgs ct ty1 ty2 -mkTyVarEqErr :: ReportErrCtxt -> Ct +mkTyVarEqErr :: SolverReportErrCtxt -> Ct -> TcTyVar -> TcType -> TcM (AccReportMsgs, [GhcHint]) -- tv1 and ty2 are already tidied mkTyVarEqErr ctxt ct tv1 ty2 @@ -1488,7 +1492,7 @@ mkTyVarEqErr ctxt ct tv1 ty2 ; dflags <- getDynFlags ; mkTyVarEqErr' dflags ctxt ct tv1 ty2 } -mkTyVarEqErr' :: DynFlags -> ReportErrCtxt -> Ct +mkTyVarEqErr' :: DynFlags -> SolverReportErrCtxt -> Ct -> TcTyVar -> TcType -> TcM (AccReportMsgs, [GhcHint]) mkTyVarEqErr' dflags ctxt ct tv1 ty2 -- impredicativity is a simple error to understand; try it first @@ -1585,7 +1589,7 @@ mkTyVarEqErr' dflags ctxt ct tv1 ty2 insoluble_occurs_check = check_eq_result `cterHasProblem` cteInsolubleOccurs -eqInfoMsgs :: Ct -> TcType -> TcType -> [TcReportInfo] +eqInfoMsgs :: Ct -> TcType -> TcType -> [TcSolverReportInfo] -- 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 @@ -1612,8 +1616,8 @@ eqInfoMsgs ct ty1 ty2 | otherwise = Nothing -misMatchOrCND :: Bool -> ReportErrCtxt -> Ct - -> TcType -> TcType -> TcReportMsg +misMatchOrCND :: Bool -> SolverReportErrCtxt -> Ct + -> TcType -> TcType -> TcSolverReportMsg -- 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] @@ -1639,7 +1643,7 @@ misMatchOrCND insoluble_occurs_check ctxt ct ty1 ty2 -- 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 SolverReport +mkBlockedEqErr :: SolverReportErrCtxt -> [Ct] -> TcM SolverReport mkBlockedEqErr ctxt (ct:_) = return $ important ctxt (BlockedEquality ct) mkBlockedEqErr _ [] = panic "mkBlockedEqErr no constraints" @@ -1683,7 +1687,7 @@ addition to superclasses (see Note [Remove redundant provided dicts] in GHC.Tc.TyCl.PatSyn). -} -extraTyVarEqInfo :: TcTyVar -> TcType -> TcM [TcReportInfo] +extraTyVarEqInfo :: TcTyVar -> TcType -> TcM [TcSolverReportInfo] -- Add on extra info about skolem constants -- NB: The types themselves are already tidied extraTyVarEqInfo tv1 ty2 @@ -1693,7 +1697,7 @@ extraTyVarEqInfo tv1 ty2 Just (tv, _) -> (:[]) <$> extraTyVarInfo tv Nothing -> return [] -extraTyVarInfo :: TcTyVar -> TcM TcReportInfo +extraTyVarInfo :: TcTyVar -> TcM TcSolverReportInfo extraTyVarInfo tv = assertPpr (isTyVar tv) (ppr tv) $ case tcTyVarDetails tv of SkolemTv skol_info lvl overlaps -> do @@ -1702,7 +1706,7 @@ extraTyVarInfo tv = assertPpr (isTyVar tv) (ppr tv) $ _ -> return $ TyVarInfo tv -suggestAddSig :: ReportErrCtxt -> TcType -> TcType -> Maybe GhcHint +suggestAddSig :: SolverReportErrCtxt -> TcType -> TcType -> Maybe GhcHint -- See Note [Suggest adding a type signature] suggestAddSig ctxt ty1 _ty2 | bndr : bndrs <- inferred_bndrs @@ -1729,7 +1733,7 @@ suggestAddSig ctxt ty1 _ty2 -------------------- -mkMismatchMsg :: Ct -> Type -> Type -> TcReportMsg +mkMismatchMsg :: Ct -> Type -> Type -> TcSolverReportMsg mkMismatchMsg ct ty1 ty2 = case ctOrigin ct of TypeEqOrigin { uo_actual, uo_expected, uo_thing = mb_thing } -> @@ -1794,7 +1798,7 @@ This is done in misMatchOrCND (via the insoluble_occurs_check arg) want to be as draconian with them.) -} -sameOccExtras :: TcType -> TcType -> [TcReportInfo] +sameOccExtras :: TcType -> TcType -> [TcSolverReportInfo] -- See Note [Disambiguating (X ~ X) errors] sameOccExtras ty1 ty2 | Just (tc1, _) <- tcSplitTyConApp_maybe ty1 @@ -1876,7 +1880,7 @@ Warn of loopy local equalities that were dropped. ************************************************************************ -} -mkDictErr :: HasDebugCallStack => ReportErrCtxt -> [Ct] -> TcM SolverReport +mkDictErr :: HasDebugCallStack => SolverReportErrCtxt -> [Ct] -> TcM SolverReport mkDictErr ctxt cts = assert (not (null cts)) $ do { inst_envs <- tcGetInstEnvs @@ -1921,8 +1925,8 @@ mkDictErr ctxt cts -- - One match, one or more unifiers: report "Overlapping instances for", show the -- 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 TcReportMsg +mk_dict_err :: HasCallStack => SolverReportErrCtxt -> (Ct, ClsInstLookupResult) + -> TcM TcSolverReportMsg -- Report an overlap error if this class constraint results -- from an overlap (returning Left clas), otherwise return (Right pred) mk_dict_err ctxt (ct, (matches, unifiers, unsafe_overlapped)) @@ -1986,12 +1990,12 @@ mk_dict_err ctxt (ct, (matches, unifiers, unsafe_overlapped)) HasFieldOrigin name -> Just (mkVarOccFS name) _ -> Nothing - cannot_resolve_msg :: Ct -> [ClsInst] -> RelevantBindings -> [ImportError] -> [GhcHint] -> TcReportMsg + cannot_resolve_msg :: Ct -> [ClsInst] -> RelevantBindings -> [ImportError] -> [GhcHint] -> TcSolverReportMsg cannot_resolve_msg ct candidate_insts binds imp_errs field_suggestions = CannotResolveInstance ct (getPotentialUnifiers unifiers) candidate_insts imp_errs field_suggestions binds -- Overlap errors. - overlap_msg, safe_haskell_msg :: TcReportMsg + overlap_msg, safe_haskell_msg :: TcSolverReportMsg -- Normal overlap error overlap_msg = assert (not (null matches)) $ OverlappingInstances ct ispecs (getPotentialUnifiers unifiers) @@ -2101,8 +2105,8 @@ getAmbigTkvs ct relevantBindings :: Bool -- True <=> filter by tyvar; False <=> no filtering -- See #8191 - -> ReportErrCtxt -> Ct - -> TcM (ReportErrCtxt, RelevantBindings, Ct) + -> SolverReportErrCtxt -> Ct + -> TcM (SolverReportErrCtxt, RelevantBindings, Ct) -- Also returns the zonked and tidied CtOrigin of the constraint relevantBindings want_filtering ctxt ct = do { traceTc "relevantBindings" (ppr ct) @@ -2261,3 +2265,45 @@ solverDepthErrorTcS loc ty , text "(any upper bound you could choose might fail unpredictably with" , text " minor updates to GHC, so disabling the check is recommended if" , text " you're sure that type checking should terminate)" ] + +{-********************************************************************** +* * + GHC API helper functions +* * +**********************************************************************-} + +-- | If the 'TcSolverReportMsg' is a type mismatch between +-- an actual and an expected type, return the actual and expected types +-- (in that order). +-- +-- Prefer using this over manually inspecting the 'TcSolverReportMsg' datatype +-- if you just want this information, as the datatype itself is subject to change +-- across GHC versions. +solverReportMsg_ExpectedActuals :: TcSolverReportMsg -> [(Type, Type)] +solverReportMsg_ExpectedActuals + = \case + TcReportWithInfo msg infos -> + solverReportMsg_ExpectedActuals msg + ++ (solverReportInfo_ExpectedActuals =<< toList infos) + Mismatch { mismatch_ty1 = exp, mismatch_ty2 = act } -> + [(exp, act)] + KindMismatch { kmismatch_expected = exp, kmismatch_actual = act } -> + [(exp, act)] + TypeEqMismatch { teq_mismatch_expected = exp, teq_mismatch_actual = act } -> + [(exp,act)] + _ -> [] + +-- | Retrieves all @"expected"/"actual"@ messages from a 'TcSolverReportInfo'. +-- +-- Prefer using this over inspecting the 'TcSolverReportInfo' datatype if +-- you just need this information, as the datatype itself is subject to change +-- across GHC versions. +solverReportInfo_ExpectedActuals :: TcSolverReportInfo -> [(Type, Type)] +solverReportInfo_ExpectedActuals + = \case + ExpectedActual { ea_expected = exp, ea_actual = act } -> + [(exp, act)] + ExpectedActualAfterTySynExpansion + { ea_expanded_expected = exp, ea_expanded_actual = act } -> + [(exp, act)] + _ -> [] diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs index edd4b127ee..d1ea6d93e2 100644 --- a/compiler/GHC/Tc/Errors/Ppr.hs +++ b/compiler/GHC/Tc/Errors/Ppr.hs @@ -29,6 +29,7 @@ import GHC.Core.InstEnv import GHC.Core.TyCo.Rep (Type(..)) import GHC.Core.TyCo.Ppr (pprWithExplicitKindsWhen, pprSourceTyCon, pprTyVars, pprWithTYPE) +import GHC.Core.PatSyn ( patSynName, pprPatSynType ) import GHC.Core.Predicate import GHC.Core.Type @@ -91,7 +92,7 @@ instance Diagnostic TcRnMessage where -> messageWithInfoDiagnosticMessage unit_state err_info (diagnosticMessage msg) TcRnSolverReport msgs _ _ -> mkDecorated $ - map pprReportWithCtxt msgs + map pprSolverReportWithCtxt msgs TcRnRedundantConstraints redundants (info, show_info) -> mkSimpleDecorated $ text "Redundant constraint" <> plural redundants <> colon @@ -101,7 +102,7 @@ instance Diagnostic TcRnMessage where -> mkSimpleDecorated $ hang (text "Inaccessible code in") 2 (ppr (ic_info implic)) - $$ vcat (map pprReportWithCtxt (NE.toList contras)) + $$ vcat (map pprSolverReportWithCtxt (NE.toList contras)) TcRnTypeDoesNotHaveFixedRuntimeRep ty prov (ErrInfo extra supplementary) -> mkDecorated [pprTypeDoesNotHaveFixedRuntimeRep ty prov, extra, supplementary] TcRnImplicitLift id_or_name ErrInfo{..} @@ -230,6 +231,24 @@ instance Diagnostic TcRnMessage where hang (text "Can't quantify over" <+> quotes (ppr n)) 2 (hang (text "bound by the partial type signature:") 2 (ppr fn_name <+> dcolon <+> ppr hs_ty)) + TcRnMissingSignature what _ _ -> + mkSimpleDecorated $ + case what of + MissingPatSynSig p -> + hang (text "Pattern synonym with no type signature:") + 2 (text "pattern" <+> pprPrefixName (patSynName p) <+> dcolon <+> pprPatSynType p) + MissingTopLevelBindingSig name ty -> + hang (text "Top-level binding with no type signature:") + 2 (pprPrefixName name <+> dcolon <+> pprSigmaType ty) + MissingTyConKindSig tc cusks_enabled -> + hang msg + 2 (text "type" <+> pprPrefixName (tyConName tc) <+> dcolon <+> pprKind (tyConKind tc)) + where + msg | cusks_enabled + = text "Top-level type constructor with no standalone kind signature or CUSK:" + | otherwise + = text "Top-level type constructor with no standalone kind signature:" + TcRnPolymorphicBinderMissingSig n ty -> mkSimpleDecorated $ sep [ text "Polymorphic local binding with no type signature:" @@ -701,6 +720,8 @@ instance Diagnostic TcRnMessage where -> ErrorWithoutFlag TcRnPartialTypeSigBadQuantifier{} -> ErrorWithoutFlag + TcRnMissingSignature what exported overridden + -> WarningWithFlag $ missingSignatureWarningFlag what exported overridden TcRnPolymorphicBinderMissingSig{} -> WarningWithFlag Opt_WarnMissingLocalSignatures TcRnOverloadedSig{} @@ -937,6 +958,8 @@ instance Diagnostic TcRnMessage where -> noHints TcRnPartialTypeSigBadQuantifier{} -> noHints + TcRnMissingSignature {} + -> noHints TcRnPolymorphicBinderMissingSig{} -> noHints TcRnOverloadedSig{} @@ -1230,6 +1253,23 @@ formatExportItemError exportedThing reason = , quotes exportedThing , text reason ] +-- | What warning flag is associated with the given missing signature? +missingSignatureWarningFlag :: MissingSignature -> Exported -> Bool -> WarningFlag +missingSignatureWarningFlag (MissingTopLevelBindingSig {}) exported overridden + | IsExported <- exported + , not overridden + = Opt_WarnMissingExportedSignatures + | otherwise + = Opt_WarnMissingSignatures +missingSignatureWarningFlag (MissingPatSynSig {}) exported overridden + | IsExported <- exported + , not overridden + = Opt_WarnMissingExportedPatternSynonymSignatures + | otherwise + = Opt_WarnMissingPatternSynonymSignatures +missingSignatureWarningFlag (MissingTyConKindSig {}) _ _ + = Opt_WarnMissingKindSignatures + useDerivingStrategies :: GhcHint useDerivingStrategies = useExtensionInOrderTo (text "to pick a different strategy") LangExt.DerivingStrategies @@ -1439,11 +1479,11 @@ derivErrDiagnosticMessage cls cls_tys mb_strat newtype_deriving pprHerald = \cas {- ********************************************************************* * * - Outputable ReportErrCtxt (for debugging) + Outputable SolverReportErrCtxt (for debugging) * * **********************************************************************-} -instance Outputable ReportErrCtxt where +instance Outputable SolverReportErrCtxt where ppr (CEC { cec_binds = bvar , cec_defer_type_errors = dte , cec_expr_holes = eh @@ -1464,34 +1504,34 @@ instance Outputable ReportErrCtxt where {- ********************************************************************* * * - Outputting TcReportMsg errors + Outputting TcSolverReportMsg errors * * **********************************************************************-} --- | Pretty-print a 'ReportWithCtxt', containing a 'TcReportMsg' --- with its enclosing 'ReportErrCtxt'. -pprReportWithCtxt :: ReportWithCtxt -> SDoc -pprReportWithCtxt (ReportWithCtxt { reportContext = ctxt, reportContent = msg }) - = pprTcReportMsg ctxt msg +-- | Pretty-print a 'SolverReportWithCtxt', containing a 'TcSolverReportMsg' +-- with its enclosing 'SolverReportErrCtxt'. +pprSolverReportWithCtxt :: SolverReportWithCtxt -> SDoc +pprSolverReportWithCtxt (SolverReportWithCtxt { reportContext = ctxt, reportContent = msg }) + = pprTcSolverReportMsg ctxt msg --- | Pretty-print a 'TcReportMsg', with its enclosing 'ReportErrCtxt'. -pprTcReportMsg :: ReportErrCtxt -> TcReportMsg -> SDoc -pprTcReportMsg ctxt (TcReportWithInfo msg (info :| infos)) = +-- | Pretty-print a 'TcSolverReportMsg', with its enclosing 'SolverReportErrCtxt'. +pprTcSolverReportMsg :: SolverReportErrCtxt -> TcSolverReportMsg -> SDoc +pprTcSolverReportMsg ctxt (TcReportWithInfo msg (info :| infos)) = vcat - ( pprTcReportMsg ctxt msg - : pprTcReportInfo ctxt info - : map (pprTcReportInfo ctxt) infos ) -pprTcReportMsg _ (BadTelescope telescope skols) = + ( pprTcSolverReportMsg ctxt msg + : pprTcSolverReportInfo ctxt info + : map (pprTcSolverReportInfo ctxt) infos ) +pprTcSolverReportMsg _ (BadTelescope telescope skols) = hang (text "These kind and type variables:" <+> ppr telescope $$ text "are out of dependency order. Perhaps try this ordering:") 2 (pprTyVars sorted_tvs) where sorted_tvs = scopedSort skols -pprTcReportMsg _ (UserTypeError ty) = +pprTcSolverReportMsg _ (UserTypeError ty) = pprUserTypeErrorTy ty -pprTcReportMsg ctxt (ReportHoleError hole err) = +pprTcSolverReportMsg ctxt (ReportHoleError hole err) = pprHoleError ctxt hole err -pprTcReportMsg _ (CannotUnifyWithPolytype ct tv1 ty2) = +pprTcSolverReportMsg _ (CannotUnifyWithPolytype ct tv1 ty2) = vcat [ (if isSkolemTyVar tv1 then text "Cannot equate type variable" else text "Cannot instantiate unification variable") @@ -1500,7 +1540,7 @@ pprTcReportMsg _ (CannotUnifyWithPolytype ct tv1 ty2) = where what = text $ levelString $ ctLocTypeOrKind_maybe (ctLoc ct) `orElse` TypeLevel -pprTcReportMsg _ +pprTcSolverReportMsg _ (Mismatch { mismatch_ea = add_ea , mismatch_ct = ct , mismatch_ty1 = ty1 @@ -1547,7 +1587,7 @@ pprTcReportMsg _ add_space s1 s2 | null s1 = s2 | null s2 = s1 | otherwise = s1 ++ (' ' : s2) -pprTcReportMsg _ +pprTcSolverReportMsg _ (KindMismatch { kmismatch_what = thing , kmismatch_expected = exp , kmismatch_actual = act }) @@ -1563,7 +1603,7 @@ pprTcReportMsg _ | otherwise = text "kind" <+> quotes (ppr exp) -pprTcReportMsg ctxt +pprTcSolverReportMsg ctxt (TypeEqMismatch { teq_mismatch_ppr_explicit_kinds = ppr_explicit_kinds , teq_mismatch_ct = ct , teq_mismatch_ty1 = ty1 @@ -1589,17 +1629,17 @@ pprTcReportMsg ctxt , quotes (pprWithTYPE act) ] | Just nargs_msg <- num_args_msg , Right ea_msg <- mk_ea_msg ctxt (Just ct) level orig - = nargs_msg $$ pprTcReportMsg ctxt ea_msg + = nargs_msg $$ pprTcSolverReportMsg ctxt ea_msg | -- pprTrace "check" (ppr ea_looks_same $$ ppr exp $$ ppr act $$ ppr ty1 $$ ppr ty2) $ ea_looks_same ty1 ty2 exp act , Right ea_msg <- mk_ea_msg ctxt (Just ct) level orig - = pprTcReportMsg ctxt ea_msg + = pprTcSolverReportMsg ctxt ea_msg -- The mismatched types are /inside/ exp and act | let mismatch_err = Mismatch False ct ty1 ty2 errs = case mk_ea_msg ctxt Nothing level orig of Left ea_info -> [ mkTcReportWithInfo mismatch_err ea_info ] Right ea_err -> [ mismatch_err, ea_err ] - = vcat $ map (pprTcReportMsg ctxt) errs + = vcat $ map (pprTcSolverReportMsg ctxt) errs ct_loc = ctLoc ct orig = ctOrigin ct @@ -1620,7 +1660,7 @@ pprTcReportMsg ctxt 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 $ pprTcReportMsg ctxt (ExpectingMoreArguments n thing) + -> Just $ pprTcSolverReportMsg ctxt (ExpectingMoreArguments n thing) _ -> Nothing _ -> Nothing @@ -1628,7 +1668,7 @@ pprTcReportMsg ctxt maybe_num_args_msg = num_args_msg `orElse` empty count_args ty = count isVisibleBinder $ fst $ splitPiTys ty -pprTcReportMsg _ (FixedRuntimeRepError origs_and_tys) = +pprTcSolverReportMsg _ (FixedRuntimeRepError origs_and_tys) = let -- Assemble the error message: pair up each origin with the corresponding type, e.g. -- • FixedRuntimeRep origin msg 1 ... @@ -1643,7 +1683,7 @@ pprTcReportMsg _ (FixedRuntimeRepError origs_and_tys) = ,nest 2 $ ppr ty <+> dcolon <+> pprWithTYPE (typeKind ty)] in vcat $ map (uncurry combine_origin_ty) origs_and_tys -pprTcReportMsg _ (SkolemEscape ct implic esc_skols) = +pprTcSolverReportMsg _ (SkolemEscape ct implic esc_skols) = let esc_doc = sep [ text "because" <+> what <+> text "variable" <> plural esc_skols <+> pprQuotedList esc_skols @@ -1664,40 +1704,40 @@ pprTcReportMsg _ (SkolemEscape ct implic esc_skols) = where what = text $ levelString $ ctLocTypeOrKind_maybe (ctLoc ct) `orElse` TypeLevel -pprTcReportMsg _ (UntouchableVariable tv implic) +pprTcSolverReportMsg _ (UntouchableVariable tv implic) | Implic { ic_given = given, ic_info = skol_info } <- implic = sep [ quotes (ppr tv) <+> text "is untouchable" , nest 2 $ text "inside the constraints:" <+> pprEvVarTheta given , nest 2 $ text "bound by" <+> ppr skol_info , nest 2 $ text "at" <+> ppr (getLclEnvLoc (ic_env implic)) ] -pprTcReportMsg _ (BlockedEquality ct) = +pprTcSolverReportMsg _ (BlockedEquality ct) = vcat [ hang (text "Cannot use equality for substitution:") 2 (ppr (ctPred ct)) , text "Doing so would be ill-kinded." ] -pprTcReportMsg _ (ExpectingMoreArguments n thing) = +pprTcSolverReportMsg _ (ExpectingMoreArguments n thing) = text "Expecting" <+> speakN (abs n) <+> more <+> quotes (ppr thing) where more | n == 1 = text "more argument to" | otherwise = text "more arguments to" -- n > 1 -pprTcReportMsg ctxt (UnboundImplicitParams (ct :| cts)) = +pprTcSolverReportMsg ctxt (UnboundImplicitParams (ct :| cts)) = let givens = getUserGivens ctxt in if null givens then addArising (ctOrigin ct) $ sep [ text "Unbound implicit parameter" <> plural preds , nest 2 (pprParendTheta preds) ] - else pprTcReportMsg ctxt (CouldNotDeduce givens (ct :| cts) Nothing) + else pprTcSolverReportMsg ctxt (CouldNotDeduce givens (ct :| cts) Nothing) where preds = map ctPred (ct : cts) -pprTcReportMsg ctxt (CouldNotDeduce useful_givens (ct :| others) mb_extra) +pprTcSolverReportMsg ctxt (CouldNotDeduce useful_givens (ct :| others) mb_extra) = main_msg $$ case supplementary of Left infos - -> vcat (map (pprTcReportInfo ctxt) infos) + -> vcat (map (pprTcSolverReportInfo ctxt) infos) Right other_msg - -> pprTcReportMsg ctxt other_msg + -> pprTcSolverReportMsg ctxt other_msg where main_msg | null useful_givens @@ -1725,21 +1765,21 @@ pprTcReportMsg ctxt (CouldNotDeduce useful_givens (ct :| others) mb_extra) = text "Could not deduce" <+> pprParendType wanted | otherwise = text "Could not deduce:" <+> pprTheta wanteds -pprTcReportMsg ctxt (AmbiguityPreventsSolvingCt ct ambigs) = - pprTcReportInfo ctxt (Ambiguity True ambigs) <+> +pprTcSolverReportMsg ctxt (AmbiguityPreventsSolvingCt ct ambigs) = + pprTcSolverReportInfo ctxt (Ambiguity True ambigs) <+> pprArising (ctOrigin ct) $$ text "prevents the constraint" <+> quotes (pprParendType $ ctPred ct) <+> text "from being solved." -pprTcReportMsg ctxt@(CEC {cec_encl = implics}) +pprTcSolverReportMsg ctxt@(CEC {cec_encl = implics}) (CannotResolveInstance ct unifiers candidates imp_errs suggs binds) = vcat - [ pprTcReportMsg ctxt no_inst_msg + [ pprTcSolverReportMsg ctxt no_inst_msg , nest 2 extra_note , mb_patsyn_prov `orElse` empty , ppWhen (has_ambigs && not (null unifiers && null useful_givens)) (vcat [ ppUnless lead_with_ambig $ - pprTcReportInfo ctxt (Ambiguity False (ambig_kvs, ambig_tvs)) + pprTcSolverReportInfo ctxt (Ambiguity False (ambig_kvs, ambig_tvs)) , pprRelevantBindings binds , potential_msg ]) , ppWhen (isNothing mb_patsyn_prov) $ @@ -1769,7 +1809,7 @@ pprTcReportMsg ctxt@(CEC {cec_encl = implics}) && not (null unifiers) && null useful_givens - no_inst_msg :: TcReportMsg + no_inst_msg :: TcSolverReportMsg no_inst_msg | lead_with_ambig = AmbiguityPreventsSolvingCt ct (ambig_kvs, ambig_tvs) @@ -1826,7 +1866,7 @@ pprTcReportMsg ctxt@(CEC {cec_encl = implics}) = hang (text "use a standalone 'deriving instance' declaration,") 2 (text "so you can specify the instance context yourself") -pprTcReportMsg (CEC {cec_encl = implics}) (OverlappingInstances ct matches unifiers) = +pprTcSolverReportMsg (CEC {cec_encl = implics}) (OverlappingInstances ct matches unifiers) = vcat [ addArising orig $ (text "Overlapping instances for" @@ -1886,7 +1926,7 @@ pprTcReportMsg (CEC {cec_encl = implics}) (OverlappingInstances ct matches unifi Just (clas', tys') -> clas' == clas && isJust (tcMatchTys tys tys') Nothing -> False -pprTcReportMsg _ (UnsafeOverlap ct matches unsafe_overlapped) = +pprTcSolverReportMsg _ (UnsafeOverlap ct matches unsafe_overlapped) = vcat [ addArising orig (text "Unsafe overlapping instances for" <+> pprType (mkClassPred clas tys)) , sep [text "The matching instance is:", @@ -2093,13 +2133,13 @@ we want to give it a bit of structure. Here's the plan {- ********************************************************************* * * - Outputting TcReportInfo + Outputting TcSolverReportInfo * * **********************************************************************-} --- | Pretty-print an informational message, to accompany a 'TcReportMsg'. -pprTcReportInfo :: ReportErrCtxt -> TcReportInfo -> SDoc -pprTcReportInfo _ (Ambiguity prepend_msg (ambig_kvs, ambig_tvs)) = msg +-- | Pretty-print an informational message, to accompany a 'TcSolverReportMsg'. +pprTcSolverReportInfo :: SolverReportErrCtxt -> TcSolverReportInfo -> SDoc +pprTcSolverReportInfo _ (Ambiguity prepend_msg (ambig_kvs, ambig_tvs)) = msg where msg | any isRuntimeUnkSkol ambig_kvs -- See Note [Runtime skolems] @@ -2122,21 +2162,21 @@ pprTcReportInfo _ (Ambiguity prepend_msg (ambig_kvs, ambig_tvs)) = msg | otherwise -- "The type variable 't0' is ambiguous" = text "The" <+> what <+> text "variable" <> plural tkvs <+> pprQuotedList tkvs <+> isOrAre tkvs <+> text "ambiguous" -pprTcReportInfo ctxt (TyVarInfo tv ) = +pprTcSolverReportInfo ctxt (TyVarInfo tv ) = case tcTyVarDetails tv of SkolemTv sk_info _ _ -> pprSkols ctxt [(getSkolemInfo sk_info, [tv])] RuntimeUnk {} -> quotes (ppr tv) <+> text "is an interactive-debugger skolem" MetaTv {} -> empty -pprTcReportInfo _ (NonInjectiveTyFam tc) = +pprTcSolverReportInfo _ (NonInjectiveTyFam tc) = text "NB:" <+> quotes (ppr tc) <+> text "is a non-injective type family" -pprTcReportInfo _ (ReportCoercibleMsg msg) = +pprTcSolverReportInfo _ (ReportCoercibleMsg msg) = pprCoercibleMsg msg -pprTcReportInfo _ (ExpectedActual { ea_expected = exp, ea_actual = act }) = +pprTcSolverReportInfo _ (ExpectedActual { ea_expected = exp, ea_actual = act }) = vcat [ text "Expected:" <+> ppr exp , text " Actual:" <+> ppr act ] -pprTcReportInfo _ +pprTcSolverReportInfo _ (ExpectedActualAfterTySynExpansion { ea_expanded_expected = exp , ea_expanded_actual = act } ) @@ -2144,7 +2184,7 @@ pprTcReportInfo _ [ text "Type synonyms expanded:" , text "Expected type:" <+> ppr exp , text " Actual type:" <+> ppr act ] -pprTcReportInfo ctxt (WhenMatching cty1 cty2 sub_o mb_sub_t_or_k) = +pprTcSolverReportInfo ctxt (WhenMatching cty1 cty2 sub_o mb_sub_t_or_k) = sdocOption sdocPrintExplicitCoercions $ \printExplicitCoercions -> if printExplicitCoercions || not (cty1 `pickyEqType` cty2) @@ -2160,9 +2200,9 @@ pprTcReportInfo ctxt (WhenMatching cty1 cty2 sub_o mb_sub_t_or_k) = sub_whats = text (levelString sub_t_or_k) <> char 's' supplementary = case mk_supplementary_ea_msg ctxt sub_t_or_k cty1 cty2 sub_o of - Left infos -> vcat $ map (pprTcReportInfo ctxt) infos - Right msg -> pprTcReportMsg ctxt msg -pprTcReportInfo _ (SameOcc same_pkg n1 n2) = + Left infos -> vcat $ map (pprTcSolverReportInfo ctxt) infos + Right msg -> pprTcSolverReportMsg ctxt msg +pprTcSolverReportInfo _ (SameOcc same_pkg n1 n2) = text "NB:" <+> (ppr_from same_pkg n1 $$ ppr_from same_pkg n2) where ppr_from same_pkg nm @@ -2178,7 +2218,7 @@ pprTcReportInfo _ (SameOcc same_pkg n1 n2) = pkg = moduleUnit mod mod = nameModule nm loc = nameSrcSpan nm -pprTcReportInfo ctxt (OccursCheckInterestingTyVars (tv :| tvs)) = +pprTcSolverReportInfo ctxt (OccursCheckInterestingTyVars (tv :| tvs)) = hang (text "Type variable kinds:") 2 $ vcat (map (tyvar_binding . tidyTyCoVarOcc (cec_tidy ctxt)) (tv:tvs)) @@ -2205,7 +2245,7 @@ pprCoercibleMsg (OutOfScopeNewtypeConstructor tc dc) = * * **********************************************************************-} -pprHoleError :: ReportErrCtxt -> Hole -> HoleError -> SDoc +pprHoleError :: SolverReportErrCtxt -> Hole -> HoleError -> SDoc pprHoleError _ (Hole { hole_ty, hole_occ = occ }) (OutOfScopeHole imp_errs) = out_of_scope_msg $$ vcat (map ppr imp_errs) where @@ -2508,7 +2548,7 @@ tidySigSkol env cx ty tv_prs | otherwise = tidyVarBndr env tv -pprSkols :: ReportErrCtxt -> [(SkolemInfoAnon, [TcTyVar])] -> SDoc +pprSkols :: SolverReportErrCtxt -> [(SkolemInfoAnon, [TcTyVar])] -> SDoc pprSkols ctxt zonked_ty_vars = let tidy_ty_vars = map (bimap (tidySkolemInfoAnon (cec_tidy ctxt)) id) zonked_ty_vars @@ -2551,8 +2591,8 @@ skolsSpan skol_tvs = foldr1 combineSrcSpans (map getSrcSpan skol_tvs) * * **********************************************************************-} -mk_supplementary_ea_msg :: ReportErrCtxt -> TypeOrKind - -> Type -> Type -> CtOrigin -> Either [TcReportInfo] TcReportMsg +mk_supplementary_ea_msg :: SolverReportErrCtxt -> TypeOrKind + -> Type -> Type -> CtOrigin -> Either [TcSolverReportInfo] TcSolverReportMsg 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) @@ -2574,7 +2614,7 @@ ea_looks_same ty1 ty2 exp act -- when the types really look the same. However, -- (TYPE 'LiftedRep) and Type both print the same way. -mk_ea_msg :: ReportErrCtxt -> Maybe Ct -> TypeOrKind -> CtOrigin -> Either [TcReportInfo] TcReportMsg +mk_ea_msg :: SolverReportErrCtxt -> Maybe Ct -> TypeOrKind -> CtOrigin -> Either [TcSolverReportInfo] TcSolverReportMsg -- Constructs a "Couldn't match" message -- The (Maybe Ct) says whether this is the main top-level message (Just) -- or a supplementary message (Nothing) diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs index e292d864d8..c244c4c2a4 100644 --- a/compiler/GHC/Tc/Errors/Types.hs +++ b/compiler/GHC/Tc/Errors/Types.hs @@ -1,4 +1,6 @@ {-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} + module GHC.Tc.Errors.Types ( -- * Main types TcRnMessage(..) @@ -31,12 +33,14 @@ module GHC.Tc.Errors.Types ( , associatedTyLastVarInKind , AssociatedTyNotParamOverLastTyVar(..) , associatedTyNotParamOverLastTyVar + , MissingSignature(..) + , Exported(..) , SolverReport(..), SolverReportSupplementary(..) - , ReportWithCtxt(..) - , ReportErrCtxt(..) + , SolverReportWithCtxt(..) + , SolverReportErrCtxt(..) , getUserGivens, discardProvCtxtGivens - , TcReportMsg(..), TcReportInfo(..) + , TcSolverReportMsg(..), TcSolverReportInfo(..) , CND_Extra(..) , mkTcReportWithInfo , FitsMbSuppressed(..) @@ -77,6 +81,7 @@ import GHC.Core.ConLike (ConLike) import GHC.Core.DataCon (DataCon) import GHC.Core.FamInstEnv (FamInst) import GHC.Core.InstEnv (ClsInst) +import GHC.Core.PatSyn (PatSyn) import GHC.Core.TyCon (TyCon, TyConFlavour) import GHC.Core.Type (Kind, Type, ThetaType, PredType) import GHC.Unit.State (UnitState) @@ -164,10 +169,10 @@ data TcRnMessage where {-| TcRnSolverReport is the constructor used to report unsolved constraints after constraint solving, as well as other errors such as hole fit errors. - See the documentation of the 'TcReportMsg' datatype for an overview + See the documentation of the 'TcSolverReportMsg' datatype for an overview of the different errors. -} - TcRnSolverReport :: [ReportWithCtxt] + TcRnSolverReport :: [SolverReportWithCtxt] -> DiagnosticReason -> [GhcHint] -> TcRnMessage @@ -202,7 +207,7 @@ data TcRnMessage where Test cases: T7293, T7294, T15558, T17646, T18572, T18610, tcfail167. -} TcRnInaccessibleCode :: Implication -- ^ The implication containing a contradiction. - -> NE.NonEmpty ReportWithCtxt -- ^ The contradiction(s). + -> NE.NonEmpty SolverReportWithCtxt -- ^ The contradiction(s). -> TcRnMessage {-| A type which was expected to have a fixed runtime representation @@ -601,6 +606,27 @@ data TcRnMessage where -> Name -- ^ function name -> LHsSigWcType GhcRn -> TcRnMessage + {-| TcRnMissingSignature is a warning that occurs when a top-level binding + or a pattern synonym does not have a type signature. + + Controlled by the flags: + -Wmissing-signatures + -Wmissing-exported-signatures + -Wmissing-pattern-synonym-signatures + -Wmissing-exported-pattern-synonym-signatures + -Wmissing-kind-signatures + + Test cases: + T11077 (top-level bindings) + T12484 (pattern synonyms) + T19564 (kind signatures) + -} + TcRnMissingSignature :: MissingSignature + -> Exported + -> Bool -- ^ True: -Wmissing-signatures overrides -Wmissing-exported-signatures, + -- or -Wmissing-pattern-synonym-signatures overrides -Wmissing-exported-pattern-synonym-signatures + -> TcRnMessage + {-| TcRnPolymorphicBinderMissingSig is a warning controlled by -Wmissing-local-signatures that occurs when a local polymorphic binding lacks a type signature. @@ -1825,6 +1851,29 @@ associatedTyNotParamOverLastTyVar :: Maybe TyCon -> AssociatedTyNotParamOverLast associatedTyNotParamOverLastTyVar (Just tc) = YesAssociatedTyNotParamOverLastTyVar tc associatedTyNotParamOverLastTyVar Nothing = NoAssociatedTyNotParamOverLastTyVar +-- | What kind of thing is missing a type signature? +-- +-- Used for reporting @"missing signature"@ warnings, see +-- 'tcRnMissingSignature'. +data MissingSignature + = MissingTopLevelBindingSig Name Type + | MissingPatSynSig PatSyn + | MissingTyConKindSig + TyCon + Bool -- ^ whether -XCUSKs is enabled + +-- | Is the object we are dealing with exported or not? +-- +-- Used for reporting @"missing signature"@ warnings, see +-- 'TcRnMissingSignature'. +data Exported + = IsNotExported + | IsExported + +instance Outputable Exported where + ppr IsNotExported = text "IsNotExported" + ppr IsExported = text "IsExported" + -------------------------------------------------------------------------------- -- Errors used in GHC.Tc.Errors @@ -1854,7 +1903,7 @@ See 'GHC.Tc.Errors.Types.SolverReport' and 'GHC.Tc.Errors.mkErrorReport'. -- See Note [Error report] for details. data SolverReport = SolverReport - { sr_important_msgs :: [ReportWithCtxt] + { sr_important_msgs :: [SolverReportWithCtxt] , sr_supplementary :: [SolverReportSupplementary] , sr_hints :: [GhcHint] } @@ -1868,15 +1917,15 @@ data SolverReportSupplementary | SupplementaryHoleFits ValidHoleFits | SupplementaryCts [(PredType, RealSrcSpan)] --- | A 'TcReportMsg', together with context (e.g. enclosing implication constraints) +-- | A 'TcSolverReportMsg', together with context (e.g. enclosing implication constraints) -- that are needed in order to report it. -data ReportWithCtxt = - ReportWithCtxt - { reportContext :: ReportErrCtxt +data SolverReportWithCtxt = + SolverReportWithCtxt + { reportContext :: SolverReportErrCtxt -- ^ Context for what we wish to report. -- This can change as we enter implications, so is -- stored alongside the content. - , reportContent :: TcReportMsg + , reportContent :: TcSolverReportMsg -- ^ The content of the message to report. } @@ -1888,9 +1937,9 @@ instance Monoid SolverReport where mempty = SolverReport [] [] [] mappend = (Semigroup.<>) --- | Context needed when reporting a 'TcReportMsg', such as +-- | Context needed when reporting a 'TcSolverReportMsg', such as -- the enclosing implication constraints or whether we are deferring type errors. -data ReportErrCtxt +data SolverReportErrCtxt = CEC { cec_encl :: [Implication] -- ^ Enclosing implications -- (innermost first) -- ic_skols and givens are tidied, rest are not @@ -1918,7 +1967,7 @@ data ReportErrCtxt -- See Note [Suppressing error messages] } -getUserGivens :: ReportErrCtxt -> [UserGiven] +getUserGivens :: SolverReportErrCtxt -> [UserGiven] -- One item for each enclosing implication getUserGivens (CEC {cec_encl = implics}) = getUserGivensFromImplics implics @@ -1980,7 +2029,7 @@ discardProvCtxtGivens orig givens -- See Note [discardProvCtxtGivens] -- | An error reported after constraint solving. -- This is usually, some sort of unsolved constraint error, -- but we try to be specific about the precise problem we encountered. -data TcReportMsg +data TcSolverReportMsg -- NB: this datatype is only a first step in refactoring GHC.Tc.Errors -- to use the diagnostic infrastructure (TcRnMessage etc). -- If you see possible improvements, please go right ahead! @@ -1988,7 +2037,7 @@ data TcReportMsg -- | Wrap a message with additional information. -- -- Prefer using the 'mkTcReportWithInfo' smart constructor - = TcReportWithInfo TcReportMsg (NE.NonEmpty TcReportInfo) + = TcReportWithInfo TcSolverReportMsg (NE.NonEmpty TcSolverReportInfo) -- | Quantified variables appear out of dependency order. -- @@ -2174,12 +2223,12 @@ data TcReportMsg -- which is then passed on to 'mk_supplementary_ea_msg'. data CND_Extra = CND_Extra TypeOrKind Type Type --- | Additional information that can be appended to an existing 'TcReportMsg'. -data TcReportInfo +-- | Additional information that can be appended to an existing 'TcSolverReportMsg'. +data TcSolverReportInfo -- NB: this datatype is only a first step in refactoring GHC.Tc.Errors -- to use the diagnostic infrastructure (TcRnMessage etc). -- It would be better for these constructors to not be so closely tied - -- to the constructors of 'TcReportMsg'. + -- to the constructors of 'TcSolverReportMsg'. -- If you see possible improvements, please go right ahead! -- | Some type variables remained ambiguous: print them to the user. @@ -2337,8 +2386,8 @@ data PotentialInstances , unifiers :: [ClsInst] } --- | Append additional information to a `TcReportMsg`. -mkTcReportWithInfo :: TcReportMsg -> [TcReportInfo] -> TcReportMsg +-- | Append additional information to a `TcSolverReportMsg`. +mkTcReportWithInfo :: TcSolverReportMsg -> [TcSolverReportInfo] -> TcSolverReportMsg mkTcReportWithInfo msg [] = msg mkTcReportWithInfo (TcReportWithInfo msg (prev NE.:| prevs)) infos diff --git a/compiler/GHC/Tc/Types/Origin.hs b/compiler/GHC/Tc/Types/Origin.hs index bfaa1a0675..7edd94439b 100644 --- a/compiler/GHC/Tc/Types/Origin.hs +++ b/compiler/GHC/Tc/Types/Origin.hs @@ -431,7 +431,7 @@ data TypedThing -- | Some kind of type variable binder. -- --- Used for reporting errors, in 'SkolemInfo' and 'TcReportMsg'. +-- Used for reporting errors, in 'SkolemInfo' and 'TcSolverReportMsg'. data TyVarBndrs = forall flag. OutputableBndrFlag flag 'Renamed => HsTyVarBndrsRn [HsTyVarBndr flag GhcRn] diff --git a/testsuite/tests/driver/werror.stderr b/testsuite/tests/driver/werror.stderr index 2ca8354a91..c74e2e02a5 100644 --- a/testsuite/tests/driver/werror.stderr +++ b/testsuite/tests/driver/werror.stderr @@ -21,7 +21,7 @@ werror.hs:10:1: error: [-Wunused-top-binds (in -Wextra, -Wunused-binds), -Werror werror.hs:10:1: error: [-Wincomplete-patterns (in -Wextra), -Werror=incomplete-patterns] Pattern match(es) are non-exhaustive - In an equation for ‘f’: Patterns of type ‘[a]’ not matched: (_:_) + In an equation for ‘f’: Patterns of type ‘[a]’ not matched: (_:_) werror.hs:11:1: error: [-Woverlapping-patterns (in -Wdefault), -Werror=overlapping-patterns] Pattern match is redundant diff --git a/testsuite/tests/warnings/should_compile/Werror01.stderr b/testsuite/tests/warnings/should_compile/Werror01.stderr index 91fcc8449f..1cebb3f0d0 100644 --- a/testsuite/tests/warnings/should_compile/Werror01.stderr +++ b/testsuite/tests/warnings/should_compile/Werror01.stderr @@ -1,2 +1,3 @@ + Werror01.hs:5:1: warning: [-Wmissing-signatures (in -Wall)] Top-level binding with no type signature: foo :: () -> () diff --git a/testsuite/tests/warnings/should_fail/WerrorFail2.stderr b/testsuite/tests/warnings/should_fail/WerrorFail2.stderr index 68c642107b..c3bc935392 100644 --- a/testsuite/tests/warnings/should_fail/WerrorFail2.stderr +++ b/testsuite/tests/warnings/should_fail/WerrorFail2.stderr @@ -4,7 +4,7 @@ WerrorFail2.hs:15:1: warning: [-Wmissing-signatures (in -Wall)] WerrorFail2.hs:15:10: error: [-Wincomplete-patterns (in -Wextra), -Werror=incomplete-patterns] Pattern match(es) are non-exhaustive - In a case alternative: Patterns of type ‘S’ not matched: C2 _ + In a case alternative: Patterns of type ‘S’ not matched: C2 _ WerrorFail2.hs:19:1: warning: [-Wmissing-signatures (in -Wall)] Top-level binding with no type signature: printRec :: IO () |