From 0ef1d8aeaf57ecae402142a2b691109ad78900aa Mon Sep 17 00:00:00 2001
From: sheaf <sam.derbyshire@gmail.com>
Date: Tue, 8 Aug 2023 13:15:04 +0200
Subject: [PATCH] Compute all emitted diagnostic codes
This commit introduces in GHC.Types.Error.Codes the function
constructorCodes :: forall diag. (...) => Map DiagnosticCode String
which computes a collection of all the diagnostic codes that correspond
to a particular type. In particular, we can compute the collection of
all diagnostic codes emitted by GHC using the invocation
constructorCodes @GhcMessage
We then make use of this functionality in the new "codes" test which
checks consistency and coverage of GHC diagnostic codes.
It performs three checks:
- check 1: all non-outdated GhcDiagnosticCode equations
are statically used.
- check 2: all outdated GhcDiagnosticCode equations
are statically unused.
- check 3: all statically used diagnostic codes are covered by
the testsuite (modulo accepted exceptions).
---
compiler/GHC/Driver/Errors/Ppr.hs | 2 +-
compiler/GHC/HsToCore/Errors/Ppr.hs | 2 +-
compiler/GHC/Iface/Errors/Ppr.hs | 2 +-
compiler/GHC/Parser/Errors/Ppr.hs | 2 +-
compiler/GHC/Tc/Errors/Ppr.hs | 3 +-
compiler/GHC/Types/Error.hs | 15 +-
compiler/GHC/Types/Error/Codes.hs | 143 ++++++++++++--
hadrian/src/Packages.hs | 7 +-
hadrian/src/Rules/Test.hs | 8 +
hadrian/src/Settings/Default.hs | 12 +-
linters/lint-codes/LintCodes/Coverage.hs | 46 +++++
linters/lint-codes/LintCodes/Static.hs | 179 ++++++++++++++++++
linters/lint-codes/Main.hs | 158 ++++++++++++++++
linters/lint-codes/Makefile | 15 ++
linters/lint-codes/cabal.project | 1 +
linters/lint-codes/ghc.mk | 18 ++
linters/lint-codes/lint-codes.cabal | 42 ++++
testsuite/mk/boilerplate.mk | 4 +
testsuite/tests/diagnostic-codes/Makefile | 6 +
testsuite/tests/diagnostic-codes/all.T | 12 ++
testsuite/tests/diagnostic-codes/codes.stdout | 127 +++++++++++++
21 files changed, 765 insertions(+), 39 deletions(-)
create mode 100644 linters/lint-codes/LintCodes/Coverage.hs
create mode 100644 linters/lint-codes/LintCodes/Static.hs
create mode 100644 linters/lint-codes/Main.hs
create mode 100644 linters/lint-codes/Makefile
create mode 100644 linters/lint-codes/cabal.project
create mode 100644 linters/lint-codes/ghc.mk
create mode 100644 linters/lint-codes/lint-codes.cabal
create mode 100644 testsuite/tests/diagnostic-codes/Makefile
create mode 100644 testsuite/tests/diagnostic-codes/all.T
create mode 100644 testsuite/tests/diagnostic-codes/codes.stdout
diff --git a/compiler/GHC/Driver/Errors/Ppr.hs b/compiler/GHC/Driver/Errors/Ppr.hs
index 1fa3f5bad713..d899094b8e61 100644
--- a/compiler/GHC/Driver/Errors/Ppr.hs
+++ b/compiler/GHC/Driver/Errors/Ppr.hs
@@ -17,7 +17,7 @@ import GHC.Driver.DynFlags
import GHC.HsToCore.Errors.Ppr ()
import GHC.Parser.Errors.Ppr ()
import GHC.Types.Error
-import GHC.Types.Error.Codes ( constructorCode )
+import GHC.Types.Error.Codes
import GHC.Unit.Types
import GHC.Utils.Outputable
import GHC.Unit.Module
diff --git a/compiler/GHC/HsToCore/Errors/Ppr.hs b/compiler/GHC/HsToCore/Errors/Ppr.hs
index 402b5a2f49e3..18a6996da22d 100644
--- a/compiler/GHC/HsToCore/Errors/Ppr.hs
+++ b/compiler/GHC/HsToCore/Errors/Ppr.hs
@@ -15,7 +15,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.Error.Codes
import GHC.Types.Id (idType)
import GHC.Types.SrcLoc
import GHC.Utils.Misc
diff --git a/compiler/GHC/Iface/Errors/Ppr.hs b/compiler/GHC/Iface/Errors/Ppr.hs
index 5f23fe01cae8..6d3cc42b2099 100644
--- a/compiler/GHC/Iface/Errors/Ppr.hs
+++ b/compiler/GHC/Iface/Errors/Ppr.hs
@@ -31,7 +31,7 @@ import GHC.Prelude
import GHC.Types.Error
import GHC.Types.Hint.Ppr () -- Outputable GhcHint
-import GHC.Types.Error.Codes ( constructorCode )
+import GHC.Types.Error.Codes
import GHC.Types.Name
import GHC.Types.TyThing
diff --git a/compiler/GHC/Parser/Errors/Ppr.hs b/compiler/GHC/Parser/Errors/Ppr.hs
index f90875c4a7f2..7d95d34b5c10 100644
--- a/compiler/GHC/Parser/Errors/Ppr.hs
+++ b/compiler/GHC/Parser/Errors/Ppr.hs
@@ -22,7 +22,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.Error.Codes
import GHC.Types.Name.Reader ( opIsAt, rdrNameOcc, mkUnqual )
import GHC.Types.Name.Occurrence (isSymOcc, occNameFS, varName)
import GHC.Utils.Outputable
diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs
index 5bbf2ecbee93..5d87e30d6162 100644
--- a/compiler/GHC/Tc/Errors/Ppr.hs
+++ b/compiler/GHC/Tc/Errors/Ppr.hs
@@ -74,7 +74,7 @@ import GHC.Types.Error
import GHC.Types.Hint
import GHC.Types.Hint.Ppr () -- Outputable GhcHint
import GHC.Types.Basic
-import GHC.Types.Error.Codes ( constructorCode )
+import GHC.Types.Error.Codes
import GHC.Types.Id
import GHC.Types.Id.Info ( RecSelParent(..) )
import GHC.Types.Name
@@ -3113,7 +3113,6 @@ instance Diagnostic TcRnMessage where
TcRnIllegalTypeExpr{}
-> noHints
- diagnosticCode :: TcRnMessage -> Maybe DiagnosticCode
diagnosticCode = constructorCode
-- | Change [x] to "x", [x, y] to "x and y", [x, y, z] to "x, y, and z",
diff --git a/compiler/GHC/Types/Error.hs b/compiler/GHC/Types/Error.hs
index c011e85d52e7..0f67dc0ff53a 100644
--- a/compiler/GHC/Types/Error.hs
+++ b/compiler/GHC/Types/Error.hs
@@ -113,10 +113,8 @@ import Data.Typeable ( Typeable )
import Numeric.Natural ( Natural )
import Text.Printf ( printf )
-{-
-Note [Messages]
-~~~~~~~~~~~~~~~
-
+{- Note [Messages]
+~~~~~~~~~~~~~~~~~~
We represent the 'Messages' as a single bag of warnings and errors.
The reason behind that is that there is a fluid relationship between errors
@@ -809,8 +807,11 @@ data DiagnosticCode =
, diagnosticCodeNumber :: Natural
-- ^ the actual diagnostic code
}
+ deriving ( Eq, Ord )
-instance Outputable DiagnosticCode where
- ppr (DiagnosticCode prefix c) =
- text prefix <> text "-" <> text (printf "%05d" c)
+instance Show DiagnosticCode where
+ show (DiagnosticCode prefix c) =
+ prefix ++ "-" ++ printf "%05d" c
-- pad the numeric code to have at least 5 digits
+instance Outputable DiagnosticCode where
+ ppr code = text (show code)
diff --git a/compiler/GHC/Types/Error/Codes.hs b/compiler/GHC/Types/Error/Codes.hs
index 087b17054e5d..c71d69e9f26f 100644
--- a/compiler/GHC/Types/Error/Codes.hs
+++ b/compiler/GHC/Types/Error/Codes.hs
@@ -16,7 +16,7 @@
-- A diagnostic code is a numeric unique identifier for a diagnostic.
-- See Note [Diagnostic codes].
module GHC.Types.Error.Codes
- ( constructorCode )
+ ( GhcDiagnosticCode, constructorCode, constructorCodes )
where
import GHC.Prelude
@@ -36,9 +36,13 @@ 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.TypeLits ( Symbol, KnownSymbol, symbolVal'
+ , TypeError, ErrorMessage(..) )
import GHC.TypeNats ( Nat, KnownNat, natVal' )
+import Data.Map.Strict ( Map )
+import qualified Data.Map.Strict as Map
+
{- Note [Diagnostic codes]
~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -110,6 +114,18 @@ constructorCode :: (Generic diag, GDiagnosticCode (Rep diag))
=> diag -> Maybe DiagnosticCode
constructorCode diag = gdiagnosticCode (from diag)
+-- | This function computes all diagnostic codes that occur inside a given
+-- type using generics and the 'GhcDiagnosticCode' type family.
+--
+-- For example, if @T = MkT1 | MkT2@, @GhcDiagnosticCode \"MkT1\" = 123@ and
+-- @GhcDiagnosticCode \"MkT2\" = 456@, then we will get
+-- > constructorCodes @T = fromList [ (123, \"MkT1\"), (456, \"MkT2\") ]
+constructorCodes :: forall diag. (Generic diag, GDiagnosticCodes '[diag] (Rep diag))
+ => Map DiagnosticCode String
+constructorCodes = gdiagnosticCodes @'[diag] @(Rep diag)
+ -- See Note [diagnosticCodes: don't recur into already-seen types]
+ -- for the @'[diag] type argument.
+
-- | Type family computing the numeric diagnostic code for a given error message constructor.
--
-- Its injectivity annotation ensures uniqueness of error codes.
@@ -479,7 +495,6 @@ type family GhcDiagnosticCode c = n | n -> c where
GhcDiagnosticCode "TcRnIllegalHsigDefaultMethods" = 93006
GhcDiagnosticCode "TcRnHsigFixityMismatch" = 93007
- GhcDiagnosticCode "TcRnHsigNoIface" = 93010
GhcDiagnosticCode "TcRnHsigMissingModuleExport" = 93011
GhcDiagnosticCode "TcRnBadGenericMethod" = 59794
GhcDiagnosticCode "TcRnWarningMinimalDefIncomplete" = 13511
@@ -488,7 +503,6 @@ type family GhcDiagnosticCode c = n | n -> c where
GhcDiagnosticCode "TcRnBadMethodErr" = 46284
GhcDiagnosticCode "TcRnIllegalTypeData" = 15013
GhcDiagnosticCode "TcRnTypeDataForbids" = 67297
- GhcDiagnosticCode "TcRnInterfaceLookupError" = 52243
GhcDiagnosticCode "TcRnUnsatisfiedMinimalDef" = 06201
GhcDiagnosticCode "TcRnMisplacedInstSig" = 06202
GhcDiagnosticCode "TcRnCapturedTermName" = 54201
@@ -864,21 +878,29 @@ type family GhcDiagnosticCode c = n | n -> c where
-- and this includes outdated diagnostic codes for errors that GHC
-- no longer reports. These are collected below.
- GhcDiagnosticCode "TcRnIllegalInstanceHeadDecl" = 12222
- GhcDiagnosticCode "TcRnNoClassInstHead" = 56538
+ GhcDiagnosticCode "TcRnIllegalInstanceHeadDecl" = Outdated 12222
+ GhcDiagnosticCode "TcRnNoClassInstHead" = Outdated 56538
-- The above two are subsumed by InstHeadNonClass [GHC-53946]
- GhcDiagnosticCode "TcRnNameByTemplateHaskellQuote" = 40027
- GhcDiagnosticCode "TcRnIllegalBindingOfBuiltIn" = 69639
- GhcDiagnosticCode "TcRnMixedSelectors" = 40887
- GhcDiagnosticCode "TcRnBadBootFamInstDecl" = 06203
- GhcDiagnosticCode "TcRnBindInBootFile" = 11247
- GhcDiagnosticCode "TcRnUnexpectedTypeSplice" = 39180
- GhcDiagnosticCode "PsErrUnexpectedTypeAppInDecl" = 45054
- GhcDiagnosticCode "TcRnUnpromotableThing" = 88634
- GhcDiagnosticCode "UntouchableVariable" = 34699
- GhcDiagnosticCode "TcRnBindVarAlreadyInScope" = 69710
- GhcDiagnosticCode "TcRnBindMultipleVariables" = 92957
+ GhcDiagnosticCode "TcRnNameByTemplateHaskellQuote" = Outdated 40027
+ GhcDiagnosticCode "TcRnIllegalBindingOfBuiltIn" = Outdated 69639
+ GhcDiagnosticCode "TcRnMixedSelectors" = Outdated 40887
+ GhcDiagnosticCode "TcRnBadBootFamInstDecl" = Outdated 06203
+ GhcDiagnosticCode "TcRnBindInBootFile" = Outdated 11247
+ GhcDiagnosticCode "TcRnUnexpectedTypeSplice" = Outdated 39180
+ GhcDiagnosticCode "PsErrUnexpectedTypeAppInDecl" = Outdated 45054
+ GhcDiagnosticCode "TcRnUnpromotableThing" = Outdated 88634
+ GhcDiagnosticCode "UntouchableVariable" = Outdated 34699
+ GhcDiagnosticCode "TcRnBindVarAlreadyInScope" = Outdated 69710
+ GhcDiagnosticCode "TcRnBindMultipleVariables" = Outdated 92957
+ GhcDiagnosticCode "TcRnHsigNoIface" = Outdated 93010
+ GhcDiagnosticCode "TcRnInterfaceLookupError" = Outdated 52243
+
+-- | Use this type synonym to mark a diagnostic code as outdated.
+--
+-- The presence of this type synonym is used by the 'codes' test to determine
+-- which diagnostic codes to check for testsuite coverage.
+type Outdated a = a
{- *********************************************************************
* *
@@ -1106,12 +1128,26 @@ To achieve this, we use a variant of the 'typed' lens from 'generic-lens'
type GDiagnosticCode :: (Type -> Type) -> Constraint
class GDiagnosticCode f where
gdiagnosticCode :: f a -> Maybe DiagnosticCode
+-- | Use the generic representation of a type to retrieve the collection
+-- of all diagnostic codes it can give rise to.
+type GDiagnosticCodes :: [Type] -> (Type -> Type) -> Constraint
+class GDiagnosticCodes seen f where
+ gdiagnosticCodes :: Map DiagnosticCode String
-type ConstructorCode :: Symbol -> (Type -> Type) -> Maybe Type -> Constraint
+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
+type ConstructorCodes :: Symbol -> (Type -> Type) -> [Type] -> Maybe Type -> Constraint
+class ConstructorCodes con f seen recur where
+ gconstructorCodes :: Map DiagnosticCode String
+
+instance (KnownConstructor con, KnownSymbol con) => ConstructorCode con f 'Nothing where
gconstructorCode _ = Just $ DiagnosticCode "GHC" $ natVal' @(GhcDiagnosticCode con) proxy#
+instance (KnownConstructor con, KnownSymbol con) => ConstructorCodes con f seen 'Nothing where
+ gconstructorCodes =
+ Map.singleton
+ (DiagnosticCode "GHC" $ natVal' @(GhcDiagnosticCode con) proxy#)
+ (symbolVal' @con proxy#)
-- If we recur into the 'UnknownDiagnostic' existential datatype,
-- unwrap the existential and obtain the error code.
@@ -1121,30 +1157,51 @@ instance {-# OVERLAPPING #-}
=> ConstructorCode con f ('Just (UnknownDiagnostic opts)) where
gconstructorCode diag = case getType @(UnknownDiagnostic opts) @con @f diag of
UnknownDiagnostic _ diag -> diagnosticCode diag
+instance {-# OVERLAPPING #-}
+ ( ConRecursInto con ~ 'Just (UnknownDiagnostic opts) )
+ => ConstructorCodes con f seen ('Just (UnknownDiagnostic opts)) where
+ gconstructorCodes = Map.empty
-- (*) 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)
+ gconstructorCode diag = gdiagnosticCode (from $ getType @ty @con @f diag)
+instance ( ConRecursInto con ~ 'Just ty, HasType ty con f
+ , Generic ty, GDiagnosticCodes (Insert ty seen) (Rep ty)
+ , Seen seen ty )
+ => ConstructorCodes con f seen ('Just ty) where
+ gconstructorCodes =
+ -- See Note [diagnosticCodes: don't recur into already-seen types]
+ if wasSeen @seen @ty
+ then Map.empty
+ else gdiagnosticCodes @(Insert ty seen) @(Rep ty)
-- (**) 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)
+instance (ConstructorCode con f recur, recur ~ ConRecursInto con, KnownSymbol con)
=> GDiagnosticCode (M1 i ('MetaCons con x y) f) where
gdiagnosticCode (M1 x) = gconstructorCode @con @f @recur x
+instance (ConstructorCodes con f seen recur, recur ~ ConRecursInto con, KnownSymbol con)
+ => GDiagnosticCodes seen (M1 i ('MetaCons con x y) f) where
+ gdiagnosticCodes = gconstructorCodes @con @f @seen @recur
-- 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
+instance (GDiagnosticCodes seen f, GDiagnosticCodes seen g) => GDiagnosticCodes seen (f :+: g) where
+ gdiagnosticCodes = Map.union (gdiagnosticCodes @seen @f) (gdiagnosticCodes @seen @g)
-- 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
+instance GDiagnosticCodes seen f
+ => GDiagnosticCodes seen (M1 i ('MetaData nm mod pkg nt) f) where
+ gdiagnosticCodes = gdiagnosticCodes @seen @f
-- | Decide whether to pick the left or right branch
-- when deciding how to recurse into a product.
@@ -1196,6 +1253,50 @@ instance HasType ty orig f => HasTypeProd ty ('Just l) orig f g where
instance HasType ty orig g => HasTypeProd ty 'Nothing orig f g where
getTypeProd (_ :*: y) = getType @ty @orig @g y
+{- Note [diagnosticCodes: don't recur into already-seen types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When traversing through the Generic representation of a datatype to compute all
+of the corresponding error codes, we need to keep track of types we have already
+seen in order to avoid a runtime loop.
+
+For example, TcRnMessage is defined recursively in terms of itself:
+
+ data TcRnMessage where
+ ...
+ TcRnMessageWithInfo :: !UnitState
+ -> !TcRnMessageDetailed -- contains a TcRnMessage
+ -> TcRnMessage
+
+If we naively computed the collection of error codes, we would get a computation
+of the form
+
+ diagnosticCodes @TcRnMessage = ... `Map.union` constructorCodes "TcRnMessageWithInfo"
+ constructorCodes "TcRnMessageWithInfo" = diagnosticCodes @TcRnMessage
+
+This would cause an infinite loop. We thus keep track of a list of types we
+have already encountered, and when we recur into a type we have already
+encountered, we simply skip taking that union (see (*)).
+
+Note that 'constructorCodes' starts by marking the initial type itself as "seen",
+which precisely avoids the loop above when calling 'constructorCodes @TcRnMessage'.
+-}
+
+type Seen :: [Type] -> Type -> Constraint
+class Seen seen ty where
+ wasSeen :: Bool
+instance Seen '[] ty where
+ wasSeen = False
+instance {-# OVERLAPPING #-} Seen (ty ': tys) ty where
+ wasSeen = True
+instance Seen tys ty => Seen (ty' ': tys) ty where
+ wasSeen = wasSeen @tys @ty
+
+type Insert :: Type -> [Type] -> [Type]
+type family Insert ty tys where
+ Insert ty '[] = '[ty]
+ Insert ty (ty ': tys) = ty ': tys
+ Insert ty (ty' ': tys) = ty' ': Insert ty tys
+
{- *********************************************************************
* *
Custom type errors for diagnostic codes
diff --git a/hadrian/src/Packages.hs b/hadrian/src/Packages.hs
index 957ec5e1585c..fdc3515b12be 100644
--- a/hadrian/src/Packages.hs
+++ b/hadrian/src/Packages.hs
@@ -11,7 +11,7 @@ module Packages (
libffi, mtl, parsec, pretty, primitive, process, remoteIserv, rts,
runGhc, semaphoreCompat, stm, templateHaskell, terminfo, text, time, timeout, touchy,
transformers, unlit, unix, win32, xhtml,
- lintersCommon, lintNotes, lintCommitMsg, lintSubmoduleRefs, lintWhitespace,
+ lintersCommon, lintNotes, lintCodes, lintCommitMsg, lintSubmoduleRefs, lintWhitespace,
ghcPackages, isGhcPackage,
-- * Package information
@@ -45,7 +45,7 @@ ghcPackages =
, terminfo, text, time, touchy, transformers, unlit, unix, win32, xhtml
, timeout
, lintersCommon
- , lintNotes, lintCommitMsg, lintSubmoduleRefs, lintWhitespace ]
+ , lintNotes, lintCodes, lintCommitMsg, lintSubmoduleRefs, lintWhitespace ]
-- TODO: Optimise by switching to sets of packages.
isGhcPackage :: Package -> Bool
@@ -61,7 +61,7 @@ array, base, binary, bytestring, cabalSyntax, cabal, checkPpr, checkExact, count
parsec, pretty, primitive, process, rts, runGhc, semaphoreCompat, stm, templateHaskell,
terminfo, text, time, touchy, transformers, unlit, unix, win32, xhtml,
timeout,
- lintersCommon, lintNotes, lintCommitMsg, lintSubmoduleRefs, lintWhitespace
+ lintersCommon, lintNotes, lintCodes, lintCommitMsg, lintSubmoduleRefs, lintWhitespace
:: Package
array = lib "array"
base = lib "base"
@@ -133,6 +133,7 @@ xhtml = lib "xhtml"
lintersCommon = lib "linters-common" `setPath` "linters/linters-common"
lintNotes = linter "lint-notes"
+lintCodes = linter "lint-codes"
lintCommitMsg = linter "lint-commit-msg"
lintSubmoduleRefs = linter "lint-submodule-refs"
lintWhitespace = linter "lint-whitespace"
diff --git a/hadrian/src/Rules/Test.hs b/hadrian/src/Rules/Test.hs
index 4f687b13bcc3..e70c604fcfc8 100644
--- a/hadrian/src/Rules/Test.hs
+++ b/hadrian/src/Rules/Test.hs
@@ -55,6 +55,12 @@ noteLinterSourcePath = "linters/lint-notes/Main.hs"
noteLinterExtra :: [String]
noteLinterExtra = ["-ilinters/lint-notes"]
+codeLinterProgPath, codeLinterSourcePath :: FilePath
+codeLinterProgPath = "test/bin/lint-codes" <.> exe
+codeLinterSourcePath = "linters/lint-codes/Main.hs"
+codeLinterExtra :: [String]
+codeLinterExtra = ["-ilinters/lint-codes"]
+
whitespaceLinterProgPath, whitespaceLinterSourcePath :: FilePath
whitespaceLinterProgPath = "test/bin/lint-whitespace" <.> exe
whitespaceLinterSourcePath = "linters/lint-whitespace/Main.hs"
@@ -78,6 +84,7 @@ checkPrograms =
, CheckProgram "test:count-deps" countDepsProgPath countDepsSourcePath countDepsExtra countDeps id id
, CheckProgram "test:dump-decls" dumpDeclsProgPath dumpDeclsSourcePath dumpDeclsExtra dumpDecls id id
, CheckProgram "lint:notes" noteLinterProgPath noteLinterSourcePath noteLinterExtra lintNotes (const stage0Boot) id
+ , CheckProgram "lint:codes" codeLinterProgPath codeLinterSourcePath codeLinterExtra lintCodes id id
, CheckProgram "lint:whitespace" whitespaceLinterProgPath whitespaceLinterSourcePath whitespaceLinterExtra lintWhitespace (const stage0Boot) (filter (/= lintersCommon))
]
@@ -273,6 +280,7 @@ testRules = do
setEnv "DUMP_DECLS" (top -/- root -/- dumpDeclsProgPath)
setEnv "COUNT_DEPS" (top -/- root -/- countDepsProgPath)
setEnv "LINT_NOTES" (top -/- root -/- noteLinterProgPath)
+ setEnv "LINT_CODES" (top -/- root -/- codeLinterProgPath)
setEnv "LINT_WHITESPACE" (top -/- root -/- whitespaceLinterProgPath)
-- This lets us bypass the need to generate a config
diff --git a/hadrian/src/Settings/Default.hs b/hadrian/src/Settings/Default.hs
index 2e879864ee6a..89e26e10d68e 100644
--- a/hadrian/src/Settings/Default.hs
+++ b/hadrian/src/Settings/Default.hs
@@ -65,7 +65,15 @@ defaultBignumBackend = "gmp"
-- packages in StageBoot so if you also need to distribute anything here then add
-- it to `stage0packages` or `stage1packages` as appropiate.
stageBootPackages :: Action [Package]
-stageBootPackages = return [lintersCommon, lintCommitMsg, lintSubmoduleRefs, lintWhitespace, lintNotes, hsc2hs, compareSizes, deriveConstants, genapply, genprimopcode, unlit ]
+stageBootPackages = return
+ [ lintersCommon, lintCommitMsg, lintSubmoduleRefs, lintWhitespace, lintNotes
+ , hsc2hs
+ , compareSizes
+ , deriveConstants
+ , genapply
+ , genprimopcode
+ , unlit
+ ]
-- | Packages built in 'Stage0' by default. You can change this in "UserSettings".
stage0Packages :: Action [Package]
@@ -170,7 +178,7 @@ stage2Packages = stage1Packages
-- | Packages that are built only for the testsuite.
testsuitePackages :: Action [Package]
-testsuitePackages = return ([ timeout | windowsHost ] ++ [ checkPpr, checkExact, countDeps, ghcConfig, dumpDecls ])
+testsuitePackages = return ([ timeout | windowsHost ] ++ [ checkPpr, checkExact, countDeps, lintCodes, ghcConfig, dumpDecls ])
-- | Default build ways for library packages:
-- * We always build 'vanilla' way.
diff --git a/linters/lint-codes/LintCodes/Coverage.hs b/linters/lint-codes/LintCodes/Coverage.hs
new file mode 100644
index 000000000000..1f4b570bbfd2
--- /dev/null
+++ b/linters/lint-codes/LintCodes/Coverage.hs
@@ -0,0 +1,46 @@
+module LintCodes.Coverage
+ ( getCoveredCodes )
+ where
+
+-- containers
+import Data.Set
+ ( Set )
+import qualified Data.Set as Set
+ ( fromList )
+
+-- ghc
+import GHC.Types.Error
+ ( DiagnosticCode(..) )
+
+-- process
+import System.Process
+ ( readProcess )
+
+--------------------------------------------------------------------------------
+-- Diagnostic code coverage from testsuite .stdout and .stderr files
+
+-- | Get all diagnostic codes that appear in testsuite .stdout and .stderr
+-- files.
+getCoveredCodes :: IO (Set DiagnosticCode)
+getCoveredCodes =
+ -- Run git grep on .stdout and .stderr files in the testsuite subfolder.
+ do { codes <- lines
+ <$> readProcess "git"
+ [ "grep", "-oh", codeRegex
+ -- -oh: only show the match, and omit the filename.
+ , "--", ":/testsuite/*.stdout", ":/testsuite/*.stderr"
+ , ":!*/codes.stdout" -- Don't include the output of this test itself.
+ ] ""
+ ; return $ Set.fromList $ map parseCode codes }
+
+-- | Regular expression to parse a diagnostic code.
+codeRegex :: String
+codeRegex = "\\[[A-Za-z]\\+-[0-9]\\+\\]"
+
+-- | Turn a string that matches the 'codeRegex' regular expression
+-- into its corresponding 'DiagnosticCode'.
+parseCode :: String -> DiagnosticCode
+parseCode c =
+ case break (== '-') $ drop 1 c of
+ (ns, rest) ->
+ DiagnosticCode ns ( read $ init $ drop 1 rest )
diff --git a/linters/lint-codes/LintCodes/Static.hs b/linters/lint-codes/LintCodes/Static.hs
new file mode 100644
index 000000000000..0600832f8699
--- /dev/null
+++ b/linters/lint-codes/LintCodes/Static.hs
@@ -0,0 +1,179 @@
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE GeneralisedNewtypeDeriving #-}
+{-# LANGUAGE TypeApplications #-}
+
+module LintCodes.Static
+ ( FamEqnIndex, Use(..), used, outdated
+ , getFamEqnCodes
+ , staticallyUsedCodes
+ )
+ where
+
+-- base
+import Data.Maybe
+ ( listToMaybe )
+import System.Environment
+ ( getArgs )
+
+-- containers
+import Data.Map.Strict
+ ( Map )
+import qualified Data.Map.Strict as Map
+ ( fromList )
+
+-- transformers
+import Control.Monad.IO.Class
+ ( liftIO )
+
+-- ghc
+import GHC.Driver.Errors.Types
+ ( GhcMessage )
+import GHC.Types.Error
+ ( DiagnosticCode(..) )
+import GHC.Types.Error.Codes
+ ( constructorCodes )
+
+-- ghc (API usage)
+import GHC
+ ( runGhc, parseDynamicFlags
+ , getSessionDynFlags, setSessionDynFlags
+ , getSession, getLogger
+ , noLoc
+ )
+import GHC.Core.Coercion.Axiom
+ ( CoAxBranch(..), coAxiomBranches, fromBranches )
+import GHC.Core.TyCon
+ ( TyCon, tyConName
+ , isClosedSynFamilyTyConWithAxiom_maybe
+ )
+import qualified GHC.Core.TyCo.Rep as GHC
+ ( Type )
+import GHC.Core.Type
+ ( isNumLitTy, isStrLitTy
+ , splitTyConAppNoView_maybe
+ )
+import GHC.Data.FastString
+ ( unpackFS )
+import GHC.Driver.Env
+ ( lookupType )
+import GHC.Iface.Env
+ ( lookupOrig )
+import GHC.Iface.Load
+ ( WhereFrom(..), loadInterface )
+import GHC.Types.Name
+ ( nameOccName, occNameFS )
+import GHC.Types.Name.Occurrence
+ ( mkTcOcc )
+import GHC.Types.TyThing
+ ( TyThing(..) )
+import GHC.Types.PkgQual
+ ( PkgQual(..) )
+import GHC.Tc.Utils.Monad
+ ( initIfaceLoad )
+import GHC.Unit.Finder
+ ( FindResult(..), findImportedModule )
+import GHC.Utils.Outputable
+ ( text )
+import Language.Haskell.Syntax.Module.Name
+ ( mkModuleName )
+
+--------------------------------------------------------------------------------
+
+-- | The diagnostic codes that are statically reachable from the
+-- 'GhcMessage' datatype.
+staticallyUsedCodes :: Map DiagnosticCode String
+staticallyUsedCodes = constructorCodes @GhcMessage
+
+--------------------------------------------------------------------------------
+
+-- | The index of an equation of the 'GhcDiagnosticCode' type family,
+-- starting from '1'.
+newtype FamEqnIndex = FamEqnIndex Int
+ deriving newtype ( Eq, Ord )
+ deriving stock Show
+-- | Whether an equation of the 'GhcDiagnosticCode' type family is still
+-- statically used, or whether it corresponds to an outdated diagnostic code
+-- that GHC previously emitted but no longer does.
+data Use = Used | Outdated
+ deriving stock ( Eq, Show )
+
+used, outdated :: ( FamEqnIndex, String, Use ) -> Maybe ( FamEqnIndex, String )
+used ( i, con, Used ) = Just ( i, con )
+used _ = Nothing
+outdated ( i, con, Outdated ) = Just ( i, con )
+outdated _ = Nothing
+
+--------------------------------------------------------------------------------
+-- Use the GHC API to obtain the 'TyCon' for the 'GhcDiagnosticCode' type
+-- family, and inspect its equations.
+-- It would also be possible to use Template Haskell reification, but usage
+-- of Template Haskell at compile-time is problematic for Hadrian.
+
+-- | The diagnostic codes returned by the 'GhcDiagnosticCode' type family.
+getFamEqnCodes :: IO ( Map DiagnosticCode ( FamEqnIndex, String, Use ) )
+getFamEqnCodes =
+ do { tc <- ghcDiagnosticCodeTyCon
+ ; return $ case isClosedSynFamilyTyConWithAxiom_maybe tc of
+ { Nothing -> error "can't find equations for 'GhcDiagnosticCode'"
+ ; Just ax -> Map.fromList
+ $ zipWith parseBranch [1..]
+ $ fromBranches $ coAxiomBranches ax
+ } }
+
+parseBranch :: Int -> CoAxBranch -> ( DiagnosticCode, ( FamEqnIndex, String, Use ) )
+parseBranch i ( CoAxBranch { cab_lhs = lhs, cab_rhs = rhs })
+ | [ con ] <- lhs
+ , Just con_fs <- isStrLitTy con
+ , let con_str = unpackFS con_fs
+ (code, use) = parseBranchRHS rhs
+ = ( DiagnosticCode "GHC" ( fromInteger code ), ( FamEqnIndex i, con_str, use ) )
+ | otherwise
+ = error "couldn't parse equation of 'GhcDiagnosticCode'"
+
+parseBranchRHS :: GHC.Type -> ( Integer, Use )
+parseBranchRHS rhs
+ | Just code <- isNumLitTy rhs
+ = ( code, use )
+ | otherwise
+ = error "couldn't parse equation RHS of 'GhcDiagnosticCode'"
+ where
+ use
+ | Just (tc,_) <- splitTyConAppNoView_maybe rhs
+ , unpackFS (occNameFS (nameOccName (tyConName tc))) == "Outdated"
+ = Outdated
+ | otherwise
+ = Used
+
+-- | Look up the 'GhcDiagnosticCode' type family using the GHC API.
+ghcDiagnosticCodeTyCon :: IO TyCon
+ghcDiagnosticCodeTyCon =
+ do { args <- getArgs
+ ; runGhc (listToMaybe args)
+
+ -- STEP 1: start a GHC API session with "-package ghc"
+ do { dflags1 <- getSessionDynFlags
+ ; let opts = map noLoc ["-package ghc"]
+ ; logger <- getLogger
+ ; (dflags2, _,_) <- parseDynamicFlags logger dflags1 opts
+ ; setSessionDynFlags dflags2
+ ; hsc_env <- getSession
+ ; liftIO
+
+ -- STEP 2: look up the module "GHC.Types.Error.Codes"
+ do { res <- findImportedModule hsc_env (mkModuleName "GHC.Types.Error.Codes") NoPkgQual
+ ; case res of
+ { Found _ modl ->
+
+ -- STEP 3: look up the 'GhcDiagnosticCode' type family.
+ do { nm <- initIfaceLoad hsc_env do
+ _ <- loadInterface (text "lint-codes: need 'GhcDiagnosticCode'")
+ modl ImportBySystem
+ lookupOrig modl $ mkTcOcc "GhcDiagnosticCode"
+ ; mb_tyThing <- lookupType hsc_env nm
+ ; return $ case mb_tyThing of
+ Just (ATyCon tc) -> tc
+ _ -> error "lint-codes: failed to look up TyCon for 'GhcDiagnosticCode'"
+ }
+
+ ; _ -> error "lint-codes: failed to find 'GHC.Types.Error.Codes'" } } } }
diff --git a/linters/lint-codes/Main.hs b/linters/lint-codes/Main.hs
new file mode 100644
index 000000000000..880e44fd0a16
--- /dev/null
+++ b/linters/lint-codes/Main.hs
@@ -0,0 +1,158 @@
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE TupleSections #-}
+
+module Main where
+
+-- base
+import Control.Monad
+ ( when )
+import Data.List
+ ( sortOn )
+import Text.Printf
+ ( printf )
+
+-- containers
+import Data.Map.Strict
+ ( Map )
+import qualified Data.Map.Strict as Map
+ ( (\\), intersection, mapMaybe, toList, withoutKeys )
+
+-- ghc
+import GHC.Types.Error
+ ( DiagnosticCode(..) )
+
+-- lint-codes
+import LintCodes.Static
+ ( FamEqnIndex, used, outdated
+ , getFamEqnCodes
+ , staticallyUsedCodes
+ )
+import LintCodes.Coverage
+ ( getCoveredCodes )
+
+--------------------------------------------------------------------------------
+
+main :: IO ()
+main = do
+
+ ------------------------------
+ -- Static consistency checks.
+ famEqnCodes <- getFamEqnCodes
+
+ let
+ familyEqnUsedCodes = Map.mapMaybe used famEqnCodes
+ familyEqnOutdatedCodes = Map.mapMaybe outdated famEqnCodes
+
+ -- Consistency of diagnostic codes:
+ -- all diagnostic codes returned by the 'GhcDiagnosticCode' type family
+ -- should be statically used, unless they are marked as outdated.
+ staticallyUnusedCodes = familyEqnUsedCodes Map.\\ staticallyUsedCodes
+
+ -- Consistency of outdated diagnostic codes:
+ -- if a diagnostic code is marked as outdated, it should not be statically used.
+ outdatedStaticallyUsedCodes =
+ familyEqnOutdatedCodes `Map.intersection` staticallyUsedCodes
+
+ -- Test 1: all non-outdated 'GhcDiagnosticCode' equations are statically used.
+ let plural1 = length staticallyUnusedCodes > 1
+ test1OK :: Bool
+ test1Message :: String
+ (test1OK, test1Message)
+ | null staticallyUnusedCodes
+ = (True,) $
+ "- All non-outdated 'GhcDiagnosticCode' equations are statically used."
+ | otherwise
+ = (False,) $
+ unlines [ "- The following 'GhcDiagnosticCode' equation" ++ (if plural1 then "s appear" else " appears") ++ " to be unused."
+ , " If " ++ (if plural1 then "any of these codes are indeed no longer used, but were"
+ else "this code is indeed no longer used, but was")
+ , " emitted by a previous version of GHC, you should mark " ++ (if plural1 then "them" else "it") ++ " as outdated"
+ , " by tagging the RHS of the appropriate type family equation of"
+ , " the 'GhcDiagnosticCode' type family in 'GHC.Types.Error.Codes'"
+ , " with the 'Outdated' type synonym."
+ , ""
+ , showDiagnosticCodesWith printUnused staticallyUnusedCodes
+ ]
+ putStrLn ""
+ putStrLn test1Message
+ putStrLn ""
+
+ -- Test 2: all outdated 'GhcDiagnosticCode' equations are statically unused.
+ let plural2 = length outdatedStaticallyUsedCodes > 1
+ test2OK :: Bool
+ test2Message :: String
+ (test2OK, test2Message)
+ | null outdatedStaticallyUsedCodes
+ = (True,) $
+ "- All outdated 'GhcDiagnosticCode' equations are statically unused."
+ | otherwise
+ = (False,) $
+ unlines [ "- The following 'GhcDiagnosticCode' equation" ++ (if plural2 then "s are" else " is") ++ " still in use,"
+ , " even though " ++ (if plural2 then "they are" else "it is") ++ " marked as being outdated."
+ , " Perhaps you should remove the 'Outdated' tag on " ++ (if plural2 then "them" else "it") ++ "."
+ , ""
+ , showDiagnosticCodesWith printOutdatedUsed outdatedStaticallyUsedCodes
+ ]
+ putStrLn test2Message
+ putStrLn ""
+
+ -------------------------
+ -- Code coverage checks.
+
+ -- Test 3: all statically used diagnostic codes are covered by the testsuite,
+ -- (exceptions are allowed in the test output).
+ coveredCodes <- getCoveredCodes
+ when ( null coveredCodes ) $
+ error $ unlines [ "internal error in 'lint-codes' test:"
+ , " failed to parse any diagnostic codes from the testsuite"
+ ]
+
+ let uncoveredCodes :: Map DiagnosticCode (FamEqnIndex, String)
+ uncoveredCodes = (familyEqnUsedCodes `Map.intersection` staticallyUsedCodes)
+ `Map.withoutKeys` coveredCodes
+ plural3 = length uncoveredCodes > 1
+ test3OK :: Bool
+ test3Message :: String
+ (test3OK, test3Message)
+ | null uncoveredCodes
+ = (True,) $
+ "- All diagnostic codes are covered by the testsuite."
+ | otherwise
+ = (False,) $
+ unlines [ "- The following diagnostic code" ++ (if plural3 then "s seem" else " seems") ++ " to not be covered by any tests,"
+ , " as determined by analysing all '.stderr' and '.stdout' files in the testsuite."
+ , " If there is a change in the expected output of this test, you can:"
+ , " - add test cases to exercise any newly uncovered diagnostic codes,"
+ , " - accept the expected output of the 'codes' test by passing the '-a' flag to Hadrian."
+ , ""
+ , showDiagnosticCodesWith printUntested uncoveredCodes
+ ]
+
+ putStrLn test3Message
+ when (test1OK && test2OK && test3OK) do
+ putStrLn ""
+ putStrLn "All good!"
+
+-- | Show a collection of diagnostic codes, ordered by the index in which
+-- the diagnostic code appears in the 'GhcDiagnosticCode' type family.
+showDiagnosticCodesWith :: ( (DiagnosticCode, String) -> String )
+ -- ^ how to print each diagnostic code
+ -> Map DiagnosticCode (FamEqnIndex, String) -> String
+showDiagnosticCodesWith f codes = unlines $ map showCodeCon $ sortOn famEqnIndex $ Map.toList codes
+ where
+ showCodeCon :: (DiagnosticCode, (FamEqnIndex, String)) -> String
+ showCodeCon (code, (_, con)) = f (code, con)
+ famEqnIndex :: (DiagnosticCode, (FamEqnIndex, String)) -> FamEqnIndex
+ famEqnIndex (_, (i,_)) = i
+
+printUnused, printOutdatedUsed, printUntested :: (DiagnosticCode, String) -> String
+printUnused (code, con) =
+ "Unused equation: GhcDiagnosticCode " ++ show con ++ " = " ++ showDiagnosticCodeNumber code
+printOutdatedUsed (code, con) =
+ "Outdated equation is used: GhcDiagnosticCode " ++ show con ++ " = Outdated " ++ showDiagnosticCodeNumber code
+printUntested (code, con) =
+ "[" ++ show code ++ "] is untested (constructor = " ++ con ++ ")"
+
+showDiagnosticCodeNumber :: DiagnosticCode -> String
+showDiagnosticCodeNumber (DiagnosticCode { diagnosticCodeNumber = c })
+ = printf "%05d" c
diff --git a/linters/lint-codes/Makefile b/linters/lint-codes/Makefile
new file mode 100644
index 000000000000..ca23c15cdda8
--- /dev/null
+++ b/linters/lint-codes/Makefile
@@ -0,0 +1,15 @@
+# -----------------------------------------------------------------------------
+#
+# (c) 2009 The University of Glasgow
+#
+# This file is part of the GHC build system.
+#
+# To understand how the build system works and how to modify it, see
+# https://gitlab.haskell.org/ghc/ghc/wikis/building/architecture
+# https://gitlab.haskell.org/ghc/ghc/wikis/building/modifying
+#
+# -----------------------------------------------------------------------------
+
+dir = linters/lint-codes
+TOP = ../..
+include $(TOP)/mk/sub-makefile.mk
diff --git a/linters/lint-codes/cabal.project b/linters/lint-codes/cabal.project
new file mode 100644
index 000000000000..e6fdbadb4398
--- /dev/null
+++ b/linters/lint-codes/cabal.project
@@ -0,0 +1 @@
+packages: .
diff --git a/linters/lint-codes/ghc.mk b/linters/lint-codes/ghc.mk
new file mode 100644
index 000000000000..6c3d33e8258f
--- /dev/null
+++ b/linters/lint-codes/ghc.mk
@@ -0,0 +1,18 @@
+# -----------------------------------------------------------------------------
+#
+# (c) 2009 The University of Glasgow
+#
+# This file is part of the GHC build system.
+#
+# To understand how the build system works and how to modify it, see
+# https://gitlab.haskell.org/ghc/ghc/wikis/building/architecture
+# https://gitlab.haskell.org/ghc/ghc/wikis/building/modifying
+#
+# -----------------------------------------------------------------------------
+
+linters/lint-codes_USES_CABAL = YES
+linters/lint-codes_PACKAGE = lint-codes
+linters/lint-codes_dist-install_PROGNAME = lint-codes
+linters/lint-codes_dist-install_INSTALL = NO
+linters/lint-codes_dist-install_INSTALL_INPLACE = YES
+$(eval $(call build-prog,linters/lint-codes,dist-install,1))
diff --git a/linters/lint-codes/lint-codes.cabal b/linters/lint-codes/lint-codes.cabal
new file mode 100644
index 000000000000..0c08b05d376f
--- /dev/null
+++ b/linters/lint-codes/lint-codes.cabal
@@ -0,0 +1,42 @@
+cabal-version: 2.4
+name: lint-codes
+version: 0.1.0.0
+synopsis: A tool for checking coverage of GHC diagnostic codes
+bug-reports: https://gitlab.haskell.org/ghc/ghc
+license: BSD-3-Clause
+author: Sam Derbyshire
+maintainer: sam@well-typed.com
+copyright: (c) 2023 Sam Derbyshire
+
+executable lint-codes
+
+ main-is:
+ Main.hs
+
+ other-modules:
+ LintCodes.Coverage
+ LintCodes.Static
+
+ build-depends:
+ base >= 4 && < 5
+ , ghc >= 9.9
+ , bytestring
+ , containers
+ , directory
+ , filepath
+ , text
+ , transformers
+ , process
+
+ default-language:
+ Haskell2010
+
+ ghc-options:
+ -O1
+ -Wall
+ -Wcompat
+ -fwarn-missing-local-signatures
+ -fwarn-incomplete-patterns
+ -fwarn-incomplete-uni-patterns
+ -fwarn-missing-deriving-strategies
+ -fno-warn-unticked-promoted-constructors
diff --git a/testsuite/mk/boilerplate.mk b/testsuite/mk/boilerplate.mk
index 465ec29b9b80..53bd81f36244 100644
--- a/testsuite/mk/boilerplate.mk
+++ b/testsuite/mk/boilerplate.mk
@@ -239,6 +239,10 @@ ifeq "$(LINT_NOTES)" ""
LINT_NOTES := $(abspath $(TOP)/../inplace/bin/lint-notes)
endif
+ifeq "$(LINT_CODES)" ""
+LINT_CODES:= $(abspath $(TOP)/../inplace/bin/lint-codes)
+endif
+
ifeq "$(LINT_WHITESPACE)" ""
LINT_WHITESPACE := $(abspath $(TOP)/../inplace/bin/lint-whitespace)
endif
diff --git a/testsuite/tests/diagnostic-codes/Makefile b/testsuite/tests/diagnostic-codes/Makefile
new file mode 100644
index 000000000000..d47faa2d1574
--- /dev/null
+++ b/testsuite/tests/diagnostic-codes/Makefile
@@ -0,0 +1,6 @@
+TOP=../..
+
+LIBDIR := "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`"
+
+codes:
+ (cd $(TOP)/.. && $(LINT_CODES) $(LIBDIR))
diff --git a/testsuite/tests/diagnostic-codes/all.T b/testsuite/tests/diagnostic-codes/all.T
new file mode 100644
index 000000000000..30fd3c97f775
--- /dev/null
+++ b/testsuite/tests/diagnostic-codes/all.T
@@ -0,0 +1,12 @@
+
+# Copied from linters/all.T:
+def has_ls_files() -> bool:
+ try:
+ files = subprocess.check_output(['git', 'ls-files']).splitlines()
+ return b"hie.yaml" in files
+ except subprocess.CalledProcessError:
+ return False
+
+test('codes', [ normal if has_ls_files() else skip
+ , req_hadrian_deps(["lint:codes"]) ]
+ , makefile_test, ['codes'])
diff --git a/testsuite/tests/diagnostic-codes/codes.stdout b/testsuite/tests/diagnostic-codes/codes.stdout
new file mode 100644
index 000000000000..a3c10dd9eb31
--- /dev/null
+++ b/testsuite/tests/diagnostic-codes/codes.stdout
@@ -0,0 +1,127 @@
+
+- All non-outdated 'GhcDiagnosticCode' equations are statically used.
+
+- All outdated 'GhcDiagnosticCode' equations are statically unused.
+
+- The following diagnostic codes seem to not be covered by any tests,
+ as determined by analysing all '.stderr' and '.stdout' files in the testsuite.
+ If there is a change in the expected output of this test, you can:
+ - add test cases to exercise any newly uncovered diagnostic codes,
+ - accept the expected output of the 'codes' test by passing the '-a' flag to Hadrian.
+
+[GHC-93315] is untested (constructor = DsUselessSpecialiseForClassMethodSelector)
+[GHC-58181] is untested (constructor = DsOrphanRule)
+[GHC-69441] is untested (constructor = DsRuleLhsTooComplicated)
+[GHC-19551] is untested (constructor = DsAggregatedViewExpressions)
+[GHC-75725] is untested (constructor = PsErrCmmLexer)
+[GHC-09848] is untested (constructor = PsErrCmmParser)
+[GHC-95644] is untested (constructor = PsErrBangPatWithoutSpace)
+[GHC-45106] is untested (constructor = PsErrInvalidInfixHole)
+[GHC-44524] is untested (constructor = PsErrExpectedHyphen)
+[GHC-28021] is untested (constructor = PsErrRecordSyntaxInPatSynDecl)
+[GHC-24737] is untested (constructor = PsErrInvalidWhereBindInPatSynDecl)
+[GHC-65536] is untested (constructor = PsErrNoSingleWhereBindInPatSynDecl)
+[GHC-50396] is untested (constructor = PsErrInvalidRuleActivationMarker)
+[GHC-16863] is untested (constructor = PsErrUnsupportedBoxedSumPat)
+[GHC-40845] is untested (constructor = PsErrUnpackDataCon)
+[GHC-08195] is untested (constructor = PsErrInvalidRecordCon)
+[GHC-07636] is untested (constructor = PsErrLambdaCaseInPat)
+[GHC-92971] is untested (constructor = PsErrCaseCmdInFunAppCmd)
+[GHC-47171] is untested (constructor = PsErrLambdaCaseCmdInFunAppCmd)
+[GHC-97005] is untested (constructor = PsErrIfCmdInFunAppCmd)
+[GHC-70526] is untested (constructor = PsErrLetCmdInFunAppCmd)
+[GHC-77808] is untested (constructor = PsErrDoCmdInFunAppCmd)
+[GHC-67630] is untested (constructor = PsErrMDoInFunAppExpr)
+[GHC-25037] is untested (constructor = PsErrCaseInFunAppExpr)
+[GHC-90355] is untested (constructor = PsErrLetInFunAppExpr)
+[GHC-01239] is untested (constructor = PsErrIfInFunAppExpr)
+[GHC-04807] is untested (constructor = PsErrProcInFunAppExpr)
+[GHC-33856] is untested (constructor = PsErrSuffixAT)
+[GHC-25078] is untested (constructor = PsErrPrecedenceOutOfRange)
+[GHC-18910] is untested (constructor = PsErrSemiColonsInCondCmd)
+[GHC-66418] is untested (constructor = PsErrParseErrorOnInput)
+[GHC-85316] is untested (constructor = PsErrMalformedDecl)
+[GHC-49196] is untested (constructor = DriverFileNotFound)
+[GHC-19971] is untested (constructor = DriverBackpackModuleNotFound)
+[GHC-37141] is untested (constructor = DriverCannotLoadInterfaceFile)
+[GHC-29747] is untested (constructor = DriverMissingSafeHaskellMode)
+[GHC-06200] is untested (constructor = BlockedEquality)
+[GHC-81325] is untested (constructor = ExpectingMoreArguments)
+[GHC-78125] is untested (constructor = AmbiguityPreventsSolvingCt)
+[GHC-89223] is untested (constructor = KindMismatch)
+[GHC-84170] is untested (constructor = TcRnModMissingRealSrcSpan)
+[GHC-95822] is untested (constructor = TcRnSimplifierTooManyIterations)
+[GHC-17268] is untested (constructor = TcRnCharLiteralOutOfRange)
+[GHC-36495] is untested (constructor = TcRnTagToEnumMissingValArg)
+[GHC-55868] is untested (constructor = TcRnArrowIfThenElsePredDependsOnResultTy)
+[GHC-51876] is untested (constructor = TcRnDupeModuleExport)
+[GHC-64649] is untested (constructor = TcRnNullExportedModule)
+[GHC-94558] is untested (constructor = TcRnExportHiddenComponents)
+[GHC-63055] is untested (constructor = TcRnFieldUpdateInvalidType)
+[GHC-26133] is untested (constructor = TcRnForeignImportPrimSafeAnn)
+[GHC-03355] is untested (constructor = TcRnIllegalForeignDeclBackend)
+[GHC-01245] is untested (constructor = TcRnUnsupportedCallConv)
+[GHC-01570] is untested (constructor = TcRnExpectedValueId)
+[GHC-96665] is untested (constructor = TcRnMultipleInlinePragmas)
+[GHC-88293] is untested (constructor = TcRnUnexpectedPragmas)
+[GHC-85337] is untested (constructor = TcRnSpecialiseNotVisible)
+[GHC-91382] is untested (constructor = TcRnIllegalKindSignature)
+[GHC-72520] is untested (constructor = TcRnIgnoreSpecialisePragmaOnDefMethod)
+[GHC-10969] is untested (constructor = TcRnTyThingUsedWrong)
+[GHC-61072] is untested (constructor = TcRnGADTDataContext)
+[GHC-16409] is untested (constructor = TcRnMultipleConForNewtype)
+[GHC-54478] is untested (constructor = TcRnRedundantSourceImport)
+[GHC-78448] is untested (constructor = TcRnIllegalDataCon)
+[GHC-44990] is untested (constructor = TcRnGhciMonadLookupFail)
+[GHC-77343] is untested (constructor = TcRnIllegalQuasiQuotes)
+[GHC-22221] is untested (constructor = TyVarRoleMismatch)
+[GHC-99991] is untested (constructor = TyVarMissingInEnv)
+[GHC-92834] is untested (constructor = BadCoercionRole)
+[GHC-93008] is untested (constructor = HsigShapeSortMismatch)
+[GHC-68444] is untested (constructor = SumAltArityExceeded)
+[GHC-63966] is untested (constructor = IllegalSumAlt)
+[GHC-28709] is untested (constructor = MalformedType)
+[GHC-23882] is untested (constructor = IllegalDeclaration)
+[GHC-63930] is untested (constructor = MultiWayIfWithoutAlts)
+[GHC-91745] is untested (constructor = CasesExprWithoutAlts)
+[GHC-60220] is untested (constructor = InvalidCCallImpent)
+[GHC-18816] is untested (constructor = RecGadtNoCons)
+[GHC-38140] is untested (constructor = GadtNoCons)
+[GHC-37056] is untested (constructor = InvalidTypeInstanceHeader)
+[GHC-78486] is untested (constructor = InvalidTyFamInstLHS)
+[GHC-39639] is untested (constructor = DefaultDataInstDecl)
+[GHC-92057] is untested (constructor = ImportLookupAmbiguous)
+[GHC-91901] is untested (constructor = InstHeadMultiParam)
+[GHC-78822] is untested (constructor = AssocDefaultNotAssoc)
+[GHC-43510] is untested (constructor = NotSimpleUnliftedType)
+[GHC-41843] is untested (constructor = IOResultExpected)
+[GHC-07641] is untested (constructor = AtLeastOneArgExpected)
+[GHC-64852] is untested (constructor = BadSourceImport)
+[GHC-58427] is untested (constructor = HomeModError)
+[GHC-94559] is untested (constructor = CouldntFindInFiles)
+[GHC-22211] is untested (constructor = MissingPackageFiles)
+[GHC-88719] is untested (constructor = MissingPackageWayFiles)
+[GHC-83249] is untested (constructor = Can'tFindNameInInterface)
+[GHC-75429] is untested (constructor = CircularImport)
+[GHC-53693] is untested (constructor = HiModuleNameMismatchWarn)
+[GHC-47808] is untested (constructor = ExceptionOccurred)
+[GHC-76329] is untested (constructor = NotInScopeTc)
+[GHC-63388] is untested (constructor = DerivErrNotAClass)
+[GHC-37542] is untested (constructor = DerivErrMustHaveExactlyOneConstructor)
+[GHC-45539] is untested (constructor = DerivErrMustHaveSomeParameters)
+[GHC-10372] is untested (constructor = LookupInstErrNotExact)
+[GHC-10373] is untested (constructor = LookupInstErrFlexiVar)
+[GHC-10374] is untested (constructor = LookupInstErrNotFound)
+[GHC-41242] is untested (constructor = EmptyStmtsGroupInParallelComp)
+[GHC-63610] is untested (constructor = MissingBootDefinition)
+[GHC-52886] is untested (constructor = InvalidTopDecl)
+[GHC-77923] is untested (constructor = NonExactName)
+[GHC-86463] is untested (constructor = AddInvalidCorePlugin)
+[GHC-30384] is untested (constructor = CannotReifyInstance)
+[GHC-79890] is untested (constructor = CannotReifyThingNotInTypeEnv)
+[GHC-65923] is untested (constructor = NoRolesAssociatedWithThing)
+[GHC-75721] is untested (constructor = CannotRepresentType)
+[GHC-17599] is untested (constructor = AddTopDeclsUnexpectedDeclarationSplice)
+[GHC-86934] is untested (constructor = ClassPE)
+
+
--
GitLab