diff options
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 () |