Fix #5911 Apply unique error codes to Stack-generated errors

CONTRIBUTING.md

@@ -209,6 +209,49 @@ repository on Windows, then the files will be checked out as small plain files
 that contain the link text  See the
 [Git documentation](https://git-scm.com/docs/git-config#Documentation/git-config.txt-coresymlinks).
 
+## Error messages
+
+Stack catches exceptions thrown by its dependencies or by Stack itself in
+`Main.main`. In addition to exceptions that halt Stack's execution, Stack logs
+certain other matters as 'errors'.
+
+To support the Haskell Foundation's
+[Haskell Error Index](https://errors.haskell.org/) initiative, all Stack
+error messages generated by Stack itself should have a unique initial line:
+
+~~~text
+Error: [S-nnnn]
+~~~
+
+where `nnnn` is a four-digit number in the range 1000 to 9999.
+
+If you create a new Stack error, select a number using a random number generator
+(see, for example, [RANDOM.ORG](https://www.random.org/)) and check that number
+is not already in use in Stack's code. If it is, pick another until the number
+is unique.
+
+All exceptions generated by Stack itself are implemented using data constructors
+of closed sum types. Typically, there is one such type for each module that
+exports functions that throw exceptions. This type and the related `instance`
+definitions are usually located at the top of the relevant module.
+
+Stack supports two types of exceptions: 'pretty' exceptions that are instances
+of class `RIO.PrettyPrint.Pretty`, which provides `pretty :: e -> StyleDoc`, and
+thrown as expressions of type `RIO.PrettyPrint.PrettyException.PrettyException`;
+and other 'plain' exceptions that are simply instances of class
+`Control.Exception.Exception` and, hence, instances of class `Show`. These types
+and classes are re-exported by `Stack.Prelude`.
+
+Stack throws exceptions in parts of the code that should, in principle, be
+unreachable. The functions `Stack.Prelude.bugReport` and
+`Stack.Prelude.bugPrettyReport` are used to give the messages a consistent
+format. The names of the data constructors for those exceptions usually end in
+`Bug`.
+
+In a few cases, Stack may throw an exception in 'pure' code. The function
+`RIO.impureThrow :: Exception e => e -> a`, re-exported by `Stack.Prelude`, is
+used for that purpose.
+
 ## Code
 
 If you would like to contribute code to fix a bug, add a new feature, or

ChangeLog.md

@@ -21,6 +21,10 @@ Behavior changes:
 * `stack setup` with the `--no-install-ghc` flag warns that the flag and the
   command are inconsistent and now takes no action. Previously the flag was
   silently ignored.
+* To support the Haskell Foundation's
+  [Haskell Error Index](https://errors.haskell.org/) initiative, all Stack
+  error messages generated by Stack itself begin with an unique code in the
+  form `[S-nnnn]`, where `nnnn` is a four-digit number.
 
 Other enhancements:
 

doc/maintainers/stack_errors.md

@@ -26,7 +26,7 @@ to take stock of the errors that Stack itself can raise, by reference to the
     -   `Control.Concurrent.ExecuteException`
 
         ~~~haskell
-        [S-2816] = InconsistentDependencies
+        [S-2816] = InconsistentDependenciesBug
         ~~~
 
     -   `Main.MainException`
@@ -41,7 +41,7 @@ to take stock of the errors that Stack itself can raise, by reference to the
         ~~~haskell
         [S-8100] = GHCProfOptionInvalid
         [S-8761] | ResolverOptionInvalid
-        [S-8251] | PackageIdNotFound String
+        [S-8251] | PackageIdNotFoundBug String
         [S-2483] | ExecutableToRunNotFound
         ~~~
 
@@ -147,7 +147,7 @@ to take stock of the errors that Stack itself can raise, by reference to the
         ~~~haskell
         [S-3025] = HoogleDatabaseNotFound
         [S-1329] | HoogleNotFound String
-        [S-9669] | HoogleOnPathNotFound
+        [S-9669] | HoogleOnPathNotFoundBug
         ~~~
 
     -   `Stack.Init.InitException`
@@ -166,16 +166,16 @@ to take stock of the errors that Stack itself can raise, by reference to the
         [S-4926] = CouldNotParsePackageSelectors [String]
         ~~~
 
-    -   `Stack.Ls.LsException` *
+    -   `Stack.Lock.LockException`
 
         ~~~haskell
-        [S-3421] = ParseFailure [Value]
+        [S-1353] = WritingLockFileError (Path Abs File) Locked
         ~~~
 
-    -   `Stack.Lock.LockException`
+    -   `Stack.Ls.LsException` *
 
         ~~~haskell
-        [S-1353] = WritingLockFileError (Path Abs File) Locked
+        [S-3421] = ParseFailure [Value]
         ~~~
 
     -   `Stack.New.NewException`
@@ -272,10 +272,10 @@ to take stock of the errors that Stack itself can raise, by reference to the
         [S-1827] | UnknownArchiveStructure (Path Abs File)
         [S-9476] | StackReleaseInfoNotFound String
         [S-4461] | StackBinaryArchiveNotFound [String]
-        [S-2076] | WorkingDirectoryInvalid
+        [S-2076] | WorkingDirectoryInvalidBug
         [S-6617] | HadrianBindistNotFound
         [S-7227] | DownloadAndInstallCompilerError
-        [S-3967] | StackBinaryArchiveZipUnsupported
+        [S-3967] | StackBinaryArchiveZipUnsupportedBug
         [S-6636] | StackBinaryArchiveUnsupported Text
         [S-7871] | StackBinaryNotInArchive String Text
         [S-5046] | FileTypeInArchiveInvalid Entry Text
@@ -328,6 +328,7 @@ to take stock of the errors that Stack itself can raise, by reference to the
         [S-6739] | MulipleResultsBug PackageName [DumpPackage]
         [S-3121] | TemplateHaskellNotFoundBug
         [S-6901] | HaddockIndexNotFound
+        [S-5452] | ShowBuildErrorBug
         ~~~
 
     -   `Stack.Types.Compiler.CompilerException`
@@ -421,6 +422,13 @@ to take stock of the errors that Stack itself can raise, by reference to the
         [S-7410] = DefaultTemplateNameNotParsedBug String
         ~~~
 
+    -   `Stack.Unpack.UnpackException`
+
+        ~~~haskell
+        [S-3515] = UnpackDirectoryAlreadyExists (Set (Path Abs Dir))
+        [S-2628] | CouldNotParsePackageSelectors [String]
+        ~~~
+
     -   `Stack.Upgrade.UpgradeException`
 
         ~~~haskell
@@ -438,13 +446,6 @@ to take stock of the errors that Stack itself can raise, by reference to the
         [S-6108] | ArchiveUploadFailure Int [String] String
         ~~~
 
-    -   `Stack.Unpack.UnpackException`
-
-        ~~~haskell
-        [S-3515] = UnpackDirectoryAlreadyExists (Set (Path Abs Dir))
-        [S-2628] | CouldNotParsePackageSelectors [String]
-        ~~~
-
     -   `System.Process.Pager.PagerException`
 
         ~~~haskell

src/Control/Concurrent/Execute.hs

@@ -21,14 +21,13 @@ import qualified Data.Set                 as Set
 -- | Type representing exceptions thrown by functions exported by the
 -- "Control.Concurrent.Execute" module.
 data ExecuteException
-    = InconsistentDependencies
+    = InconsistentDependenciesBug
     deriving Typeable
 
 instance Show ExecuteException where
-    show InconsistentDependencies =
+    show InconsistentDependenciesBug = bugReport "[S-2816]"
         "Inconsistent dependencies were discovered while executing your build \
-        \plan. This should never happen, please report it as a bug to the \
-        \Stack team."
+        \plan."
 
 instance Exception ExecuteException
 
@@ -126,7 +125,8 @@ runActions' ExecuteState {..} =
                 if Set.null inAction
                     then do
                         unless esKeepGoing $
-                            modifyTVar esExceptions (toException InconsistentDependencies:)
+                            modifyTVar esExceptions
+                                (toException InconsistentDependenciesBug:)
                         pure $ pure ()
                     else retry
             (xs, action:ys) -> do

src/Options/Applicative/Builder/Extra.hs

@@ -54,8 +54,10 @@ data OptionsApplicativeExtraException
 
 instance Show OptionsApplicativeExtraException where
   show FlagNotFoundBug =
-    "Error: The impossible happened! No valid flags found in \
-    \enableDisableFlagsNoDefault."
+    "Error: [S-2797]\n"
+    ++ "The impossible happened! No valid flags found in \
+       \enableDisableFlagsNoDefault. Please report this bug at Stack's \
+       \repository."
 
 instance Exception OptionsApplicativeExtraException
 

src/Stack/Build.hs

@@ -51,6 +51,51 @@ import           Stack.Types.SourceMap
 import           Stack.Types.Compiler (compilerVersionText, getGhcVersion)
 import           System.Terminal (fixCodePage)
 
+data CabalVersionException
+    = AllowNewerNotSupported Version
+    | CabalVersionNotSupported Version
+    deriving (Typeable)
+
+instance Show CabalVersionException where
+    show (AllowNewerNotSupported cabalVer) = concat
+        [ "Error: [S-8503]\n"
+        , "'--allow-newer' requires Cabal version 1.22 or greater, but "
+        , "version "
+        , versionString cabalVer
+        , " was found."
+        ]
+    show (CabalVersionNotSupported cabalVer) = concat
+        [ "Error: [S-5973]\n"
+        , "Stack no longer supports Cabal versions before 1.19.2, "
+        , "but version "
+        , versionString cabalVer
+        , " was found. To fix this, consider updating the resolver to lts-3.0 "
+        , "or later or to nightly-2015-05-05 or later."
+        ]
+
+instance Exception CabalVersionException
+
+data QueryException
+    = SelectorNotFound [Text]
+    | IndexOutOfRange [Text]
+    | NoNumericSelector [Text]
+    | CannotApplySelector Value [Text]
+    deriving (Typeable)
+
+instance Show QueryException where
+    show (SelectorNotFound sels) = err "[S-4419]" "Selector not found" sels
+    show (IndexOutOfRange sels) = err "[S-8422]" "Index out of range" sels
+    show (NoNumericSelector sels) =
+        err "[S-4360]" "Encountered array and needed numeric selector" sels
+    show (CannotApplySelector value sels) =
+        err "[S-1711]" ("Cannot apply selector to " ++ show value) sels
+
+instance Exception QueryException
+
+-- | Helper function for 'QueryException' instance of 'Show'
+err :: String -> String -> [Text] -> String
+err msg code sels = "Error: " ++ code ++ "\n" ++ msg ++ ": " ++ show sels
+
 -- | Build.
 --
 --   If a buildLock is passed there is an important contract here.  That lock must
@@ -145,49 +190,6 @@ checkCabalVersion = do
     when (cabalVer < mkVersion [1, 19, 2]) $ throwM $
         CabalVersionNotSupported cabalVer
 
-data CabalVersionException
-    = AllowNewerNotSupported Version
-    | CabalVersionNotSupported Version
-    deriving (Typeable)
-
-instance Show CabalVersionException where
-    show (AllowNewerNotSupported cabalVer) = concat
-        [ "Error: --allow-newer requires at least Cabal version 1.22, but "
-        , "version "
-        , versionString cabalVer
-        , " was found."
-        ]
-    show (CabalVersionNotSupported cabalVer) = concat
-        [ "Error: Stack no longer supports Cabal versions older than 1.19.2, "
-        , "but version "
-        , versionString cabalVer
-        , " was found. To fix this, consider updating the resolver to lts-3.0 "
-        , "or later or to nightly-2015-05-05 or later."
-        ]
-
-instance Exception CabalVersionException
-
-data QueryException
-    = SelectorNotFound [Text]
-    | IndexOutOfRange [Text]
-    | NoNumericSelector [Text]
-    | CannotApplySelector Value [Text]
-    deriving (Typeable)
-
-instance Show QueryException where
-    show (SelectorNotFound sels) = err "Selector not found" sels
-    show (IndexOutOfRange sels) = err "Index out of range" sels
-    show (NoNumericSelector sels) =
-        err "Encountered array and needed numeric selector" sels
-    show (CannotApplySelector value sels) =
-        err ("Cannot apply selector to " ++ show value) sels
-
-instance Exception QueryException
-
--- Helper function for 'QueryException' instance of 'Show'
-err :: String -> [Text] -> String
-err msg sels = "Error: " ++ msg ++ ": " ++ show sels
-
 -- | See https://github.com/commercialhaskell/stack/issues/1198.
 warnIfExecutablesWithSameNameCouldBeOverwritten
     :: HasLogFunc env => [LocalPackage] -> Plan -> RIO env ()

src/Stack/Build/ConstructPlan.hs

@@ -283,7 +283,8 @@ data NotOnlyLocal = NotOnlyLocal [PackageName] [Text]
 
 instance Show NotOnlyLocal where
   show (NotOnlyLocal packages exes) = concat
-    [ "Specified only-locals, but I need to build snapshot contents:\n"
+    [ "Error: [S-1727]\n"
+    , "Specified only-locals, but I need to build snapshot contents:\n"
     , if null packages then "" else concat
         [ "Packages: "
         , L.intercalate ", " (map packageNameString packages)

src/Stack/BuildPlan.hs

@@ -60,13 +60,15 @@ data BuildPlanException
 
 instance Show BuildPlanException where
     show (SnapshotNotFound snapName) = unlines
-        [ "SnapshotNotFound " ++ snapName'
+        [ "Error: [S-2045]"
+        , "SnapshotNotFound " ++ snapName'
         , "Non existing resolver: " ++ snapName' ++ "."
         , "For a complete list of available snapshots see https://www.stackage.org/snapshots"
         ]
         where snapName' = show snapName
     show (UnknownPackages stackYaml unknown shadowed) =
-        unlines $ unknown' ++ shadowed'
+        "Error: [S-7571]\n"
+        ++ unlines (unknown' ++ shadowed')
       where
         unknown' :: [String]
         unknown'
@@ -133,13 +135,13 @@ instance Show BuildPlanException where
                       $ Set.unions
                       $ Map.elems shadowed
     show (NeitherCompilerOrResolverSpecified url) = concat
-        [ "Failed to load custom snapshot at "
+        [ "Error: [S-8559]\n"
+        , "Failed to load custom snapshot at "
         , T.unpack url
         , ", because no 'compiler' or 'resolver' is specified."
         ]
-    show DuplicatePackagesBug =
-        "Error: The impossible happened. Duplicate packages are not expected \
-        \here"
+    show DuplicatePackagesBug = bugReport "[S-5743]"
+        "Duplicate packages are not expected here."
 
 instance Exception BuildPlanException
 

src/Stack/Clean.hs

@@ -28,11 +28,14 @@ data CleanException
     deriving Typeable
 
 instance Show CleanException where
-    show (NonLocalPackages pkgs) =
-        "The following packages are not part of this project: " ++
-        intercalate ", " (map show pkgs)
+    show (NonLocalPackages pkgs) = concat
+        [ "Error: [S-9463]\n"
+        , "The following packages are not part of this project: "
+        , intercalate ", " (map show pkgs)
+        ]
     show (DeletionFailures failures) = concat
-        [ "Error: Exception while recursively deleting:\n"
+        [ "Error: [S-6321]\n"
+        , "Exception while recursively deleting:\n"
         , concatMap (\(dir, e) -> toFilePath dir <> "\n" <> show e <> "\n") failures
         , "Perhaps you do not have permission to delete these files or they \
           \are in use?"

src/Stack/Config.hs

@@ -288,11 +288,12 @@ configFromConfigMonoid
        shortLocalProgramsFilePath <-
          liftIO $ getShortPathName localProgramsFilePath
        when (' ' `elem` shortLocalProgramsFilePath) $ do
-         logError $ "Stack's 'programs' path contains a space character and " <>
-           "has no alternative short ('8 dot 3') name. This will cause " <>
-           "problems with packages that use the GNU project's 'configure' " <>
-           "shell script. Use the 'local-programs-path' configuration option " <>
-           "to specify an alternative path. The current path is: " <>
+         logError $ "Error: [S-8432]\n"<>
+           "Stack's 'programs' path contains a space character and has no " <>
+           "alternative short ('8 dot 3') name. This will cause problems " <>
+           "with packages that use the GNU project's 'configure' shell " <>
+           "script. Use the 'local-programs-path' configuration option to " <>
+           "specify an alternative path. The current path is: " <>
            display (T.pack localProgramsFilePath)
      platformOnlyDir <- runReaderT platformOnlyRelDir (configPlatform, configPlatformVariant)
      let configLocalPrograms = configLocalProgramsBase </> platformOnlyDir

src/Stack/Config/Docker.hs

@@ -26,7 +26,8 @@ data ConfigDockerException
 instance Show ConfigDockerException where
     show (ResolverNotSupportedException mproject maresolver) =
         concat
-            [ "Resolver not supported for Docker images:\n    "
+            [ "Error: [S-8575]\n"
+            , "Resolver not supported for Docker images:\n    "
             , case (mproject, maresolver) of
                 (Nothing, Nothing) -> "no resolver specified"
                 (_, Just aresolver) -> T.unpack $ utf8BuilderToText $ display aresolver