diff options
| author | sheaf <sam.derbyshire@gmail.com> | 2022-09-12 13:52:24 +0200 |
|---|---|---|
| committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2022-09-13 10:27:52 -0400 |
| commit | 65a0bd69ac1fb59047cd4c8554a8fc756c7b3476 (patch) | |
| tree | bc5d257c7d987097d45a9b5b61d8e1ed3cf883d3 | |
| parent | 3a815f30bcba5672085e823aeef90863253b0b1a (diff) | |
| download | haskell-65a0bd69ac1fb59047cd4c8554a8fc756c7b3476.tar.gz | |
Add diagnostic codes
This MR adds diagnostic codes, assigning unique numeric codes to
error and warnings, e.g.
error: [GHC-53633]
Pattern match is redundant
This is achieved as follows:
- a type family GhcDiagnosticCode that gives the diagnostic code
for each diagnostic constructor,
- a type family ConRecursInto that specifies whether to recur into
an argument of the constructor to obtain a more fine-grained code
(e.g. different error codes for different 'deriving' errors),
- generics machinery to generate the value-level function assigning
each diagnostic its error code; see Note [Diagnostic codes using generics]
in GHC.Types.Error.Codes.
The upshot is that, to add a new diagnostic code, contributors only need
to modify the two type families mentioned above. All logic relating to
diagnostic codes is thus contained to the GHC.Types.Error.Codes module,
with no code duplication.
This MR also refactors error message datatypes a bit, ensuring we can
derive Generic for them, and cleans up the logic around constraint
solver reports by splitting up 'TcSolverReportInfo' into separate
datatypes (see #20772).
Fixes #21684
53 files changed, 2031 insertions, 944 deletions
diff --git a/compiler/GHC/Builtin/Names.hs b/compiler/GHC/Builtin/Names.hs index e714036cd4..35ed69105a 100644 --- a/compiler/GHC/Builtin/Names.hs +++ b/compiler/GHC/Builtin/Names.hs @@ -427,7 +427,7 @@ basicKnownKeyNames rationalToDoubleName, -- Other classes - randomClassName, randomGenClassName, monadPlusClassName, + monadPlusClassName, -- Type-level naturals knownNatClassName, knownSymbolClassName, knownCharClassName, @@ -1575,11 +1575,8 @@ toAnnotationWrapperName :: Name toAnnotationWrapperName = varQual gHC_DESUGAR (fsLit "toAnnotationWrapper") toAnnotationWrapperIdKey -- Other classes, needed for type defaulting -monadPlusClassName, randomClassName, randomGenClassName, - isStringClassName :: Name +monadPlusClassName, isStringClassName :: Name monadPlusClassName = clsQual mONAD (fsLit "MonadPlus") monadPlusClassKey -randomClassName = clsQual rANDOM (fsLit "Random") randomClassKey -randomGenClassName = clsQual rANDOM (fsLit "RandomGen") randomGenClassKey isStringClassName = clsQual dATA_STRING (fsLit "IsString") isStringClassKey -- Type-level naturals diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs index f9168a46b2..e375be5340 100644 --- a/compiler/GHC/Core/Lint.hs +++ b/compiler/GHC/Core/Lint.hs @@ -2929,7 +2929,7 @@ addMsg is_error env msgs msg [] -> noSrcSpan (s:_) -> s !diag_opts = le_diagOpts env - mk_msg msg = mkLocMessage (mkMCDiagnostic diag_opts WarningWithoutFlag) msg_span + mk_msg msg = mkLocMessage (mkMCDiagnostic diag_opts WarningWithoutFlag Nothing) msg_span (msg $$ context) addLoc :: LintLocInfo -> LintM a -> LintM a diff --git a/compiler/GHC/Core/Opt/Monad.hs b/compiler/GHC/Core/Opt/Monad.hs index 28c0a5a262..2d3d9822a2 100644 --- a/compiler/GHC/Core/Opt/Monad.hs +++ b/compiler/GHC/Core/Opt/Monad.hs @@ -35,7 +35,7 @@ module GHC.Core.Opt.Monad ( getAnnotations, getFirstAnnotations, -- ** Screen output - putMsg, putMsgS, errorMsg, errorMsgS, msg, + putMsg, putMsgS, errorMsg, msg, fatalErrorMsg, fatalErrorMsgS, debugTraceMsg, debugTraceMsgS, ) where @@ -363,9 +363,9 @@ msg msg_class doc = do loc <- getSrcSpanM unqual <- getPrintUnqualified let sty = case msg_class of - MCDiagnostic _ _ -> err_sty - MCDump -> dump_sty - _ -> user_sty + MCDiagnostic _ _ _ -> err_sty + MCDump -> dump_sty + _ -> user_sty err_sty = mkErrStyle unqual user_sty = mkUserStyle unqual AllTheWay dump_sty = mkDumpStyle unqual @@ -380,10 +380,6 @@ putMsg :: SDoc -> CoreM () putMsg = msg MCInfo -- | Output an error to the screen. Does not cause the compiler to die. -errorMsgS :: String -> CoreM () -errorMsgS = errorMsg . text - --- | Output an error to the screen. Does not cause the compiler to die. errorMsg :: SDoc -> CoreM () errorMsg doc = msg errorDiagnostic doc diff --git a/compiler/GHC/Core/Opt/Specialise.hs b/compiler/GHC/Core/Opt/Specialise.hs index 2fd731c654..1b29a924ef 100644 --- a/compiler/GHC/Core/Opt/Specialise.hs +++ b/compiler/GHC/Core/Opt/Specialise.hs @@ -809,7 +809,7 @@ tryWarnMissingSpecs dflags callers fn calls_for_fn allCallersInlined = all (isAnyInlinePragma . idInlinePragma) callers diag_opts = initDiagOpts dflags doWarn reason = - msg (mkMCDiagnostic diag_opts reason) + msg (mkMCDiagnostic diag_opts reason Nothing) (vcat [ hang (text ("Could not specialise imported function") <+> quotes (ppr fn)) 2 (vcat [ text "when specialising" <+> quotes (ppr caller) | caller <- callers]) diff --git a/compiler/GHC/Driver/Errors.hs b/compiler/GHC/Driver/Errors.hs index baaa551588..5467f2ad14 100644 --- a/compiler/GHC/Driver/Errors.hs +++ b/compiler/GHC/Driver/Errors.hs @@ -20,7 +20,7 @@ printMessages :: Diagnostic a => Logger -> DiagOpts -> Messages a -> IO () printMessages logger opts msgs = sequence_ [ let style = mkErrStyle unqual ctx = (diag_ppr_ctx opts) { sdocStyle = style } - in logMsg logger (MCDiagnostic sev . diagnosticReason $ dia) s $ + in logMsg logger (MCDiagnostic sev (diagnosticReason dia) (diagnosticCode dia)) s $ withPprStyle style (messageWithHints ctx dia) | MsgEnvelope { errMsgSpan = s, errMsgDiagnostic = dia, @@ -44,6 +44,7 @@ handleFlagWarnings logger opts warns = do bag = listToBag [ mkPlainMsgEnvelope opts loc $ GhcDriverMessage $ DriverUnknownMessage $ + UnknownDiagnostic $ mkPlainDiagnostic reason noHints $ text warn | CmdLine.Warn reason (L loc warn) <- warns ] diff --git a/compiler/GHC/Driver/Errors/Ppr.hs b/compiler/GHC/Driver/Errors/Ppr.hs index ad49f81bcb..8f0ffa4a4d 100644 --- a/compiler/GHC/Driver/Errors/Ppr.hs +++ b/compiler/GHC/Driver/Errors/Ppr.hs @@ -1,8 +1,11 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic {DriverMessage, GhcMessage} -module GHC.Driver.Errors.Ppr where +module GHC.Driver.Errors.Ppr ( + -- This module only exports Diagnostic instances. + ) where import GHC.Prelude @@ -13,6 +16,7 @@ import GHC.HsToCore.Errors.Ppr () import GHC.Parser.Errors.Ppr () import GHC.Tc.Errors.Ppr () import GHC.Types.Error +import GHC.Types.Error.Codes ( constructorCode ) import GHC.Unit.Types import GHC.Utils.Outputable import GHC.Unit.Module @@ -70,6 +74,8 @@ instance Diagnostic GhcMessage where GhcUnknownMessage m -> diagnosticHints m + diagnosticCode = constructorCode + instance Diagnostic DriverMessage where diagnosticMessage = \case DriverUnknownMessage m @@ -311,3 +317,5 @@ instance Diagnostic DriverMessage where -> noHints DriverHomePackagesNotClosed {} -> noHints + + diagnosticCode = constructorCode
\ No newline at end of file diff --git a/compiler/GHC/Driver/Errors/Types.hs b/compiler/GHC/Driver/Errors/Types.hs index 015ae5e375..988f533205 100644 --- a/compiler/GHC/Driver/Errors/Types.hs +++ b/compiler/GHC/Driver/Errors/Types.hs @@ -1,4 +1,6 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE StandaloneDeriving #-} module GHC.Driver.Errors.Types ( GhcMessage(..) @@ -32,6 +34,8 @@ import GHC.Hs.Extension (GhcTc) import Language.Haskell.Syntax.Decls (RuleDecl) +import GHC.Generics ( Generic ) + -- | A collection of warning messages. -- /INVARIANT/: Each 'GhcMessage' in the collection should have 'SevWarning' severity. type WarningMessages = Messages GhcMessage @@ -83,7 +87,9 @@ data GhcMessage where -- 'Diagnostic' constraint ensures that worst case scenario we can still -- render this into something which can be eventually converted into a -- 'DecoratedSDoc'. - GhcUnknownMessage :: forall a. (Diagnostic a, Typeable a) => a -> GhcMessage + GhcUnknownMessage :: UnknownDiagnostic -> GhcMessage + + deriving Generic -- | Creates a new 'GhcMessage' out of any diagnostic. This function is also -- provided to ease the integration of #18516 by allowing diagnostics to be @@ -92,7 +98,7 @@ data GhcMessage where -- GHC, as it would typically be used by plugin or library authors (see -- comment for the 'GhcUnknownMessage' type constructor) ghcUnknownMessage :: (Diagnostic a, Typeable a) => a -> GhcMessage -ghcUnknownMessage = GhcUnknownMessage +ghcUnknownMessage = GhcUnknownMessage . UnknownDiagnostic -- | Abstracts away the frequent pattern where we are calling 'ioMsgMaybe' on -- the result of 'IO (Messages TcRnMessage, a)'. @@ -110,7 +116,7 @@ type DriverMessages = Messages DriverMessage -- | A message from the driver. data DriverMessage where -- | Simply wraps a generic 'Diagnostic' message @a@. - DriverUnknownMessage :: (Diagnostic a, Typeable a) => a -> DriverMessage + DriverUnknownMessage :: UnknownDiagnostic -> DriverMessage -- | A parse error in parsing a Haskell file header during dependency -- analysis DriverPsHeaderMessage :: !PsMessage -> DriverMessage @@ -351,6 +357,8 @@ data DriverMessage where DriverHomePackagesNotClosed :: ![UnitId] -> DriverMessage +deriving instance Generic DriverMessage + -- | Pass to a 'DriverMessage' the information whether or not the -- '-fbuilding-cabal-package' flag is set. data BuildingCabalPackage diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs index e03883702b..546fbda015 100644 --- a/compiler/GHC/Driver/Main.hs +++ b/compiler/GHC/Driver/Main.hs @@ -1568,6 +1568,7 @@ markUnsafeInfer tcg_env whyUnsafe = do (logDiagnostics $ singleMessage $ mkPlainMsgEnvelope diag_opts (warnUnsafeOnLoc dflags) $ GhcDriverMessage $ DriverUnknownMessage $ + UnknownDiagnostic $ mkPlainDiagnostic reason noHints $ whyUnsafe' dflags) @@ -2227,7 +2228,8 @@ hscImport hsc_env str = runInteractiveHsc hsc_env $ do [L _ i] -> return i _ -> liftIO $ throwOneError $ mkPlainErrorMsgEnvelope noSrcSpan $ - GhcPsMessage $ PsUnknownMessage $ mkPlainError noHints $ + GhcPsMessage $ PsUnknownMessage $ + UnknownDiagnostic $ mkPlainError noHints $ text "parse error in import declaration" -- | Typecheck an expression (but don't run it) @@ -2258,7 +2260,7 @@ hscParseExpr expr = do Just (L _ (BodyStmt _ expr _ _)) -> return expr _ -> throwOneError $ mkPlainErrorMsgEnvelope noSrcSpan $ - GhcPsMessage $ PsUnknownMessage $ mkPlainError noHints $ + GhcPsMessage $ PsUnknownMessage $ UnknownDiagnostic $ mkPlainError noHints $ text "not an expression:" <+> quotes (text expr) hscParseStmt :: String -> Hsc (Maybe (GhciLStmt GhcPs)) diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs index c9607fb79f..d1f9ba0104 100644 --- a/compiler/GHC/Driver/Make.hs +++ b/compiler/GHC/Driver/Make.hs @@ -2229,9 +2229,9 @@ withDeferredDiagnostics f = do let deferDiagnostics _dflags !msgClass !srcSpan !msg = do let action = logMsg logger msgClass srcSpan msg case msgClass of - MCDiagnostic SevWarning _reason + MCDiagnostic SevWarning _reason _code -> atomicModifyIORef' warnings $ \i -> (action: i, ()) - MCDiagnostic SevError _reason + MCDiagnostic SevError _reason _code -> atomicModifyIORef' errors $ \i -> (action: i, ()) MCFatal -> atomicModifyIORef' fatals $ \i -> (action: i, ()) @@ -2252,7 +2252,8 @@ withDeferredDiagnostics f = do noModError :: HscEnv -> SrcSpan -> ModuleName -> FindResult -> MsgEnvelope GhcMessage -- ToDo: we don't have a proper line number for this error noModError hsc_env loc wanted_mod err - = mkPlainErrorMsgEnvelope loc $ GhcDriverMessage $ DriverUnknownMessage $ mkPlainError noHints $ + = mkPlainErrorMsgEnvelope loc $ GhcDriverMessage $ + DriverUnknownMessage $ UnknownDiagnostic $ mkPlainError noHints $ cannotFindModule hsc_env wanted_mod err {- diff --git a/compiler/GHC/Driver/MakeFile.hs b/compiler/GHC/Driver/MakeFile.hs index a461ead22c..35a429a7d4 100644 --- a/compiler/GHC/Driver/MakeFile.hs +++ b/compiler/GHC/Driver/MakeFile.hs @@ -27,6 +27,7 @@ import GHC.Data.Graph.Directed ( SCC(..) ) import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Panic.Plain +import GHC.Types.Error (UnknownDiagnostic(..)) import GHC.Types.SourceError import GHC.Types.SrcLoc import GHC.Types.PkgQual @@ -306,7 +307,8 @@ findDependency hsc_env srcloc pkg imp is_boot include_pkg_deps = do fail -> throwOneError $ mkPlainErrorMsgEnvelope srcloc $ - GhcDriverMessage $ DriverUnknownMessage $ mkPlainError noHints $ + GhcDriverMessage $ DriverUnknownMessage $ + UnknownDiagnostic $ mkPlainError noHints $ cannotFindModule hsc_env imp fail ----------------------------- diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs index 242887b353..0ebe1f792f 100644 --- a/compiler/GHC/Driver/Pipeline.hs +++ b/compiler/GHC/Driver/Pipeline.hs @@ -96,7 +96,7 @@ import GHC.Runtime.Loader ( initializePlugins ) import GHC.Types.Basic ( SuccessFlag(..), ForeignSrcLang(..) ) -import GHC.Types.Error ( singleMessage, getMessages ) +import GHC.Types.Error ( singleMessage, getMessages, UnknownDiagnostic (..) ) import GHC.Types.Target import GHC.Types.SrcLoc import GHC.Types.SourceFile @@ -155,7 +155,7 @@ preprocess hsc_env input_fn mb_input_buf mb_phase = handler (ProgramError msg) = return $ Left $ singleMessage $ mkPlainErrorMsgEnvelope srcspan $ - DriverUnknownMessage $ mkPlainError noHints $ text msg + DriverUnknownMessage $ UnknownDiagnostic $ mkPlainError noHints $ text msg handler ex = throwGhcExceptionIO ex to_driver_messages :: Messages GhcMessage -> Messages DriverMessage diff --git a/compiler/GHC/HsToCore/Errors/Ppr.hs b/compiler/GHC/HsToCore/Errors/Ppr.hs index 9695eee60c..ede0e6febf 100644 --- a/compiler/GHC/HsToCore/Errors/Ppr.hs +++ b/compiler/GHC/HsToCore/Errors/Ppr.hs @@ -1,4 +1,6 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-} + {-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic DsMessage module GHC.HsToCore.Errors.Ppr where @@ -11,6 +13,7 @@ import GHC.HsToCore.Errors.Types import GHC.Prelude import GHC.Types.Basic (pprRuleName) import GHC.Types.Error +import GHC.Types.Error.Codes ( constructorCode ) import GHC.Types.Id (idType) import GHC.Types.SrcLoc import GHC.Utils.Misc @@ -272,6 +275,8 @@ instance Diagnostic DsMessage where DsRuleMightInlineFirst _ lhs_id rule_act -> [SuggestAddInlineOrNoInlinePragma lhs_id rule_act] DsAnotherRuleMightFireFirst _ bad_rule _ -> [SuggestAddPhaseToCompetingRule bad_rule] + diagnosticCode = constructorCode + {- Note [Suggest NegativeLiterals] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/GHC/HsToCore/Errors/Types.hs b/compiler/GHC/HsToCore/Errors/Types.hs index d178eecfed..1b1c5532f8 100644 --- a/compiler/GHC/HsToCore/Errors/Types.hs +++ b/compiler/GHC/HsToCore/Errors/Types.hs @@ -1,9 +1,7 @@ -{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE DeriveGeneric #-} module GHC.HsToCore.Errors.Types where -import Data.Typeable - import GHC.Prelude import GHC.Core (CoreRule, CoreExpr, RuleName) @@ -19,6 +17,8 @@ import GHC.Types.Id import GHC.Types.Name (Name) import qualified GHC.LanguageExtensions as LangExt +import GHC.Generics (Generic) + newtype MinBound = MinBound Integer newtype MaxBound = MaxBound Integer type MaxUncoveredPatterns = Int @@ -27,7 +27,7 @@ type MaxPmCheckModels = Int -- | Diagnostics messages emitted during desugaring. data DsMessage -- | Simply wraps a generic 'Diagnostic' message. - = forall a. (Diagnostic a, Typeable a) => DsUnknownMessage a + = DsUnknownMessage UnknownDiagnostic {-| DsEmptyEnumeration is a warning (controlled by the -Wempty-enumerations flag) that is emitted if an enumeration is empty. @@ -146,6 +146,8 @@ data DsMessage !RuleName -- the \"bad\" rule !Var + deriving Generic + -- The positional number of the argument for an expression (first, second, third, etc) newtype DsArgNum = DsArgNum Int diff --git a/compiler/GHC/Iface/Load.hs b/compiler/GHC/Iface/Load.hs index 18554fdc50..6e219cb257 100644 --- a/compiler/GHC/Iface/Load.hs +++ b/compiler/GHC/Iface/Load.hs @@ -300,7 +300,7 @@ loadSrcInterface :: SDoc loadSrcInterface doc mod want_boot maybe_pkg = do { res <- loadSrcInterface_maybe doc mod want_boot maybe_pkg ; case res of - Failed err -> failWithTc (TcRnUnknownMessage $ mkPlainError noHints err) + Failed err -> failWithTc (mkTcRnUnknownMessage $ mkPlainError noHints err) Succeeded iface -> return iface } -- | Like 'loadSrcInterface', but returns a 'MaybeErr'. diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs index bf8cd91cd4..acef3bca68 100644 --- a/compiler/GHC/IfaceToCore.hs +++ b/compiler/GHC/IfaceToCore.hs @@ -576,9 +576,9 @@ tcHiBootIface hsc_src mod Nothing -> return NoSelfBoot -- error cases Just (GWIB { gwib_isBoot = is_boot }) -> case is_boot of - IsBoot -> failWithTc (TcRnUnknownMessage $ mkPlainError noHints (elaborate err)) + IsBoot -> failWithTc (mkTcRnUnknownMessage $ mkPlainError noHints (elaborate err)) -- The hi-boot file has mysteriously disappeared. - NotBoot -> failWithTc (TcRnUnknownMessage $ mkPlainError noHints moduleLoop) + NotBoot -> failWithTc (mkTcRnUnknownMessage $ mkPlainError noHints moduleLoop) -- Someone below us imported us! -- This is a loop with no hi-boot in the way }}}} diff --git a/compiler/GHC/Linker/Loader.hs b/compiler/GHC/Linker/Loader.hs index 6c2829c432..286c50416c 100644 --- a/compiler/GHC/Linker/Loader.hs +++ b/compiler/GHC/Linker/Loader.hs @@ -1505,7 +1505,7 @@ load_dyn interp hsc_env crash_early dll = do else when (diag_wopt Opt_WarnMissedExtraSharedLib diag_opts) $ logMsg logger - (mkMCDiagnostic diag_opts $ WarningWithFlag Opt_WarnMissedExtraSharedLib) + (mkMCDiagnostic diag_opts (WarningWithFlag Opt_WarnMissedExtraSharedLib) Nothing) noSrcSpan $ withPprStyle defaultUserStyle (note err) where diag_opts = initDiagOpts (hsc_dflags hsc_env) @@ -1693,7 +1693,7 @@ locateLib interp hsc_env is_hs lib_dirs gcc_dirs lib0 , not loading_dynamic_hs_libs , interpreterProfiled interp = do - let diag = mkMCDiagnostic diag_opts WarningWithoutFlag + let diag = mkMCDiagnostic diag_opts WarningWithoutFlag Nothing logMsg logger diag noSrcSpan $ withPprStyle defaultErrStyle $ text "Interpreter failed to load profiled static library" <+> text lib <> char '.' $$ text " \tTrying dynamic library instead. If this fails try to rebuild" <+> diff --git a/compiler/GHC/Parser/Errors/Ppr.hs b/compiler/GHC/Parser/Errors/Ppr.hs index 6f7581c2a2..1a368b0fac 100644 --- a/compiler/GHC/Parser/Errors/Ppr.hs +++ b/compiler/GHC/Parser/Errors/Ppr.hs @@ -3,6 +3,8 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic PsMessage @@ -18,6 +20,7 @@ import GHC.Types.Hint import GHC.Types.Error import GHC.Types.Hint.Ppr (perhapsAsPat) import GHC.Types.SrcLoc +import GHC.Types.Error.Codes ( constructorCode ) import GHC.Types.Name.Reader ( opIsAt, rdrNameOcc, mkUnqual ) import GHC.Types.Name.Occurrence (isSymOcc, occNameFS, varName) import GHC.Utils.Outputable @@ -786,6 +789,8 @@ instance Diagnostic PsMessage where PsErrIllegalGadtRecordMultiplicity{} -> noHints PsErrInvalidCApiImport {} -> noHints + diagnosticCode = constructorCode + psHeaderMessageDiagnostic :: PsHeaderMessage -> DecoratedSDoc psHeaderMessageDiagnostic = \case PsErrParseLanguagePragma diff --git a/compiler/GHC/Parser/Errors/Types.hs b/compiler/GHC/Parser/Errors/Types.hs index 1d3fcbc08e..f0314d80c7 100644 --- a/compiler/GHC/Parser/Errors/Types.hs +++ b/compiler/GHC/Parser/Errors/Types.hs @@ -1,11 +1,9 @@ -{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE DeriveGeneric #-} module GHC.Parser.Errors.Types where import GHC.Prelude -import Data.Typeable - import GHC.Core.TyCon (Role) import GHC.Data.FastString import GHC.Hs @@ -15,10 +13,11 @@ import GHC.Types.Error import GHC.Types.Hint import GHC.Types.Name.Occurrence (OccName) import GHC.Types.Name.Reader -import GHC.Utils.Outputable import Data.List.NonEmpty (NonEmpty) import GHC.Types.SrcLoc (PsLoc) +import GHC.Generics ( Generic ) + -- The type aliases below are useful to make some type signatures a bit more -- descriptive, like 'handleWarningsThrowErrors' in 'GHC.Driver.Main'. @@ -59,6 +58,7 @@ data PsHeaderMessage tests/driver/T2499 -} | PsErrUnknownOptionsPragma !String + deriving Generic data PsMessage @@ -67,7 +67,7 @@ data PsMessage arbitrary messages to be embedded. The typical use case would be GHC plugins willing to emit custom diagnostics. -} - forall a. (Diagnostic a, Typeable a) => PsUnknownMessage a + PsUnknownMessage UnknownDiagnostic {-| A group of parser messages emitted in 'GHC.Parser.Header'. See Note [Messages from GHC.Parser.Header]. @@ -456,13 +456,15 @@ data PsMessage -- | Parse error in right operator section pattern -- TODO: embed the proper operator, if possible - | forall infixOcc. (OutputableBndr infixOcc) => PsErrParseRightOpSectionInPat !infixOcc !(PatBuilder GhcPs) + | PsErrParseRightOpSectionInPat !RdrName !(PatBuilder GhcPs) -- | Illegal linear arrow or multiplicity annotation in GADT record syntax | PsErrIllegalGadtRecordMultiplicity !(HsArrow GhcPs) | PsErrInvalidCApiImport + deriving Generic + -- | Extra details about a parse error, which helps -- us in determining which should be the hints to -- suggest. diff --git a/compiler/GHC/Rename/Bind.hs b/compiler/GHC/Rename/Bind.hs index f69091c92d..a70a3df06c 100644 --- a/compiler/GHC/Rename/Bind.hs +++ b/compiler/GHC/Rename/Bind.hs @@ -668,7 +668,7 @@ makeMiniFixityEnv decls = foldlM add_one_sig emptyFsEnv decls dupFixityDecl :: SrcSpan -> RdrName -> TcRnMessage dupFixityDecl loc rdr_name - = TcRnUnknownMessage $ mkPlainError noHints $ + = mkTcRnUnknownMessage $ mkPlainError noHints $ vcat [text "Multiple fixity declarations for" <+> quotes (ppr rdr_name), text "also at " <+> ppr loc] @@ -759,7 +759,7 @@ rnPatSynBind sig_fn bind@(PSB { psb_id = L l name patternSynonymErr :: TcRnMessage patternSynonymErr - = TcRnUnknownMessage $ mkPlainError noHints $ + = mkTcRnUnknownMessage $ mkPlainError noHints $ hang (text "Illegal pattern synonym declaration") 2 (text "Use -XPatternSynonyms to enable this extension") @@ -915,7 +915,7 @@ rnMethodBindLHS _ cls (L loc bind@(FunBind { fun_id = name })) rest -- Report error for all other forms of bindings -- This is why we use a fold rather than map rnMethodBindLHS is_cls_decl _ (L loc bind) rest - = do { addErrAt (locA loc) $ TcRnUnknownMessage $ mkPlainError noHints $ + = do { addErrAt (locA loc) $ mkTcRnUnknownMessage $ mkPlainError noHints $ vcat [ what <+> text "not allowed in" <+> decl_sort , nest 2 (ppr bind) ] ; return rest } @@ -1060,7 +1060,7 @@ renameSig _ctxt sig@(CompleteMatchSig (_, s) (L l bf) mty) return (CompleteMatchSig (noAnn, s) (L l new_bf) new_mty, emptyFVs) where orphanError :: TcRnMessage - orphanError = TcRnUnknownMessage $ mkPlainError noHints $ + orphanError = mkTcRnUnknownMessage $ mkPlainError noHints $ text "Orphan COMPLETE pragmas not supported" $$ text "A COMPLETE pragma must mention at least one data constructor" $$ text "or pattern synonym defined in the same module." @@ -1250,7 +1250,7 @@ rnMatch' ctxt rnBody (Match { m_ctxt = mf, m_pats = pats, m_grhss = grhss }) , m_grhss = grhss'}, grhss_fvs ) } emptyCaseErr :: HsMatchContext GhcRn -> TcRnMessage -emptyCaseErr ctxt = TcRnUnknownMessage $ mkPlainError noHints $ message ctxt +emptyCaseErr ctxt = mkTcRnUnknownMessage $ mkPlainError noHints $ message ctxt where pp_ctxt :: HsMatchContext GhcRn -> SDoc pp_ctxt c = case c of @@ -1308,7 +1308,7 @@ rnGRHS' ctxt rnBody (GRHS _ guards rhs) rnBody rhs ; unless (pattern_guards_allowed || is_standard_guard guards') $ - let diag = TcRnUnknownMessage $ + let diag = mkTcRnUnknownMessage $ mkPlainDiagnostic WarningWithoutFlag noHints (nonStdGuardErr guards') in addDiagnostic diag @@ -1363,7 +1363,7 @@ rnSrcFixityDecl sig_ctxt = rn_decl dupSigDeclErr :: NonEmpty (LocatedN RdrName, Sig GhcPs) -> RnM () dupSigDeclErr pairs@((L loc name, sig) :| _) - = addErrAt (locA loc) $ TcRnUnknownMessage $ mkPlainError noHints $ + = addErrAt (locA loc) $ mkTcRnUnknownMessage $ mkPlainError noHints $ vcat [ text "Duplicate" <+> what_it_is <> text "s for" <+> quotes (ppr name) , text "at" <+> vcat (map ppr $ sortBy SrcLoc.leftmost_smallest @@ -1375,18 +1375,18 @@ dupSigDeclErr pairs@((L loc name, sig) :| _) misplacedSigErr :: LSig GhcRn -> RnM () misplacedSigErr (L loc sig) - = addErrAt (locA loc) $ TcRnUnknownMessage $ mkPlainError noHints $ + = addErrAt (locA loc) $ mkTcRnUnknownMessage $ mkPlainError noHints $ sep [text "Misplaced" <+> hsSigDoc sig <> colon, ppr sig] defaultSigErr :: Sig GhcPs -> TcRnMessage -defaultSigErr sig = TcRnUnknownMessage $ mkPlainError noHints $ +defaultSigErr sig = mkTcRnUnknownMessage $ mkPlainError noHints $ vcat [ hang (text "Unexpected default signature:") 2 (ppr sig) , text "Use DefaultSignatures to enable default signatures" ] bindInHsBootFileErr :: LHsBindLR GhcRn GhcPs -> RnM () bindInHsBootFileErr (L loc _) - = addErrAt (locA loc) $ TcRnUnknownMessage $ mkPlainError noHints $ + = addErrAt (locA loc) $ mkTcRnUnknownMessage $ mkPlainError noHints $ vcat [ text "Bindings in hs-boot files are not allowed" ] nonStdGuardErr :: (Outputable body, @@ -1398,7 +1398,7 @@ nonStdGuardErr guards dupMinimalSigErr :: [LSig GhcPs] -> RnM () dupMinimalSigErr sigs@(L loc _ : _) - = addErrAt (locA loc) $ TcRnUnknownMessage $ mkPlainError noHints $ + = addErrAt (locA loc) $ mkTcRnUnknownMessage $ mkPlainError noHints $ vcat [ text "Multiple minimal complete definitions" , text "at" <+> vcat (map ppr $ sortBy SrcLoc.leftmost_smallest $ map getLocA sigs) , text "Combine alternative minimal complete definitions with `|'" ] diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs index 642ffb04c4..eacaf6468a 100644 --- a/compiler/GHC/Rename/Expr.hs +++ b/compiler/GHC/Rename/Expr.hs @@ -484,12 +484,12 @@ rnExpr (RecordUpd { rupd_expr = expr, rupd_flds = rbinds }) } Right flds -> -- 'OverloadedRecordUpdate' is in effect. Record dot update desugaring. do { ; unlessXOptM LangExt.RebindableSyntax $ - addErr $ TcRnUnknownMessage $ mkPlainError noHints $ + addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $ text "RebindableSyntax is required if OverloadedRecordUpdate is enabled." ; let punnedFields = [fld | (L _ fld) <- flds, hfbPun fld] ; punsEnabled <-xoptM LangExt.NamedFieldPuns ; unless (null punnedFields || punsEnabled) $ - addErr $ TcRnUnknownMessage $ mkPlainError noHints $ + addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $ text "For this to work enable NamedFieldPuns." ; (getField, fv_getField) <- lookupSyntaxName getFieldName ; (setField, fv_setField) <- lookupSyntaxName setFieldName @@ -565,16 +565,17 @@ rnExpr e@(HsStatic _ expr) = do -- absolutely prepared to cope with static forms, we check for -- -XStaticPointers here as well. unlessXOptM LangExt.StaticPointers $ - addErr $ TcRnUnknownMessage $ mkPlainError noHints $ + addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $ hang (text "Illegal static expression:" <+> ppr e) 2 (text "Use StaticPointers to enable this extension") (expr',fvExpr) <- rnLExpr expr stage <- getStage case stage of - Splice _ -> addErr $ TcRnUnknownMessage $ mkPlainError noHints $ sep - [ text "static forms cannot be used in splices:" - , nest 2 $ ppr e - ] + Splice _ -> addErr $ mkTcRnUnknownMessage $ + mkPlainError noHints $ sep + [ text "static forms cannot be used in splices:" + , nest 2 $ ppr e + ] _ -> return () mod <- getModule let fvExpr' = filterNameSet (nameIsLocalOrFrom mod) fvExpr @@ -1311,7 +1312,7 @@ rnParallelStmts ctxt return_op segs thing_inside ; return ((seg':segs', thing), fvs) } cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2 - dupErr vs = addErr $ TcRnUnknownMessage $ mkPlainError noHints $ + dupErr vs = addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $ (text "Duplicate binding in parallel list comprehension for:" <+> quotes (ppr (NE.head vs))) @@ -2463,13 +2464,13 @@ okEmpty (PatGuard {}) = True okEmpty _ = False emptyErr :: HsStmtContext GhcRn -> TcRnMessage -emptyErr (ParStmtCtxt {}) = TcRnUnknownMessage $ mkPlainError noHints $ +emptyErr (ParStmtCtxt {}) = mkTcRnUnknownMessage $ mkPlainError noHints $ text "Empty statement group in parallel comprehension" -emptyErr (TransStmtCtxt {}) = TcRnUnknownMessage $ mkPlainError noHints $ +emptyErr (TransStmtCtxt {}) = mkTcRnUnknownMessage $ mkPlainError noHints $ text "Empty statement group preceding 'group' or 'then'" -emptyErr ctxt@(HsDoStmt _) = TcRnUnknownMessage $ mkPlainError [suggestExtension LangExt.NondecreasingIndentation] $ +emptyErr ctxt@(HsDoStmt _) = mkTcRnUnknownMessage $ mkPlainError [suggestExtension LangExt.NondecreasingIndentation] $ text "Empty" <+> pprStmtContext ctxt -emptyErr ctxt = TcRnUnknownMessage $ mkPlainError noHints $ +emptyErr ctxt = mkTcRnUnknownMessage $ mkPlainError noHints $ text "Empty" <+> pprStmtContext ctxt ---------------------- @@ -2490,7 +2491,8 @@ checkLastStmt ctxt lstmt@(L loc stmt) BodyStmt _ e _ _ -> return (L loc (mkLastStmt e)) LastStmt {} -> return lstmt -- "Deriving" clauses may generate a -- LastStmt directly (unlike the parser) - _ -> do { addErr $ TcRnUnknownMessage $ mkPlainError noHints $ + _ -> do { addErr $ mkTcRnUnknownMessage + $ mkPlainError noHints $ (hang last_error 2 (ppr stmt)) ; return lstmt } last_error = (text "The last statement in" <+> pprAStmtContext ctxt @@ -2512,7 +2514,8 @@ checkStmt ctxt (L _ stmt) = do { dflags <- getDynFlags ; case okStmt dflags ctxt stmt of IsValid -> return () - NotValid extra -> addErr $ TcRnUnknownMessage $ mkPlainError noHints (msg $$ extra) } + NotValid extra -> addErr $ mkTcRnUnknownMessage + $ mkPlainError noHints (msg $$ extra) } where msg = sep [ text "Unexpected" <+> pprStmtCat stmt <+> text "statement" , text "in" <+> pprAStmtContext ctxt ] @@ -2605,19 +2608,19 @@ checkTupleSection args ; checkErr (all tupArgPresent args || tuple_section) msg } where msg :: TcRnMessage - msg = TcRnUnknownMessage $ mkPlainError noHints $ + msg = mkTcRnUnknownMessage $ mkPlainError noHints $ text "Illegal tuple section: use TupleSections" --------- sectionErr :: HsExpr GhcPs -> TcRnMessage sectionErr expr - = TcRnUnknownMessage $ mkPlainError noHints $ + = mkTcRnUnknownMessage $ mkPlainError noHints $ hang (text "A section must be enclosed in parentheses") 2 (text "thus:" <+> (parens (ppr expr))) badIpBinds :: Outputable a => SDoc -> a -> TcRnMessage badIpBinds what binds - = TcRnUnknownMessage $ mkPlainError noHints $ + = mkTcRnUnknownMessage $ mkPlainError noHints $ hang (text "Implicit-parameter bindings illegal in" <+> what) 2 (ppr binds) diff --git a/compiler/GHC/Rename/HsType.hs b/compiler/GHC/Rename/HsType.hs index 8a9fdf6542..04c0c73adb 100644 --- a/compiler/GHC/Rename/HsType.hs +++ b/compiler/GHC/Rename/HsType.hs @@ -215,7 +215,7 @@ rnHsPatSigTypeBindingVars ctxt sigType thing_inside = case sigType of -- Should the inner `a` refer to the outer one? shadow it? We are, as yet, undecided, -- so we currently reject. when (not (null varsInScope)) $ - addErr $ TcRnUnknownMessage $ mkPlainError noHints $ + addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $ vcat [ text "Type variable" <> plural varsInScope <+> hcat (punctuate (text ",") (map (quotes . ppr) varsInScope)) @@ -446,7 +446,7 @@ rnImplicitTvBndrs ctx mb_assoc implicit_vs_with_dups thing_inside = do { implicit_vs <- forM (NE.groupBy eqLocated $ sortBy cmpLocated $ implicit_vs_with_dups) $ \case (x :| []) -> return x (x :| _) -> do - let msg = TcRnUnknownMessage $ mkPlainError noHints $ + let msg = mkTcRnUnknownMessage $ mkPlainError noHints $ text "Variable" <+> text "`" <> ppr x <> text "'" <+> text "would be bound multiple times by" <+> pprHsDocContext ctx <> text "." addErr msg return x @@ -622,7 +622,7 @@ rnHsTyKi env ty@(HsQualTy { hst_ctxt = lctxt, hst_body = tau }) rnHsTyKi env (HsTyVar _ ip (L loc rdr_name)) = do { when (isRnKindLevel env && isRdrTyVar rdr_name) $ - unlessXOptM LangExt.PolyKinds $ addErr $ TcRnUnknownMessage $ mkPlainError noHints $ + unlessXOptM LangExt.PolyKinds $ addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $ withHsDocContext (rtke_ctxt env) $ vcat [ text "Unexpected kind variable" <+> quotes (ppr rdr_name) , text "Perhaps you intended to use PolyKinds" ] @@ -663,7 +663,7 @@ rnHsTyKi env ty@(HsRecTy _ flds) get_fields (ConDeclCtx names) = concatMapM (lookupConstructorFields . unLoc) names get_fields _ - = do { addErr $ TcRnUnknownMessage $ mkPlainError noHints $ + = do { addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $ (hang (text "Record syntax is illegal here:") 2 (ppr ty)) ; return [] } @@ -716,7 +716,7 @@ rnHsTyKi env tyLit@(HsTyLit src t) negLit (HsNumTy _ i) = i < 0 negLit (HsCharTy _ _) = False negLitErr :: TcRnMessage - negLitErr = TcRnUnknownMessage $ mkPlainError noHints $ + negLitErr = mkTcRnUnknownMessage $ mkPlainError noHints $ text "Illegal literal in type (type literals must not be negative):" <+> ppr tyLit rnHsTyKi env (HsAppTy _ ty1 ty2) @@ -758,9 +758,9 @@ rnHsTyKi env (XHsType ty) check_in_scope :: RdrName -> RnM () check_in_scope rdr_name = do mb_name <- lookupLocalOccRn_maybe rdr_name - -- TODO: refactor this to avoid TcRnUnknownMessage + -- TODO: refactor this to avoid mkTcRnUnknownMessage when (isNothing mb_name) $ - addErr $ TcRnUnknownMessage $ mkPlainError noHints $ + addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $ withHsDocContext (rtke_ctxt env) $ pprScopeError rdr_name (notInScopeErr WL_LocalOnly rdr_name) @@ -924,7 +924,7 @@ checkPolyKinds env ty | isRnKindLevel env = do { polykinds <- xoptM LangExt.PolyKinds ; unless polykinds $ - addErr $ TcRnUnknownMessage $ mkPlainError noHints $ + addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $ (text "Illegal kind:" <+> ppr ty $$ text "Did you mean to enable PolyKinds?") } checkPolyKinds _ _ = return () @@ -935,7 +935,7 @@ notInKinds :: Outputable ty -> RnM () notInKinds env ty | isRnKindLevel env - = addErr $ TcRnUnknownMessage $ mkPlainError noHints $ + = addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $ text "Illegal kind:" <+> ppr ty notInKinds _ _ = return () @@ -1615,7 +1615,7 @@ precParseErr op1@(n1,_) op2@(n2,_) | is_unbound n1 || is_unbound n2 = return () -- Avoid error cascade | otherwise - = addErr $ TcRnUnknownMessage $ mkPlainError noHints $ + = addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $ hang (text "Precedence parsing error") 4 (hsep [text "cannot mix", ppr_opfix op1, text "and", ppr_opfix op2, @@ -1626,7 +1626,7 @@ sectionPrecErr op@(n1,_) arg_op@(n2,_) section | is_unbound n1 || is_unbound n2 = return () -- Avoid error cascade | otherwise - = addErr $ TcRnUnknownMessage $ mkPlainError noHints $ + = addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $ vcat [text "The operator" <+> ppr_opfix op <+> text "of a section", nest 4 (sep [text "must have lower precedence than that of the operand,", nest 2 (text "namely" <+> ppr_opfix arg_op)]), @@ -1652,20 +1652,20 @@ ppr_opfix (op, fixity) = pp_op <+> brackets (ppr fixity) unexpectedPatSigTypeErr :: HsPatSigType GhcPs -> TcRnMessage unexpectedPatSigTypeErr ty - = TcRnUnknownMessage $ mkPlainError noHints $ + = mkTcRnUnknownMessage $ mkPlainError noHints $ hang (text "Illegal type signature:" <+> quotes (ppr ty)) 2 (text "Type signatures are only allowed in patterns with ScopedTypeVariables") badKindSigErr :: HsDocContext -> LHsType GhcPs -> TcM () badKindSigErr doc (L loc ty) - = setSrcSpanA loc $ addErr $ TcRnUnknownMessage $ mkPlainError noHints $ + = setSrcSpanA loc $ addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $ withHsDocContext doc $ hang (text "Illegal kind signature:" <+> quotes (ppr ty)) 2 (text "Perhaps you intended to use KindSignatures") dataKindsErr :: RnTyKiEnv -> HsType GhcPs -> TcRnMessage dataKindsErr env thing - = TcRnUnknownMessage $ mkPlainError noHints $ + = mkTcRnUnknownMessage $ mkPlainError noHints $ hang (text "Illegal" <+> pp_what <> colon <+> quotes (ppr thing)) 2 (text "Perhaps you intended to use DataKinds") where @@ -1676,7 +1676,7 @@ warnUnusedForAll :: OutputableBndrFlag flag 'Renamed => HsDocContext -> LHsTyVarBndr flag GhcRn -> FreeVars -> TcM () warnUnusedForAll doc (L loc tv) used_names = unless (hsTyVarName tv `elemNameSet` used_names) $ do - let msg = TcRnUnknownMessage $ + let msg = mkTcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag Opt_WarnUnusedForalls) noHints $ vcat [ text "Unused quantified type variable" <+> quotes (ppr tv) , inHsDocContext doc ] diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs index f34235b52d..f387474244 100644 --- a/compiler/GHC/Rename/Module.hs +++ b/compiler/GHC/Rename/Module.hs @@ -552,7 +552,7 @@ checkCanonicalInstances cls poly_ty mbinds = do -- got "lhs = rhs" but expected something different addWarnNonCanonicalMethod1 refURL flag lhs rhs = do - let dia = TcRnUnknownMessage $ + let dia = mkTcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag flag) noHints $ vcat [ text "Noncanonical" <+> quotes (text (lhs ++ " = " ++ rhs)) <+> @@ -568,7 +568,7 @@ checkCanonicalInstances cls poly_ty mbinds = do -- expected "lhs = rhs" but got something else addWarnNonCanonicalMethod2 refURL flag lhs rhs = do - let dia = TcRnUnknownMessage $ + let dia = mkTcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag flag) noHints $ vcat [ text "Noncanonical" <+> quotes (text lhs) <+> @@ -679,7 +679,7 @@ rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds -- reach the typechecker, lest we encounter different errors that are -- hopelessly confusing (such as the one in #16114). bail_out (l, err_msg) = do - addErrAt l $ TcRnUnknownMessage $ mkPlainError noHints (withHsDocContext ctxt err_msg) + addErrAt l $ mkTcRnUnknownMessage $ mkPlainError noHints (withHsDocContext ctxt err_msg) pure $ mkUnboundName (mkTcOccFS (fsLit "<class>")) rnFamEqn :: HsDocContext @@ -843,7 +843,7 @@ rnFamEqn doc atfi extra_kvars badAssocRhs :: [Name] -> RnM () badAssocRhs ns - = addErr $ TcRnUnknownMessage $ mkPlainError noHints $ + = addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $ (hang (text "The RHS of an associated type declaration mentions" <+> text "out-of-scope variable" <> plural ns <+> pprWithCommas (quotes . ppr) ns) @@ -1206,7 +1206,7 @@ rnSrcDerivDecl (DerivDecl _ ty mds overlap) standaloneDerivErr :: TcRnMessage standaloneDerivErr - = TcRnUnknownMessage $ mkPlainError noHints $ + = mkTcRnUnknownMessage $ mkPlainError noHints $ hang (text "Illegal standalone deriving declaration") 2 (text "Use StandaloneDeriving to enable this extension") @@ -1351,14 +1351,14 @@ validRuleLhs foralls lhs badRuleVar :: FastString -> Name -> TcRnMessage badRuleVar name var - = TcRnUnknownMessage $ mkPlainError noHints $ + = mkTcRnUnknownMessage $ mkPlainError noHints $ sep [text "Rule" <+> doubleQuotes (ftext name) <> colon, text "Forall'd variable" <+> quotes (ppr var) <+> text "does not appear on left hand side"] badRuleLhsErr :: FastString -> LHsExpr GhcRn -> HsExpr GhcRn -> TcRnMessage badRuleLhsErr name lhs bad_e - = TcRnUnknownMessage $ mkPlainError noHints $ + = mkTcRnUnknownMessage $ mkPlainError noHints $ sep [text "Rule" <+> pprRuleName name <> colon, nest 2 (vcat [err, text "in left-hand side:" <+> ppr lhs])] @@ -1623,7 +1623,7 @@ rnStandaloneKindSignature tc_names (StandaloneKindSig _ v ki) } where standaloneKiSigErr :: TcRnMessage - standaloneKiSigErr = TcRnUnknownMessage $ mkPlainError noHints $ + standaloneKiSigErr = mkTcRnUnknownMessage $ mkPlainError noHints $ hang (text "Illegal standalone kind signature") 2 (text "Did you mean to enable StandaloneKindSignatures?") @@ -1696,7 +1696,7 @@ rnRoleAnnots tc_names role_annots dupRoleAnnotErr :: NonEmpty (LRoleAnnotDecl GhcPs) -> RnM () dupRoleAnnotErr list - = addErrAt (locA loc) $ TcRnUnknownMessage $ mkPlainError noHints $ + = addErrAt (locA loc) $ mkTcRnUnknownMessage $ mkPlainError noHints $ hang (text "Duplicate role annotations for" <+> quotes (ppr $ roleAnnotDeclName first_decl) <> colon) 2 (vcat $ map pp_role_annot $ NE.toList sorted_list) @@ -1711,7 +1711,7 @@ dupRoleAnnotErr list dupKindSig_Err :: NonEmpty (LStandaloneKindSig GhcPs) -> RnM () dupKindSig_Err list - = addErrAt (locA loc) $ TcRnUnknownMessage $ mkPlainError noHints $ + = addErrAt (locA loc) $ mkTcRnUnknownMessage $ mkPlainError noHints $ hang (text "Duplicate standalone kind signatures for" <+> quotes (ppr $ standaloneKindSigName first_decl) <> colon) 2 (vcat $ map pp_kisig $ NE.toList sorted_list) @@ -1992,7 +1992,7 @@ warnNoDerivStrat mds loc = do { dyn_flags <- getDynFlags ; case mds of Nothing -> - let dia = TcRnUnknownMessage $ + let dia = mkTcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag Opt_WarnMissingDerivingStrategies) noHints $ (if xopt LangExt.DerivingStrategies dyn_flags then no_strat_warning @@ -2100,13 +2100,13 @@ rnLDerivStrategy doc mds thing_inside badGadtStupidTheta :: HsDocContext -> TcRnMessage badGadtStupidTheta _ - = TcRnUnknownMessage $ mkPlainError noHints $ + = mkTcRnUnknownMessage $ mkPlainError noHints $ vcat [text "No context is allowed on a GADT-style data declaration", text "(You can put a context on each constructor, though.)"] illegalDerivStrategyErr :: DerivStrategy GhcPs -> TcRnMessage illegalDerivStrategyErr ds - = TcRnUnknownMessage $ mkPlainError noHints $ + = mkTcRnUnknownMessage $ mkPlainError noHints $ vcat [ text "Illegal deriving strategy" <> colon <+> derivStrategyName ds , text enableStrategy ] @@ -2120,7 +2120,7 @@ illegalDerivStrategyErr ds multipleDerivClausesErr :: TcRnMessage multipleDerivClausesErr - = TcRnUnknownMessage $ mkPlainError noHints $ + = mkTcRnUnknownMessage $ mkPlainError noHints $ vcat [ text "Illegal use of multiple, consecutive deriving clauses" , text "Use DerivingStrategies to allow this" ] @@ -2186,7 +2186,7 @@ rnFamResultSig doc (TyVarSig _ tvbndr) rdr_env <- getLocalRdrEnv ; let resName = hsLTyVarName tvbndr ; when (resName `elemLocalRdrEnv` rdr_env) $ - addErrAt (getLocA tvbndr) $ TcRnUnknownMessage $ mkPlainError noHints $ + addErrAt (getLocA tvbndr) $ mkTcRnUnknownMessage $ mkPlainError noHints $ (hsep [ text "Type variable", quotes (ppr resName) <> comma , text "naming a type family result," ] $$ @@ -2260,7 +2260,7 @@ rnInjectivityAnn tvBndrs (L _ (TyVarSig _ resTv)) -- not-in-scope variables) don't check the validity of injectivity -- annotation. This gives better error messages. ; when (noRnErrors && not lhsValid) $ - addErrAt (getLocA injFrom) $ TcRnUnknownMessage $ mkPlainError noHints $ + addErrAt (getLocA injFrom) $ mkTcRnUnknownMessage $ mkPlainError noHints $ ( vcat [ text $ "Incorrect type variable on the LHS of " ++ "injectivity condition" , nest 5 @@ -2269,7 +2269,7 @@ rnInjectivityAnn tvBndrs (L _ (TyVarSig _ resTv)) ; when (noRnErrors && not (Set.null rhsValid)) $ do { let errorVars = Set.toList rhsValid - ; addErrAt (locA srcSpan) $ TcRnUnknownMessage $ mkPlainError noHints $ + ; addErrAt (locA srcSpan) $ mkTcRnUnknownMessage $ mkPlainError noHints $ ( hsep [ text "Unknown type variable" <> plural errorVars , text "on the RHS of injectivity condition:" @@ -2553,7 +2553,7 @@ add gp loc (SpliceD _ splice@(SpliceDecl _ _ flag)) ds ; return (gp, Just (splice, ds)) } where badImplicitSplice :: TcRnMessage - badImplicitSplice = TcRnUnknownMessage $ mkPlainError noHints $ + badImplicitSplice = mkTcRnUnknownMessage $ mkPlainError noHints $ text "Parse error: module header, import declaration" $$ text "or top-level declaration expected." -- The compiler should suggest the above, and not using diff --git a/compiler/GHC/Rename/Names.hs b/compiler/GHC/Rename/Names.hs index daaf128ea1..597936fbe5 100644 --- a/compiler/GHC/Rename/Names.hs +++ b/compiler/GHC/Rename/Names.hs @@ -352,7 +352,7 @@ rnImportDecl this_mod NoPkgQual -> True ThisPkg uid -> uid == homeUnitId_ (hsc_dflags hsc_env) OtherPkg _ -> False)) - (addErr $ TcRnUnknownMessage $ mkPlainError noHints $ + (addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $ (text "A module cannot import itself:" <+> ppr imp_mod_name)) -- Check for a missing import list (Opt_WarnMissingImportList also @@ -362,7 +362,7 @@ rnImportDecl this_mod _ | implicit -> return () -- Do not bleat for implicit imports | qual_only -> return () | otherwise -> whenWOptM Opt_WarnMissingImportList $ do - let msg = TcRnUnknownMessage $ + let msg = mkTcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag Opt_WarnMissingImportList) noHints (missingImportListWarn imp_mod_name) @@ -387,7 +387,7 @@ rnImportDecl this_mod warnIf ((want_boot == IsBoot) && (mi_boot iface == NotBoot) && isOneShot (ghcMode dflags)) (warnRedundantSourceImport imp_mod_name) when (mod_safe && not (safeImportsOn dflags)) $ - addErr $ TcRnUnknownMessage $ mkPlainError noHints $ + addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $ (text "safe import can't be used as Safe Haskell isn't on!" $+$ text ("please enable Safe Haskell through either Safe, Trustworthy or Unsafe")) @@ -429,7 +429,7 @@ rnImportDecl this_mod -- Complain if we import a deprecated module case mi_warns iface of WarnAll txt -> do - let msg = TcRnUnknownMessage $ + let msg = mkTcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag Opt_WarnWarningsDeprecations) noHints (moduleWarn imp_mod_name txt) @@ -610,7 +610,7 @@ calculateAvails home_unit other_home_units iface mod_safe' want_boot imported_by warnUnqualifiedImport :: ImportDecl GhcPs -> ModIface -> RnM () warnUnqualifiedImport decl iface = when bad_import $ do - let msg = TcRnUnknownMessage $ + let msg = mkTcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag Opt_WarnCompatUnqualifiedImports) noHints warning @@ -643,7 +643,7 @@ warnUnqualifiedImport decl iface = warnRedundantSourceImport :: ModuleName -> TcRnMessage warnRedundantSourceImport mod_name - = TcRnUnknownMessage $ mkPlainDiagnostic WarningWithoutFlag noHints $ + = mkTcRnUnknownMessage $ mkPlainDiagnostic WarningWithoutFlag noHints $ text "Unnecessary {-# SOURCE #-} in the import of module" <+> quotes (ppr mod_name) {- @@ -1277,7 +1277,7 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items)) emit_warning MissingImportList = whenWOptM Opt_WarnMissingImportList $ addTcRnDiagnostic (TcRnMissingImportList ieRdr) emit_warning (BadImportW ie) = whenWOptM Opt_WarnDodgyImports $ do - let msg = TcRnUnknownMessage $ + let msg = mkTcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag Opt_WarnDodgyImports) noHints (lookup_err_msg (BadImport ie)) @@ -1286,7 +1286,7 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items)) run_lookup :: IELookupM a -> TcRn (Maybe a) run_lookup m = case m of Failed err -> do - addErr $ TcRnUnknownMessage $ mkPlainError noHints (lookup_err_msg err) + addErr $ mkTcRnUnknownMessage $ mkPlainError noHints (lookup_err_msg err) return Nothing Succeeded a -> return (Just a) @@ -1834,7 +1834,7 @@ warnUnusedImport flag fld_env (L loc decl, used, unused) -- Nothing used; drop entire declaration | null used - = let dia = TcRnUnknownMessage $ + = let dia = mkTcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag flag) noHints msg1 in addDiagnosticAt (locA loc) dia @@ -1847,12 +1847,12 @@ warnUnusedImport flag fld_env (L loc decl, used, unused) | Just (_, L _ imports) <- ideclImportList decl , length unused == 1 , Just (L loc _) <- find (\(L _ ie) -> ((ieName ie) :: Name) `elem` unused) imports - = let dia = TcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag flag) noHints msg2 + = let dia = mkTcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag flag) noHints msg2 in addDiagnosticAt (locA loc) dia -- Some imports are unused | otherwise - = let dia = TcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag flag) noHints msg2 + = let dia = mkTcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag flag) noHints msg2 in addDiagnosticAt (locA loc) dia where @@ -2144,7 +2144,7 @@ illegalImportItemErr = text "Illegal import item" addDupDeclErr :: [GlobalRdrElt] -> TcRn () addDupDeclErr [] = panic "addDupDeclErr: empty list" addDupDeclErr gres@(gre : _) - = addErrAt (getSrcSpan (last sorted_names)) $ TcRnUnknownMessage $ mkPlainError noHints $ + = addErrAt (getSrcSpan (last sorted_names)) $ mkTcRnUnknownMessage $ mkPlainError noHints $ -- Report the error at the later location vcat [text "Multiple declarations of" <+> quotes (ppr (greOccName gre)), @@ -2175,7 +2175,7 @@ moduleWarn mod (DeprecatedTxt _ txt) packageImportErr :: TcRnMessage packageImportErr - = TcRnUnknownMessage $ mkPlainError noHints $ + = mkTcRnUnknownMessage $ mkPlainError noHints $ text "Package-qualified imports are not enabled; use PackageImports" -- This data decl will parse OK @@ -2193,5 +2193,5 @@ checkConName name = checkErr (isRdrDataCon name) (badDataCon name) badDataCon :: RdrName -> TcRnMessage badDataCon name - = TcRnUnknownMessage $ mkPlainError noHints $ + = mkTcRnUnknownMessage $ mkPlainError noHints $ hsep [text "Illegal data constructor name", quotes (ppr name)] diff --git a/compiler/GHC/Rename/Pat.hs b/compiler/GHC/Rename/Pat.hs index f6f3ba0799..0d4760defd 100644 --- a/compiler/GHC/Rename/Pat.hs +++ b/compiler/GHC/Rename/Pat.hs @@ -643,7 +643,7 @@ rnConPatAndThen mk con (PrefixCon tyargs pats) unless (scoped_tyvars && type_app) $ case listToMaybe tyargs of Nothing -> pure () - Just tyarg -> addErr $ TcRnUnknownMessage $ mkPlainError noHints $ + Just tyarg -> addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $ hang (text "Illegal visible type application in a pattern:" <+> quotes (ppr tyarg)) 2 (text "Both ScopedTypeVariables and TypeApplications are" diff --git a/compiler/GHC/Rename/Splice.hs b/compiler/GHC/Rename/Splice.hs index db032bbc23..b56b15f625 100644 --- a/compiler/GHC/Rename/Splice.hs +++ b/compiler/GHC/Rename/Splice.hs @@ -84,7 +84,7 @@ checkForTemplateHaskellQuotes :: HsExpr GhcPs -> RnM () checkForTemplateHaskellQuotes e = do { thQuotesEnabled <- xoptM LangExt.TemplateHaskellQuotes ; unless thQuotesEnabled $ - failWith ( TcRnUnknownMessage $ mkPlainError noHints $ vcat + failWith ( mkTcRnUnknownMessage $ mkPlainError noHints $ vcat [ text "Syntax error on" <+> ppr e , text ("Perhaps you intended to use TemplateHaskell" ++ " or TemplateHaskellQuotes") ] ) @@ -235,21 +235,21 @@ untypedQuotationCtxtDoc br_body 2 (ppr br_body) illegalBracket :: TcRnMessage -illegalBracket = TcRnUnknownMessage $ mkPlainError noHints $ +illegalBracket = mkTcRnUnknownMessage $ mkPlainError noHints $ text "Template Haskell brackets cannot be nested" <+> text "(without intervening splices)" illegalTypedBracket :: TcRnMessage -illegalTypedBracket = TcRnUnknownMessage $ mkPlainError noHints $ +illegalTypedBracket = mkTcRnUnknownMessage $ mkPlainError noHints $ text "Typed brackets may only appear in typed splices." illegalUntypedBracket :: TcRnMessage -illegalUntypedBracket = TcRnUnknownMessage $ mkPlainError noHints $ +illegalUntypedBracket = mkTcRnUnknownMessage $ mkPlainError noHints $ text "Untyped brackets may only appear in untyped splices." quotedNameStageErr :: HsQuote GhcPs -> TcRnMessage quotedNameStageErr br - = TcRnUnknownMessage $ mkPlainError noHints $ + = mkTcRnUnknownMessage $ mkPlainError noHints $ sep [ text "Stage error: the non-top-level quoted name" <+> ppr br , text "must be used at the same stage at which it is bound" ] @@ -331,7 +331,7 @@ checkTopSpliceAllowed splice = do let (herald, ext) = spliceExtension splice extEnabled <- xoptM ext unless extEnabled - (failWith $ TcRnUnknownMessage $ mkPlainError noHints $ + (failWith $ mkTcRnUnknownMessage $ mkPlainError noHints $ text herald <+> text "are not permitted without" <+> ppr ext) where spliceExtension :: HsUntypedSplice GhcPs -> (String, LangExt.Extension) @@ -462,7 +462,7 @@ rnTypedSplice expr _ -> do { extEnabled <- xoptM LangExt.TemplateHaskell ; unless extEnabled - (failWith $ TcRnUnknownMessage $ mkPlainError noHints $ + (failWith $ mkTcRnUnknownMessage $ mkPlainError noHints $ text "Top-level splices are not permitted without" <+> ppr LangExt.TemplateHaskell) @@ -886,11 +886,11 @@ traceSplice (SpliceInfo { spliceDescription = sd, spliceSource = mb_src , gen ] illegalTypedSplice :: TcRnMessage -illegalTypedSplice = TcRnUnknownMessage $ mkPlainError noHints $ +illegalTypedSplice = mkTcRnUnknownMessage $ mkPlainError noHints $ text "Typed splices may not appear in untyped brackets" illegalUntypedSplice :: TcRnMessage -illegalUntypedSplice = TcRnUnknownMessage $ mkPlainError noHints $ +illegalUntypedSplice = mkTcRnUnknownMessage $ mkPlainError noHints $ text "Untyped splices may not appear in typed brackets" checkThLocalName :: Name -> RnM () diff --git a/compiler/GHC/Rename/Utils.hs b/compiler/GHC/Rename/Utils.hs index 16f6d49767..78e3285a24 100644 --- a/compiler/GHC/Rename/Utils.hs +++ b/compiler/GHC/Rename/Utils.hs @@ -203,7 +203,7 @@ checkInferredVars ctxt (Just msg) ty = let bndrs = sig_ty_bndrs ty in case find ((==) InferredSpec . hsTyVarBndrFlag) bndrs of Nothing -> return () - Just _ -> addErr $ TcRnUnknownMessage $ mkPlainError noHints (withHsDocContext ctxt msg) + Just _ -> addErr $ mkTcRnUnknownMessage $ mkPlainError noHints (withHsDocContext ctxt msg) where sig_ty_bndrs :: LHsSigType GhcPs -> [HsTyVarBndr Specificity GhcPs] sig_ty_bndrs (L _ (HsSig{sig_bndrs = outer_bndrs})) @@ -312,7 +312,7 @@ noNestedForallsContextsErr what lty = addNoNestedForallsContextsErr :: HsDocContext -> SDoc -> LHsType GhcRn -> RnM () addNoNestedForallsContextsErr ctxt what lty = whenIsJust (noNestedForallsContextsErr what lty) $ \(l, err_msg) -> - addErrAt l $ TcRnUnknownMessage $ mkPlainError noHints (withHsDocContext ctxt err_msg) + addErrAt l $ mkTcRnUnknownMessage $ mkPlainError noHints (withHsDocContext ctxt err_msg) {- ************************************************************************ @@ -390,7 +390,7 @@ checkUnusedRecordWildcard loc fvs (Just dotdot_names) = warnRedundantRecordWildcard :: RnM () warnRedundantRecordWildcard = whenWOptM Opt_WarnRedundantRecordWildcards $ - let msg = TcRnUnknownMessage $ + let msg = mkTcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag Opt_WarnRedundantRecordWildcards) noHints redundantWildcardWarning @@ -489,7 +489,7 @@ reportable child addUnusedWarning :: WarningFlag -> OccName -> SrcSpan -> SDoc -> RnM () addUnusedWarning flag occ span msg = do - let diag = TcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag flag) noHints $ + let diag = mkTcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag flag) noHints $ sep [msg <> colon, nest 2 $ pprNonVarNameSpace (occNameSpace occ) <+> quotes (ppr occ)] @@ -497,7 +497,7 @@ addUnusedWarning flag occ span msg = do unusedRecordWildcardWarning :: TcRnMessage unusedRecordWildcardWarning = - TcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag Opt_WarnUnusedRecordWildcards) noHints $ + mkTcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag Opt_WarnUnusedRecordWildcards) noHints $ wildcardDoc $ text "No variables bound in the record wildcard match are used" redundantWildcardWarning :: SDoc @@ -547,7 +547,7 @@ addNameClashErrRn rdr_name gres -- already, and we don't want an error cascade. = return () | otherwise - = addErr $ TcRnUnknownMessage $ mkPlainError noHints $ + = addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $ (vcat [ text "Ambiguous occurrence" <+> quotes (ppr rdr_name) , text "It could refer to" , nest 3 (vcat (msg1 : msgs)) ]) @@ -600,7 +600,7 @@ addNameClashErrRn rdr_name gres dupNamesErr :: Outputable n => (n -> SrcSpan) -> NE.NonEmpty n -> RnM () dupNamesErr get_loc names - = addErrAt big_loc $ TcRnUnknownMessage $ mkPlainError noHints $ + = addErrAt big_loc $ mkTcRnUnknownMessage $ mkPlainError noHints $ vcat [text "Conflicting definitions for" <+> quotes (ppr (NE.head names)), locations] where @@ -610,19 +610,19 @@ dupNamesErr get_loc names badQualBndrErr :: RdrName -> TcRnMessage badQualBndrErr rdr_name - = TcRnUnknownMessage $ mkPlainError noHints $ + = mkTcRnUnknownMessage $ mkPlainError noHints $ text "Qualified name in binding position:" <+> ppr rdr_name typeAppErr :: String -> LHsType GhcPs -> TcRnMessage typeAppErr what (L _ k) - = TcRnUnknownMessage $ mkPlainError noHints $ + = mkTcRnUnknownMessage $ mkPlainError noHints $ hang (text "Illegal visible" <+> text what <+> text "application" <+> quotes (char '@' <> ppr k)) 2 (text "Perhaps you intended to use TypeApplications") badFieldConErr :: Name -> FieldLabelString -> TcRnMessage badFieldConErr con field - = TcRnUnknownMessage $ mkPlainError noHints $ + = mkTcRnUnknownMessage $ mkPlainError noHints $ hsep [text "Constructor" <+> quotes (ppr con), text "does not have field", quotes (ppr field)] @@ -633,7 +633,7 @@ checkTupSize tup_size | tup_size <= mAX_TUPLE_SIZE = return () | otherwise - = addErr $ TcRnUnknownMessage $ mkPlainError noHints $ + = addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $ sep [text "A" <+> int tup_size <> text "-tuple is too large for GHC", nest 2 (parens (text "max size is" <+> int mAX_TUPLE_SIZE)), nest 2 (text "Workaround: use nested tuples or define a data type")] @@ -644,7 +644,7 @@ checkCTupSize tup_size | tup_size <= mAX_CTUPLE_SIZE = return () | otherwise - = addErr $ TcRnUnknownMessage $ mkPlainError noHints $ + = addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $ hang (text "Constraint tuple arity too large:" <+> int tup_size <+> parens (text "max arity =" <+> int mAX_CTUPLE_SIZE)) 2 (text "Instead, use a nested tuple") diff --git a/compiler/GHC/Stg/Lint.hs b/compiler/GHC/Stg/Lint.hs index 6104407913..f1e7c98321 100644 --- a/compiler/GHC/Stg/Lint.hs +++ b/compiler/GHC/Stg/Lint.hs @@ -512,7 +512,7 @@ addErr diag_opts errs_so_far msg locs = errs_so_far `snocBag` mk_msg locs where mk_msg (loc:_) = let (l,hdr) = dumpLoc loc - in mkLocMessage (Err.mkMCDiagnostic diag_opts WarningWithoutFlag) + in mkLocMessage (Err.mkMCDiagnostic diag_opts WarningWithoutFlag Nothing) l (hdr $$ msg) mk_msg [] = msg diff --git a/compiler/GHC/Tc/Errors.hs b/compiler/GHC/Tc/Errors.hs index 237c6fa4a3..35deaf06bc 100644 --- a/compiler/GHC/Tc/Errors.hs +++ b/compiler/GHC/Tc/Errors.hs @@ -13,7 +13,6 @@ module GHC.Tc.Errors( -- * GHC API helper functions solverReportMsg_ExpectedActuals, - solverReportInfo_ExpectedActuals ) where import GHC.Prelude @@ -79,13 +78,12 @@ import GHC.Data.List.SetOps ( equivClasses, nubOrdBy ) import GHC.Data.Maybe import qualified GHC.Data.Strict as Strict -import Control.Monad ( unless, when, foldM, forM_ ) -import Data.Foldable ( toList ) -import Data.Function ( on ) -import Data.List ( partition, sort, sortBy ) -import Data.List.NonEmpty ( NonEmpty(..), (<|) ) -import qualified Data.List.NonEmpty as NE ( map, reverse ) -import Data.Ord ( comparing ) +import Control.Monad ( unless, when, foldM, forM_ ) +import Data.Foldable ( toList ) +import Data.Function ( on ) +import Data.List ( partition, sort, sortBy ) +import Data.List.NonEmpty ( NonEmpty(..) ) +import Data.Ord ( comparing ) import qualified Data.Semigroup as S {- @@ -263,13 +261,18 @@ report_unsolved type_errors expr_holes -- | Make a report from a single 'TcSolverReportMsg'. important :: SolverReportErrCtxt -> TcSolverReportMsg -> SolverReport -important ctxt doc = mempty { sr_important_msgs = [SolverReportWithCtxt ctxt doc] } +important ctxt doc + = SolverReport { sr_important_msg = SolverReportWithCtxt ctxt doc + , sr_supplementary = [] + , sr_hints = [] } -mk_relevant_bindings :: RelevantBindings -> SolverReport -mk_relevant_bindings binds = mempty { sr_supplementary = [SupplementaryBindings binds] } +add_relevant_bindings :: RelevantBindings -> SolverReport -> SolverReport +add_relevant_bindings binds report@(SolverReport { sr_supplementary = supp }) + = report { sr_supplementary = SupplementaryBindings binds : supp } -mk_report_hints :: [GhcHint] -> SolverReport -mk_report_hints hints = mempty { sr_hints = hints } +add_report_hints :: [GhcHint] -> SolverReport -> SolverReport +add_report_hints hints report@(SolverReport { sr_hints = prev_hints }) + = report { sr_hints = prev_hints ++ hints } -- | Returns True <=> the SolverReportErrCtxt indicates that something is deferred deferringAnyBindings :: SolverReportErrCtxt -> Bool @@ -436,7 +439,7 @@ reportBadTelescope :: SolverReportErrCtxt -> TcLclEnv -> SkolemInfoAnon -> [TcTy reportBadTelescope ctxt env (ForAllSkol telescope) skols = do { msg <- mkErrorReport env - (TcRnSolverReport [report] ErrorWithoutFlag noHints) + (TcRnSolverReport report ErrorWithoutFlag noHints) (Just ctxt) [] ; reportDiagnostic msg } @@ -905,7 +908,7 @@ reportNotConcreteErrs ctxt errs@(err0:_) frr_origins = acc_errors errs diag = TcRnSolverReport - [SolverReportWithCtxt ctxt (FixedRuntimeRepError frr_origins)] + (SolverReportWithCtxt ctxt (FixedRuntimeRepError frr_origins)) ErrorWithoutFlag noHints -- Accumulate the different kind of errors arising from syntactic equality. @@ -961,10 +964,10 @@ mkGivenErrorReporter ctxt items -- with one from the immediately-enclosing implication. -- See Note [Inaccessible code] - ; (eq_err_msgs, _hints) <- mkEqErr_help ctxt item' ty1 ty2 + ; (eq_err_msg, _hints) <- mkEqErr_help ctxt item' 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 (SolverReportWithCtxt ctxt) $ eq_err_msgs) + msg = TcRnInaccessibleCode implic (SolverReportWithCtxt ctxt eq_err_msg) ; msg <- mkErrorReport (ctLocEnv loc') msg (Just ctxt) supplementary ; reportDiagnostic msg } where @@ -1061,7 +1064,7 @@ nonDeferrableOrigin _ = False maybeReportError :: SolverReportErrCtxt -> [ErrorItem] -- items covered by the Report -> SolverReport -> TcM () -maybeReportError ctxt items@(item1:_) (SolverReport { sr_important_msgs = important +maybeReportError ctxt items@(item1:_) (SolverReport { sr_important_msg = important , sr_supplementary = supp , sr_hints = hints }) = unless (cec_suppress ctxt -- Some worse error has occurred, so suppress this diagnostic @@ -1099,7 +1102,7 @@ addDeferredBinding _ _ _ = return () -- Do not set any evidence for Given mkErrorTerm :: SolverReportErrCtxt -> CtLoc -> Type -- of the error term -> SolverReport -> TcM EvTerm -mkErrorTerm ctxt ct_loc ty (SolverReport { sr_important_msgs = important, sr_supplementary = supp }) +mkErrorTerm ctxt ct_loc ty (SolverReport { sr_important_msg = important, sr_supplementary = supp }) = do { msg <- mkErrorReport (ctLocEnv ct_loc) (TcRnSolverReport important ErrorWithoutFlag noHints) (Just ctxt) supp @@ -1278,10 +1281,10 @@ coercion. mkIrredErr :: SolverReportErrCtxt -> [ErrorItem] -> TcM SolverReport mkIrredErr ctxt items - = do { (ctxt, binds_msg, item1) <- relevantBindings True ctxt item1 - ; let msg = important ctxt $ + = do { (ctxt, binds, item1) <- relevantBindings True ctxt item1 + ; let msg = important ctxt $ mkPlainMismatchMsg $ CouldNotDeduce (getUserGivens ctxt) (item1 :| others) Nothing - ; return $ msg `mappend` mk_relevant_bindings binds_msg } + ; return $ add_relevant_bindings binds msg } where (item1:others) = final_items @@ -1342,11 +1345,11 @@ 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 = [SolverReportWithCtxt ctxt (ReportHoleError hole $ OutOfScopeHole imp_errs)] - report = SolverReport errs [] hints + err = SolverReportWithCtxt ctxt (ReportHoleError hole $ OutOfScopeHole imp_errs) + report = SolverReport err [] hints ; maybeAddDeferredBindings ctxt hole report - ; mkErrorReport lcl_env (TcRnSolverReport errs (cec_out_of_scope_holes ctxt) hints) Nothing [] + ; mkErrorReport lcl_env (TcRnSolverReport err (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. } @@ -1376,14 +1379,14 @@ 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 = [SolverReportWithCtxt ctxt $ ReportHoleError hole $ HoleError sort other_tvs grouped_skvs] + err = SolverReportWithCtxt ctxt $ ReportHoleError hole $ HoleError sort other_tvs grouped_skvs supp = [ SupplementaryBindings rel_binds , SupplementaryCts relevant_cts , SupplementaryHoleFits hole_fits ] - ; maybeAddDeferredBindings ctxt hole (SolverReport errs supp []) + ; maybeAddDeferredBindings ctxt hole (SolverReport err supp []) - ; mkErrorReport lcl_env (TcRnSolverReport errs reason noHints) (Just ctxt) supp + ; mkErrorReport lcl_env (TcRnSolverReport err reason noHints) (Just ctxt) supp } where @@ -1472,9 +1475,9 @@ mkIPErr :: SolverReportErrCtxt -> [ErrorItem] -> TcM SolverReport -- Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint? Very unclear -- what's best. Let's not worry about this. mkIPErr ctxt items - = do { (ctxt, binds_msg, item1) <- relevantBindings True ctxt item1 + = do { (ctxt, binds, item1) <- relevantBindings True ctxt item1 ; let msg = important ctxt $ UnboundImplicitParams (item1 :| others) - ; return $ msg `mappend` mk_relevant_bindings binds_msg } + ; return $ add_relevant_bindings binds msg } where item1:others = items @@ -1584,19 +1587,13 @@ mkEqErr ctxt items mkEqErr1 :: SolverReportErrCtxt -> ErrorItem -> TcM SolverReport mkEqErr1 ctxt item -- Wanted only -- givens handled in mkGivenErrorReporter - = do { (ctxt, binds_msg, item) <- relevantBindings True ctxt item - ; rdr_env <- getGlobalRdrEnv - ; fam_envs <- tcGetFamInstEnvs - ; let mb_coercible_msg = case errorItemEqRel item of - NomEq -> Nothing - ReprEq -> ReportCoercibleMsg <$> mkCoercibleExplanation rdr_env fam_envs ty1 ty2 + = do { (ctxt, binds, item) <- relevantBindings True ctxt item ; traceTc "mkEqErr1" (ppr item $$ pprCtOrigin (errorItemOrigin item)) - ; (last_msg :| prev_msgs, hints) <- mkEqErr_help ctxt item ty1 ty2 + ; (err_msg, hints) <- mkEqErr_help ctxt item 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) + report = add_relevant_bindings binds + $ add_report_hints hints + $ important ctxt err_msg ; return report } where (ty1, ty2) = getEqPredTys (errorItemPred item) @@ -1642,38 +1639,55 @@ mkCoercibleExplanation rdr_env fam_envs ty1 ty2 | otherwise = False --- | Accumulated messages in reverse order. -type AccReportMsgs = NonEmpty TcSolverReportMsg - mkEqErr_help :: SolverReportErrCtxt -> ErrorItem - -> TcType -> TcType -> TcM (AccReportMsgs, [GhcHint]) + -> TcType -> TcType -> TcM (TcSolverReportMsg, [GhcHint]) mkEqErr_help ctxt item ty1 ty2 | Just casted_tv1 <- tcGetCastedTyVar_maybe ty1 = mkTyVarEqErr ctxt item casted_tv1 ty2 | Just casted_tv2 <- tcGetCastedTyVar_maybe ty2 = mkTyVarEqErr ctxt item casted_tv2 ty1 | otherwise - = return (reportEqErr ctxt item ty1 ty2 :| [], []) + = do + err <- reportEqErr ctxt item ty1 ty2 + return (err, noHints) reportEqErr :: SolverReportErrCtxt -> ErrorItem - -> TcType -> TcType -> TcSolverReportMsg + -> TcType -> TcType + -> TcM TcSolverReportMsg reportEqErr ctxt item ty1 ty2 - = mkTcReportWithInfo mismatch eqInfos + = do + mb_coercible_info <- + if errorItemEqRel item == ReprEq + then coercible_msg ty1 ty2 + else return Nothing + return $ + Mismatch + { mismatchMsg = mismatch + , mismatchTyVarInfo = Nothing + , mismatchAmbiguityInfo = eqInfos + , mismatchCoercibleInfo = mb_coercible_info } where mismatch = misMatchOrCND False ctxt item ty1 ty2 eqInfos = eqInfoMsgs ty1 ty2 +coercible_msg :: TcType -> TcType -> TcM (Maybe CoercibleMsg) +coercible_msg ty1 ty2 + = do + rdr_env <- getGlobalRdrEnv + fam_envs <- tcGetFamInstEnvs + return $ mkCoercibleExplanation rdr_env fam_envs ty1 ty2 + mkTyVarEqErr :: SolverReportErrCtxt -> ErrorItem - -> (TcTyVar, TcCoercionN) -> TcType -> TcM (AccReportMsgs, [GhcHint]) + -> (TcTyVar, TcCoercionN) -> TcType -> TcM (TcSolverReportMsg, [GhcHint]) -- tv1 and ty2 are already tidied mkTyVarEqErr ctxt item casted_tv1 ty2 = do { traceTc "mkTyVarEqErr" (ppr item $$ ppr casted_tv1 $$ ppr ty2) ; mkTyVarEqErr' ctxt item casted_tv1 ty2 } mkTyVarEqErr' :: SolverReportErrCtxt -> ErrorItem - -> (TcTyVar, TcCoercionN) -> TcType -> TcM (AccReportMsgs, [GhcHint]) + -> (TcTyVar, TcCoercionN) -> TcType -> TcM (TcSolverReportMsg, [GhcHint]) mkTyVarEqErr' ctxt item (tv1, co1) ty2 -- Is this a representation-polymorphism error, e.g. @@ -1681,24 +1695,28 @@ mkTyVarEqErr' ctxt item (tv1, co1) ty2 | Just frr_info <- mb_concrete_reason = do (_, infos) <- zonkTidyFRRInfos (cec_tidy ctxt) [frr_info] - return (FixedRuntimeRepError infos :| [], []) + return (FixedRuntimeRepError infos, []) -- Impredicativity is a simple error to understand; try it before -- anything more complicated. | check_eq_result `cterHasProblem` cteImpredicative = do - tyvar_eq_info <- extraTyVarEqInfo tv1 ty2 + tyvar_eq_info <- extraTyVarEqInfo (tv1, Nothing) ty2 let - poly_msg = CannotUnifyWithPolytype item tv1 ty2 - poly_msg_with_info + poly_msg = CannotUnifyWithPolytype item tv1 ty2 mb_tv_info + mb_tv_info | isSkolemTyVar tv1 - = mkTcReportWithInfo poly_msg tyvar_eq_info + = Just tyvar_eq_info | otherwise - = poly_msg + = Nothing + main_msg = + CannotUnifyVariable + { mismatchMsg = headline_msg + , cannotUnifyReason = 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. - return (poly_msg_with_info <| headline_msg :| [], []) + return (main_msg, []) | isSkolemTyVar tv1 -- ty2 won't be a meta-tyvar; we would have -- swapped in Solver.Canonical.canEqTyVarHomo @@ -1706,30 +1724,43 @@ mkTyVarEqErr' ctxt item (tv1, co1) ty2 || errorItemEqRel item == ReprEq -- The cases below don't really apply to ReprEq (except occurs check) = do - tv_extra <- extraTyVarEqInfo tv1 ty2 - return (mkTcReportWithInfo headline_msg tv_extra :| [], add_sig) + tv_extra <- extraTyVarEqInfo (tv1, Nothing) ty2 + reason <- + if errorItemEqRel item == ReprEq + then RepresentationalEq tv_extra <$> coercible_msg ty1 ty2 + else return $ DifferentTyVars tv_extra + let main_msg = + CannotUnifyVariable + { mismatchMsg = headline_msg + , cannotUnifyReason = reason } + return (main_msg, 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 extras2 = eqInfoMsgs ty1 ty2 + = let ambiguity_infos = eqInfoMsgs ty1 ty2 interesting_tyvars = filter (not . noFreeVarsOfType . tyVarKind) $ filter isTyVar $ fvVarList $ tyCoFVsOfType ty1 `unionFV` tyCoFVsOfType ty2 - extras3 = case interesting_tyvars of - [] -> [] - (tv : tvs) -> [OccursCheckInterestingTyVars (tv :| tvs)] + occurs_err = + OccursCheck + { occursCheckInterestingTyVars = interesting_tyvars + , occursCheckAmbiguityInfos = ambiguity_infos } + main_msg = + CannotUnifyVariable + { mismatchMsg = headline_msg + , cannotUnifyReason = occurs_err } - in return (mkTcReportWithInfo headline_msg (extras2 ++ extras3) :| [], []) + in return (main_msg, []) -- This is wrinkle (4) in Note [Equalities with incompatible kinds] in -- GHC.Tc.Solver.Canonical | hasCoercionHoleCo co1 || hasCoercionHoleTy ty2 - = return (mkBlockedEqErr item :| [], []) + = return (mkBlockedEqErr item, []) -- If the immediately-enclosing implication has 'tv' a skolem, and -- we know by now its an InferSkol kind of skolem, then presumably @@ -1739,15 +1770,25 @@ mkTyVarEqErr' ctxt item (tv1, co1) ty2 , Implic { ic_skols = skols } <- implic , tv1 `elem` skols = do - tv_extra <- extraTyVarEqInfo tv1 ty2 - return (mkTcReportWithInfo mismatch_msg tv_extra :| [], []) + tv_extra <- extraTyVarEqInfo (tv1, Nothing) ty2 + let msg = Mismatch + { mismatchMsg = mismatch_msg + , mismatchTyVarInfo = Just tv_extra + , mismatchAmbiguityInfo = [] + , mismatchCoercibleInfo = Nothing } + return (msg, []) -- Check for skolem escape | (implic:_) <- cec_encl ctxt -- Get the innermost context , Implic { ic_skols = skols } <- implic , let esc_skols = filter (`elemVarSet` (tyCoVarsOfType ty2)) skols , not (null esc_skols) - = return (SkolemEscape item implic esc_skols :| [mismatch_msg], []) + = let main_msg = + CannotUnifyVariable + { mismatchMsg = mismatch_msg + , cannotUnifyReason = SkolemEscape item implic esc_skols } + + in return (main_msg, []) -- Nastiest case: attempt to unify an untouchable variable -- So tv is a meta tyvar (or started that way before we @@ -1758,12 +1799,19 @@ mkTyVarEqErr' ctxt item (tv1, co1) ty2 , Implic { ic_tclvl = lvl } <- implic = assertPpr (not (isTouchableMetaTyVar lvl tv1)) (ppr tv1 $$ ppr lvl) $ do -- See Note [Error messages for untouchables] - let tclvl_extra = UntouchableVariable tv1 implic - tv_extra <- extraTyVarEqInfo tv1 ty2 - return (mkTcReportWithInfo tclvl_extra tv_extra :| [mismatch_msg], add_sig) + tv_extra <- extraTyVarEqInfo (tv1, Just implic) ty2 + let tv_extra' = tv_extra { thisTyVarIsUntouchable = Just implic } + msg = Mismatch + { mismatchMsg = mismatch_msg + , mismatchTyVarInfo = Just tv_extra' + , mismatchAmbiguityInfo = [] + , mismatchCoercibleInfo = Nothing } + return (msg, add_sig) | otherwise - = return (reportEqErr ctxt item (mkTyVarTy tv1) ty2 :| [], []) + = do + err <- reportEqErr ctxt item (mkTyVarTy tv1) ty2 + return (err, []) -- This *can* happen (#6123) -- Consider an ambiguous top-level constraint (a ~ F a) -- Not an occurs check, because F is a type function. @@ -1802,7 +1850,7 @@ mkTyVarEqErr' ctxt item (tv1, co1) ty2 insoluble_occurs_check = check_eq_result `cterHasProblem` cteInsolubleOccurs -eqInfoMsgs :: TcType -> TcType -> [TcSolverReportInfo] +eqInfoMsgs :: TcType -> TcType -> [AmbiguityInfo] -- 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 @@ -1836,7 +1884,7 @@ eqInfoMsgs ty1 ty2 = Nothing misMatchOrCND :: Bool -> SolverReportErrCtxt -> ErrorItem - -> TcType -> TcType -> TcSolverReportMsg + -> TcType -> TcType -> MismatchMsg -- If oriented then ty1 is actual, ty2 is expected misMatchOrCND insoluble_occurs_check ctxt item ty1 ty2 | insoluble_occurs_check -- See Note [Insoluble occurs check] @@ -1904,23 +1952,30 @@ addition to superclasses (see Note [Remove redundant provided dicts] in GHC.Tc.TyCl.PatSyn). -} -extraTyVarEqInfo :: TcTyVar -> TcType -> TcM [TcSolverReportInfo] +extraTyVarEqInfo :: (TcTyVar, Maybe Implication) -> TcType -> TcM TyVarInfo -- Add on extra info about skolem constants -- NB: The types themselves are already tidied -extraTyVarEqInfo tv1 ty2 - = (:) <$> extraTyVarInfo tv1 <*> ty_extra ty2 +extraTyVarEqInfo (tv1, mb_implic) ty2 + = do + tv1_info <- extraTyVarInfo tv1 + ty2_info <- ty_extra ty2 + return $ + TyVarInfo + { thisTyVar = tv1_info + , thisTyVarIsUntouchable = mb_implic + , otherTy = ty2_info } where ty_extra ty = case tcGetCastedTyVar_maybe ty of - Just (tv, _) -> (:[]) <$> extraTyVarInfo tv - Nothing -> return [] + Just (tv, _) -> Just <$> extraTyVarInfo tv + Nothing -> return Nothing -extraTyVarInfo :: TcTyVar -> TcM TcSolverReportInfo +extraTyVarInfo :: TcTyVar -> TcM TyVar extraTyVarInfo tv = assertPpr (isTyVar tv) (ppr tv) $ case tcTyVarDetails tv of SkolemTv skol_info lvl overlaps -> do new_skol_info <- zonkSkolemInfo skol_info - return $ TyVarInfo (mkTcTyVar (tyVarName tv) (tyVarKind tv) (SkolemTv new_skol_info lvl overlaps)) - _ -> return $ TyVarInfo tv + return $ mkTcTyVar (tyVarName tv) (tyVarKind tv) (SkolemTv new_skol_info lvl overlaps) + _ -> return tv suggestAddSig :: SolverReportErrCtxt -> TcType -> TcType -> Maybe GhcHint @@ -1949,30 +2004,30 @@ suggestAddSig ctxt ty1 _ty2 = find implics (seen_eqs || ic_given_eqs implic /= NoGivenEqs) tv -------------------- -mkMismatchMsg :: ErrorItem -> Type -> Type -> TcSolverReportMsg +mkMismatchMsg :: ErrorItem -> Type -> Type -> MismatchMsg mkMismatchMsg item ty1 ty2 = case orig of TypeEqOrigin { uo_actual, uo_expected, uo_thing = mb_thing } -> - mkTcReportWithInfo - (TypeEqMismatch - { teq_mismatch_ppr_explicit_kinds = ppr_explicit_kinds - , teq_mismatch_item = item - , teq_mismatch_ty1 = ty1 - , teq_mismatch_ty2 = ty2 - , teq_mismatch_actual = uo_actual - , teq_mismatch_expected = uo_expected - , teq_mismatch_what = mb_thing}) - extras + (TypeEqMismatch + { teq_mismatch_ppr_explicit_kinds = ppr_explicit_kinds + , teq_mismatch_item = item + , teq_mismatch_ty1 = ty1 + , teq_mismatch_ty2 = ty2 + , teq_mismatch_actual = uo_actual + , teq_mismatch_expected = uo_expected + , teq_mismatch_what = mb_thing + , teq_mb_same_occ = sameOccExtras ty2 ty1 }) KindEqOrigin cty1 cty2 sub_o mb_sub_t_or_k -> - mkTcReportWithInfo (Mismatch False item ty1 ty2) - (WhenMatching cty1 cty2 sub_o mb_sub_t_or_k : extras) + (mkBasicMismatchMsg NoEA item ty1 ty2) + { mismatch_whenMatching = Just $ WhenMatching cty1 cty2 sub_o mb_sub_t_or_k + , mismatch_mb_same_occ = mb_same_occ + } _ -> - mkTcReportWithInfo - (Mismatch False item ty1 ty2) - extras + (mkBasicMismatchMsg NoEA item ty1 ty2) + { mismatch_mb_same_occ = mb_same_occ } where orig = errorItemOrigin item - extras = sameOccExtras ty2 ty1 + mb_same_occ = sameOccExtras ty2 ty1 ppr_explicit_kinds = shouldPprWithExplicitKinds ty1 ty2 orig -- | Whether to print explicit kinds (with @-fprint-explicit-kinds@) @@ -2011,7 +2066,7 @@ This is done in misMatchOrCND (via the insoluble_occurs_check arg) want to be as draconian with them.) -} -sameOccExtras :: TcType -> TcType -> [TcSolverReportInfo] +sameOccExtras :: TcType -> TcType -> Maybe SameOccInfo -- See Note [Disambiguating (X ~ X) errors] sameOccExtras ty1 ty2 | Just (tc1, _) <- tcSplitTyConApp_maybe ty1 @@ -2022,9 +2077,9 @@ sameOccExtras ty1 ty2 same_pkg = moduleUnit (nameModule n1) == moduleUnit (nameModule n2) , n1 /= n2 -- Different Names , same_occ -- but same OccName - = [SameOcc same_pkg n1 n2] + = Just $ SameOcc same_pkg n1 n2 | otherwise - = [] + = Nothing {- Note [Suggest adding a type signature] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2468,28 +2523,14 @@ are created by in GHC.Runtime.Heap.Inspect.zonkRTTIType. 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)] + Mismatch { mismatchMsg = mismatch_msg } -> + case mismatch_msg of + BasicMismatch { 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)] + CouldNotDeduce {} -> + [] _ -> [] diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs index 7d4e7e3948..ab338cf452 100644 --- a/compiler/GHC/Tc/Errors/Ppr.hs +++ b/compiler/GHC/Tc/Errors/Ppr.hs @@ -3,6 +3,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DataKinds #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic TcRnMessage @@ -56,6 +57,7 @@ import GHC.Types.FieldLabel (flIsOverloaded) import GHC.Types.Hint (UntickedPromotedThing(..), pprUntickedConstructor, isBareSymbol) import GHC.Types.Hint.Ppr () -- Outputable GhcHint import GHC.Types.Basic +import GHC.Types.Error.Codes ( constructorCode ) import GHC.Types.Id import GHC.Types.Name import GHC.Types.Name.Reader ( GreName(..), pprNameProvenance @@ -102,19 +104,18 @@ instance Diagnostic TcRnMessage where -> case msg_with_info of TcRnMessageDetailed err_info msg -> messageWithInfoDiagnosticMessage unit_state err_info (diagnosticMessage msg) - TcRnSolverReport msgs _ _ - -> mkDecorated $ - map pprSolverReportWithCtxt msgs + TcRnSolverReport msg _ _ + -> mkSimpleDecorated $ pprSolverReportWithCtxt msg TcRnRedundantConstraints redundants (info, show_info) -> mkSimpleDecorated $ text "Redundant constraint" <> plural redundants <> colon <+> pprEvVarTheta redundants $$ if show_info then text "In" <+> ppr info else empty - TcRnInaccessibleCode implic contras + TcRnInaccessibleCode implic contra -> mkSimpleDecorated $ hang (text "Inaccessible code in") 2 (ppr (ic_info implic)) - $$ vcat (map pprSolverReportWithCtxt (NE.toList contras)) + $$ pprSolverReportWithCtxt contra TcRnTypeDoesNotHaveFixedRuntimeRep ty prov (ErrInfo extra supplementary) -> mkDecorated [pprTypeDoesNotHaveFixedRuntimeRep ty prov, extra, supplementary] TcRnImplicitLift id_or_name ErrInfo{..} @@ -906,7 +907,7 @@ instance Diagnostic TcRnMessage where TyConPE -> same_rec_group_msg TermVariablePE -> text "term variables cannot be promoted" same_rec_group_msg = text "it is defined and used in the same recursive group" - TcRnMatchesHaveDiffNumArgs argsContext match1 bad_matches + TcRnMatchesHaveDiffNumArgs argsContext (MatchArgMatches match1 bad_matches) -> mkSimpleDecorated $ (vcat [ pprArgsContext argsContext <+> text "have different numbers of arguments" @@ -1634,16 +1635,29 @@ instance Diagnostic TcRnMessage where -> noHints TcRnSpecialiseNotVisible name -> [SuggestSpecialiseVisibilityHints name] - TcRnNameByTemplateHaskellQuote{} -> noHints - TcRnIllegalBindingOfBuiltIn{} -> noHints - TcRnPragmaWarning{} -> noHints - TcRnIllegalHsigDefaultMethods{} -> noHints - TcRnBadGenericMethod{} -> noHints - TcRnWarningMinimalDefIncomplete{} -> noHints - TcRnDefaultMethodForPragmaLacksBinding{} -> noHints - TcRnIgnoreSpecialisePragmaOnDefMethod{} -> noHints - TcRnBadMethodErr{} -> noHints - TcRnNoExplicitAssocTypeOrDefaultDeclaration{} -> noHints + TcRnNameByTemplateHaskellQuote{} + -> noHints + TcRnIllegalBindingOfBuiltIn{} + -> noHints + TcRnPragmaWarning{} + -> noHints + TcRnIllegalHsigDefaultMethods{} + -> noHints + TcRnBadGenericMethod{} + -> noHints + TcRnWarningMinimalDefIncomplete{} + -> noHints + TcRnDefaultMethodForPragmaLacksBinding{} + -> noHints + TcRnIgnoreSpecialisePragmaOnDefMethod{} + -> noHints + TcRnBadMethodErr{} + -> noHints + TcRnNoExplicitAssocTypeOrDefaultDeclaration{} + -> noHints + + diagnosticCode = constructorCode + -- | Change [x] to "x", [x, y] to "x and y", [x, y, z] to "x, y, and z", -- and so on. The `and` stands for any `conjunction`, which is passed in. @@ -2059,11 +2073,6 @@ pprSolverReportWithCtxt (SolverReportWithCtxt { reportContext = ctxt, reportCont -- | Pretty-print a 'TcSolverReportMsg', with its enclosing 'SolverReportErrCtxt'. pprTcSolverReportMsg :: SolverReportErrCtxt -> TcSolverReportMsg -> SDoc -pprTcSolverReportMsg ctxt (TcReportWithInfo msg (info :| infos)) = - vcat - ( 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:") @@ -2074,143 +2083,22 @@ pprTcSolverReportMsg _ (UserTypeError ty) = pprUserTypeErrorTy ty pprTcSolverReportMsg ctxt (ReportHoleError hole err) = pprHoleError ctxt hole err -pprTcSolverReportMsg _ (CannotUnifyWithPolytype item tv1 ty2) = - 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) ] - where - what = text $ levelString $ - ctLocTypeOrKind_maybe (errorItemCtLoc item) `orElse` TypeLevel -pprTcSolverReportMsg _ - (Mismatch { mismatch_ea = add_ea - , mismatch_item = item - , mismatch_ty1 = ty1 - , mismatch_ty2 = ty2 }) - = addArising (errorItemCtLoc item) msg - where - msg - | (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 ] - - 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 errorItemEqRel item of { ReprEq -> True; NomEq -> False } - - what = levelString (ctLocTypeOrKind_maybe (errorItemCtLoc item) `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) -pprTcSolverReportMsg _ - (KindMismatch { kmismatch_what = thing - , kmismatch_expected = exp - , kmismatch_actual = act }) - = hang (text "Expected" <+> kind_desc <> comma) - 2 (text "but" <+> quotes (ppr thing) <+> text "has kind" <+> - quotes (ppr act)) - where - 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) - - pprTcSolverReportMsg ctxt - (TypeEqMismatch { teq_mismatch_ppr_explicit_kinds = ppr_explicit_kinds - , teq_mismatch_item = item - , teq_mismatch_ty1 = ty1 - , teq_mismatch_ty2 = ty2 - , teq_mismatch_expected = exp - , teq_mismatch_actual = act - , teq_mismatch_what = mb_thing }) - = addArising ct_loc $ pprWithExplicitKindsWhen ppr_explicit_kinds msg - where - msg - | 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 (ppr thing) <+> text "has kind" - , quotes (pprWithTYPE act) ] - | Just nargs_msg <- num_args_msg - , Right ea_msg <- mk_ea_msg ctxt (Just item) level orig - = 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 item) level orig - = pprTcSolverReportMsg ctxt ea_msg - -- The mismatched types are /inside/ exp and act - | let mismatch_err = Mismatch False item 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 (pprTcSolverReportMsg ctxt) errs - - ct_loc = errorItemCtLoc item - orig = errorItemOrigin item - level = ctLocTypeOrKind_maybe ct_loc `orElse` TypeLevel - - thing_msg (Just thing) _ levity = quotes (ppr 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 $ pprTcSolverReportMsg ctxt (ExpectingMoreArguments n thing) - _ -> Nothing - - _ -> Nothing - - maybe_num_args_msg = num_args_msg `orElse` empty - - count_args ty = count isVisibleBinder $ fst $ splitPiTys ty + (CannotUnifyVariable + { mismatchMsg = msg + , cannotUnifyReason = reason }) + = pprMismatchMsg ctxt msg + $$ pprCannotUnifyVariableReason ctxt reason +pprTcSolverReportMsg ctxt + (Mismatch + { mismatchMsg = mismatch_msg + , mismatchTyVarInfo = tv_info + , mismatchAmbiguityInfo = ambig_infos + , mismatchCoercibleInfo = coercible_info }) + = hang (pprMismatchMsg ctxt mismatch_msg) + 2 (vcat ( maybe empty (pprTyVarInfo ctxt) tv_info + : maybe empty pprCoercibleMsg coercible_info + : map pprAmbiguityInfo ambig_infos )) pprTcSolverReportMsg _ (FixedRuntimeRepError frr_origs) = vcat (map make_msg frr_origs) where @@ -2287,28 +2175,6 @@ pprTcSolverReportMsg _ (FixedRuntimeRepError frr_origs) = = quotes (text "Levity") | otherwise = text "type" - -pprTcSolverReportMsg _ (SkolemEscape item implic esc_skols) = - let - 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" ] - in - 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 (ic_info implic) - , nest 2 $ text "at" <+> - ppr (getLclEnvLoc (ic_env implic)) ] ] - where - what = text $ levelString $ - ctLocTypeOrKind_maybe (errorItemCtLoc item) `orElse` TypeLevel pprTcSolverReportMsg _ (UntouchableVariable tv implic) | Implic { ic_given = given, ic_info = skol_info } <- implic = sep [ quotes (ppr tv) <+> text "is untouchable" @@ -2333,52 +2199,11 @@ pprTcSolverReportMsg ctxt (UnboundImplicitParams (item :| items)) = then addArising (errorItemCtLoc item) $ sep [ text "Unbound implicit parameter" <> plural preds , nest 2 (pprParendTheta preds) ] - else pprTcSolverReportMsg ctxt (CouldNotDeduce givens (item :| items) Nothing) + else pprMismatchMsg ctxt (CouldNotDeduce givens (item :| items) Nothing) where preds = map errorItemPred (item : items) -pprTcSolverReportMsg ctxt (CouldNotDeduce useful_givens (item :| others) mb_extra) - = main_msg $$ - case supplementary of - Left infos - -> vcat (map (pprTcSolverReportInfo ctxt) infos) - Right other_msg - -> pprTcSolverReportMsg ctxt other_msg - where - main_msg - | null useful_givens - = addArising ct_loc (no_instance_msg <+> missing) - | otherwise - = vcat (addArising ct_loc (no_deduce_msg <+> missing) - : pp_givens useful_givens) - - supplementary = case mb_extra of - Nothing - -> Left [] - Just (CND_Extra level ty1 ty2) - -> mk_supplementary_ea_msg ctxt level ty1 ty2 orig - ct_loc = errorItemCtLoc item - orig = ctLocOrigin ct_loc - wanteds = map errorItemPred (item:others) - - no_instance_msg = - case wanteds of - [wanted] | Just (tc, _) <- splitTyConApp_maybe wanted - -- Don't say "no instance" for a constraint such as "c" for a type variable c. - , isClassTyCon tc -> text "No instance for" - _ -> text "Could not solve:" - - no_deduce_msg = - case wanteds of - [_wanted] -> text "Could not deduce" - _ -> text "Could not deduce:" - - missing = - case wanteds of - [wanted] -> quotes (ppr wanted) - _ -> pprTheta wanteds - -pprTcSolverReportMsg ctxt (AmbiguityPreventsSolvingCt item ambigs) = - pprTcSolverReportInfo ctxt (Ambiguity True ambigs) <+> +pprTcSolverReportMsg _ (AmbiguityPreventsSolvingCt item ambigs) = + pprAmbiguityInfo (Ambiguity True ambigs) <+> pprArising (errorItemCtLoc item) $$ text "prevents the constraint" <+> quotes (pprParendType $ errorItemPred item) <+> text "from being solved." @@ -2386,12 +2211,12 @@ pprTcSolverReportMsg ctxt@(CEC {cec_encl = implics}) (CannotResolveInstance item unifiers candidates imp_errs suggs binds) = vcat - [ pprTcSolverReportMsg ctxt no_inst_msg + [ 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 $ - pprTcSolverReportInfo ctxt (Ambiguity False (ambig_kvs, ambig_tvs)) + pprAmbiguityInfo (Ambiguity False (ambig_kvs, ambig_tvs)) , pprRelevantBindings binds , potential_msg ]) , ppWhen (isNothing mb_patsyn_prov) $ @@ -2421,12 +2246,12 @@ pprTcSolverReportMsg ctxt@(CEC {cec_encl = implics}) && not (null unifiers) && null useful_givens - no_inst_msg :: TcSolverReportMsg + no_inst_msg :: SDoc no_inst_msg | lead_with_ambig - = AmbiguityPreventsSolvingCt item (ambig_kvs, ambig_tvs) + = pprTcSolverReportMsg ctxt $ AmbiguityPreventsSolvingCt item (ambig_kvs, ambig_tvs) | otherwise - = CouldNotDeduce useful_givens (item :| []) Nothing + = pprMismatchMsg ctxt $ CouldNotDeduce useful_givens (item :| []) Nothing -- Report "potential instances" only when the constraint arises -- directly from the user's use of an overloaded function @@ -2556,6 +2381,242 @@ pprTcSolverReportMsg _ (UnsafeOverlap item matches unsafe_overlapped) = pred = errorItemPred item (clas, tys) = getClassPredTys pred +pprCannotUnifyVariableReason :: SolverReportErrCtxt -> CannotUnifyVariableReason -> SDoc +pprCannotUnifyVariableReason ctxt (CannotUnifyWithPolytype item tv1 ty2 mb_tv_info) = + 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) + , maybe empty (pprTyVarInfo ctxt) mb_tv_info ] + where + what = text $ levelString $ + ctLocTypeOrKind_maybe (errorItemCtLoc item) `orElse` TypeLevel + +pprCannotUnifyVariableReason _ (SkolemEscape item implic esc_skols) = + let + 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" ] + in + 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 (ic_info implic) + , nest 2 $ text "at" <+> + ppr (getLclEnvLoc (ic_env implic)) ] ] + where + what = text $ levelString $ + ctLocTypeOrKind_maybe (errorItemCtLoc item) `orElse` TypeLevel + +pprCannotUnifyVariableReason ctxt + (OccursCheck + { occursCheckInterestingTyVars = interesting_tvs + , occursCheckAmbiguityInfos = ambig_infos }) + = ppr_interesting_tyVars interesting_tvs + $$ vcat (map pprAmbiguityInfo ambig_infos) + where + ppr_interesting_tyVars [] = empty + ppr_interesting_tyVars (tv:tvs) = + hang (text "Type variable kinds:") 2 $ + vcat (map (tyvar_binding . tidyTyCoVarOcc (cec_tidy ctxt)) + (tv:tvs)) + tyvar_binding tyvar = ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar) +pprCannotUnifyVariableReason ctxt (DifferentTyVars tv_info) + = pprTyVarInfo ctxt tv_info +pprCannotUnifyVariableReason ctxt (RepresentationalEq tv_info mb_coercible_msg) + = pprTyVarInfo ctxt tv_info + $$ maybe empty pprCoercibleMsg mb_coercible_msg + +pprMismatchMsg :: SolverReportErrCtxt -> MismatchMsg -> SDoc +pprMismatchMsg ctxt + (BasicMismatch { mismatch_ea = ea + , mismatch_item = item + , mismatch_ty1 = ty1 + , mismatch_ty2 = ty2 + , mismatch_whenMatching = mb_match_txt + , mismatch_mb_same_occ = same_occ_info }) + = addArising (errorItemCtLoc item) msg + $$ maybe empty (pprWhenMatching ctxt) mb_match_txt + $$ maybe empty pprSameOccInfo same_occ_info + where + msg + | (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 ] + + want_ea = case ea of { NoEA -> False; EA {} -> True } + + herald1 = conc [ "Couldn't match" + , if is_repr then "representation of" else "" + , if want_ea then "expected" else "" + , what ] + herald2 = conc [ "with" + , if is_repr then "that of" else "" + , if want_ea then ("actual " ++ what) else "" ] + + padding = length herald1 - length herald2 + + is_repr = case errorItemEqRel item of { ReprEq -> True; NomEq -> False } + + what = levelString (ctLocTypeOrKind_maybe (errorItemCtLoc item) `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) +pprMismatchMsg _ + (KindMismatch { kmismatch_what = thing + , kmismatch_expected = exp + , kmismatch_actual = act }) + = hang (text "Expected" <+> kind_desc <> comma) + 2 (text "but" <+> quotes (ppr thing) <+> text "has kind" <+> + quotes (ppr act)) + where + 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) + +pprMismatchMsg ctxt + (TypeEqMismatch { teq_mismatch_ppr_explicit_kinds = ppr_explicit_kinds + , teq_mismatch_item = item + , teq_mismatch_ty1 = ty1 + , teq_mismatch_ty2 = ty2 + , teq_mismatch_expected = exp + , teq_mismatch_actual = act + , teq_mismatch_what = mb_thing + , teq_mb_same_occ = mb_same_occ }) + = (addArising ct_loc $ pprWithExplicitKindsWhen ppr_explicit_kinds msg) + $$ maybe empty pprSameOccInfo mb_same_occ + where + msg + | 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 (ppr thing) <+> text "has kind" + , quotes (pprWithTYPE act) ] + | Just nargs_msg <- num_args_msg + , Right ea_msg <- mk_ea_msg ctxt (Just item) level orig + = nargs_msg $$ pprMismatchMsg 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 item) level orig + = pprMismatchMsg ctxt ea_msg + + | otherwise + = + -- The mismatched types are /inside/ exp and act + let mismatch_err = mkBasicMismatchMsg NoEA item ty1 ty2 + errs = case mk_ea_msg ctxt Nothing level orig of + Left ea_info -> pprMismatchMsg ctxt mismatch_err : map (pprExpectedActualInfo ctxt) ea_info + Right ea_err -> [ pprMismatchMsg ctxt mismatch_err, pprMismatchMsg ctxt ea_err ] + in vcat errs + + ct_loc = errorItemCtLoc item + orig = errorItemOrigin item + level = ctLocTypeOrKind_maybe ct_loc `orElse` TypeLevel + + thing_msg (Just thing) _ levity = quotes (ppr 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 $ pprTcSolverReportMsg ctxt (ExpectingMoreArguments n thing) + _ -> Nothing + + _ -> Nothing + + maybe_num_args_msg = num_args_msg `orElse` empty + + count_args ty = count isVisibleBinder $ fst $ splitPiTys ty + +pprMismatchMsg ctxt (CouldNotDeduce useful_givens (item :| others) mb_extra) + = main_msg $$ + case supplementary of + Left infos + -> vcat (map (pprExpectedActualInfo ctxt) infos) + Right other_msg + -> pprMismatchMsg ctxt other_msg + where + main_msg + | null useful_givens + = addArising ct_loc (no_instance_msg <+> missing) + | otherwise + = vcat (addArising ct_loc (no_deduce_msg <+> missing) + : pp_givens useful_givens) + + supplementary = case mb_extra of + Nothing + -> Left [] + Just (CND_Extra level ty1 ty2) + -> mk_supplementary_ea_msg ctxt level ty1 ty2 orig + ct_loc = errorItemCtLoc item + orig = ctLocOrigin ct_loc + wanteds = map errorItemPred (item:others) + + no_instance_msg = + case wanteds of + [wanted] | Just (tc, _) <- splitTyConApp_maybe wanted + -- Don't say "no instance" for a constraint such as "c" for a type variable c. + , isClassTyCon tc -> text "No instance for" + _ -> text "Could not solve:" + + no_deduce_msg = + case wanteds of + [_wanted] -> text "Could not deduce" + _ -> text "Could not deduce:" + + missing = + case wanteds of + [wanted] -> quotes (ppr wanted) + _ -> pprTheta wanteds + + + {- ********************************************************************* * * Displaying potential instances @@ -2746,50 +2807,17 @@ we want to give it a bit of structure. Here's the plan {- ********************************************************************* * * - Outputting TcSolverReportInfo + Outputting additional solver report information * * **********************************************************************-} -- | 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] - || 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" -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 -pprTcSolverReportInfo _ (NonInjectiveTyFam tc) = - text "NB:" <+> quotes (ppr tc) - <+> text "is a non-injective type family" -pprTcSolverReportInfo _ (ReportCoercibleMsg msg) = - pprCoercibleMsg msg -pprTcSolverReportInfo _ (ExpectedActual { ea_expected = exp, ea_actual = act }) = +pprExpectedActualInfo :: SolverReportErrCtxt -> ExpectedActualInfo -> SDoc +pprExpectedActualInfo _ (ExpectedActual { ea_expected = exp, ea_actual = act }) = vcat [ text "Expected:" <+> ppr exp , text " Actual:" <+> ppr act ] -pprTcSolverReportInfo _ +pprExpectedActualInfo _ (ExpectedActualAfterTySynExpansion { ea_expanded_expected = exp , ea_expanded_actual = act } ) @@ -2797,7 +2825,23 @@ pprTcSolverReportInfo _ [ text "Type synonyms expanded:" , text "Expected type:" <+> ppr exp , text " Actual type:" <+> ppr act ] -pprTcSolverReportInfo ctxt (WhenMatching cty1 cty2 sub_o mb_sub_t_or_k) = + +pprCoercibleMsg :: CoercibleMsg -> SDoc +pprCoercibleMsg (UnknownRoles ty) = + hang (text "NB: We cannot know what roles the parameters to" <+> + quotes (ppr ty) <+> text "have;") + 2 (text "we must assume that the role is nominal") +pprCoercibleMsg (TyConIsAbstract tc) = + hsep [ text "NB: The type constructor" + , quotes (pprSourceTyCon tc) + , text "is abstract" ] +pprCoercibleMsg (OutOfScopeNewtypeConstructor tc dc) = + hang (text "The data constructor" <+> quotes (ppr $ dataConName dc)) + 2 (sep [ text "of newtype" <+> quotes (pprSourceTyCon tc) + , text "is not in scope" ]) + +pprWhenMatching :: SolverReportErrCtxt -> WhenMatching -> SDoc +pprWhenMatching ctxt (WhenMatching cty1 cty2 sub_o mb_sub_t_or_k) = sdocOption sdocPrintExplicitCoercions $ \printExplicitCoercions -> if printExplicitCoercions || not (cty1 `pickyEqType` cty2) @@ -2813,9 +2857,48 @@ pprTcSolverReportInfo 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 (pprTcSolverReportInfo ctxt) infos - Right msg -> pprTcSolverReportMsg ctxt msg -pprTcSolverReportInfo _ (SameOcc same_pkg n1 n2) = + Left infos -> vcat $ map (pprExpectedActualInfo ctxt) infos + Right msg -> pprMismatchMsg ctxt msg + +pprTyVarInfo :: SolverReportErrCtxt -> TyVarInfo -> SDoc +pprTyVarInfo ctxt (TyVarInfo { thisTyVar = tv1, otherTy = mb_tv2 }) = + mk_msg tv1 $$ case mb_tv2 of { Nothing -> empty; Just tv2 -> mk_msg tv2 } + where + mk_msg 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 + +pprAmbiguityInfo :: AmbiguityInfo -> SDoc +pprAmbiguityInfo (Ambiguity prepend_msg (ambig_kvs, ambig_tvs)) = msg + where + + 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" +pprAmbiguityInfo (NonInjectiveTyFam tc) = + text "NB:" <+> quotes (ppr tc) + <+> text "is a non-injective type family" + +pprSameOccInfo :: SameOccInfo -> SDoc +pprSameOccInfo (SameOcc same_pkg n1 n2) = text "NB:" <+> (ppr_from same_pkg n1 $$ ppr_from same_pkg n2) where ppr_from same_pkg nm @@ -2831,26 +2914,6 @@ pprTcSolverReportInfo _ (SameOcc same_pkg n1 n2) = pkg = moduleUnit mod mod = nameModule nm loc = nameSrcSpan nm -pprTcSolverReportInfo ctxt (OccursCheckInterestingTyVars (tv :| tvs)) = - hang (text "Type variable kinds:") 2 $ - vcat (map (tyvar_binding . tidyTyCoVarOcc (cec_tidy ctxt)) - (tv:tvs)) - where - tyvar_binding tyvar = ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar) - -pprCoercibleMsg :: CoercibleMsg -> SDoc -pprCoercibleMsg (UnknownRoles ty) = - hang (text "NB: We cannot know what roles the parameters to" <+> - quotes (ppr ty) <+> text "have;") - 2 (text "we must assume that the role is nominal") -pprCoercibleMsg (TyConIsAbstract tc) = - hsep [ text "NB: The type constructor" - , quotes (pprSourceTyCon tc) - , text "is abstract" ] -pprCoercibleMsg (OutOfScopeNewtypeConstructor tc dc) = - hang (text "The data constructor" <+> quotes (ppr $ dataConName dc)) - 2 (sep [ text "of newtype" <+> quotes (pprSourceTyCon tc) - , text "is not in scope" ]) {- ********************************************************************* * * @@ -3229,7 +3292,7 @@ skolsSpan skol_tvs = foldr1 combineSrcSpans (map getSrcSpan skol_tvs) **********************************************************************-} mk_supplementary_ea_msg :: SolverReportErrCtxt -> TypeOrKind - -> Type -> Type -> CtOrigin -> Either [TcSolverReportInfo] TcSolverReportMsg + -> Type -> Type -> CtOrigin -> Either [ExpectedActualInfo] MismatchMsg 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) @@ -3252,7 +3315,7 @@ ea_looks_same ty1 ty2 exp act -- (TYPE 'LiftedRep) and Type both print the same way. mk_ea_msg :: SolverReportErrCtxt -> Maybe ErrorItem -> TypeOrKind - -> CtOrigin -> Either [TcSolverReportInfo] TcSolverReportMsg + -> CtOrigin -> Either [ExpectedActualInfo] MismatchMsg -- Constructs a "Couldn't match" message -- The (Maybe ErrorItem) says whether this is the main top-level message (Just) -- or a supplementary message (Nothing) @@ -3264,16 +3327,9 @@ mk_ea_msg ctxt at_top level , kmismatch_expected = exp , kmismatch_actual = act } | Just item <- at_top - , let mismatch = - Mismatch - { mismatch_ea = True - , mismatch_item = item - , mismatch_ty1 = exp - , mismatch_ty2 = act } - = Right $ - if expanded_syns - then mkTcReportWithInfo mismatch [ea_expanded] - else mismatch + , let ea = EA $ if expanded_syns then Just ea_expanded else Nothing + mismatch = mkBasicMismatchMsg ea item exp act + = Right mismatch | otherwise = Left $ if expanded_syns diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs index 34fba52546..a6125e7dfc 100644 --- a/compiler/GHC/Tc/Errors/Types.hs +++ b/compiler/GHC/Tc/Errors/Types.hs @@ -1,8 +1,11 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} module GHC.Tc.Errors.Types ( -- * Main types TcRnMessage(..) + , mkTcRnUnknownMessage , TcRnMessageDetailed(..) , ErrInfo(..) , FixedRuntimeRepProvenance(..) @@ -48,9 +51,16 @@ module GHC.Tc.Errors.Types ( , SolverReportWithCtxt(..) , SolverReportErrCtxt(..) , getUserGivens, discardProvCtxtGivens - , TcSolverReportMsg(..), TcSolverReportInfo(..) + , TcSolverReportMsg(..) + , CannotUnifyVariableReason(..) + , MismatchMsg(..) + , MismatchEA(..) + , mkPlainMismatchMsg, mkBasicMismatchMsg + , WhenMatching(..) + , ExpectedActualInfo(..) + , TyVarInfo(..), SameOccInfo(..) + , AmbiguityInfo(..) , CND_Extra(..) - , mkTcReportWithInfo , FitsMbSuppressed(..) , ValidHoleFits(..), noValidHoleFits , HoleFitDispConfig(..) @@ -64,7 +74,7 @@ module GHC.Tc.Errors.Types ( , UnsupportedCallConvention(..) , ExpectedBackends , ArgOrResult(..) - , MatchArgsContext(..) + , MatchArgsContext(..), MatchArgBadMatches(..) ) where import GHC.Prelude @@ -111,10 +121,11 @@ import GHC.Data.FastString (FastString) import Language.Haskell.Syntax.Basic (FieldLabelString(..)) import qualified Data.List.NonEmpty as NE -import Data.Typeable hiding (TyCon) -import qualified Data.Semigroup as Semigroup +import Data.Typeable (Typeable) import GHC.Unit.Module.Warnings (WarningTxt) +import GHC.Generics ( Generic ) + {- Note [Migrating TcM Messages] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -167,13 +178,17 @@ data TcRnMessageDetailed = TcRnMessageDetailed !ErrInfo -- ^ Extra info associated with the message !TcRnMessage + deriving Generic + +mkTcRnUnknownMessage :: (Diagnostic a, Typeable a) => a -> TcRnMessage +mkTcRnUnknownMessage diag = TcRnUnknownMessage (UnknownDiagnostic diag) -- | An error which might arise during typechecking/renaming. data TcRnMessage where {-| Simply wraps a generic 'Diagnostic' message @a@. It can be used by plugins to provide custom diagnostic messages originated during typechecking/renaming. -} - TcRnUnknownMessage :: (Diagnostic a, Typeable a) => a -> TcRnMessage + TcRnUnknownMessage :: UnknownDiagnostic -> TcRnMessage {-| TcRnMessageWithInfo is a constructor which is used when extra information is needed to be provided in order to qualify a diagnostic and where it was originated (and why). @@ -193,7 +208,7 @@ data TcRnMessage where See the documentation of the 'TcSolverReportMsg' datatype for an overview of the different errors. -} - TcRnSolverReport :: [SolverReportWithCtxt] + TcRnSolverReport :: SolverReportWithCtxt -> DiagnosticReason -> [GhcHint] -> TcRnMessage @@ -234,8 +249,8 @@ data TcRnMessage where Test cases: T7293, T7294, T15558, T17646, T18572, T18610, tcfail167. -} - TcRnInaccessibleCode :: Implication -- ^ The implication containing a contradiction. - -> NE.NonEmpty SolverReportWithCtxt -- ^ The contradiction(s). + TcRnInaccessibleCode :: Implication -- ^ The implication containing a contradiction. + -> SolverReportWithCtxt -- ^ The contradiction. -> TcRnMessage {-| A type which was expected to have a fixed runtime representation @@ -263,7 +278,7 @@ data TcRnMessage where Test cases: th/T17804 -} - TcRnImplicitLift :: Outputable var => var -> !ErrInfo -> TcRnMessage + TcRnImplicitLift :: Name -> !ErrInfo -> TcRnMessage {-| TcRnUnusedPatternBinds is a warning (controlled with -Wunused-pattern-binds) that occurs if a pattern binding binds no variables at all, unless it is a lone wild-card pattern, or a banged pattern. @@ -1744,7 +1759,7 @@ data TcRnMessage where Test cases: ffi/should_fail/T20116 -} - TcRnForeignImportPrimExtNotSet :: ForeignImport p -> TcRnMessage + TcRnForeignImportPrimExtNotSet :: ForeignImport GhcRn -> TcRnMessage {- TcRnForeignImportPrimSafeAnn is an error declaring that the safe/unsafe annotation should not be used with @prim@ foreign imports. @@ -1754,7 +1769,7 @@ data TcRnMessage where Test cases: None -} - TcRnForeignImportPrimSafeAnn :: ForeignImport p -> TcRnMessage + TcRnForeignImportPrimSafeAnn :: ForeignImport GhcRn -> TcRnMessage {- TcRnForeignFunctionImportAsValue is an error explaining that foreign @value@ imports cannot have function types. @@ -1764,7 +1779,7 @@ data TcRnMessage where Test cases: ffi/should_fail/capi_value_function -} - TcRnForeignFunctionImportAsValue :: ForeignImport p -> TcRnMessage + TcRnForeignFunctionImportAsValue :: ForeignImport GhcRn -> TcRnMessage {- TcRnFunPtrImportWithoutAmpersand is a warning controlled by @-Wdodgy-foreign-imports@ that informs the user of a possible missing @&@ in the declaration of a @@ -1775,7 +1790,7 @@ data TcRnMessage where Test cases: ffi/should_compile/T1357 -} - TcRnFunPtrImportWithoutAmpersand :: ForeignImport p -> TcRnMessage + TcRnFunPtrImportWithoutAmpersand :: ForeignImport GhcRn -> TcRnMessage {- TcRnIllegalForeignDeclBackend is an error occurring when a foreign import declaration is not compatible with the code generation backend being used. @@ -1785,7 +1800,7 @@ data TcRnMessage where Test cases: None -} TcRnIllegalForeignDeclBackend - :: Either (ForeignExport p) (ForeignImport p) + :: Either (ForeignExport GhcRn) (ForeignImport GhcRn) -> Backend -> ExpectedBackends -> TcRnMessage @@ -1799,7 +1814,9 @@ data TcRnMessage where Test cases: None -} - TcRnUnsupportedCallConv :: Either (ForeignExport p) (ForeignImport p) -> UnsupportedCallConvention -> TcRnMessage + TcRnUnsupportedCallConv :: Either (ForeignExport GhcRn) (ForeignImport GhcRn) + -> UnsupportedCallConvention + -> TcRnMessage {- TcRnIllegalForeignType is an error for when a type appears in a foreign function signature that is not compatible with the FFI. @@ -2055,8 +2072,7 @@ data TcRnMessage where -} TcRnMatchesHaveDiffNumArgs :: !MatchArgsContext - -> !(LocatedA (Match GhcRn body)) - -> !(NE.NonEmpty (LocatedA (Match GhcRn body))) -- ^ bad matches + -> !MatchArgBadMatches -> TcRnMessage {- TcRnCannotBindScopedTyVarInPatSig is an error stating that scoped type @@ -2272,6 +2288,8 @@ data TcRnMessage where :: Name -> TcRnMessage + deriving Generic + -- | Specifies which back ends can handle a requested foreign import or export type ExpectedBackends = [Backend] -- | Specifies which calling convention is unsupported on the current platform @@ -2492,6 +2510,7 @@ data DeriveInstanceErrReason -- | We couldn't derive an instance either because the type was not an -- enum type or because it did have more than one constructor. | DerivErrEnumOrProduct !DeriveInstanceErrReason !DeriveInstanceErrReason + deriving Generic data DeriveInstanceBadConstructor = @@ -2643,9 +2662,9 @@ See 'GHC.Tc.Errors.Types.SolverReport' and 'GHC.Tc.Errors.mkErrorReport'. -- See Note [Error report] for details. data SolverReport = SolverReport - { sr_important_msgs :: [SolverReportWithCtxt] - , sr_supplementary :: [SolverReportSupplementary] - , sr_hints :: [GhcHint] + { sr_important_msg :: SolverReportWithCtxt + , sr_supplementary :: [SolverReportSupplementary] + , sr_hints :: [GhcHint] } -- | Additional information to print in a 'SolverReport', after the @@ -2668,14 +2687,7 @@ data SolverReportWithCtxt = , reportContent :: TcSolverReportMsg -- ^ The content of the message to report. } - -instance Semigroup SolverReport where - SolverReport main1 supp1 hints1 <> SolverReport main2 supp2 hints2 - = SolverReport (main1 ++ main2) (supp1 ++ supp2) (hints1 ++ hints2) - -instance Monoid SolverReport where - mempty = SolverReport [] [] [] - mappend = (Semigroup.<>) + deriving Generic -- | Context needed when reporting a 'TcSolverReportMsg', such as -- the enclosing implication constraints or whether we are deferring type errors. @@ -2820,15 +2832,6 @@ discardProvCtxtGivens orig givens -- See Note [discardProvCtxtGivens] -- This is usually, some sort of unsolved constraint error, -- but we try to be specific about the precise problem we encountered. 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! - - -- | Wrap a message with additional information. - -- - -- Prefer using the 'mkTcReportWithInfo' smart constructor - = TcReportWithInfo TcSolverReportMsg (NE.NonEmpty TcSolverReportInfo) - -- | Quantified variables appear out of dependency order. -- -- Example: @@ -2836,7 +2839,7 @@ data TcSolverReportMsg -- forall (a :: k) k. ... -- -- Test cases: BadTelescope2, T16418, T16247, T16726, T18451. - | BadTelescope TyVarBndrs [TyCoVar] + = BadTelescope TyVarBndrs [TyCoVar] -- | We came across a custom type error and we have decided to report it. -- @@ -2855,69 +2858,31 @@ data TcSolverReportMsg -- See 'HoleError'. | ReportHoleError Hole HoleError - -- | A type equality between a type variable and a polytype. - -- - -- Test cases: T12427a, T2846b, T10194, ... - | CannotUnifyWithPolytype ErrorItem TyVar Type - - -- | Couldn't unify two types or kinds. - -- - -- Example: - -- - -- 3 + 3# -- can't match a lifted type with an unlifted type + -- | Trying to unify an untouchable variable, e.g. a variable from an outer scope. -- - -- Test cases: T1396, T8263, ... - | Mismatch - { mismatch_ea :: Bool -- ^ Should this be phrased in terms of expected vs actual? - , mismatch_item :: ErrorItem -- ^ The constraint in which the mismatch originated. - , mismatch_ty1 :: Type -- ^ First type (the expected type if if mismatch_ea is True) - , mismatch_ty2 :: Type -- ^ Second type (the actual type if mismatch_ea is True) - } + -- Test case: Simple14 + | UntouchableVariable + { untouchableTyVar :: TyVar + , untouchableTyVarImplication :: Implication + } - -- | A type has an unexpected kind. - -- - -- Test cases: T2994, T7609, ... - | KindMismatch - { kmismatch_what :: TypedThing -- ^ What thing is 'kmismatch_actual' the kind of? - , kmismatch_expected :: Type - , kmismatch_actual :: Type - } - -- TODO: combine 'Mismatch' and 'KindMismatch' messages. + -- | Cannot unify a variable, because of a type mismatch. + | CannotUnifyVariable + { mismatchMsg :: MismatchMsg + , cannotUnifyReason :: CannotUnifyVariableReason } - -- | A mismatch between two types, which arose from a type equality. - -- - -- Test cases: T1470, tcfail212. - | TypeEqMismatch - { teq_mismatch_ppr_explicit_kinds :: Bool - , teq_mismatch_item :: ErrorItem - , teq_mismatch_ty1 :: Type - , teq_mismatch_ty2 :: Type - , teq_mismatch_expected :: Type -- ^ The overall expected type - , teq_mismatch_actual :: Type -- ^ The overall actual type - , teq_mismatch_what :: Maybe TypedThing -- ^ What thing is 'teq_mismatch_actual' the kind of? - } - -- TODO: combine 'Mismatch' and 'TypeEqMismatch' messages. + -- | A mismatch between two types. + | Mismatch + { mismatchMsg :: MismatchMsg + , mismatchTyVarInfo :: Maybe TyVarInfo + , mismatchAmbiguityInfo :: [AmbiguityInfo] + , mismatchCoercibleInfo :: Maybe CoercibleMsg } -- | A violation of the representation-polymorphism invariants. -- -- See 'FixedRuntimeRepErrorInfo' and 'FixedRuntimeRepContext' for more information. | FixedRuntimeRepError [FixedRuntimeRepErrorInfo] - -- | A skolem type variable escapes its scope. - -- - -- Example: - -- - -- data Ex where { MkEx :: a -> MkEx } - -- foo (MkEx x) = x - -- - -- Test cases: TypeSkolEscape, T11142. - | SkolemEscape ErrorItem Implication [TyVar] - - -- | Trying to unify an untouchable variable, e.g. a variable from an outer scope. - -- - -- Test case: Simple14 - | UntouchableVariable TyVar Implication - -- | An equality between two types is blocked on a kind equality -- beteen their kinds. -- @@ -2944,21 +2909,6 @@ data TcSolverReportMsg | UnboundImplicitParams (NE.NonEmpty ErrorItem) - -- | Couldn't solve some Wanted constraints using the Givens. - -- This is the most commonly used constructor, used for generic - -- @"No instance for ..."@ and @"Could not deduce ... from"@ messages. - | CouldNotDeduce - { cnd_user_givens :: [Implication] - -- | The Wanted constraints we couldn't solve. - -- - -- N.B.: the 'ErrorItem' at the head of the list has been tidied, - -- perhaps not the others. - , cnd_wanted :: NE.NonEmpty ErrorItem - - -- | Some additional info consumed by 'mk_supplementary_ea_msg'. - , cnd_extra :: Maybe CND_Extra - } - -- | A constraint couldn't be solved because it contains -- ambiguous type variables. -- @@ -3008,17 +2958,148 @@ data TcSolverReportMsg , unsafeOverlap_matches :: [ClsInst] , unsafeOverlapped :: [ClsInst] } + deriving Generic + +data MismatchMsg + = -- | Couldn't unify two types or kinds. + -- + -- Example: + -- + -- 3 + 3# -- can't match a lifted type with an unlifted type + -- + -- Test cases: T1396, T8263, ... + BasicMismatch -- SLD TODO rename this + { mismatch_ea :: MismatchEA -- ^ Should this be phrased in terms of expected vs actual? + , mismatch_item :: ErrorItem -- ^ The constraint in which the mismatch originated. + , mismatch_ty1 :: Type -- ^ First type (the expected type if if mismatch_ea is True) + , mismatch_ty2 :: Type -- ^ Second type (the actual type if mismatch_ea is True) + , mismatch_whenMatching :: Maybe WhenMatching + , mismatch_mb_same_occ :: Maybe SameOccInfo + } + + -- | A type has an unexpected kind. + -- + -- Test cases: T2994, T7609, ... + | KindMismatch + { kmismatch_what :: TypedThing -- ^ What thing is 'kmismatch_actual' the kind of? + , kmismatch_expected :: Type + , kmismatch_actual :: Type + } + -- TODO: combine with 'BasicMismatch'. + + -- | A mismatch between two types, which arose from a type equality. + -- + -- Test cases: T1470, tcfail212. + | TypeEqMismatch + { teq_mismatch_ppr_explicit_kinds :: Bool + , teq_mismatch_item :: ErrorItem + , teq_mismatch_ty1 :: Type + , teq_mismatch_ty2 :: Type + , teq_mismatch_expected :: Type -- ^ The overall expected type + , teq_mismatch_actual :: Type -- ^ The overall actual type + , teq_mismatch_what :: Maybe TypedThing -- ^ What thing is 'teq_mismatch_actual' the kind of? + , teq_mb_same_occ :: Maybe SameOccInfo + } + -- TODO: combine with 'BasicMismatch'. + + -- | Couldn't solve some Wanted constraints using the Givens. + -- Used for messages such as @"No instance for ..."@ and + -- @"Could not deduce ... from"@. + | CouldNotDeduce + { cnd_user_givens :: [Implication] + -- | The Wanted constraints we couldn't solve. + -- + -- N.B.: the 'ErrorItem' at the head of the list has been tidied, + -- perhaps not the others. + , cnd_wanted :: NE.NonEmpty ErrorItem + + -- | Some additional info consumed by 'mk_supplementary_ea_msg'. + , cnd_extra :: Maybe CND_Extra + } + deriving Generic + +mkBasicMismatchMsg :: MismatchEA -> ErrorItem -> Type -> Type -> MismatchMsg +mkBasicMismatchMsg ea item ty1 ty2 + = BasicMismatch + { mismatch_ea = ea + , mismatch_item = item + , mismatch_ty1 = ty1 + , mismatch_ty2 = ty2 + , mismatch_whenMatching = Nothing + , mismatch_mb_same_occ = Nothing + } + +-- | Whether to use expected/actual in a type mismatch message. +data MismatchEA + -- | Don't use expected/actual. + = NoEA + -- | Use expected/actual. + | EA + { mismatch_mbEA :: Maybe ExpectedActualInfo + -- ^ Whether to also mention type synonym expansion. + } + +data CannotUnifyVariableReason + = -- | A type equality between a type variable and a polytype. + -- + -- Test cases: T12427a, T2846b, T10194, ... + CannotUnifyWithPolytype ErrorItem TyVar Type (Maybe TyVarInfo) + + -- | An occurs check. + | OccursCheck + { occursCheckInterestingTyVars :: [TyVar] + , occursCheckAmbiguityInfos :: [AmbiguityInfo] } + + -- | A skolem type variable escapes its scope. + -- + -- Example: + -- + -- data Ex where { MkEx :: a -> MkEx } + -- foo (MkEx x) = x + -- + -- Test cases: TypeSkolEscape, T11142. + | SkolemEscape ErrorItem Implication [TyVar] + + -- | Can't unify the type variable with the other type + -- due to the kind of type variable it is. + -- + -- For example, trying to unify a 'SkolemTv' with the + -- type Int, or with a 'TyVarTv'. + | DifferentTyVars TyVarInfo + | RepresentationalEq TyVarInfo (Maybe CoercibleMsg) + deriving Generic + +mkPlainMismatchMsg :: MismatchMsg -> TcSolverReportMsg +mkPlainMismatchMsg msg + = Mismatch + { mismatchMsg = msg + , mismatchTyVarInfo = Nothing + , mismatchAmbiguityInfo = [] + , mismatchCoercibleInfo = Nothing } + -- | Additional information to be given in a 'CouldNotDeduce' message, -- which is then passed on to 'mk_supplementary_ea_msg'. data CND_Extra = CND_Extra TypeOrKind Type Type --- | 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 'TcSolverReportMsg'. - -- If you see possible improvements, please go right ahead! +-- | A cue to print out information about type variables, +-- e.g. where they were bound, when there is a mismatch @tv1 ~ ty2@. +data TyVarInfo = + TyVarInfo { thisTyVar :: TyVar + , thisTyVarIsUntouchable :: Maybe Implication + , otherTy :: Maybe TyVar } + +-- | Add some information to disambiguate errors in which +-- two 'Names' would otherwise appear to be identical. +-- +-- See Note [Disambiguating (X ~ X) errors]. +data SameOccInfo + = SameOcc + { sameOcc_same_pkg :: Bool -- ^ Whether the two 'Name's also came from the same package. + , sameOcc_lhs :: Name + , sameOcc_rhs :: Name } + +-- | Add some information about ambiguity +data AmbiguityInfo -- | Some type variables remained ambiguous: print them to the user. = Ambiguity @@ -3028,38 +3109,24 @@ data TcSolverReportInfo -- Guaranteed to not both be empty. } - -- | Specify some information about a type variable, - -- e.g. its 'SkolemInfo'. - | TyVarInfo TyVar - -- | Remind the user that a particular type family is not injective. | NonInjectiveTyFam TyCon - -- | Explain why we couldn't coerce between two types. See 'CoercibleMsg'. - | ReportCoercibleMsg CoercibleMsg - +-- | Expected/actual information. +data ExpectedActualInfo -- | Display the expected and actual types. - | ExpectedActual + = ExpectedActual { ea_expected, ea_actual :: Type } -- | Display the expected and actual types, after expanding type synonyms. | ExpectedActualAfterTySynExpansion { ea_expanded_expected, ea_expanded_actual :: Type } - -- | Explain how a kind equality originated. - | WhenMatching TcType TcType CtOrigin (Maybe TypeOrKind) +-- | Explain how a kind equality originated. +data WhenMatching - -- | Add some information to disambiguate errors in which - -- two 'Names' would otherwise appear to be identical. - -- - -- See Note [Disambiguating (X ~ X) errors]. - | SameOcc - { sameOcc_same_pkg :: Bool -- ^ Whether the two 'Name's also came from the same package. - , sameOcc_lhs :: Name - , sameOcc_rhs :: Name } - - -- | Report some type variables that might be participating in an occurs-check failure. - | OccursCheckInterestingTyVars (NE.NonEmpty TyVar) + = WhenMatching TcType TcType CtOrigin (Maybe TypeOrKind) + deriving Generic -- | Some form of @"not in scope"@ error. See also the 'OutOfScopeHole' -- constructor of 'HoleError'. @@ -3099,6 +3166,7 @@ data NotInScopeError -- or, a class doesn't have an associated type with this name, -- or, a record doesn't have a record field with this name. | UnknownSubordinate SDoc + deriving Generic -- | Create a @"not in scope"@ error message for the given 'RdrName'. mkTcRnNotInScope :: RdrName -> NotInScopeError -> TcRnMessage @@ -3175,15 +3243,6 @@ data PotentialInstances , unifiers :: [ClsInst] } --- | Append additional information to a `TcSolverReportMsg`. -mkTcReportWithInfo :: TcSolverReportMsg -> [TcSolverReportInfo] -> TcSolverReportMsg -mkTcReportWithInfo msg [] - = msg -mkTcReportWithInfo (TcReportWithInfo msg (prev NE.:| prevs)) infos - = TcReportWithInfo msg (prev NE.:| prevs ++ infos) -mkTcReportWithInfo msg (info : infos) - = TcReportWithInfo msg (info NE.:| infos) - -- | A collection of valid hole fits or refinement fits, -- in which some fits might have been suppressed. data FitsMbSuppressed @@ -3323,3 +3382,11 @@ data MatchArgsContext !Name -- ^ Name of the function | PatternArgs !(HsMatchContext GhcTc) -- ^ Pattern match specifics + +-- | The information necessary to report mismatched +-- numbers of arguments in a match group. +data MatchArgBadMatches where + MatchArgMatches + :: { matchArgFirstMatch :: LocatedA (Match GhcRn body) + , matchArgBadMatches :: NE.NonEmpty (LocatedA (Match GhcRn body)) } + -> MatchArgBadMatches diff --git a/compiler/GHC/Tc/Gen/Foreign.hs b/compiler/GHC/Tc/Gen/Foreign.hs index ea251c2bcb..0f1c9084d7 100644 --- a/compiler/GHC/Tc/Gen/Foreign.hs +++ b/compiler/GHC/Tc/Gen/Foreign.hs @@ -340,14 +340,14 @@ tcCheckFIType arg_tys res_ty idecl@(CImport src (L lc cconv) (L ls safety) mh -- This makes a convenient place to check -- that the C identifier is valid for C -checkCTarget :: ForeignImport p -> CCallTarget -> TcM () +checkCTarget :: ForeignImport GhcRn -> CCallTarget -> TcM () checkCTarget idecl (StaticTarget _ str _ _) = do checkCg (Right idecl) backendValidityOfCImport checkTc (isCLabelString str) (TcRnInvalidCIdentifier str) checkCTarget _ DynamicTarget = panic "checkCTarget DynamicTarget" -checkMissingAmpersand :: ForeignImport p -> [Type] -> Type -> TcM () +checkMissingAmpersand :: ForeignImport GhcRn -> [Type] -> Type -> TcM () checkMissingAmpersand idecl arg_tys res_ty | null arg_tys && isFunPtrTy res_ty = addDiagnosticTc $ TcRnFunPtrImportWithoutAmpersand idecl @@ -497,7 +497,8 @@ checkSafe, noCheckSafe :: Bool checkSafe = True noCheckSafe = False -checkCg :: Either (ForeignExport p) (ForeignImport p) -> (Backend -> Validity' ExpectedBackends) -> TcM () +checkCg :: Either (ForeignExport GhcRn) (ForeignImport GhcRn) + -> (Backend -> Validity' ExpectedBackends) -> TcM () checkCg decl check = do dflags <- getDynFlags let bcknd = backend dflags @@ -508,7 +509,8 @@ checkCg decl check = do -- Calling conventions -checkCConv :: Either (ForeignExport p) (ForeignImport p) -> CCallConv -> TcM CCallConv +checkCConv :: Either (ForeignExport GhcRn) (ForeignImport GhcRn) + -> CCallConv -> TcM CCallConv checkCConv _ CCallConv = return CCallConv checkCConv _ CApiConv = return CApiConv checkCConv decl StdCallConv = do diff --git a/compiler/GHC/Tc/Gen/Head.hs b/compiler/GHC/Tc/Gen/Head.hs index 1c72c877ab..dd67b7f2b2 100644 --- a/compiler/GHC/Tc/Gen/Head.hs +++ b/compiler/GHC/Tc/Gen/Head.hs @@ -1334,7 +1334,7 @@ checkCrossStageLifting top_lvl id (Brack _ (TcPending ps_var lie_var q)) [getRuntimeRep id_ty, id_ty] -- Warning for implicit lift (#17804) - ; addDetailedDiagnostic (TcRnImplicitLift id) + ; addDetailedDiagnostic (TcRnImplicitLift $ idName id) -- Update the pending splices ; ps <- readMutVar ps_var diff --git a/compiler/GHC/Tc/Gen/Match.hs b/compiler/GHC/Tc/Gen/Match.hs index e1a0c2401b..94f11dd5ea 100644 --- a/compiler/GHC/Tc/Gen/Match.hs +++ b/compiler/GHC/Tc/Gen/Match.hs @@ -1159,7 +1159,8 @@ check_match_pats _ (MG { mg_alts = L _ [] }) = return () check_match_pats matchContext (MG { mg_alts = L _ (match1:matches) }) | Just bad_matches <- mb_bad_matches - = failWithTc $ TcRnMatchesHaveDiffNumArgs matchContext match1 bad_matches + = failWithTc $ TcRnMatchesHaveDiffNumArgs matchContext + $ MatchArgMatches match1 bad_matches | otherwise = return () where diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs index 251d17c27f..027ae27aff 100644 --- a/compiler/GHC/Tc/Gen/Splice.hs +++ b/compiler/GHC/Tc/Gen/Splice.hs @@ -800,7 +800,7 @@ tcTExpTy m_ty exp_ty ; return (mkTyConApp codeCon [rep, m_ty, exp_ty]) } where err_msg ty - = TcRnUnknownMessage $ mkPlainError noHints $ + = mkTcRnUnknownMessage $ mkPlainError noHints $ vcat [ text "Illegal polytype:" <+> ppr ty , text "The type of a Typed Template Haskell expression must" <+> text "not have any quantification." ] @@ -1256,7 +1256,7 @@ runMeta' show_code ppr_hs run_and_convert expr -- see where this splice is do { mb_result <- run_and_convert expr_span hval ; case mb_result of - Left err -> failWithTc (TcRnUnknownMessage $ mkPlainError noHints err) + Left err -> failWithTc (mkTcRnUnknownMessage $ mkPlainError noHints err) Right result -> do { traceTc "Got HsSyn result:" (ppr_hs result) ; return $! result } } @@ -1274,7 +1274,7 @@ runMeta' show_code ppr_hs run_and_convert expr let msg = vcat [text "Exception when trying to" <+> text phase <+> text "compile-time code:", nest 2 (text exn_msg), if show_code then text "Code:" <+> ppr expr else empty] - failWithTc (TcRnUnknownMessage $ mkPlainError noHints msg) + failWithTc (mkTcRnUnknownMessage $ mkPlainError noHints msg) {- Note [Running typed splices in the zonker] @@ -1390,10 +1390,11 @@ instance TH.Quasi TcM where -- 'msg' is forced to ensure exceptions don't escape, -- see Note [Exceptions in TH] - qReport True msg = seqList msg $ addErr $ TcRnUnknownMessage $ mkPlainError noHints (text msg) - qReport False msg = seqList msg $ addDiagnostic $ TcRnUnknownMessage $ + qReport True msg = seqList msg $ addErr $ mkTcRnUnknownMessage $ mkPlainError noHints (text msg) + qReport False msg = seqList msg $ addDiagnostic $ mkTcRnUnknownMessage $ mkPlainDiagnostic WarningWithoutFlag noHints (text msg) + qLocation :: TcM TH.Loc qLocation = do { m <- getModule ; l <- getSrcSpanM ; r <- case l of @@ -1444,7 +1445,7 @@ instance TH.Quasi TcM where th_origin <- getThSpliceOrigin let either_hval = convertToHsDecls th_origin l thds ds <- case either_hval of - Left exn -> failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ + Left exn -> failWithTc $ mkTcRnUnknownMessage $ mkPlainError noHints $ hang (text "Error in a declaration passed to addTopDecls:") 2 exn Right ds -> return ds @@ -1462,7 +1463,7 @@ instance TH.Quasi TcM where checkTopDecl (ForD _ (ForeignImport { fd_name = L _ name })) = bindName name checkTopDecl _ - = addErr $ TcRnUnknownMessage $ mkPlainError noHints $ + = addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $ text "Only function, value, annotation, and foreign import declarations may be added with addTopDecl" bindName :: RdrName -> TcM () @@ -1472,7 +1473,7 @@ instance TH.Quasi TcM where } bindName name = - addErr $ TcRnUnknownMessage $ mkPlainError noHints $ + addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $ hang (text "The binder" <+> quotes (ppr name) <+> text "is not a NameU.") 2 (text "Probable cause: you used mkName instead of newName to generate a binding.") @@ -1499,8 +1500,8 @@ instance TH.Quasi TcM where 2 (text "Plugins in the current package can't be specified.") case r of - Found {} -> addErr $ TcRnUnknownMessage $ mkPlainError noHints err - FoundMultiple {} -> addErr $ TcRnUnknownMessage $ mkPlainError noHints err + Found {} -> addErr $ mkTcRnUnknownMessage $ mkPlainError noHints err + FoundMultiple {} -> addErr $ mkTcRnUnknownMessage $ mkPlainError noHints err _ -> return () th_coreplugins_var <- tcg_th_coreplugins <$> getGblEnv updTcRef th_coreplugins_var (plugin:) @@ -1525,7 +1526,7 @@ instance TH.Quasi TcM where th_doc_var <- tcg_th_docs <$> getGblEnv resolved_doc_loc <- resolve_loc doc_loc is_local <- checkLocalName resolved_doc_loc - unless is_local $ failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ text + unless is_local $ failWithTc $ mkTcRnUnknownMessage $ mkPlainError noHints $ text "Can't add documentation to" <+> ppr_loc doc_loc <+> text "as it isn't inside the current module" let ds = mkGeneratedHsDocString s @@ -1615,7 +1616,7 @@ lookupThInstName th_type = do Right (_, (inst:_)) -> return $ getName inst Right (_, []) -> noMatches where - noMatches = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ + noMatches = failWithTc $ mkTcRnUnknownMessage $ mkPlainError noHints $ text "Couldn't find any instances of" <+> ppr_th th_type <+> text "to add documentation to" @@ -1654,7 +1655,7 @@ lookupThInstName th_type = do inst_cls_name TH.WildCardT = inst_cls_name_err inst_cls_name (TH.ImplicitParamT _ _) = inst_cls_name_err - inst_cls_name_err = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ + inst_cls_name_err = failWithTc $ mkTcRnUnknownMessage $ mkPlainError noHints $ text "Couldn't work out what instance" <+> ppr_th th_type <+> text "is supposed to be" @@ -1945,7 +1946,7 @@ reifyInstances' th_nm th_tys ; let matches = lookupFamInstEnv inst_envs tc tys ; traceTc "reifyInstances'2" (ppr matches) ; return $ Right (tc, map fim_instance matches) } - _ -> bale_out $ TcRnUnknownMessage $ mkPlainError noHints $ + _ -> bale_out $ mkTcRnUnknownMessage $ mkPlainError noHints $ (hang (text "reifyInstances:" <+> quotes (ppr ty)) 2 (text "is not a class constraint or type family application")) } where @@ -1954,7 +1955,7 @@ reifyInstances' th_nm th_tys cvt :: Origin -> SrcSpan -> TH.Type -> TcM (LHsType GhcPs) cvt origin loc th_ty = case convertToHsType origin loc th_ty of - Left msg -> failWithTc (TcRnUnknownMessage $ mkPlainError noHints msg) + Left msg -> failWithTc (mkTcRnUnknownMessage $ mkPlainError noHints msg) Right ty -> return ty {- @@ -2055,17 +2056,17 @@ tcLookupTh name do { mb_thing <- tcLookupImported_maybe name ; case mb_thing of Succeeded thing -> return (AGlobal thing) - Failed msg -> failWithTc (TcRnUnknownMessage $ mkPlainError noHints msg) + Failed msg -> failWithTc (mkTcRnUnknownMessage $ mkPlainError noHints msg) }}}} notInScope :: TH.Name -> TcRnMessage -notInScope th_name = TcRnUnknownMessage $ mkPlainError noHints $ +notInScope th_name = mkTcRnUnknownMessage $ mkPlainError noHints $ quotes (text (TH.pprint th_name)) <+> text "is not in scope at a reify" -- Ugh! Rather an indirect way to display the name notInEnv :: Name -> TcRnMessage -notInEnv name = TcRnUnknownMessage $ mkPlainError noHints $ +notInEnv name = mkTcRnUnknownMessage $ mkPlainError noHints $ quotes (ppr name) <+> text "is not in the type environment at a reify" ------------------------------ @@ -2074,7 +2075,7 @@ reifyRoles th_name = do { thing <- getThing th_name ; case thing of AGlobal (ATyCon tc) -> return (map reify_role (tyConRoles tc)) - _ -> failWithTc (TcRnUnknownMessage $ mkPlainError noHints $ text "No roles associated with" <+> (ppr thing)) + _ -> failWithTc (mkTcRnUnknownMessage $ mkPlainError noHints $ text "No roles associated with" <+> (ppr thing)) } where reify_role Nominal = TH.NominalR @@ -2868,7 +2869,7 @@ mkThAppTs :: TH.Type -> [TH.Type] -> TH.Type mkThAppTs fun_ty arg_tys = foldl' TH.AppT fun_ty arg_tys noTH :: SDoc -> SDoc -> TcM a -noTH s d = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ +noTH s d = failWithTc $ mkTcRnUnknownMessage $ mkPlainError noHints $ (hsep [text "Can't represent" <+> s <+> text "in Template Haskell:", nest 2 d]) diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs index 9ab53792a8..aa4d18b8cc 100644 --- a/compiler/GHC/Tc/Module.hs +++ b/compiler/GHC/Tc/Module.hs @@ -264,7 +264,7 @@ tcRnModuleTcRnM hsc_env mod_sum implicit_prelude import_decls } ; when (notNull prel_imports) $ do - let msg = TcRnUnknownMessage $ + let msg = mkTcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag Opt_WarnImplicitPrelude) noHints (implicitPreludeWarn) addDiagnostic msg @@ -627,7 +627,7 @@ tc_rn_src_decls ds { Nothing -> return () ; Just (SpliceDecl _ (L loc _) _, _) -> setSrcSpanA loc - $ addErr (TcRnUnknownMessage $ mkPlainError noHints $ text + $ addErr (mkTcRnUnknownMessage $ mkPlainError noHints $ text ("Declaration splices are not " ++ "permitted inside top-level " ++ "declarations added with addTopDecls")) @@ -749,7 +749,7 @@ tcRnHsBootDecls hsc_src decls badBootDecl :: HscSource -> String -> LocatedA decl -> TcM () badBootDecl hsc_src what (L loc _) - = addErrAt (locA loc) $ TcRnUnknownMessage $ mkPlainError noHints $ + = addErrAt (locA loc) $ mkTcRnUnknownMessage $ mkPlainError noHints $ (char 'A' <+> text what <+> text "declaration is not (currently) allowed in a" <+> (case hsc_src of @@ -1378,7 +1378,7 @@ emptyRnEnv2 = mkRnEnv2 emptyInScopeSet ---------------- missingBootThing :: Bool -> Name -> String -> TcRnMessage missingBootThing is_boot name what - = TcRnUnknownMessage $ mkPlainError noHints $ + = mkTcRnUnknownMessage $ mkPlainError noHints $ quotes (ppr name) <+> text "is exported by the" <+> (if is_boot then text "hs-boot" else text "hsig") <+> text "file, but not" @@ -1386,7 +1386,7 @@ missingBootThing is_boot name what badReexportedBootThing :: Bool -> Name -> Name -> TcRnMessage badReexportedBootThing is_boot name name' - = TcRnUnknownMessage $ mkPlainError noHints $ + = mkTcRnUnknownMessage $ mkPlainError noHints $ withUserStyle alwaysQualify AllTheWay $ vcat [ text "The" <+> (if is_boot then text "hs-boot" else text "hsig") <+> text "file (re)exports" <+> quotes (ppr name) @@ -1395,7 +1395,7 @@ badReexportedBootThing is_boot name name' bootMisMatch :: Bool -> SDoc -> TyThing -> TyThing -> TcRnMessage bootMisMatch is_boot extra_info real_thing boot_thing - = TcRnUnknownMessage $ mkPlainError noHints $ + = mkTcRnUnknownMessage $ mkPlainError noHints $ pprBootMisMatch is_boot extra_info real_thing real_doc boot_doc where to_doc @@ -1426,7 +1426,7 @@ bootMisMatch is_boot extra_info real_thing boot_thing instMisMatch :: DFunId -> TcRnMessage instMisMatch dfun - = TcRnUnknownMessage $ mkPlainError noHints $ + = mkTcRnUnknownMessage $ mkPlainError noHints $ hang (text "instance" <+> ppr (idType dfun)) 2 (text "is defined in the hs-boot file, but not in the module itself") @@ -1619,7 +1619,7 @@ tcPreludeClashWarn warnFlag name = do (hang (ppr name) 4 (sep [ppr clashingElts])) ; let warn_msg x = addDiagnosticAt (nameSrcSpan (greMangledName x)) $ - TcRnUnknownMessage $ + mkTcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag warnFlag) noHints $ (hsep [ text "Local definition of" , (quotes . ppr . nameOccName . greMangledName) x @@ -1732,7 +1732,7 @@ tcMissingParentClassWarn warnFlag isName shouldName ; let instLoc = srcLocSpan . nameSrcLoc $ getName isInst warnMsg (RM_KnownTc name:_) = addDiagnosticAt instLoc $ - TcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag warnFlag) noHints $ + mkTcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag warnFlag) noHints $ hsep [ (quotes . ppr . nameOccName) name , text "is an instance of" , (ppr . nameOccName . className) isClass @@ -1870,7 +1870,7 @@ checkMain explicit_mod_hdr export_ies -- in other modes, add error message and go on with typechecking. noMainMsg main_mod main_occ - = TcRnUnknownMessage $ mkPlainError noHints $ + = mkTcRnUnknownMessage $ mkPlainError noHints $ text "The" <+> ppMainFn main_occ <+> text "is not" <+> text defOrExp <+> text "module" <+> quotes (ppr main_mod) @@ -2188,7 +2188,7 @@ tcRnStmt hsc_env rdr_stmt return (global_ids, zonked_expr, fix_env) } where - bad_unboxed id = addErr $ TcRnUnknownMessage $ mkPlainError noHints $ + bad_unboxed id = addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $ (sep [text "GHCi can't bind a variable of unlifted type:", nest 2 (pprPrefixOcc id <+> dcolon <+> ppr (idType id))]) @@ -2543,8 +2543,8 @@ isGHCiMonad hsc_env ty _ <- tcLookupInstance ghciClass [userTy] return name - Just _ -> failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ text "Ambiguous type!" - Nothing -> failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ text ("Can't find type:" ++ ty) + Just _ -> failWithTc $ mkTcRnUnknownMessage $ mkPlainError noHints $ text "Ambiguous type!" + Nothing -> failWithTc $ mkTcRnUnknownMessage $ mkPlainError noHints $ text ("Can't find type:" ++ ty) -- | How should we infer a type? See Note [TcRnExprMode] data TcRnExprMode = TM_Inst -- ^ Instantiate inferred quantifiers only (:type) @@ -2847,7 +2847,7 @@ tcRnLookupRdrName hsc_env (L loc rdr_name) let rdr_names = dataTcOccs rdr_name ; names_s <- mapM lookupInfoOccRn rdr_names ; let names = concat names_s - ; when (null names) (addErrTc $ TcRnUnknownMessage $ mkPlainError noHints $ + ; when (null names) (addErrTc $ mkTcRnUnknownMessage $ mkPlainError noHints $ (text "Not in scope:" <+> quotes (ppr rdr_name))) ; return names } diff --git a/compiler/GHC/Tc/Solver/Monad.hs b/compiler/GHC/Tc/Solver/Monad.hs index f41e1991ce..6666758226 100644 --- a/compiler/GHC/Tc/Solver/Monad.hs +++ b/compiler/GHC/Tc/Solver/Monad.hs @@ -1872,7 +1872,7 @@ solverDepthError loc ty ; env0 <- TcM.tcInitTidyEnv ; let tidy_env = tidyFreeTyCoVars env0 (tyCoVarsOfTypeList ty) tidy_ty = tidyType tidy_env ty - msg = TcRnUnknownMessage $ mkPlainError noHints $ + msg = mkTcRnUnknownMessage $ mkPlainError noHints $ vcat [ text "Reduction stack overflow; size =" <+> ppr depth , hang (text "When simplifying the following type:") 2 (ppr tidy_ty) diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs index ee9314e74b..3e9fa96e39 100644 --- a/compiler/GHC/Tc/TyCl.hs +++ b/compiler/GHC/Tc/TyCl.hs @@ -34,7 +34,8 @@ import GHC.Driver.Config.HsToCore import GHC.Hs -import GHC.Tc.Errors.Types ( TcRnMessage(..), FixedRuntimeRepProvenance(..) ) +import GHC.Tc.Errors.Types ( TcRnMessage(..), FixedRuntimeRepProvenance(..) + , mkTcRnUnknownMessage ) import GHC.Tc.TyCl.Build import GHC.Tc.Solver( pushLevelAndSolveEqualities, pushLevelAndSolveEqualitiesX , reportUnsolvedEqualities ) @@ -2541,7 +2542,7 @@ tcDefaultAssocDecl _ [] = return Nothing -- No default declaration tcDefaultAssocDecl _ (d1:_:_) - = failWithTc (TcRnUnknownMessage $ mkPlainError noHints $ + = failWithTc (mkTcRnUnknownMessage $ mkPlainError noHints $ text "More than one default declaration for" <+> ppr (tyFamInstDeclName (unLoc d1))) @@ -2828,7 +2829,7 @@ tcInjectivity tcbs (Just (L loc (InjectivityAnn _ _ lInjNames))) do { let tvs = binderVars tcbs ; dflags <- getDynFlags ; checkTc (xopt LangExt.TypeFamilyDependencies dflags) - (TcRnUnknownMessage $ mkPlainError noHints $ + (mkTcRnUnknownMessage $ mkPlainError noHints $ text "Illegal injectivity annotation" $$ text "Use TypeFamilyDependencies to allow this") ; inj_tvs <- mapM (tcLookupTyVar . unLoc) lInjNames @@ -4237,7 +4238,7 @@ checkValidTyCon tc ; ClosedSynFamilyTyCon Nothing -> return () ; AbstractClosedSynFamilyTyCon -> do { hsBoot <- tcIsHsBootOrSig - ; checkTc hsBoot $ TcRnUnknownMessage $ mkPlainError noHints $ + ; checkTc hsBoot $ mkTcRnUnknownMessage $ mkPlainError noHints $ text "You may define an abstract closed type family" $$ text "only in a .hs-boot file" } ; DataFamilyTyCon {} -> return () @@ -4315,7 +4316,7 @@ checkPartialRecordField :: [DataCon] -> FieldLabel -> TcM () checkPartialRecordField all_cons fld = setSrcSpan loc $ warnIf (not is_exhaustive && not (startsWithUnderscore occ_name)) - (TcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag Opt_WarnPartialFields) noHints $ + (mkTcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag Opt_WarnPartialFields) noHints $ sep [text "Use of partial record field selector" <> colon, nest 2 $ quotes (ppr occ_name)]) where @@ -4426,13 +4427,13 @@ checkValidDataCon dflags existential_ok tc con check_bang orig_arg_ty bang rep_bang n | HsSrcBang _ _ SrcLazy <- bang , not (bang_opt_strict_data bang_opts) - = addErrTc $ TcRnUnknownMessage $ mkPlainError noHints $ + = addErrTc $ mkTcRnUnknownMessage $ mkPlainError noHints $ (bad_bang n (text "Lazy annotation (~) without StrictData")) | HsSrcBang _ want_unpack strict_mark <- bang , isSrcUnpacked want_unpack, not (is_strict strict_mark) , not (isUnliftedType orig_arg_ty) - = addDiagnosticTc $ TcRnUnknownMessage $ + = addDiagnosticTc $ mkTcRnUnknownMessage $ mkPlainDiagnostic WarningWithoutFlag noHints (bad_bang n (text "UNPACK pragma lacks '!'")) -- Warn about a redundant ! on an unlifted type @@ -4461,7 +4462,7 @@ checkValidDataCon dflags existential_ok tc con -- warn in this case (it gives users the wrong idea about whether -- or not UNPACK on abstract types is supported; it is!) , isHomeUnitDefinite (hsc_home_unit hsc_env) - = addDiagnosticTc $ TcRnUnknownMessage $ + = addDiagnosticTc $ mkTcRnUnknownMessage $ mkPlainDiagnostic WarningWithoutFlag noHints (bad_bang n (text "Ignoring unusable UNPACK pragma")) | otherwise @@ -4523,18 +4524,18 @@ checkNewDataCon con ; unlifted_newtypes <- xoptM LangExt.UnliftedNewtypes ; let allowedArgType = unlifted_newtypes || typeLevity_maybe (scaledThing arg_ty1) == Just Lifted - ; checkTc allowedArgType $ TcRnUnknownMessage $ mkPlainError noHints $ vcat + ; checkTc allowedArgType $ mkTcRnUnknownMessage $ mkPlainError noHints $ vcat [ text "A newtype cannot have an unlifted argument type" , text "Perhaps you intended to use UnliftedNewtypes" ] ; show_linear_types <- xopt LangExt.LinearTypes <$> getDynFlags ; let check_con what msg = - checkTc what $ TcRnUnknownMessage $ mkPlainError noHints $ + checkTc what $ mkTcRnUnknownMessage $ mkPlainError noHints $ (msg $$ ppr con <+> dcolon <+> ppr (dataConDisplayType show_linear_types con)) ; checkTc (ok_mult (scaledMult arg_ty1)) $ - TcRnUnknownMessage $ mkPlainError noHints $ text "A newtype constructor must be linear" + mkTcRnUnknownMessage $ mkPlainError noHints $ text "A newtype constructor must be linear" ; check_con (null eq_spec) $ text "A newtype constructor must have a return type of form T a1 ... an" @@ -4630,7 +4631,7 @@ checkValidClass cls ; unless undecidable_super_classes $ case checkClassCycles cls of Just err -> setSrcSpan (getSrcSpan cls) $ - addErrTc (TcRnUnknownMessage $ mkPlainError noHints err) + addErrTc (mkTcRnUnknownMessage $ mkPlainError noHints err) Nothing -> return () -- Check the class operations. @@ -4773,7 +4774,7 @@ checkValidClass cls -- default foo2 :: a -> b unless (isJust $ tcMatchTys [dm_phi_ty, vanilla_phi_ty] [vanilla_phi_ty, dm_phi_ty]) $ addErrTc $ - TcRnUnknownMessage $ mkPlainError noHints $ + mkTcRnUnknownMessage $ mkPlainError noHints $ hang (text "The default type signature for" <+> ppr sel_id <> colon) 2 (ppr dm_ty) @@ -4793,14 +4794,14 @@ checkFamFlag tc_name ; checkTc idx_tys err_msg } where err_msg :: TcRnMessage - err_msg = TcRnUnknownMessage $ mkPlainError noHints $ + err_msg = mkTcRnUnknownMessage $ mkPlainError noHints $ hang (text "Illegal family declaration for" <+> quotes (ppr tc_name)) 2 (text "Enable TypeFamilies to allow indexed type families") checkResultSigFlag :: Name -> FamilyResultSig GhcRn -> TcM () checkResultSigFlag tc_name (TyVarSig _ tvb) = do { ty_fam_deps <- xoptM LangExt.TypeFamilyDependencies - ; checkTc ty_fam_deps $ TcRnUnknownMessage $ mkPlainError noHints $ + ; checkTc ty_fam_deps $ mkTcRnUnknownMessage $ mkPlainError noHints $ hang (text "Illegal result type variable" <+> ppr tvb <+> text "for" <+> quotes (ppr tc_name)) 2 (text "Enable TypeFamilyDependencies to allow result variable names") } checkResultSigFlag _ _ = return () -- other cases OK @@ -5143,7 +5144,7 @@ checkValidRoles tc check_ty_roles env role ty report_error doc - = addErrTc $ TcRnUnknownMessage $ mkPlainError noHints $ + = addErrTc $ mkTcRnUnknownMessage $ mkPlainError noHints $ vcat [text "Internal error in role inference:", doc, text "Please report this as a GHC bug: https://www.haskell.org/ghc/reportabug"] @@ -5227,14 +5228,14 @@ tcAddClosedTypeFamilyDeclCtxt tc resultTypeMisMatch :: FieldLabelString -> DataCon -> DataCon -> TcRnMessage resultTypeMisMatch field_name con1 con2 - = TcRnUnknownMessage $ mkPlainError noHints $ + = mkTcRnUnknownMessage $ mkPlainError noHints $ vcat [sep [text "Constructors" <+> ppr con1 <+> text "and" <+> ppr con2, text "have a common field" <+> quotes (ppr field_name) <> comma], nest 2 $ text "but have different result types"] fieldTypeMisMatch :: FieldLabelString -> DataCon -> DataCon -> TcRnMessage fieldTypeMisMatch field_name con1 con2 - = TcRnUnknownMessage $ mkPlainError noHints $ + = mkTcRnUnknownMessage $ mkPlainError noHints $ sep [text "Constructors" <+> ppr con1 <+> text "and" <+> ppr con2, text "give different types for field", quotes (ppr field_name)] @@ -5259,20 +5260,20 @@ classArityErr n cls | n == 0 = mkErr "No" "no-parameter" | otherwise = mkErr "Too many" "multi-parameter" where - mkErr howMany allowWhat = TcRnUnknownMessage $ mkPlainError noHints $ + mkErr howMany allowWhat = mkTcRnUnknownMessage $ mkPlainError noHints $ vcat [text (howMany ++ " parameters for class") <+> quotes (ppr cls), parens (text ("Enable MultiParamTypeClasses to allow " ++ allowWhat ++ " classes"))] classFunDepsErr :: Class -> TcRnMessage classFunDepsErr cls - = TcRnUnknownMessage $ mkPlainError noHints $ + = mkTcRnUnknownMessage $ mkPlainError noHints $ vcat [text "Fundeps in class" <+> quotes (ppr cls), parens (text "Enable FunctionalDependencies to allow fundeps")] badMethPred :: Id -> TcPredType -> TcRnMessage badMethPred sel_id pred - = TcRnUnknownMessage $ mkPlainError noHints $ + = mkTcRnUnknownMessage $ mkPlainError noHints $ vcat [ hang (text "Constraint" <+> quotes (ppr pred) <+> text "in the type of" <+> quotes (ppr sel_id)) 2 (text "constrains only the class type variables") @@ -5280,14 +5281,14 @@ badMethPred sel_id pred noClassTyVarErr :: Class -> TyCon -> TcRnMessage noClassTyVarErr clas fam_tc - = TcRnUnknownMessage $ mkPlainError noHints $ + = mkTcRnUnknownMessage $ mkPlainError noHints $ sep [ text "The associated type" <+> quotes (ppr fam_tc <+> hsep (map ppr (tyConTyVars fam_tc))) , text "mentions none of the type or kind variables of the class" <+> quotes (ppr clas <+> hsep (map ppr (classTyVars clas)))] badDataConTyCon :: DataCon -> Type -> TcRnMessage badDataConTyCon data_con res_ty_tmpl - = TcRnUnknownMessage $ mkPlainError noHints $ + = mkTcRnUnknownMessage $ mkPlainError noHints $ hang (text "Data constructor" <+> quotes (ppr data_con) <+> text "returns type" <+> quotes (ppr actual_res_ty)) 2 (text "instead of an instance of its parent type" <+> quotes (ppr res_ty_tmpl)) @@ -5296,13 +5297,13 @@ badDataConTyCon data_con res_ty_tmpl badGadtDecl :: Name -> TcRnMessage badGadtDecl tc_name - = TcRnUnknownMessage $ mkPlainError noHints $ + = mkTcRnUnknownMessage $ mkPlainError noHints $ vcat [ text "Illegal generalised algebraic data declaration for" <+> quotes (ppr tc_name) , nest 2 (parens $ text "Enable the GADTs extension to allow this") ] badExistential :: DataCon -> TcRnMessage badExistential con - = TcRnUnknownMessage $ mkPlainError noHints $ + = mkTcRnUnknownMessage $ mkPlainError noHints $ sdocOption sdocLinearTypes (\show_linear_types -> hang (text "Data constructor" <+> quotes (ppr con) <+> text "has existential type variables, a context, or a specialised result type") @@ -5311,43 +5312,43 @@ badExistential con badStupidTheta :: Name -> TcRnMessage badStupidTheta tc_name - = TcRnUnknownMessage $ mkPlainError noHints $ + = mkTcRnUnknownMessage $ mkPlainError noHints $ text "A data type declared in GADT style cannot have a context:" <+> quotes (ppr tc_name) newtypeConError :: Name -> Int -> TcRnMessage newtypeConError tycon n - = TcRnUnknownMessage $ mkPlainError noHints $ + = mkTcRnUnknownMessage $ mkPlainError noHints $ sep [text "A newtype must have exactly one constructor,", nest 2 $ text "but" <+> quotes (ppr tycon) <+> text "has" <+> speakN n ] newtypeStrictError :: DataCon -> TcRnMessage newtypeStrictError con - = TcRnUnknownMessage $ mkPlainError noHints $ + = mkTcRnUnknownMessage $ mkPlainError noHints $ sep [text "A newtype constructor cannot have a strictness annotation,", nest 2 $ text "but" <+> quotes (ppr con) <+> text "does"] newtypeFieldErr :: DataCon -> Int -> TcRnMessage newtypeFieldErr con_name n_flds - = TcRnUnknownMessage $ mkPlainError noHints $ + = mkTcRnUnknownMessage $ mkPlainError noHints $ sep [text "The constructor of a newtype must have exactly one field", nest 2 $ text "but" <+> quotes (ppr con_name) <+> text "has" <+> speakN n_flds] badSigTyDecl :: Name -> TcRnMessage badSigTyDecl tc_name - = TcRnUnknownMessage $ mkPlainError noHints $ + = mkTcRnUnknownMessage $ mkPlainError noHints $ vcat [ text "Illegal kind signature" <+> quotes (ppr tc_name) , nest 2 (parens $ text "Use KindSignatures to allow kind signatures") ] emptyConDeclsErr :: Name -> TcRnMessage emptyConDeclsErr tycon - = TcRnUnknownMessage $ mkPlainError noHints $ + = mkTcRnUnknownMessage $ mkPlainError noHints $ sep [quotes (ppr tycon) <+> text "has no constructors", nest 2 $ text "(EmptyDataDecls permits this)"] wrongKindOfFamily :: TyCon -> TcRnMessage wrongKindOfFamily family - = TcRnUnknownMessage $ mkPlainError noHints $ + = mkTcRnUnknownMessage $ mkPlainError noHints $ text "Wrong category of family instance; declaration was for a" <+> kindOfFamily where @@ -5360,13 +5361,13 @@ wrongKindOfFamily family -- See Note [Oversaturated type family equations] in "GHC.Tc.Validity". wrongNumberOfParmsErr :: Arity -> TcRnMessage wrongNumberOfParmsErr max_args - = TcRnUnknownMessage $ mkPlainError noHints $ + = mkTcRnUnknownMessage $ mkPlainError noHints $ text "Number of parameters must match family declaration; expected" <+> ppr max_args badRoleAnnot :: Name -> Role -> Role -> TcRnMessage badRoleAnnot var annot inferred - = TcRnUnknownMessage $ mkPlainError noHints $ + = mkTcRnUnknownMessage $ mkPlainError noHints $ hang (text "Role mismatch on variable" <+> ppr var <> colon) 2 (sep [ text "Annotation says", ppr annot , text "but role", ppr inferred @@ -5374,7 +5375,7 @@ badRoleAnnot var annot inferred wrongNumberOfRoles :: [a] -> LRoleAnnotDecl GhcRn -> TcRnMessage wrongNumberOfRoles tyvars d@(L _ (RoleAnnotDecl _ _ annots)) - = TcRnUnknownMessage $ mkPlainError noHints $ + = mkTcRnUnknownMessage $ mkPlainError noHints $ hang (text "Wrong number of roles listed in role annotation;" $$ text "Expected" <+> (ppr $ length tyvars) <> comma <+> text "got" <+> (ppr $ length annots) <> colon) @@ -5385,25 +5386,25 @@ illegalRoleAnnotDecl :: LRoleAnnotDecl GhcRn -> TcM () illegalRoleAnnotDecl (L loc (RoleAnnotDecl _ tycon _)) = setErrCtxt [] $ setSrcSpanA loc $ - addErrTc $ TcRnUnknownMessage $ mkPlainError noHints $ + addErrTc $ mkTcRnUnknownMessage $ mkPlainError noHints $ (text "Illegal role annotation for" <+> ppr tycon <> char ';' $$ text "they are allowed only for datatypes and classes.") needXRoleAnnotations :: TyCon -> TcRnMessage needXRoleAnnotations tc - = TcRnUnknownMessage $ mkPlainError noHints $ + = mkTcRnUnknownMessage $ mkPlainError noHints $ text "Illegal role annotation for" <+> ppr tc <> char ';' $$ text "did you intend to use RoleAnnotations?" incoherentRoles :: TcRnMessage -incoherentRoles = TcRnUnknownMessage $ mkPlainError noHints $ +incoherentRoles = mkTcRnUnknownMessage $ mkPlainError noHints $ (text "Roles other than" <+> quotes (text "nominal") <+> text "for class parameters can lead to incoherence.") $$ (text "Use IncoherentInstances to allow this; bad role found") wrongTyFamName :: Name -> Name -> TcRnMessage wrongTyFamName fam_tc_name eqn_tc_name - = TcRnUnknownMessage $ mkPlainError noHints $ + = mkTcRnUnknownMessage $ mkPlainError noHints $ hang (text "Mismatched type name in type family instance.") 2 (vcat [ text "Expected:" <+> ppr fam_tc_name , text " Actual:" <+> ppr eqn_tc_name ]) diff --git a/compiler/GHC/Tc/TyCl/Instance.hs b/compiler/GHC/Tc/TyCl/Instance.hs index da85cd0881..72081727be 100644 --- a/compiler/GHC/Tc/TyCl/Instance.hs +++ b/compiler/GHC/Tc/TyCl/Instance.hs @@ -2030,7 +2030,7 @@ methSigCtxt sel_name sig_ty meth_ty env0 misplacedInstSig :: Name -> LHsSigType GhcRn -> TcRnMessage misplacedInstSig name hs_ty - = TcRnUnknownMessage $ mkPlainError noHints $ + = mkTcRnUnknownMessage $ mkPlainError noHints $ vcat [ hang (text "Illegal type signature in instance declaration:") 2 (hang (pprPrefixName name) 2 (dcolon <+> ppr hs_ty)) @@ -2158,7 +2158,7 @@ derivBindCtxt sel_id clas tys warnUnsatisfiedMinimalDefinition :: ClassMinimalDef -> TcM () warnUnsatisfiedMinimalDefinition mindef = do { warn <- woptM Opt_WarnMissingMethods - ; let msg = TcRnUnknownMessage $ + ; let msg = mkTcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag Opt_WarnMissingMethods) noHints message ; diagnosticTc warn msg } @@ -2381,28 +2381,28 @@ inst_decl_ctxt doc = hang (text "In the instance declaration for") badBootFamInstDeclErr :: TcRnMessage badBootFamInstDeclErr - = TcRnUnknownMessage $ mkPlainError noHints $ text "Illegal family instance in hs-boot file" + = mkTcRnUnknownMessage $ mkPlainError noHints $ text "Illegal family instance in hs-boot file" notFamily :: TyCon -> TcRnMessage notFamily tycon - = TcRnUnknownMessage $ mkPlainError noHints $ + = mkTcRnUnknownMessage $ mkPlainError noHints $ vcat [ text "Illegal family instance for" <+> quotes (ppr tycon) , nest 2 $ parens (ppr tycon <+> text "is not an indexed type family")] assocInClassErr :: TyCon -> TcRnMessage assocInClassErr name - = TcRnUnknownMessage $ mkPlainError noHints $ + = mkTcRnUnknownMessage $ mkPlainError noHints $ text "Associated type" <+> quotes (ppr name) <+> text "must be inside a class instance" badFamInstDecl :: TyCon -> TcRnMessage badFamInstDecl tc_name - = TcRnUnknownMessage $ mkPlainError noHints $ + = mkTcRnUnknownMessage $ mkPlainError noHints $ vcat [ text "Illegal family instance for" <+> quotes (ppr tc_name) , nest 2 (parens $ text "Use TypeFamilies to allow indexed type families") ] notOpenFamily :: TyCon -> TcRnMessage notOpenFamily tc - = TcRnUnknownMessage $ mkPlainError noHints $ + = mkTcRnUnknownMessage $ mkPlainError noHints $ text "Illegal instance for closed family" <+> quotes (ppr tc) diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs index 8076d575ac..bb142f080a 100644 --- a/compiler/GHC/Tc/TyCl/PatSyn.hs +++ b/compiler/GHC/Tc/TyCl/PatSyn.hs @@ -241,7 +241,7 @@ dependentArgErr :: (Id, DTyCoVarSet) -> TcM () -- See Note [Coercions that escape] dependentArgErr (arg, bad_cos) = failWithTc $ -- fail here: otherwise we get downstream errors - TcRnUnknownMessage $ mkPlainError noHints $ + mkTcRnUnknownMessage $ mkPlainError noHints $ vcat [ text "Iceland Jack! Iceland Jack! Stop torturing me!" , hang (text "Pattern-bound variable") 2 (ppr arg <+> dcolon <+> ppr (idType arg)) @@ -406,7 +406,7 @@ tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details -- The existential 'x' should not appear in the result type -- Can't check this until we know P's arity (decl_arity above) ; let bad_tvs = filter (`elemVarSet` tyCoVarsOfType pat_ty) $ binderVars explicit_ex_bndrs - ; checkTc (null bad_tvs) $ TcRnUnknownMessage $ mkPlainError noHints $ + ; checkTc (null bad_tvs) $ mkTcRnUnknownMessage $ mkPlainError noHints $ hang (sep [ text "The result type of the signature for" <+> quotes (ppr name) <> comma , text "namely" <+> quotes (ppr pat_ty) ]) 2 (text "mentions existential type variable" <> plural bad_tvs @@ -680,7 +680,7 @@ collectPatSynArgInfo details = wrongNumberOfParmsErr :: Name -> Arity -> Arity -> TcM a wrongNumberOfParmsErr name decl_arity missing - = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ + = failWithTc $ mkTcRnUnknownMessage $ mkPlainError noHints $ hang (text "Pattern synonym" <+> quotes (ppr name) <+> text "has" <+> speakNOf decl_arity (text "argument")) 2 (text "but its type signature has" <+> int missing <+> text "fewer arrows") @@ -922,7 +922,7 @@ tcPatSynBuilderBind prag_fn (PSB { psb_id = ps_lname@(L loc ps_name) = return emptyBag | Left why <- mb_match_group -- Can't invert the pattern - = setSrcSpan (getLocA lpat) $ failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ + = setSrcSpan (getLocA lpat) $ failWithTc $ mkTcRnUnknownMessage $ mkPlainError noHints $ vcat [ hang (text "Invalid right-hand side of bidirectional pattern synonym" <+> quotes (ppr ps_name) <> colon) 2 why diff --git a/compiler/GHC/Tc/TyCl/Utils.hs b/compiler/GHC/Tc/TyCl/Utils.hs index 2ca71dec1b..26a28e7296 100644 --- a/compiler/GHC/Tc/TyCl/Utils.hs +++ b/compiler/GHC/Tc/TyCl/Utils.hs @@ -208,7 +208,7 @@ checkTyConIsAcyclic tc m = SynCycleM $ \s -> checkSynCycles :: Unit -> [TyCon] -> [LTyClDecl GhcRn] -> TcM () checkSynCycles this_uid tcs tyclds = case runSynCycleM (mapM_ (go emptyTyConSet []) tcs) emptyTyConSet of - Left (loc, err) -> setSrcSpan loc $ failWithTc (TcRnUnknownMessage $ mkPlainError noHints err) + Left (loc, err) -> setSrcSpan loc $ failWithTc (mkTcRnUnknownMessage $ mkPlainError noHints err) Right _ -> return () where -- Try our best to print the LTyClDecl for locally defined things diff --git a/compiler/GHC/Tc/Utils/Backpack.hs b/compiler/GHC/Tc/Utils/Backpack.hs index d553ec4fad..4cba3f20b1 100644 --- a/compiler/GHC/Tc/Utils/Backpack.hs +++ b/compiler/GHC/Tc/Utils/Backpack.hs @@ -90,9 +90,10 @@ import Data.List (find) import {-# SOURCE #-} GHC.Tc.Module + fixityMisMatch :: TyThing -> Fixity -> Fixity -> TcRnMessage fixityMisMatch real_thing real_fixity sig_fixity = - TcRnUnknownMessage $ mkPlainError noHints $ + mkTcRnUnknownMessage $ mkPlainError noHints $ vcat [ppr real_thing <+> text "has conflicting fixities in the module", text "and its hsig file", text "Main module:" <+> ppr_fix real_fixity, @@ -169,7 +170,7 @@ checkHsigIface tcg_env gr sig_iface -- tcg_env (TODO: but maybe this isn't relevant anymore). r <- tcLookupImported_maybe name case r of - Failed err -> addErr (TcRnUnknownMessage $ mkPlainError noHints err) + Failed err -> addErr (mkTcRnUnknownMessage $ mkPlainError noHints err) Succeeded real_thing -> checkHsigDeclM sig_iface sig_thing real_thing -- The hsig did NOT define this function; that means it must @@ -687,7 +688,7 @@ mergeSignatures -- 3(d). Extend the name substitution (performing shaping) mb_r <- extend_ns nsubst as2 case mb_r of - Left err -> failWithTc (TcRnUnknownMessage $ mkPlainError noHints err) + Left err -> failWithTc (mkTcRnUnknownMessage $ mkPlainError noHints err) Right nsubst' -> return (nsubst',oks',(imod, thinned_iface):ifaces) nsubst0 = mkNameShape (moduleName inner_mod) (mi_exports lcl_iface0) ok_to_use0 = mkOccSet (exportOccs (mi_exports lcl_iface0)) @@ -994,7 +995,7 @@ checkImplements impl_mod req_mod@(Module uid mod_name) = do isig_mod sig_mod NotBoot isig_iface <- case mb_isig_iface of Succeeded (iface, _) -> return iface - Failed err -> failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ + Failed err -> failWithTc $ mkTcRnUnknownMessage $ mkPlainError noHints $ hang (text "Could not find hi interface for signature" <+> quotes (ppr isig_mod) <> colon) 4 err @@ -1002,7 +1003,7 @@ checkImplements impl_mod req_mod@(Module uid mod_name) = do -- we need. (Notice we IGNORE the Modules in the AvailInfos.) forM_ (exportOccs (mi_exports isig_iface)) $ \occ -> case lookupGlobalRdrEnv impl_gr occ of - [] -> addErr $ TcRnUnknownMessage $ mkPlainError noHints $ + [] -> addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $ quotes (ppr occ) <+> text "is exported by the hsig file, but not exported by the implementing module" <+> quotes (pprWithUnitState unit_state $ ppr impl_mod) diff --git a/compiler/GHC/Tc/Utils/Env.hs b/compiler/GHC/Tc/Utils/Env.hs index 01fde4cd1a..84b9d8f9a0 100644 --- a/compiler/GHC/Tc/Utils/Env.hs +++ b/compiler/GHC/Tc/Utils/Env.hs @@ -257,7 +257,7 @@ tcLookupGlobal name do { mb_thing <- tcLookupImported_maybe name ; case mb_thing of Succeeded thing -> return thing - Failed msg -> failWithTc (TcRnUnknownMessage $ mkPlainError noHints msg) + Failed msg -> failWithTc (mkTcRnUnknownMessage $ mkPlainError noHints msg) }}} -- Look up only in this module's global env't. Don't look in imports, etc. @@ -328,11 +328,11 @@ tcLookupInstance cls tys = do { instEnv <- tcGetInstEnvs ; case lookupUniqueInstEnv instEnv cls tys of Left err -> - failWithTc $ TcRnUnknownMessage + failWithTc $ mkTcRnUnknownMessage $ mkPlainError noHints (text "Couldn't match instance:" <+> err) Right (inst, tys) | uniqueTyVars tys -> return inst - | otherwise -> failWithTc (TcRnUnknownMessage $ mkPlainError noHints errNotExact) + | otherwise -> failWithTc (mkTcRnUnknownMessage $ mkPlainError noHints errNotExact) } where errNotExact = text "Not an exact match (i.e., some variables get instantiated)" @@ -899,7 +899,7 @@ checkWellStaged pp_thing bind_lvl use_lvl | otherwise -- Badly staged = failWithTc $ -- E.g. \x -> $(f x) - TcRnUnknownMessage $ mkPlainError noHints $ + mkTcRnUnknownMessage $ mkPlainError noHints $ text "Stage error:" <+> pp_thing <+> hsep [text "is bound at stage" <+> ppr bind_lvl, text "but used at stage" <+> ppr use_lvl] @@ -907,7 +907,7 @@ checkWellStaged pp_thing bind_lvl use_lvl stageRestrictionError :: SDoc -> TcM a stageRestrictionError pp_thing = failWithTc $ - TcRnUnknownMessage $ mkPlainError noHints $ + mkTcRnUnknownMessage $ mkPlainError noHints $ sep [ text "GHC stage restriction:" , nest 2 (vcat [ pp_thing <+> text "is used in a top-level splice, quasi-quote, or annotation," , text "and must be imported, not defined locally"])] @@ -1175,7 +1175,7 @@ notFound name -- don't report it again (#11941) | otherwise -> stageRestrictionError (quotes (ppr name)) _ -> failWithTc $ - TcRnUnknownMessage $ mkPlainError noHints $ + mkTcRnUnknownMessage $ mkPlainError noHints $ vcat[text "GHC internal error:" <+> quotes (ppr name) <+> text "is not in scope during type checking, but it passed the renamer", text "tcl_env of environment:" <+> ppr (tcl_env lcl_env)] @@ -1188,7 +1188,7 @@ notFound name wrongThingErr :: String -> TcTyThing -> Name -> TcM a wrongThingErr expected thing name - = let msg = TcRnUnknownMessage $ mkPlainError noHints $ + = let msg = mkTcRnUnknownMessage $ mkPlainError noHints $ (pprTcTyThingCategory thing <+> quotes (ppr name) <+> text "used as a" <+> text expected) in failWithTc msg diff --git a/compiler/GHC/Tc/Utils/TcMType.hs b/compiler/GHC/Tc/Utils/TcMType.hs index eed03d9323..19f368ba99 100644 --- a/compiler/GHC/Tc/Utils/TcMType.hs +++ b/compiler/GHC/Tc/Utils/TcMType.hs @@ -1845,7 +1845,7 @@ defaultTyVar def_strat tv ; writeMetaTyVar kv liftedTypeKind ; return True } | otherwise - = do { addErr $ TcRnUnknownMessage $ mkPlainError noHints $ + = do { addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $ (vcat [ text "Cannot default kind variable" <+> quotes (ppr kv') , text "of kind:" <+> ppr (tyVarKind kv') , text "Perhaps enable PolyKinds or add a kind signature" ]) @@ -2065,7 +2065,7 @@ doNotQuantifyTyVars dvs where_found ; unless (null leftover_metas) $ do { let (tidy_env1, tidied_tvs) = tidyOpenTyCoVars emptyTidyEnv leftover_metas ; (tidy_env2, where_doc) <- where_found tidy_env1 - ; let msg = TcRnUnknownMessage $ + ; let msg = mkTcRnUnknownMessage $ mkPlainError noHints $ pprWithExplicitKindsWhen True $ vcat [ text "Uninferrable type variable" @@ -2735,7 +2735,7 @@ naughtyQuantification orig_ty tv escapees orig_ty' = tidyType env orig_ty1 ppr_tidied = pprTyVars . map (tidyTyCoVarOcc env) - msg = TcRnUnknownMessage $ mkPlainError noHints $ + msg = mkTcRnUnknownMessage $ mkPlainError noHints $ pprWithExplicitKindsWhen True $ vcat [ sep [ text "Cannot generalise type; skolem" <> plural escapees' , quotes $ ppr_tidied escapees' diff --git a/compiler/GHC/Tc/Utils/TcType.hs b/compiler/GHC/Tc/Utils/TcType.hs index 805e58fc39..240cfb9ef1 100644 --- a/compiler/GHC/Tc/Utils/TcType.hs +++ b/compiler/GHC/Tc/Utils/TcType.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} @@ -246,6 +247,7 @@ import Data.IORef import Data.List.NonEmpty( NonEmpty(..) ) import Data.List ( partition ) +import GHC.Generics ( Generic ) {- ************************************************************************ @@ -2244,6 +2246,7 @@ data IllegalForeignTypeReason | LinearTypesNotAllowed | OneArgExpected | AtLeastOneArgExpected + deriving Generic -- | Reason why a type cannot be marshalled through the FFI. data TypeCannotBeMarshaledReason @@ -2254,6 +2257,7 @@ data TypeCannotBeMarshaledReason | ForeignLabelNotAPtr | NotSimpleUnliftedType | NotBoxedKindAny + deriving Generic isFFIArgumentTy :: DynFlags -> Safety -> Type -> Validity' IllegalForeignTypeReason -- Checks for valid argument type for a 'foreign import' diff --git a/compiler/GHC/Tc/Validity.hs b/compiler/GHC/Tc/Validity.hs index bfad7b7d38..b5879940b0 100644 --- a/compiler/GHC/Tc/Validity.hs +++ b/compiler/GHC/Tc/Validity.hs @@ -1199,7 +1199,7 @@ checkSimplifiableClassConstraint env dflags ctxt cls tys = do { result <- matchGlobalInst dflags False cls tys ; case result of OneInst { cir_what = what } - -> let dia = TcRnUnknownMessage $ + -> let dia = mkTcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag Opt_WarnSimplifiableClassConstraints) noHints (simplifiable_constraint_warn what) @@ -1327,7 +1327,7 @@ tyConArityErr tc tks arityErr :: Outputable a => SDoc -> a -> Int -> Int -> TcRnMessage arityErr what name n m - = TcRnUnknownMessage $ mkPlainError noHints $ + = mkTcRnUnknownMessage $ mkPlainError noHints $ hsep [ text "The" <+> what, quotes (ppr name), text "should have", n_arguments <> comma, text "but has been given", if m==0 then text "none" else int m] @@ -1568,7 +1568,7 @@ dropCastsB b = b -- Don't bother in the kind of a forall instTypeErr :: Class -> [Type] -> SDoc -> TcRnMessage instTypeErr cls tys msg - = TcRnUnknownMessage $ mkPlainError noHints $ + = mkTcRnUnknownMessage $ mkPlainError noHints $ hang (hang (text "Illegal instance declaration for") 2 (quotes (pprClassPred cls tys))) 2 msg @@ -1831,11 +1831,11 @@ checkInstTermination theta head_pred -- when the predicates are individually checked for validity check2 foralld_tvs pred pred_size - | not (null bad_tvs) = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ + | not (null bad_tvs) = failWithTc $ mkTcRnUnknownMessage $ mkPlainError noHints $ (noMoreMsg bad_tvs what (ppr head_pred)) - | not (isTyFamFree pred) = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ + | not (isTyFamFree pred) = failWithTc $ mkTcRnUnknownMessage $ mkPlainError noHints $ (nestedMsg what) - | pred_size >= head_size = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ + | pred_size >= head_size = failWithTc $ mkTcRnUnknownMessage $ mkPlainError noHints $ (smallerMsg what (ppr head_pred)) | otherwise = return () -- isTyFamFree: see Note [Type families in instance contexts] @@ -1918,7 +1918,7 @@ checkValidCoAxiom ax@(CoAxiom { co_ax_tc = fam_tc, co_ax_branches = branches }) -- (b) failure of injectivity check_branch_compat prev_branches cur_branch | cur_branch `isDominatedBy` prev_branches - = do { let dia = TcRnUnknownMessage $ + = do { let dia = mkTcRnUnknownMessage $ mkPlainDiagnostic WarningWithoutFlag noHints (inaccessibleCoAxBranch fam_tc cur_branch) ; addDiagnosticAt (coAxBranchSpan cur_branch) dia ; return prev_branches } @@ -2035,7 +2035,7 @@ checkValidAssocTyFamDeflt fam_tc pats = extract_tv pat pat_vis = case getTyVar_maybe pat of Just tv -> pure tv - Nothing -> failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ + Nothing -> failWithTc $ mkTcRnUnknownMessage $ mkPlainError noHints $ pprWithExplicitKindsWhen (isInvisibleArgFlag pat_vis) $ hang (text "Illegal argument" <+> quotes (ppr pat) <+> text "in:") 2 (vcat [ppr_eqn, suggestion]) @@ -2053,7 +2053,7 @@ checkValidAssocTyFamDeflt fam_tc pats = let dups = findDupsEq ((==) `on` fst) cpt_tvs_vis in traverse_ (\d -> let (pat_tv, pat_vis) = NE.head d in failWithTc $ - TcRnUnknownMessage $ mkPlainError noHints $ + mkTcRnUnknownMessage $ mkPlainError noHints $ pprWithExplicitKindsWhen (isInvisibleArgFlag pat_vis) $ hang (text "Illegal duplicate variable" <+> quotes (ppr pat_tv) <+> text "in:") @@ -2078,7 +2078,7 @@ checkFamInstRhs :: TyCon -> [Type] -- LHS -> [(TyCon, [Type])] -- type family calls in RHS -> [TcRnMessage] checkFamInstRhs lhs_tc lhs_tys famInsts - = map (TcRnUnknownMessage . mkPlainError noHints) $ mapMaybe check famInsts + = map (mkTcRnUnknownMessage . mkPlainError noHints) $ mapMaybe check famInsts where lhs_size = sizeTyConAppArgs lhs_tc lhs_tys inst_head = pprType (TyConApp lhs_tc lhs_tys) @@ -2149,7 +2149,7 @@ checkFamPatBinders fam_tc qtvs pats rhs dodgy_tvs = cpt_tvs `minusVarSet` inj_cpt_tvs check_tvs tvs what what2 - = unless (null tvs) $ addErrAt (getSrcSpan (head tvs)) $ TcRnUnknownMessage $ mkPlainError noHints $ + = unless (null tvs) $ addErrAt (getSrcSpan (head tvs)) $ mkTcRnUnknownMessage $ mkPlainError noHints $ hang (text "Type variable" <> plural tvs <+> pprQuotedList tvs <+> isOrAre tvs <+> what <> comma) 2 (vcat [ text "but not" <+> what2 <+> text "the family instance" @@ -2180,7 +2180,7 @@ checkValidTypePats tc pat_ty_args -- Ensure that no type family applications occur a type pattern ; case tcTyConAppTyFamInstsAndVis tc pat_ty_args of [] -> pure () - ((tf_is_invis_arg, tf_tc, tf_args):_) -> failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ + ((tf_is_invis_arg, tf_tc, tf_args):_) -> failWithTc $ mkTcRnUnknownMessage $ mkPlainError noHints $ ty_fam_inst_illegal_err tf_is_invis_arg (mkTyConApp tf_tc tf_args) } where @@ -2281,7 +2281,7 @@ checkConsistentFamInst (InClsInst { ai_class = clas , Just rl_subst1 <- tcMatchTyX_BM bind_me rl_subst ty2 ty1 = go lr_subst1 rl_subst1 triples | otherwise - = addErrTc (TcRnUnknownMessage $ mkPlainError noHints $ pp_wrong_at_arg vis) + = addErrTc (mkTcRnUnknownMessage $ mkPlainError noHints $ pp_wrong_at_arg vis) -- The /scoped/ type variables from the class-instance header -- should not be alpha-renamed. Inferred ones can be. @@ -2709,7 +2709,7 @@ checkTyConTelescope :: TyCon -> TcM () checkTyConTelescope tc | bad_scope = -- See "Ill-scoped binders" in Note [Bad TyCon telescopes] - addErr $ TcRnUnknownMessage $ mkPlainError noHints $ + addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $ vcat [ hang (text "The kind of" <+> quotes (ppr tc) <+> text "is ill-scoped") 2 pp_tc_kind , extra diff --git a/compiler/GHC/Types/Error.hs b/compiler/GHC/Types/Error.hs index aab0bbf0e8..3c8ff8b4bb 100644 --- a/compiler/GHC/Types/Error.hs +++ b/compiler/GHC/Types/Error.hs @@ -23,6 +23,7 @@ module GHC.Types.Error , MessageClass (..) , Severity (..) , Diagnostic (..) + , UnknownDiagnostic (..) , DiagnosticMessage (..) , DiagnosticReason (..) , DiagnosticHint (..) @@ -54,7 +55,7 @@ module GHC.Types.Error , pprMessageBag , mkLocMessage - , mkLocMessageAnn + , mkLocMessageWarningGroups , getCaretDiagnostic -- * Queries , isIntrinsicErrorMessage @@ -65,6 +66,9 @@ module GHC.Types.Error , partitionMessages , errorsFound , errorsOrFatalWarningsFound + + -- * Diagnostic codes + , DiagnosticCode(..) ) where @@ -77,13 +81,19 @@ import GHC.IO (catchException) import GHC.Utils.Outputable as Outputable import qualified GHC.Utils.Ppr.Colour as Col import GHC.Types.SrcLoc as SrcLoc +import GHC.Types.Hint import GHC.Data.FastString (unpackFS) import GHC.Data.StringBuffer (atLine, hGetStringBuffer, len, lexemeToString) import GHC.Utils.Json +import GHC.Utils.Panic import Data.Bifunctor import Data.Foldable ( fold ) -import GHC.Types.Hint +import qualified Data.List.NonEmpty as NE +import Data.List ( intercalate ) +import Data.Typeable ( Typeable ) +import Numeric.Natural ( Natural ) +import Text.Printf ( printf ) {- Note [Messages] @@ -191,39 +201,6 @@ mapDecoratedSDoc :: (SDoc -> SDoc) -> DecoratedSDoc -> DecoratedSDoc mapDecoratedSDoc f (Decorated s1) = Decorated (map f s1) -{- -Note [Rendering Messages] -~~~~~~~~~~~~~~~~~~~~~~~~~ - -Turning 'Messages' into something that renders nicely for the user is one of -the last steps, and it happens typically at the application's boundaries (i.e. -from the 'Driver' upwards). - -For now (see #18516) this class has few instance, but the idea is that as the -more domain-specific types are defined, the more instances we would get. For -example, given something like: - - data TcRnDiagnostic - = TcRnOutOfScope .. - | .. - - newtype TcRnMessage = TcRnMessage (DiagnosticMessage TcRnDiagnostic) - -We could then define how a 'TcRnDiagnostic' is displayed to the user. Rather -than scattering pieces of 'SDoc' around the codebase, we would write once for -all: - - instance Diagnostic TcRnDiagnostic where - diagnosticMessage (TcRnMessage msg) = case diagMessage msg of - TcRnOutOfScope .. -> Decorated [text "Out of scope error ..."] - ... - -This way, we can easily write generic rendering functions for errors that all -they care about is the knowledge that a given type 'e' has a 'Diagnostic' -constraint. - --} - -- | A class identifying a diagnostic. -- Dictionary.com defines a diagnostic as: -- @@ -232,13 +209,43 @@ constraint. -- -- A 'Diagnostic' carries the /actual/ description of the message (which, in -- GHC's case, it can be an error or a warning) and the /reason/ why such --- message was generated in the first place. See also Note [Rendering --- Messages]. +-- message was generated in the first place. class Diagnostic a where + -- | Extract the error message text from a 'Diagnostic'. diagnosticMessage :: a -> DecoratedSDoc + + -- | Extract the reason for this diagnostic. For warnings, + -- a 'DiagnosticReason' includes the warning flag diagnosticReason :: a -> DiagnosticReason + + -- | Extract any hints a user might use to repair their + -- code to avoid this diagnostic. diagnosticHints :: a -> [GhcHint] + -- | Get the 'DiagnosticCode' associated with this 'Diagnostic'. + -- This can return 'Nothing' for at least two reasons: + -- + -- 1. The message might be from a plugin that does not supply codes. + -- 2. The message might not yet have been assigned a code. See the + -- 'Diagnostic' instance for 'DiagnosticMessage'. + -- + -- Ideally, case (2) would not happen, but because + -- some errors in GHC still use the old system of just writing the + -- error message in-place (instead of using a dedicated error type + -- and constructor), we do not have error codes for all errors. + -- #18516 tracks our progress toward this goal. + diagnosticCode :: a -> Maybe DiagnosticCode + +-- | An existential wrapper around an unknown diagnostic. +data UnknownDiagnostic where + UnknownDiagnostic :: (Typeable diag, Diagnostic diag) => diag -> UnknownDiagnostic + +instance Diagnostic UnknownDiagnostic where + diagnosticMessage (UnknownDiagnostic diag) = diagnosticMessage diag + diagnosticReason (UnknownDiagnostic diag) = diagnosticReason diag + diagnosticHints (UnknownDiagnostic diag) = diagnosticHints diag + diagnosticCode (UnknownDiagnostic diag) = diagnosticCode diag + pprDiagnostic :: Diagnostic e => e -> SDoc pprDiagnostic e = vcat [ ppr (diagnosticReason e) , nest 2 (vcat (unDecorated (diagnosticMessage e))) ] @@ -264,6 +271,7 @@ instance Diagnostic DiagnosticMessage where diagnosticMessage = diagMessage diagnosticReason = diagReason diagnosticHints = diagHints + diagnosticCode _ = Nothing -- | Helper function to use when no hints can be provided. Currently this function -- can be used to construct plain 'DiagnosticMessage' and add hints to them, but @@ -344,7 +352,7 @@ data MessageClass -- ^ Log messages intended for end users. -- No file\/line\/column stuff. - | MCDiagnostic Severity DiagnosticReason + | MCDiagnostic Severity DiagnosticReason (Maybe DiagnosticCode) -- ^ Diagnostics from the compiler. This constructor is very powerful as -- it allows the construction of a 'MessageClass' with a completely -- arbitrary permutation of 'Severity' and 'DiagnosticReason'. As such, @@ -353,7 +361,11 @@ data MessageClass -- and manipulate diagnostic messages directly, for example inside -- 'GHC.Utils.Error'. In all the other circumstances, /especially/ when -- emitting compiler diagnostics, use the smart constructor. - deriving (Eq, Show) + -- + -- The @Maybe 'DiagnosticCode'@ field carries a code (if available) for + -- this diagnostic. If you are creating a message not tied to any + -- error-message type, then use Nothing. In the long run, this really + -- should always have a 'DiagnosticCode'. See Note [Diagnostic codes]. {- Note [Suppressing Messages] @@ -411,8 +423,8 @@ instance ToJson MessageClass where json MCInteractive = JSString "MCInteractive" json MCDump = JSString "MCDump" json MCInfo = JSString "MCInfo" - json (MCDiagnostic sev reason) = - JSString $ renderWithContext defaultSDocContext (ppr $ text "MCDiagnostic" <+> ppr sev <+> ppr reason) + json (MCDiagnostic sev reason code) = + JSString $ renderWithContext defaultSDocContext (ppr $ text "MCDiagnostic" <+> ppr sev <+> ppr reason <+> ppr code) instance Show (MsgEnvelope DiagnosticMessage) where show = showMsgEnvelope @@ -425,13 +437,17 @@ showMsgEnvelope err = pprMessageBag :: Bag SDoc -> SDoc pprMessageBag msgs = vcat (punctuate blankLine (bagToList msgs)) --- | Make an unannotated error message with location info. -mkLocMessage :: MessageClass -> SrcSpan -> SDoc -> SDoc -mkLocMessage = mkLocMessageAnn Nothing +mkLocMessage + :: MessageClass -- ^ What kind of message? + -> SrcSpan -- ^ location + -> SDoc -- ^ message + -> SDoc +mkLocMessage = mkLocMessageWarningGroups True --- | Make a possibly annotated error message with location info. -mkLocMessageAnn - :: Maybe String -- ^ optional annotation +-- | Make an error message with location info, specifying whether to show +-- warning groups (if applicable). +mkLocMessageWarningGroups + :: Bool -- ^ Print warning groups (if applicable)? -> MessageClass -- ^ What kind of message? -> SrcSpan -- ^ location -> SDoc -- ^ message @@ -439,41 +455,76 @@ mkLocMessageAnn -- Always print the location, even if it is unhelpful. Error messages -- are supposed to be in a standard format, and one without a location -- would look strange. Better to say explicitly "<no location info>". -mkLocMessageAnn ann msg_class locn msg +mkLocMessageWarningGroups show_warn_groups msg_class locn msg = sdocOption sdocColScheme $ \col_scheme -> let locn' = sdocOption sdocErrorSpans $ \case True -> ppr locn False -> ppr (srcSpanStart locn) - msgColour = getMessageClassColour msg_class col_scheme - - -- Add optional information - optAnn = case ann of - Nothing -> text "" - Just i -> text " [" <> coloured msgColour (text i) <> text "]" + msg_colour = getMessageClassColour msg_class col_scheme + col = coloured msg_colour . text + + msg_title = coloured msg_colour $ + case msg_class of + MCDiagnostic SevError _ _ -> text "error" + MCDiagnostic SevWarning _ _ -> text "warning" + MCFatal -> text "fatal" + _ -> empty + + warning_flag_doc = + case msg_class of + MCDiagnostic sev reason _code + | Just msg <- flag_msg sev reason -> brackets msg + _ -> empty + + code_doc = + case msg_class of + MCDiagnostic _ _ (Just code) -> brackets (coloured msg_colour $ ppr code) + _ -> empty + + flag_msg :: Severity -> DiagnosticReason -> Maybe SDoc + flag_msg SevIgnore _ = Nothing + -- The above can happen when displaying an error message + -- in a log file, e.g. with -ddump-tc-trace. It should not + -- happen otherwise, though. + flag_msg SevError WarningWithoutFlag = Just (col "-Werror") + flag_msg SevError (WarningWithFlag wflag) = + let name = NE.head (warnFlagNames wflag) in + Just $ col ("-W" ++ name) <+> warn_flag_grp wflag + <> comma + <+> col ("Werror=" ++ name) + flag_msg SevError ErrorWithoutFlag = Nothing + flag_msg SevWarning WarningWithoutFlag = Nothing + flag_msg SevWarning (WarningWithFlag wflag) = + let name = NE.head (warnFlagNames wflag) in + Just (col ("-W" ++ name) <+> warn_flag_grp wflag) + flag_msg SevWarning ErrorWithoutFlag = + pprPanic "SevWarning with ErrorWithoutFlag" $ + vcat [ text "locn:" <+> ppr locn + , text "msg:" <+> ppr msg ] + + warn_flag_grp flag + | show_warn_groups = + case smallestWarningGroups flag of + [] -> empty + groups -> text $ "(in " ++ intercalate ", " (map ("-W"++) groups) ++ ")" + | otherwise = empty -- Add prefixes, like Foo.hs:34: warning: -- <the warning message> header = locn' <> colon <+> - coloured msgColour msgText <> optAnn + msg_title <> colon <+> + code_doc <+> warning_flag_doc in coloured (Col.sMessage col_scheme) (hang (coloured (Col.sHeader col_scheme) header) 4 msg) - where - msgText = - case msg_class of - MCDiagnostic SevError _reason -> text "error:" - MCDiagnostic SevWarning _reason -> text "warning:" - MCFatal -> text "fatal:" - _ -> empty - getMessageClassColour :: MessageClass -> Col.Scheme -> Col.PprColour -getMessageClassColour (MCDiagnostic SevError _reason) = Col.sError -getMessageClassColour (MCDiagnostic SevWarning _reason) = Col.sWarning -getMessageClassColour MCFatal = Col.sFatal -getMessageClassColour _ = const mempty +getMessageClassColour (MCDiagnostic SevError _reason _code) = Col.sError +getMessageClassColour (MCDiagnostic SevWarning _reason _code) = Col.sWarning +getMessageClassColour MCFatal = Col.sFatal +getMessageClassColour _ = const mempty getCaretDiagnostic :: MessageClass -> SrcSpan -> IO SDoc getCaretDiagnostic _ (UnhelpfulSpan _) = pure empty @@ -603,3 +654,29 @@ getErrorMessages (Messages xs) = fst $ partitionBag isIntrinsicErrorMessage xs -- warnings, and the second the errors. partitionMessages :: Diagnostic e => Messages e -> (Messages e, Messages e) partitionMessages (Messages xs) = bimap Messages Messages (partitionBag isWarningMessage xs) + +---------------------------------------------------------------- +-- -- +-- Definition of diagnostic codes -- +-- -- +---------------------------------------------------------------- + +-- | A diagnostic code is a namespaced numeric identifier +-- unique to the given diagnostic (error or warning). +-- +-- All diagnostic codes defined within GHC are given the +-- GHC namespace. +-- +-- See Note [Diagnostic codes] in GHC.Types.Error.Codes. +data DiagnosticCode = + DiagnosticCode + { diagnosticCodeNameSpace :: String + -- ^ diagnostic code prefix (e.g. "GHC") + , diagnosticCodeNumber :: Natural + -- ^ the actual diagnostic code + } + +instance Outputable DiagnosticCode where + ppr (DiagnosticCode prefix c) = + text prefix <> text "-" <> text (printf "%05d" c) + -- pad the numeric code to have at least 5 digits diff --git a/compiler/GHC/Types/Error/Codes.hs b/compiler/GHC/Types/Error/Codes.hs new file mode 100644 index 0000000000..cb24cda08a --- /dev/null +++ b/compiler/GHC/Types/Error/Codes.hs @@ -0,0 +1,819 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | Defines diagnostic codes for the diagnostics emitted by GHC. +-- +-- A diagnostic code is a numeric unique identifier for a diagnostic. +-- See Note [Diagnostic codes]. +module GHC.Types.Error.Codes + ( constructorCode ) + where + +import GHC.Prelude +import GHC.Types.Error ( DiagnosticCode(..), UnknownDiagnostic (..), diagnosticCode ) + +import GHC.Hs.Extension ( GhcRn ) + +import GHC.Driver.Errors.Types ( DriverMessage ) +import GHC.Parser.Errors.Types ( PsMessage, PsHeaderMessage ) +import GHC.HsToCore.Errors.Types ( DsMessage ) +import GHC.Tc.Errors.Types +import GHC.Tc.Utils.TcType ( IllegalForeignTypeReason, TypeCannotBeMarshaledReason ) +import GHC.Unit.Module.Warnings ( WarningTxt ) +import GHC.Utils.Panic.Plain + +import Data.Kind ( Type, Constraint ) +import GHC.Exts ( proxy# ) +import GHC.Generics +import GHC.TypeLits ( Symbol, TypeError, ErrorMessage(..) ) +import GHC.TypeNats ( Nat, KnownNat, natVal' ) + +{- Note [Diagnostic codes] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Every time a new diagnostic (error or warning) is introduced to GHC, +it is assigned a new numeric code, which has never been used before. + +To ensure uniqueness across GHC versions, we proceed as follows: + + - all diagnostic codes are defined in a single module, GHC.Types.Error.Codes. + - uniqueness of diagnostic codes is ensured by the use of an injective type family, + GhcDiagnosticCode, + - a diagnostic code never gets deleted from the GhcDiagnosticCode type family + in GHC.Types.Error.Codes, even if it is no longer used. + Older versions of GHC might still display the code, and we don't want that + old code to get confused with the error code of a different, new, error message. + +[Instructions for adding a new diagnostic code] + + After adding a constructor to a diagnostic datatype, such as PsMessage, + TcRnMessage, DsMessage or DriverMessage, you can add corresponding + diagnostic codes as follows: + + a. To give a single diagnostic code to the constructor, simply add a + type family equation to GHC.Error.Codes.GhcDiagnosticCode, e.g.: + + GhcDiagnosticCode "MyNewErrorConstructor" = 12345 + + You can obtain new randomly-generated error codes by using + https://www.random.org/integers/?num=10&min=1&max=99999&col=1&base=10&format=plain. + + You will get a type error if you try to use an error code that is already + used by another constructor. + + b. If you instead require more granular diagnostic codes, add a type family + equation to GHC.Error.Codes.ConRecursInto, specifying which argument + to recur into to obtain an diagnostic code. + + For example, the 'TcRnCannotDeriveInstance' constructor is associated + with several diagnostic codes, depending on the value of the argument of + type 'DeriveInstanceErrReason'. This is achieved as follows: + + - The equation + ConRecursInto "TcRnCannotDeriveInstance" = 'Just DeriveInstanceErrReason + says to recur into the argument of type 'DeriveInstanceErrReason' + to get a diagnostic code. + + - The equations + GhcDiagnosticCode "DerivErrNotWellKinded" = 62016 + GhcDiagnosticCode "DerivErrSafeHaskellGenericInst" = 07214 + GhcDiagnosticCode "DerivErrDerivingViaWrongKind" = 63174 + ... + give the diagnostic codes for the various constructors of DeriveInstanceErrReason. + These are added following the procedure in (a). + + Never remove a return value from the 'GhcDiagnosticCode' type family! + Outdated error messages must still be tracked to ensure uniqueness + of diagnostic codes across GHC versions. +-} + +{- ********************************************************************* +* * + The GhcDiagnosticCode type family +* * +********************************************************************* -} + +-- | This function obtain a diagnostic code by looking up the constructor +-- name using generics, and using the 'GhcDiagnosticCode' type family. +constructorCode :: (Generic diag, GDiagnosticCode (Rep diag)) + => diag -> Maybe DiagnosticCode +constructorCode diag = gdiagnosticCode (from diag) + +-- | Type family computing the numeric diagnostic code for a given error message constructor. +-- +-- Its injectivity annotation ensures uniqueness of error codes. +-- +-- Never remove a return value from this type family! Outdated error messages must still +-- be tracked here to ensure uniqueness of diagnostic codes across GHC versions. +-- +-- See Note [Diagnostic codes] in GHC.Types.Error. +type GhcDiagnosticCode :: Symbol -> Nat +type family GhcDiagnosticCode c = n | n -> c where + + -- Desugarer diagnostic codes + GhcDiagnosticCode "DsEmptyEnumeration" = 10190 + GhcDiagnosticCode "DsIdentitiesFound" = 04214 + GhcDiagnosticCode "DsOverflowedLiterals" = 97441 + GhcDiagnosticCode "DsRedundantBangPatterns" = 38520 + GhcDiagnosticCode "DsOverlappingPatterns" = 53633 + GhcDiagnosticCode "DsInaccessibleRhs" = 94210 + GhcDiagnosticCode "DsMaxPmCheckModelsReached" = 61505 + GhcDiagnosticCode "DsNonExhaustivePatterns" = 62161 + GhcDiagnosticCode "DsTopLevelBindsNotAllowed" = 48099 + GhcDiagnosticCode "DsUselessSpecialiseForClassMethodSelector" = 93315 + GhcDiagnosticCode "DsUselessSpecialiseForNoInlineFunction" = 38524 + GhcDiagnosticCode "DsMultiplicityCoercionsNotSupported" = 59840 + GhcDiagnosticCode "DsOrphanRule" = 58181 + GhcDiagnosticCode "DsRuleLhsTooComplicated" = 69441 + GhcDiagnosticCode "DsRuleIgnoredDueToConstructor" = 00828 + GhcDiagnosticCode "DsRuleBindersNotBound" = 40548 + GhcDiagnosticCode "DsMultipleConForNewtype" = 05380 + GhcDiagnosticCode "DsLazyPatCantBindVarsOfUnliftedType" = 17879 + GhcDiagnosticCode "DsNotYetHandledByTH" = 65904 + GhcDiagnosticCode "DsAggregatedViewExpressions" = 19551 + GhcDiagnosticCode "DsUnbangedStrictPatterns" = 21030 + GhcDiagnosticCode "DsCannotMixPolyAndUnliftedBindings" = 20036 + GhcDiagnosticCode "DsWrongDoBind" = 08838 + GhcDiagnosticCode "DsUnusedDoBind" = 81995 + GhcDiagnosticCode "DsRecBindsNotAllowedForUnliftedTys" = 20185 + GhcDiagnosticCode "DsRuleMightInlineFirst" = 95396 + GhcDiagnosticCode "DsAnotherRuleMightFireFirst" = 87502 + + + -- Parser diagnostic codes + GhcDiagnosticCode "PsErrParseLanguagePragma" = 68686 + GhcDiagnosticCode "PsErrUnsupportedExt" = 46537 + GhcDiagnosticCode "PsErrParseOptionsPragma" = 24342 + GhcDiagnosticCode "PsErrUnknownOptionsPragma" = 04924 + GhcDiagnosticCode "PsWarnBidirectionalFormatChars" = 03272 + GhcDiagnosticCode "PsWarnTab" = 94817 + GhcDiagnosticCode "PsWarnTransitionalLayout" = 93617 + GhcDiagnosticCode "PsWarnOperatorWhitespaceExtConflict" = 47082 + GhcDiagnosticCode "PsWarnOperatorWhitespace" = 40798 + GhcDiagnosticCode "PsWarnHaddockInvalidPos" = 94458 + GhcDiagnosticCode "PsWarnHaddockIgnoreMulti" = 05641 + GhcDiagnosticCode "PsWarnStarBinder" = 21887 + GhcDiagnosticCode "PsWarnStarIsType" = 39567 + GhcDiagnosticCode "PsWarnUnrecognisedPragma" = 42044 + GhcDiagnosticCode "PsWarnMisplacedPragma" = 28007 + GhcDiagnosticCode "PsWarnImportPreQualified" = 07924 + GhcDiagnosticCode "PsErrLexer" = 21231 + GhcDiagnosticCode "PsErrCmmLexer" = 75725 + GhcDiagnosticCode "PsErrCmmParser" = 09848 + GhcDiagnosticCode "PsErrParse" = 58481 + GhcDiagnosticCode "PsErrTypeAppWithoutSpace" = 84077 + GhcDiagnosticCode "PsErrLazyPatWithoutSpace" = 27207 + GhcDiagnosticCode "PsErrBangPatWithoutSpace" = 95644 + GhcDiagnosticCode "PsErrInvalidInfixHole" = 45106 + GhcDiagnosticCode "PsErrExpectedHyphen" = 44524 + GhcDiagnosticCode "PsErrSpaceInSCC" = 76176 + GhcDiagnosticCode "PsErrEmptyDoubleQuotes" = 11861 + GhcDiagnosticCode "PsErrLambdaCase" = 51179 + GhcDiagnosticCode "PsErrEmptyLambda" = 71614 + GhcDiagnosticCode "PsErrLinearFunction" = 31574 + GhcDiagnosticCode "PsErrMultiWayIf" = 28985 + GhcDiagnosticCode "PsErrOverloadedRecordUpdateNotEnabled" = 82135 + GhcDiagnosticCode "PsErrNumUnderscores" = 62330 + GhcDiagnosticCode "PsErrIllegalBangPattern" = 79767 + GhcDiagnosticCode "PsErrOverloadedRecordDotInvalid" = 26832 + GhcDiagnosticCode "PsErrIllegalPatSynExport" = 89515 + GhcDiagnosticCode "PsErrOverloadedRecordUpdateNoQualifiedFields" = 94863 + GhcDiagnosticCode "PsErrExplicitForall" = 25955 + GhcDiagnosticCode "PsErrIllegalQualifiedDo" = 40280 + GhcDiagnosticCode "PsErrQualifiedDoInCmd" = 54089 + GhcDiagnosticCode "PsErrRecordSyntaxInPatSynDecl" = 28021 + GhcDiagnosticCode "PsErrEmptyWhereInPatSynDecl" = 13248 + GhcDiagnosticCode "PsErrInvalidWhereBindInPatSynDecl" = 24737 + GhcDiagnosticCode "PsErrNoSingleWhereBindInPatSynDecl" = 65536 + GhcDiagnosticCode "PsErrDeclSpliceNotAtTopLevel" = 08451 + GhcDiagnosticCode "PsErrMultipleNamesInStandaloneKindSignature" = 42569 + GhcDiagnosticCode "PsErrIllegalExplicitNamespace" = 47007 + GhcDiagnosticCode "PsErrUnallowedPragma" = 85314 + GhcDiagnosticCode "PsErrImportPostQualified" = 87491 + GhcDiagnosticCode "PsErrImportQualifiedTwice" = 05661 + GhcDiagnosticCode "PsErrIllegalImportBundleForm" = 81284 + GhcDiagnosticCode "PsErrInvalidRuleActivationMarker" = 50396 + GhcDiagnosticCode "PsErrMissingBlock" = 16849 + GhcDiagnosticCode "PsErrUnsupportedBoxedSumExpr" = 09550 + GhcDiagnosticCode "PsErrUnsupportedBoxedSumPat" = 16863 + GhcDiagnosticCode "PsErrUnexpectedQualifiedConstructor" = 73413 + GhcDiagnosticCode "PsErrTupleSectionInPat" = 09646 + GhcDiagnosticCode "PsErrOpFewArgs" = 24180 + GhcDiagnosticCode "PsErrVarForTyCon" = 18208 + GhcDiagnosticCode "PsErrMalformedEntityString" = 26204 + GhcDiagnosticCode "PsErrDotsInRecordUpdate" = 70712 + GhcDiagnosticCode "PsErrInvalidDataCon" = 46574 + GhcDiagnosticCode "PsErrInvalidInfixDataCon" = 30670 + GhcDiagnosticCode "PsErrIllegalPromotionQuoteDataCon" = 80236 + GhcDiagnosticCode "PsErrUnpackDataCon" = 40845 + GhcDiagnosticCode "PsErrUnexpectedKindAppInDataCon" = 83653 + GhcDiagnosticCode "PsErrInvalidRecordCon" = 08195 + GhcDiagnosticCode "PsErrIllegalUnboxedStringInPat" = 69925 + GhcDiagnosticCode "PsErrIllegalUnboxedFloatingLitInPat" = 76595 + GhcDiagnosticCode "PsErrDoNotationInPat" = 06446 + GhcDiagnosticCode "PsErrIfThenElseInPat" = 45696 + GhcDiagnosticCode "PsErrLambdaCaseInPat" = 07636 + GhcDiagnosticCode "PsErrCaseInPat" = 53786 + GhcDiagnosticCode "PsErrLetInPat" = 78892 + GhcDiagnosticCode "PsErrLambdaInPat" = 00482 + GhcDiagnosticCode "PsErrArrowExprInPat" = 04584 + GhcDiagnosticCode "PsErrArrowCmdInPat" = 98980 + GhcDiagnosticCode "PsErrArrowCmdInExpr" = 66043 + GhcDiagnosticCode "PsErrViewPatInExpr" = 66228 + GhcDiagnosticCode "PsErrLambdaCmdInFunAppCmd" = 12178 + GhcDiagnosticCode "PsErrCaseCmdInFunAppCmd" = 92971 + GhcDiagnosticCode "PsErrLambdaCaseCmdInFunAppCmd" = 47171 + GhcDiagnosticCode "PsErrIfCmdInFunAppCmd" = 97005 + GhcDiagnosticCode "PsErrLetCmdInFunAppCmd" = 70526 + GhcDiagnosticCode "PsErrDoCmdInFunAppCmd" = 77808 + GhcDiagnosticCode "PsErrDoInFunAppExpr" = 52095 + GhcDiagnosticCode "PsErrMDoInFunAppExpr" = 67630 + GhcDiagnosticCode "PsErrLambdaInFunAppExpr" = 06074 + GhcDiagnosticCode "PsErrCaseInFunAppExpr" = 25037 + GhcDiagnosticCode "PsErrLambdaCaseInFunAppExpr" = 77182 + GhcDiagnosticCode "PsErrLetInFunAppExpr" = 90355 + GhcDiagnosticCode "PsErrIfInFunAppExpr" = 01239 + GhcDiagnosticCode "PsErrProcInFunAppExpr" = 04807 + GhcDiagnosticCode "PsErrMalformedTyOrClDecl" = 47568 + GhcDiagnosticCode "PsErrIllegalWhereInDataDecl" = 36952 + GhcDiagnosticCode "PsErrIllegalDataTypeContext" = 87429 + GhcDiagnosticCode "PsErrPrimStringInvalidChar" = 43080 + GhcDiagnosticCode "PsErrSuffixAT" = 33856 + GhcDiagnosticCode "PsErrPrecedenceOutOfRange" = 25078 + GhcDiagnosticCode "PsErrSemiColonsInCondExpr" = 75254 + GhcDiagnosticCode "PsErrSemiColonsInCondCmd" = 18910 + GhcDiagnosticCode "PsErrAtInPatPos" = 08382 + GhcDiagnosticCode "PsErrParseErrorOnInput" = 66418 + GhcDiagnosticCode "PsErrMalformedDecl" = 85316 + GhcDiagnosticCode "PsErrUnexpectedTypeAppInDecl" = 45054 + GhcDiagnosticCode "PsErrNotADataCon" = 25742 + GhcDiagnosticCode "PsErrInferredTypeVarNotAllowed" = 57342 + GhcDiagnosticCode "PsErrIllegalTraditionalRecordSyntax" = 65719 + GhcDiagnosticCode "PsErrParseErrorInCmd" = 03790 + GhcDiagnosticCode "PsErrInPat" = 07626 + GhcDiagnosticCode "PsErrIllegalRoleName" = 09009 + GhcDiagnosticCode "PsErrInvalidTypeSignature" = 94426 + GhcDiagnosticCode "PsErrUnexpectedTypeInDecl" = 77878 + GhcDiagnosticCode "PsErrInvalidPackageName" = 21926 + GhcDiagnosticCode "PsErrParseRightOpSectionInPat" = 72516 + GhcDiagnosticCode "PsErrIllegalGadtRecordMultiplicity" = 37475 + GhcDiagnosticCode "PsErrInvalidCApiImport" = 72744 + + -- Driver diagnostic codes + GhcDiagnosticCode "DriverMissingHomeModules" = 32850 + GhcDiagnosticCode "DriverUnknownHiddenModules" = 38189 + GhcDiagnosticCode "DriverUnknownReexportedModules" = 68286 + GhcDiagnosticCode "DriverUnusedPackages" = 42258 + GhcDiagnosticCode "DriverUnnecessarySourceImports" = 88907 + GhcDiagnosticCode "DriverDuplicatedModuleDeclaration" = 29235 + GhcDiagnosticCode "DriverModuleNotFound" = 82272 + GhcDiagnosticCode "DriverFileModuleNameMismatch" = 28623 + GhcDiagnosticCode "DriverUnexpectedSignature" = 66004 + GhcDiagnosticCode "DriverFileNotFound" = 49196 + GhcDiagnosticCode "DriverStaticPointersNotSupported" = 77799 + GhcDiagnosticCode "DriverBackpackModuleNotFound" = 19971 + GhcDiagnosticCode "DriverUserDefinedRuleIgnored" = 56147 + GhcDiagnosticCode "DriverMixedSafetyImport" = 70172 + GhcDiagnosticCode "DriverCannotLoadInterfaceFile" = 37141 + GhcDiagnosticCode "DriverInferredSafeModule" = 58656 + GhcDiagnosticCode "DriverMarkedTrustworthyButInferredSafe" = 19244 + GhcDiagnosticCode "DriverInferredSafeImport" = 82658 + GhcDiagnosticCode "DriverCannotImportUnsafeModule" = 44360 + GhcDiagnosticCode "DriverMissingSafeHaskellMode" = 29747 + GhcDiagnosticCode "DriverPackageNotTrusted" = 08674 + GhcDiagnosticCode "DriverCannotImportFromUntrustedPackage" = 75165 + GhcDiagnosticCode "DriverRedirectedNoMain" = 95379 + GhcDiagnosticCode "DriverHomePackagesNotClosed" = 03271 + + -- Constraint solver diagnostic codes + GhcDiagnosticCode "BadTelescope" = 97739 + GhcDiagnosticCode "UserTypeError" = 64725 + GhcDiagnosticCode "ReportHoleError" = 88464 + GhcDiagnosticCode "UntouchableVariable" = 34699 + GhcDiagnosticCode "FixedRuntimeRepError" = 55287 + GhcDiagnosticCode "BlockedEquality" = 06200 + GhcDiagnosticCode "ExpectingMoreArguments" = 81325 + GhcDiagnosticCode "UnboundImplicitParams" = 91416 + GhcDiagnosticCode "AmbiguityPreventsSolvingCt" = 78125 + GhcDiagnosticCode "CannotResolveInstance" = 39999 + GhcDiagnosticCode "OverlappingInstances" = 43085 + GhcDiagnosticCode "UnsafeOverlap" = 36705 + + -- Type mismatch errors + GhcDiagnosticCode "BasicMismatch" = 18872 + GhcDiagnosticCode "KindMismatch" = 89223 + GhcDiagnosticCode "TypeEqMismatch" = 83865 + GhcDiagnosticCode "CouldNotDeduce" = 05617 + + -- Variable unification errors + GhcDiagnosticCode "CannotUnifyWithPolytype" = 91028 + GhcDiagnosticCode "OccursCheck" = 27958 + GhcDiagnosticCode "SkolemEscape" = 46956 + GhcDiagnosticCode "DifferentTyVars" = 25897 + GhcDiagnosticCode "RepresentationalEq" = 10283 + + -- Typechecker/renamer diagnostic codes + GhcDiagnosticCode "TcRnRedundantConstraints" = 30606 + GhcDiagnosticCode "TcRnInaccessibleCode" = 40564 + GhcDiagnosticCode "TcRnTypeDoesNotHaveFixedRuntimeRep" = 18478 + GhcDiagnosticCode "TcRnImplicitLift" = 00846 + GhcDiagnosticCode "TcRnUnusedPatternBinds" = 61367 + GhcDiagnosticCode "TcRnDodgyImports" = 99623 + GhcDiagnosticCode "TcRnDodgyExports" = 75356 + GhcDiagnosticCode "TcRnMissingImportList" = 77037 + GhcDiagnosticCode "TcRnUnsafeDueToPlugin" = 01687 + GhcDiagnosticCode "TcRnModMissingRealSrcSpan" = 84170 + GhcDiagnosticCode "TcRnIdNotExportedFromModuleSig" = 44188 + GhcDiagnosticCode "TcRnIdNotExportedFromLocalSig" = 50058 + GhcDiagnosticCode "TcRnShadowedName" = 63397 + GhcDiagnosticCode "TcRnDuplicateWarningDecls" = 00711 + GhcDiagnosticCode "TcRnSimplifierTooManyIterations" = 95822 + GhcDiagnosticCode "TcRnIllegalPatSynDecl" = 82077 + GhcDiagnosticCode "TcRnLinearPatSyn" = 15172 + GhcDiagnosticCode "TcRnEmptyRecordUpdate" = 20825 + GhcDiagnosticCode "TcRnIllegalFieldPunning" = 44287 + GhcDiagnosticCode "TcRnIllegalWildcardsInRecord" = 37132 + GhcDiagnosticCode "TcRnIllegalWildcardInType" = 65507 + GhcDiagnosticCode "TcRnDuplicateFieldName" = 85524 + GhcDiagnosticCode "TcRnIllegalViewPattern" = 22406 + GhcDiagnosticCode "TcRnCharLiteralOutOfRange" = 17268 + GhcDiagnosticCode "TcRnIllegalWildcardsInConstructor" = 47217 + GhcDiagnosticCode "TcRnIgnoringAnnotations" = 66649 + GhcDiagnosticCode "TcRnAnnotationInSafeHaskell" = 68934 + GhcDiagnosticCode "TcRnInvalidTypeApplication" = 95781 + GhcDiagnosticCode "TcRnTagToEnumMissingValArg" = 36495 + GhcDiagnosticCode "TcRnTagToEnumUnspecifiedResTy" = 08522 + GhcDiagnosticCode "TcRnTagToEnumResTyNotAnEnum" = 49356 + GhcDiagnosticCode "TcRnArrowIfThenElsePredDependsOnResultTy" = 55868 + GhcDiagnosticCode "TcRnIllegalHsBootFileDecl" = 58195 + GhcDiagnosticCode "TcRnRecursivePatternSynonym" = 72489 + GhcDiagnosticCode "TcRnPartialTypeSigTyVarMismatch" = 88793 + GhcDiagnosticCode "TcRnPartialTypeSigBadQuantifier" = 94185 + GhcDiagnosticCode "TcRnMissingSignature" = 38417 + GhcDiagnosticCode "TcRnPolymorphicBinderMissingSig" = 64414 + GhcDiagnosticCode "TcRnOverloadedSig" = 16675 + GhcDiagnosticCode "TcRnTupleConstraintInst" = 69012 + GhcDiagnosticCode "TcRnAbstractClassInst" = 51758 + GhcDiagnosticCode "TcRnNoClassInstHead" = 56538 + GhcDiagnosticCode "TcRnUserTypeError" = 47403 + GhcDiagnosticCode "TcRnConstraintInKind" = 01259 + GhcDiagnosticCode "TcRnUnboxedTupleOrSumTypeFuncArg" = 19590 + GhcDiagnosticCode "TcRnLinearFuncInKind" = 13218 + GhcDiagnosticCode "TcRnForAllEscapeError" = 31147 + GhcDiagnosticCode "TcRnVDQInTermType" = 51580 + GhcDiagnosticCode "TcRnBadQuantPredHead" = 02550 + GhcDiagnosticCode "TcRnIllegalTupleConstraint" = 77539 + GhcDiagnosticCode "TcRnNonTypeVarArgInConstraint" = 80003 + GhcDiagnosticCode "TcRnIllegalImplicitParam" = 75863 + GhcDiagnosticCode "TcRnIllegalConstraintSynonymOfKind" = 75844 + GhcDiagnosticCode "TcRnIllegalClassInst" = 53946 + GhcDiagnosticCode "TcRnOversaturatedVisibleKindArg" = 45474 + GhcDiagnosticCode "TcRnBadAssociatedType" = 38351 + GhcDiagnosticCode "TcRnForAllRankErr" = 91510 + GhcDiagnosticCode "TcRnMonomorphicBindings" = 55524 + GhcDiagnosticCode "TcRnOrphanInstance" = 90177 + GhcDiagnosticCode "TcRnFunDepConflict" = 46208 + GhcDiagnosticCode "TcRnDupInstanceDecls" = 59692 + GhcDiagnosticCode "TcRnConflictingFamInstDecls" = 34447 + GhcDiagnosticCode "TcRnFamInstNotInjective" = 05175 + GhcDiagnosticCode "TcRnBangOnUnliftedType" = 55666 + GhcDiagnosticCode "TcRnLazyBangOnUnliftedType" = 71444 + GhcDiagnosticCode "TcRnMultipleDefaultDeclarations" = 99565 + GhcDiagnosticCode "TcRnBadDefaultType" = 88933 + GhcDiagnosticCode "TcRnPatSynBundledWithNonDataCon" = 66775 + GhcDiagnosticCode "TcRnPatSynBundledWithWrongType" = 66025 + GhcDiagnosticCode "TcRnDupeModuleExport" = 51876 + GhcDiagnosticCode "TcRnExportedModNotImported" = 90973 + GhcDiagnosticCode "TcRnNullExportedModule" = 64649 + GhcDiagnosticCode "TcRnMissingExportList" = 85401 + GhcDiagnosticCode "TcRnExportHiddenComponents" = 94558 + GhcDiagnosticCode "TcRnDuplicateExport" = 47854 + GhcDiagnosticCode "TcRnExportedParentChildMismatch" = 88993 + GhcDiagnosticCode "TcRnConflictingExports" = 69158 + GhcDiagnosticCode "TcRnAmbiguousField" = 02256 + GhcDiagnosticCode "TcRnMissingFields" = 20125 + GhcDiagnosticCode "TcRnFieldUpdateInvalidType" = 63055 + GhcDiagnosticCode "TcRnNoConstructorHasAllFields" = 14392 + GhcDiagnosticCode "TcRnMixedSelectors" = 40887 + GhcDiagnosticCode "TcRnMissingStrictFields" = 95909 + GhcDiagnosticCode "TcRnNoPossibleParentForFields" = 33238 + GhcDiagnosticCode "TcRnBadOverloadedRecordUpdate" = 99339 + GhcDiagnosticCode "TcRnStaticFormNotClosed" = 88431 + GhcDiagnosticCode "TcRnUselessTypeable" = 90584 + GhcDiagnosticCode "TcRnDerivingDefaults" = 20042 + GhcDiagnosticCode "TcRnNonUnaryTypeclassConstraint" = 73993 + GhcDiagnosticCode "TcRnPartialTypeSignatures" = 60661 + GhcDiagnosticCode "TcRnLazyGADTPattern" = 87005 + GhcDiagnosticCode "TcRnArrowProcGADTPattern" = 64525 + GhcDiagnosticCode "TcRnSpecialClassInst" = 97044 + GhcDiagnosticCode "TcRnForallIdentifier" = 64088 + GhcDiagnosticCode "TcRnTypeEqualityOutOfScope" = 12003 + GhcDiagnosticCode "TcRnTypeEqualityRequiresOperators" = 58520 + GhcDiagnosticCode "TcRnIllegalTypeOperator" = 62547 + GhcDiagnosticCode "TcRnGADTMonoLocalBinds" = 58008 + GhcDiagnosticCode "TcRnIncorrectNameSpace" = 31891 + + GhcDiagnosticCode "TcRnUntickedPromotedThing" = 49957 + GhcDiagnosticCode "TcRnIllegalBuiltinSyntax" = 39716 + GhcDiagnosticCode "TcRnWarnDefaulting" = 18042 + GhcDiagnosticCode "TcRnForeignImportPrimExtNotSet" = 49692 + GhcDiagnosticCode "TcRnForeignImportPrimSafeAnn" = 26133 + GhcDiagnosticCode "TcRnForeignFunctionImportAsValue" = 76251 + GhcDiagnosticCode "TcRnFunPtrImportWithoutAmpersand" = 57989 + GhcDiagnosticCode "TcRnIllegalForeignDeclBackend" = 03355 + GhcDiagnosticCode "TcRnUnsupportedCallConv" = 01245 + GhcDiagnosticCode "TcRnInvalidCIdentifier" = 95774 + GhcDiagnosticCode "TcRnExpectedValueId" = 01570 + GhcDiagnosticCode "TcRnNotARecordSelector" = 47535 + GhcDiagnosticCode "TcRnRecSelectorEscapedTyVar" = 55876 + GhcDiagnosticCode "TcRnPatSynNotBidirectional" = 16444 + GhcDiagnosticCode "TcRnSplicePolymorphicLocalVar" = 06568 + GhcDiagnosticCode "TcRnIllegalDerivingItem" = 11913 + GhcDiagnosticCode "TcRnUnexpectedAnnotation" = 18932 + GhcDiagnosticCode "TcRnIllegalRecordSyntax" = 89246 + GhcDiagnosticCode "TcRnUnexpectedTypeSplice" = 39180 + GhcDiagnosticCode "TcRnInvalidVisibleKindArgument" = 20967 + GhcDiagnosticCode "TcRnTooManyBinders" = 05989 + GhcDiagnosticCode "TcRnDifferentNamesForTyVar" = 17370 + GhcDiagnosticCode "TcRnInvalidReturnKind" = 55233 + GhcDiagnosticCode "TcRnClassKindNotConstraint" = 80768 + GhcDiagnosticCode "TcRnUnpromotableThing" = 88634 + GhcDiagnosticCode "TcRnMatchesHaveDiffNumArgs" = 91938 + GhcDiagnosticCode "TcRnCannotBindScopedTyVarInPatSig" = 46131 + GhcDiagnosticCode "TcRnCannotBindTyVarsInPatBind" = 48361 + GhcDiagnosticCode "TcRnTooManyTyArgsInConPattern" = 01629 + GhcDiagnosticCode "TcRnMultipleInlinePragmas" = 96665 + GhcDiagnosticCode "TcRnUnexpectedPragmas" = 88293 + GhcDiagnosticCode "TcRnNonOverloadedSpecialisePragma" = 35827 + GhcDiagnosticCode "TcRnSpecialiseNotVisible" = 85337 + GhcDiagnosticCode "TcRnIllegalTypeOperatorDecl" = 50649 + GhcDiagnosticCode "TcRnNameByTemplateHaskellQuote" = 40027 + GhcDiagnosticCode "TcRnIllegalBindingOfBuiltIn" = 69639 + + GhcDiagnosticCode "TcRnIllegalHsigDefaultMethods" = 93006 + GhcDiagnosticCode "TcRnBadGenericMethod" = 59794 + GhcDiagnosticCode "TcRnWarningMinimalDefIncomplete" = 13511 + GhcDiagnosticCode "TcRnDefaultMethodForPragmaLacksBinding" = 28587 + GhcDiagnosticCode "TcRnIgnoreSpecialisePragmaOnDefMethod" = 72520 + GhcDiagnosticCode "TcRnBadMethodErr" = 46284 + GhcDiagnosticCode "TcRnNoExplicitAssocTypeOrDefaultDeclaration" = 08585 + + -- TcRnPragmaWarning + GhcDiagnosticCode "WarningTxt" = 63394 + GhcDiagnosticCode "DeprecatedTxt" = 68441 + + -- Diagnostic codes for the foreign function interface + GhcDiagnosticCode "NotADataType" = 31136 + GhcDiagnosticCode "NewtypeDataConNotInScope" = 72317 + GhcDiagnosticCode "UnliftedFFITypesNeeded" = 10964 + GhcDiagnosticCode "NotABoxedMarshalableTyCon" = 89401 + GhcDiagnosticCode "ForeignLabelNotAPtr" = 26070 + GhcDiagnosticCode "NotSimpleUnliftedType" = 43510 + GhcDiagnosticCode "NotBoxedKindAny" = 64097 + GhcDiagnosticCode "ForeignDynNotPtr" = 27555 + GhcDiagnosticCode "SafeHaskellMustBeInIO" = 57638 + GhcDiagnosticCode "IOResultExpected" = 41843 + GhcDiagnosticCode "UnexpectedNestedForall" = 92994 + GhcDiagnosticCode "LinearTypesNotAllowed" = 57396 + GhcDiagnosticCode "OneArgExpected" = 91490 + GhcDiagnosticCode "AtLeastOneArgExpected" = 07641 + + -- Out of scope errors + GhcDiagnosticCode "NotInScope" = 76037 + GhcDiagnosticCode "NoExactName" = 97784 + GhcDiagnosticCode "SameName" = 81573 + GhcDiagnosticCode "MissingBinding" = 44432 + GhcDiagnosticCode "NoTopLevelBinding" = 10173 + GhcDiagnosticCode "UnknownSubordinate" = 54721 + + -- Diagnostic codes for deriving + GhcDiagnosticCode "DerivErrNotWellKinded" = 62016 + GhcDiagnosticCode "DerivErrSafeHaskellGenericInst" = 07214 + GhcDiagnosticCode "DerivErrDerivingViaWrongKind" = 63174 + GhcDiagnosticCode "DerivErrNoEtaReduce" = 38996 + GhcDiagnosticCode "DerivErrBootFileFound" = 30903 + GhcDiagnosticCode "DerivErrDataConsNotAllInScope" = 54540 + GhcDiagnosticCode "DerivErrGNDUsedOnData" = 10333 + GhcDiagnosticCode "DerivErrNullaryClasses" = 04956 + GhcDiagnosticCode "DerivErrLastArgMustBeApp" = 28323 + GhcDiagnosticCode "DerivErrNoFamilyInstance" = 82614 + GhcDiagnosticCode "DerivErrNotStockDeriveable" = 00158 + GhcDiagnosticCode "DerivErrHasAssociatedDatatypes" = 34611 + GhcDiagnosticCode "DerivErrNewtypeNonDeriveableClass" = 82023 + GhcDiagnosticCode "DerivErrCannotEtaReduceEnough" = 26557 + GhcDiagnosticCode "DerivErrOnlyAnyClassDeriveable" = 23244 + GhcDiagnosticCode "DerivErrNotDeriveable" = 38178 + GhcDiagnosticCode "DerivErrNotAClass" = 63388 + GhcDiagnosticCode "DerivErrNoConstructors" = 64560 + GhcDiagnosticCode "DerivErrLangExtRequired" = 86639 + GhcDiagnosticCode "DerivErrDunnoHowToDeriveForType" = 48959 + GhcDiagnosticCode "DerivErrMustBeEnumType" = 30750 + GhcDiagnosticCode "DerivErrMustHaveExactlyOneConstructor" = 37542 + GhcDiagnosticCode "DerivErrMustHaveSomeParameters" = 45539 + GhcDiagnosticCode "DerivErrMustNotHaveClassContext" = 16588 + GhcDiagnosticCode "DerivErrBadConstructor" = 16437 + GhcDiagnosticCode "DerivErrGenerics" = 30367 + GhcDiagnosticCode "DerivErrEnumOrProduct" = 58291 + + -- To generate new random numbers: + -- https://www.random.org/integers/?num=10&min=1&max=99999&col=1&base=10&format=plain + -- + -- NB: never remove a return value from this type family! + -- We need to ensure uniquess of diagnostic codes across GHC versions, + -- and this includes outdated diagnostic codes for errors that GHC + -- no longer reports. These are collected below. + + GhcDiagnosticCode "Example outdated error" = 00000 + +{- ********************************************************************* +* * + Recurring into an argument +* * +********************************************************************* -} + +-- | Some constructors of diagnostic datatypes don't have +-- corresponding error codes, because we recur inside them. +-- +-- For example, we don't have an error code for the +-- 'TcRnCannotDeriveInstance' constructor of 'TcRnMessage', +-- because we recur into the 'DeriveInstanceErrReason' to obtain +-- an error code. +-- +-- This type family keeps track of such constructors. +type ConRecursInto :: Symbol -> Maybe Type +type family ConRecursInto con where + + ---------------------------------- + -- Constructors of GhcMessage + + ConRecursInto "GhcDriverMessage" = 'Just DriverMessage + ConRecursInto "GhcPsMessage" = 'Just PsMessage + ConRecursInto "GhcTcRnMessage" = 'Just TcRnMessage + ConRecursInto "GhcDsMessage" = 'Just DsMessage + ConRecursInto "GhcUnknownMessage" = 'Just UnknownDiagnostic + + ---------------------------------- + -- Constructors of DriverMessage + + ConRecursInto "DriverUnknownMessage" = 'Just UnknownDiagnostic + ConRecursInto "DriverPsHeaderMessage" = 'Just PsMessage + + ---------------------------------- + -- Constructors of PsMessage + + ConRecursInto "PsUnknownMessage" = 'Just UnknownDiagnostic + ConRecursInto "PsHeaderMessage" = 'Just PsHeaderMessage + + ---------------------------------- + -- Constructors of TcRnMessage + + ConRecursInto "TcRnUnknownMessage" = 'Just UnknownDiagnostic + + -- Recur into TcRnMessageWithInfo to get the underlying TcRnMessage + ConRecursInto "TcRnMessageWithInfo" = 'Just TcRnMessageDetailed + ConRecursInto "TcRnMessageDetailed" = 'Just TcRnMessage + + ConRecursInto "TcRnCannotDeriveInstance" = 'Just DeriveInstanceErrReason + ConRecursInto "TcRnPragmaWarning" = 'Just (WarningTxt GhcRn) + ConRecursInto "TcRnNotInScope" = 'Just NotInScopeError + + ------------------ + -- FFI errors + + ConRecursInto "TcRnIllegalForeignType" = 'Just IllegalForeignTypeReason + -- IllegalForeignTypeReason: recur into TypeCannotBeMarshaled for the reason + ConRecursInto "TypeCannotBeMarshaled" = 'Just TypeCannotBeMarshaledReason + + ------------------ + -- Solver reports + + -- Recur inside TcRnSolverReport to get the underlying TcSolverReportMsg + ConRecursInto "TcRnSolverReport" = 'Just SolverReportWithCtxt + ConRecursInto "SolverReportWithCtxt" = 'Just TcSolverReportMsg + ConRecursInto "TcReportWithInfo" = 'Just TcSolverReportMsg + + -- Recur inside CannotUnifyVariable to get the underlying reason + ConRecursInto "CannotUnifyVariable" = 'Just CannotUnifyVariableReason + + -- Recur inside Mismatch to get the underlying reason + ConRecursInto "Mismatch" = 'Just MismatchMsg + + ---------------------------------- + -- Constructors of DsMessage + + ConRecursInto "DsUnknownMessage" = 'Just UnknownDiagnostic + + ---------------------------------- + -- Any other constructors: don't recur, instead directly + -- use the constructor name for the error code. + + ConRecursInto _ = 'Nothing + +{- ********************************************************************* +* * + Generics machinery +* * +********************************************************************* -} + +{- Note [Diagnostic codes using generics] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Diagnostic codes are specified at the type-level using the injective +type family 'GhcDiagnosticCode'. This ensures uniqueness of diagnostic +codes, giving quick feedback (in the form of a type error). + +Using this type family, we need to obtain corresponding value-level +functions, e.g. + + diagnosticCode :: TcRnMessage -> DiagnosticCode + diagnosticCode diag = case diag of + TcRnInaccessibleCode {} -> ghcDiagnosticCode 40564 + TcRnTypeDoesNotHaveFixedRuntimeRep {} -> ghcDiagnosticCode 18478 + TcRnCannotDeriveInstance _ _ _ _ reason -> + case reason of + DerivErrNotWellKinded {} -> ghcDiagnosticCode 62016 + DerivErrNotAClass {} -> ghcDiagnosticCode 63388 + ... + ... + +For some constructors, such as 'TcRnInaccessibleCode', we directly get a +diagnostic code, using the 'GhcDiagnosticCode' type family. For other +constructors, such as 'TcRnCannotDeriveInstance', we instead recur into an +argument (in this case 'DeriveInstanceErrReason') to obtain a diagnostic code. + +To achieve this, we use a variant of the 'typed' lens from 'generic-lens' +(we only need a getter, not a setter): + + - Using GHC.Generics, we obtain the type-level structure + of diagnostic types, as sums of products, with extra metadata. + - The 'ConRecursInto' type family declares when we should + recur into an argument of the constructor instead of using + the constructor name itself for the diagnostic code. + - To decide whether to recur, in the generic representation, + we must look at all factors of a product to see if there is + a type we should recur into. We look at the left branch + first, and decide whether to recur into it using the + HasTypeQ type family. + - The two different behaviours are controlled by two main instances (*) and (**). + - (*) recurs into a subtype, when we have a type family equation such as: + + ConRecursInto "TcRnCannotDeriveInstance" = 'Just DeriveInstanceErrReason + + In this case, for the constructor 'TcRnCannotDeriveInstance', we recur into the + type 'DeriveInstanceErrReason'. + The overlapping instance (ERR1) provides an error message in case a constructor + does not have the type specified by the 'ConRecursInto' type family. + - (**) directly uses the constructor name, by using the 'GhcDiagnosticCode' + type family. The 'KnownConstructor' context (ERR2) on the instance provides + a custom error message in case of a missing diagnostic code, which points + GHC contributors to the documentation explaining how to add diagnostic codes + for their diagnostics. +-} + +-- | Use the generic representation of a type to retrieve the +-- diagnostic code, using the 'GhcDiagnosticCode' type family. +-- +-- See Note [Diagnostic codes using generics] in GHC.Types.Error.Codes. +type GDiagnosticCode :: (Type -> Type) -> Constraint +class GDiagnosticCode f where + gdiagnosticCode :: f a -> Maybe DiagnosticCode + +type ConstructorCode :: Symbol -> (Type -> Type) -> Maybe Type -> Constraint +class ConstructorCode con f recur where + gconstructorCode :: f a -> Maybe DiagnosticCode +instance KnownConstructor con => ConstructorCode con f 'Nothing where + gconstructorCode _ = Just $ DiagnosticCode "GHC" $ natVal' @(GhcDiagnosticCode con) proxy# + +-- If we recur into the 'UnknownDiagnostic' existential datatype, +-- unwrap the existential and obtain the error code. +instance {-# OVERLAPPING #-} + ( ConRecursInto con ~ 'Just UnknownDiagnostic + , HasType UnknownDiagnostic con f ) + => ConstructorCode con f ('Just UnknownDiagnostic) where + gconstructorCode diag = case getType @UnknownDiagnostic @con @f diag of + UnknownDiagnostic diag -> diagnosticCode diag + +-- (*) Recursive instance: Recur into the given type. +instance ( ConRecursInto con ~ 'Just ty, HasType ty con f + , Generic ty, GDiagnosticCode (Rep ty) ) + => ConstructorCode con f ('Just ty) where + gconstructorCode diag = constructorCode (getType @ty @con @f diag) + +-- (**) Constructor instance: handle constructors directly. +-- +-- Obtain the code from the 'GhcDiagnosticCode' +-- type family, applied to the name of the constructor. +instance (ConstructorCode con f recur, recur ~ ConRecursInto con) + => GDiagnosticCode (M1 i ('MetaCons con x y) f) where + gdiagnosticCode (M1 x) = gconstructorCode @con @f @recur x + +-- Handle sum types (the diagnostic types are sums of constructors). +instance (GDiagnosticCode f, GDiagnosticCode g) => GDiagnosticCode (f :+: g) where + gdiagnosticCode (L1 x) = gdiagnosticCode @f x + gdiagnosticCode (R1 y) = gdiagnosticCode @g y + +-- Discard metadata we don't need. +instance GDiagnosticCode f + => GDiagnosticCode (M1 i ('MetaData nm mod pkg nt) f) where + gdiagnosticCode (M1 x) = gdiagnosticCode @f x + +-- | Decide whether to pick the left or right branch +-- when deciding how to recurse into a product. +type family HasTypeQ (ty :: Type) f :: Maybe Type where + HasTypeQ typ (M1 _ _ (K1 _ typ)) + = 'Just typ + HasTypeQ typ (M1 _ _ x) + = HasTypeQ typ x + HasTypeQ typ (l :*: r) + = Alt (HasTypeQ typ l) (HasTypeQ typ r) + HasTypeQ typ (l :+: r) + = Both (HasTypeQ typ l) (HasTypeQ typ r) + HasTypeQ typ (K1 _ _) + = 'Nothing + HasTypeQ typ U1 + = 'Nothing + HasTypeQ typ V1 + = 'Nothing + +type family Both (m1 :: Maybe a) (m2 :: Maybe a) :: Maybe a where + Both ('Just a) ('Just a) = 'Just a + +type family Alt (m1 :: Maybe a) (m2 :: Maybe a) :: Maybe a where + Alt ('Just a) _ = 'Just a + Alt _ b = b + +type HasType :: Type -> Symbol -> (Type -> Type) -> Constraint +class HasType ty orig f where + getType :: f a -> ty + +instance HasType ty orig (M1 i s (K1 x ty)) where + getType (M1 (K1 x)) = x +instance HasTypeProd ty (HasTypeQ ty f) orig f g => HasType ty orig (f :*: g) where + getType = getTypeProd @ty @(HasTypeQ ty f) @orig + +-- The lr parameter tells us whether to pick the left or right +-- branch in a product, and is computed using 'HasTypeQ'. +-- +-- If it's @Just l@, then we have found the type in the left branch, +-- so use that. Otherwise, look in the right branch. +class HasTypeProd ty lr orig f g where + getTypeProd :: (f :*: g) a -> ty + +-- Pick the left branch. +instance HasType ty orig f => HasTypeProd ty ('Just l) orig f g where + getTypeProd (x :*: _) = getType @ty @orig @f x + +-- Pick the right branch. +instance HasType ty orig g => HasTypeProd ty 'Nothing orig f g where + getTypeProd (_ :*: y) = getType @ty @orig @g y + +{- ********************************************************************* +* * + Custom type errors for diagnostic codes +* * +********************************************************************* -} + +-- (ERR1) Improve error messages for recurring into an argument. +instance {-# OVERLAPPABLE #-} + TypeError + ( 'Text "The constructor '" ':<>: 'Text orig ':<>: 'Text "'" + ':$$: 'Text "does not have any argument of type '" ':<>: 'ShowType ty ':<>: 'Text "'." + ':$$: 'Text "" + ':$$: 'Text "This is likely due to an incorrect type family equation:" + ':$$: 'Text " ConRecursInto \"" ':<>: 'Text orig ':<>: 'Text "\" = " ':<>: 'ShowType ty ) + => HasType ty orig f where + getType = panic "getType: unreachable" + +-- (ERR2) Improve error messages for missing 'GhcDiagnosticCode' equations. +type KnownConstructor :: Symbol -> Constraint +type family KnownConstructor con where + KnownConstructor con = + KnownNatOrErr + ( TypeError + ( 'Text "Missing diagnostic code for constructor " + ':<>: 'Text "'" ':<>: 'Text con ':<>: 'Text "'." + ':$$: 'Text "" + ':$$: 'Text "Note [Diagnostic codes] in GHC.Types.Error.Codes" + ':$$: 'Text "contains instructions for adding a new diagnostic code." + ) + ) + (GhcDiagnosticCode con) + +type KnownNatOrErr :: Constraint -> Nat -> Constraint +type KnownNatOrErr err n = (Assert err n, KnownNat n) + +-- Detecting a stuck type family using a data family. +-- See https://blog.csongor.co.uk/report-stuck-families/. +type Assert :: Constraint -> k -> Constraint +type family Assert err n where + Assert _ Dummy = Dummy + Assert _ n = () +data family Dummy :: k diff --git a/compiler/GHC/Unit/Module/Warnings.hs b/compiler/GHC/Unit/Module/Warnings.hs index 6936702b2a..6dae41ecfc 100644 --- a/compiler/GHC/Unit/Module/Warnings.hs +++ b/compiler/GHC/Unit/Module/Warnings.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} @@ -29,6 +30,7 @@ import GHC.Utils.Binary import Language.Haskell.Syntax.Extension import Data.Data +import GHC.Generics ( Generic ) -- | Warning Text -- @@ -40,6 +42,7 @@ data WarningTxt pass | DeprecatedTxt (Located SourceText) [Located (WithHsDocIdentifiers StringLiteral pass)] + deriving Generic deriving instance Eq (IdP pass) => Eq (WarningTxt pass) deriving instance (Data pass, Data (IdP pass)) => Data (WarningTxt pass) diff --git a/compiler/GHC/Utils/Error.hs b/compiler/GHC/Utils/Error.hs index 8c044c5af9..d696ddd2be 100644 --- a/compiler/GHC/Utils/Error.hs +++ b/compiler/GHC/Utils/Error.hs @@ -32,7 +32,7 @@ module GHC.Utils.Error ( -- ** Construction DiagOpts (..), diag_wopt, diag_fatal_wopt, - emptyMessages, mkDecorated, mkLocMessage, mkLocMessageAnn, + emptyMessages, mkDecorated, mkLocMessage, mkMsgEnvelope, mkPlainMsgEnvelope, mkPlainErrorMsgEnvelope, mkErrorMsgEnvelope, mkMCDiagnostic, errorDiagnostic, diagReasonSeverity, @@ -124,13 +124,13 @@ diagReasonSeverity opts reason = case reason of -- | Make a 'MessageClass' for a given 'DiagnosticReason', consulting the -- 'DiagOpts. -mkMCDiagnostic :: DiagOpts -> DiagnosticReason -> MessageClass -mkMCDiagnostic opts reason = MCDiagnostic (diagReasonSeverity opts reason) reason +mkMCDiagnostic :: DiagOpts -> DiagnosticReason -> Maybe DiagnosticCode -> MessageClass +mkMCDiagnostic opts reason code = MCDiagnostic (diagReasonSeverity opts reason) reason code -- | Varation of 'mkMCDiagnostic' which can be used when we are /sure/ the --- input 'DiagnosticReason' /is/ 'ErrorWithoutFlag'. +-- input 'DiagnosticReason' /is/ 'ErrorWithoutFlag' and there is no diagnostic code. errorDiagnostic :: MessageClass -errorDiagnostic = MCDiagnostic SevError ErrorWithoutFlag +errorDiagnostic = MCDiagnostic SevError ErrorWithoutFlag Nothing -- -- Creating MsgEnvelope(s) @@ -241,7 +241,10 @@ pprLocMsgEnvelope (MsgEnvelope { errMsgSpan = s , errMsgContext = unqual }) = sdocWithContext $ \ctx -> withErrStyle unqual $ - mkLocMessage (MCDiagnostic sev (diagnosticReason e)) s (formatBulleted ctx $ diagnosticMessage e) + mkLocMessage + (MCDiagnostic sev (diagnosticReason e) (diagnosticCode e)) + s + (formatBulleted ctx $ diagnosticMessage e) sortMsgBag :: Maybe DiagOpts -> Bag (MsgEnvelope e) -> [MsgEnvelope e] sortMsgBag mopts = maybeLimit . sortBy (cmp `on` errMsgSpan) . bagToList diff --git a/compiler/GHC/Utils/Logger.hs b/compiler/GHC/Utils/Logger.hs index 43a290189c..7a33a91963 100644 --- a/compiler/GHC/Utils/Logger.hs +++ b/compiler/GHC/Utils/Logger.hs @@ -93,8 +93,7 @@ import System.Directory import System.FilePath ( takeDirectory, (</>) ) import qualified Data.Set as Set import Data.Set (Set) -import Data.List (intercalate, stripPrefix) -import qualified Data.List.NonEmpty as NE +import Data.List (stripPrefix) import Data.Time import System.IO import Control.Monad @@ -328,7 +327,7 @@ makeThreadSafe logger = do -- See Note [JSON Error Messages] -- jsonLogAction :: LogAction -jsonLogAction _ (MCDiagnostic SevIgnore _) _ _ = return () -- suppress the message +jsonLogAction _ (MCDiagnostic SevIgnore _ _) _ _ = return () -- suppress the message jsonLogAction logflags msg_class srcSpan msg = defaultLogActionHPutStrDoc logflags True stdout @@ -345,21 +344,21 @@ defaultLogAction :: LogAction defaultLogAction logflags msg_class srcSpan msg | log_dopt Opt_D_dump_json logflags = jsonLogAction logflags msg_class srcSpan msg | otherwise = case msg_class of - MCOutput -> printOut msg - MCDump -> printOut (msg $$ blankLine) - MCInteractive -> putStrSDoc msg - MCInfo -> printErrs msg - MCFatal -> printErrs msg - MCDiagnostic SevIgnore _ -> pure () -- suppress the message - MCDiagnostic sev rea -> printDiagnostics sev rea + MCOutput -> printOut msg + MCDump -> printOut (msg $$ blankLine) + MCInteractive -> putStrSDoc msg + MCInfo -> printErrs msg + MCFatal -> printErrs msg + MCDiagnostic SevIgnore _ _ -> pure () -- suppress the message + MCDiagnostic _sev _rea _code -> printDiagnostics where printOut = defaultLogActionHPrintDoc logflags False stdout printErrs = defaultLogActionHPrintDoc logflags False stderr putStrSDoc = defaultLogActionHPutStrDoc logflags False stdout -- Pretty print the warning flag, if any (#10752) - message sev rea = mkLocMessageAnn (flagMsg sev rea) msg_class srcSpan msg + message = mkLocMessageWarningGroups (log_show_warn_groups logflags) msg_class srcSpan msg - printDiagnostics severity reason = do + printDiagnostics = do hPutChar stderr '\n' caretDiagnostic <- if log_show_caret logflags @@ -367,35 +366,12 @@ defaultLogAction logflags msg_class srcSpan msg else pure empty printErrs $ getPprStyle $ \style -> withPprStyle (setStyleColoured True style) - (message severity reason $+$ caretDiagnostic) + (message $+$ caretDiagnostic) -- careful (#2302): printErrs prints in UTF-8, -- whereas converting to string first and using -- hPutStr would just emit the low 8 bits of -- each unicode char. - flagMsg :: Severity -> DiagnosticReason -> Maybe String - flagMsg SevIgnore _ = panic "Called flagMsg with SevIgnore" - flagMsg SevError WarningWithoutFlag = Just "-Werror" - flagMsg SevError (WarningWithFlag wflag) = do - let name = NE.head (warnFlagNames wflag) - return $ - "-W" ++ name ++ warnFlagGrp wflag ++ - ", -Werror=" ++ name - flagMsg SevError ErrorWithoutFlag = Nothing - flagMsg SevWarning WarningWithoutFlag = Nothing - flagMsg SevWarning (WarningWithFlag wflag) = do - let name = NE.head (warnFlagNames wflag) - return ("-W" ++ name ++ warnFlagGrp wflag) - flagMsg SevWarning ErrorWithoutFlag = - panic "SevWarning with ErrorWithoutFlag" - - warnFlagGrp flag - | log_show_warn_groups logflags = - case smallestWarningGroups flag of - [] -> "" - groups -> " (in " ++ intercalate ", " (map ("-W"++) groups) ++ ")" - | otherwise = "" - -- | Like 'defaultLogActionHPutStrDoc' but appends an extra newline. defaultLogActionHPrintDoc :: LogFlags -> Bool -> Handle -> SDoc -> IO () defaultLogActionHPrintDoc logflags asciiSpace h d diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 0169c7ae9a..9bd00b77ed 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -706,6 +706,7 @@ Library GHC.Types.Cpr GHC.Types.Demand GHC.Types.Error + GHC.Types.Error.Codes GHC.Types.FieldLabel GHC.Types.Fixity GHC.Types.Fixity.Env diff --git a/docs/users_guide/9.6.1-notes.rst b/docs/users_guide/9.6.1-notes.rst index 2e8302ad22..d78ec969b9 100644 --- a/docs/users_guide/9.6.1-notes.rst +++ b/docs/users_guide/9.6.1-notes.rst @@ -60,6 +60,8 @@ Language add an injectivity annotation to the type family in the case that the type family is in fact injective. +- Error messages are now assigned unique error codes, of the form ``[GHC-12345]``. + Compiler ~~~~~~~~ diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs index c1ce849651..3751711b9d 100644 --- a/ghc/GHCi/UI.hs +++ b/ghc/GHCi/UI.hs @@ -619,7 +619,7 @@ ghciLogAction lastErrLocations old_log_action dflags msg_class srcSpan msg = do old_log_action dflags msg_class srcSpan msg case msg_class of - MCDiagnostic SevError _reason -> case srcSpan of + MCDiagnostic SevError _reason _code -> case srcSpan of RealSrcSpan rsp _ -> modifyIORef lastErrLocations (++ [(srcLocFile (realSrcSpanStart rsp), srcLocLine (realSrcSpanStart rsp))]) _ -> return () |