Remaining Cabal Package Exceptions (#9191)

* Remaining Cabal Package Exceptions * Accepting new error output with error code * Removing commented codes and adding constructor "RawSystemStdOut" in `Utils.hs` * Included a catch condition for VErboseException CabalException * Including "GetProgramInvocationException" with a `catch` condition for CabalException. * Rolling back "GetProgramInvocationException" --------- Co-authored-by: gbaz <[email protected]> Co-authored-by: mergify[bot] <37929162+mergify[bot]@users.noreply.github.com>
haskell · Aug 27, 2023 · 747af13 · 747af13
1 parent fbd9642
commit 747af13
Show file tree

Hide file tree

Showing 11 changed files with 206 additions and 135 deletions.
diff --git a/Cabal/src/Distribution/Simple/Errors.hs b/Cabal/src/Distribution/Simple/Errors.hs
@@ -32,6 +32,7 @@ import Distribution.Types.BenchmarkType
 import Distribution.Types.LibraryName
 import Distribution.Types.PkgconfigVersion
 import Distribution.Types.TestType
+import Distribution.Types.VersionRange.Internal ()
 import Distribution.Version
 import Text.PrettyPrint
 
@@ -144,6 +145,32 @@ data CabalException
   | CheckPackageProblems [String]
   | LibDirDepsPrefixNotRelative FilePath FilePath
   | CombinedConstraints Doc
+  | CantParseGHCOutput
+  | IncompatibleWithCabal String String
+  | Couldn'tFindTestProgram FilePath
+  | TestCoverageSupport
+  | Couldn'tFindTestProgLibV09 FilePath
+  | TestCoverageSupportLibV09
+  | RawSystemStdout String
+  | FindFileCwd FilePath
+  | FindFileEx FilePath
+  | FindModuleFileEx ModuleName [String] [FilePath]
+  | MultipleFilesWithExtension String
+  | NoDesc
+  | MultiDesc [String]
+  | RelocRegistrationInfo
+  | CreatePackageDB
+  | WithHcPkg String
+  | RegisMultiplePkgNotSupported
+  | RegisteringNotImplemented
+  | NoTestSuitesEnabled
+  | TestNameDisabled String
+  | NoSuchTest String
+  | ConfigureProgram String FilePath
+  | RequireProgram String
+  | NoProgramFound String VersionRange
+  | BadVersionDb String Version VersionRange FilePath
+  | UnknownVersionDb String VersionRange FilePath
   deriving (Show, Typeable)
 
 exceptionCode :: CabalException -> Int
@@ -249,6 +276,37 @@ exceptionCode e = case e of
   CheckPackageProblems{} -> 5559
   LibDirDepsPrefixNotRelative{} -> 6667
   CombinedConstraints{} -> 5000
+  CantParseGHCOutput{} -> 1980
+  IncompatibleWithCabal{} -> 8123
+  Couldn'tFindTestProgram{} -> 5678
+  TestCoverageSupport{} -> 7890
+  Couldn'tFindTestProgLibV09{} -> 9012
+  TestCoverageSupportLibV09{} -> 1076
+  RawSystemStdout{} -> 3098
+  FindFileCwd{} -> 4765
+  FindFileEx{} -> 2115
+  FindModuleFileEx{} -> 6663
+  MultipleFilesWithExtension{} -> 3333
+  NoDesc{} -> 7654
+  MultiDesc{} -> 5554
+  RelocRegistrationInfo{} -> 4343
+  CreatePackageDB{} -> 6787
+  WithHcPkg{} -> 9876
+  RegisMultiplePkgNotSupported{} -> 7632
+  RegisteringNotImplemented{} -> 5411
+  NoTestSuitesEnabled{} -> 9061
+  TestNameDisabled{} -> 8210
+  NoSuchTest{} -> 8000
+  ConfigureProgram{} -> 5490
+  RequireProgram{} -> 6666
+  NoProgramFound{} -> 7620
+  BadVersionDb{} -> 8038
+  UnknownVersionDb{} -> 1008
+
+versionRequirement :: VersionRange -> String
+versionRequirement range
+  | isAnyVersion range = ""
+  | otherwise = " version " ++ prettyShow range
 
 exceptionMessage :: CabalException -> String
 exceptionMessage e = case e of
@@ -538,17 +596,17 @@ exceptionMessage e = case e of
   HowToFindInstalledPackages flv ->
     "don't know how to find the installed packages for "
       ++ prettyShow flv
-  PkgConfigNotFound pkg versionRequirement ->
+  PkgConfigNotFound pkg versionReq ->
     "The pkg-config package '"
       ++ pkg
       ++ "'"
-      ++ versionRequirement
+      ++ versionReq
       ++ " is required but it could not be found."
-  BadVersion pkg versionRequirement v ->
+  BadVersion pkg versionReq v ->
     "The pkg-config package '"
       ++ pkg
       ++ "'"
-      ++ versionRequirement
+      ++ versionReq
       ++ " is required but the version installed on the"
       ++ " system is version "
       ++ prettyShow v
@@ -645,3 +703,92 @@ exceptionMessage e = case e of
       text "The following package dependencies were requested"
         $+$ nest 4 dispDepend
         $+$ text "however the given installed package instance does not exist."
+  CantParseGHCOutput -> "Can't parse --info output of GHC"
+  IncompatibleWithCabal compilerName packagePathEnvVar ->
+    "Use of "
+      ++ compilerName
+      ++ "'s environment variable "
+      ++ packagePathEnvVar
+      ++ " is incompatible with Cabal. Use the "
+      ++ "flag --package-db to specify a package database (it can be "
+      ++ "used multiple times)."
+  Couldn'tFindTestProgram cmd ->
+    "Could not find test program \""
+      ++ cmd
+      ++ "\". Did you build the package first?"
+  TestCoverageSupport -> "Test coverage is only supported for packages with a library component."
+  Couldn'tFindTestProgLibV09 cmd ->
+    "Could not find test program \""
+      ++ cmd
+      ++ "\". Did you build the package first?"
+  TestCoverageSupportLibV09 -> "Test coverage is only supported for packages with a library component."
+  RawSystemStdout errors -> errors
+  FindFileCwd fileName -> fileName ++ " doesn't exist"
+  FindFileEx fileName -> fileName ++ " doesn't exist"
+  FindModuleFileEx mod_name extensions searchPath ->
+    "Could not find module: "
+      ++ prettyShow mod_name
+      ++ " with any suffix: "
+      ++ show extensions
+      ++ " in the search path: "
+      ++ show searchPath
+  MultipleFilesWithExtension buildInfoExt -> "Multiple files with extension " ++ buildInfoExt
+  NoDesc ->
+    "No cabal file found.\n"
+      ++ "Please create a package description file <pkgname>.cabal"
+  MultiDesc l ->
+    "Multiple cabal files found.\n"
+      ++ "Please use only one of: "
+      ++ intercalate ", " l
+  RelocRegistrationInfo ->
+    "Distribution.Simple.Register.relocRegistrationInfo: \
+    \not implemented for this compiler"
+  CreatePackageDB ->
+    "Distribution.Simple.Register.createPackageDB: "
+      ++ "not implemented for this compiler"
+  WithHcPkg name ->
+    "Distribution.Simple.Register."
+      ++ name
+      ++ ":\
+         \not implemented for this compiler"
+  RegisMultiplePkgNotSupported -> "Registering multiple package instances is not yet supported for this compiler"
+  RegisteringNotImplemented -> "Registering is not implemented for this compiler"
+  NoTestSuitesEnabled ->
+    "No test suites enabled. Did you remember to configure with "
+      ++ "\'--enable-tests\'?"
+  TestNameDisabled tName ->
+    "Package configured with test suite "
+      ++ tName
+      ++ " disabled."
+  NoSuchTest tName -> "no such test: " ++ tName
+  ConfigureProgram name path ->
+    "Cannot find the program '"
+      ++ name
+      ++ "'. User-specified path '"
+      ++ path
+      ++ "' does not refer to an executable and "
+      ++ "the program is not on the system path."
+  RequireProgram progName -> "The program '" ++ progName ++ "' is required but it could not be found."
+  NoProgramFound progName versionRange ->
+    "The program '"
+      ++ progName
+      ++ "'"
+      ++ versionRequirement versionRange
+      ++ " is required but it could not be found."
+  BadVersionDb progName version range locationPath ->
+    "The program '"
+      ++ progName
+      ++ "'"
+      ++ versionRequirement range
+      ++ " is required but the version found at "
+      ++ locationPath
+      ++ " is version "
+      ++ prettyShow version
+  UnknownVersionDb progName versionRange locationPath ->
+    "The program '"
+      ++ progName
+      ++ "'"
+      ++ versionRequirement versionRange
+      ++ " is required but the version of "
+      ++ locationPath
+      ++ " could not be determined."
diff --git a/Cabal/src/Distribution/Simple/GHC/Internal.hs b/Cabal/src/Distribution/Simple/GHC/Internal.hs
@@ -51,6 +51,10 @@ module Distribution.Simple.GHC.Internal
 import Distribution.Compat.Prelude
 import Prelude ()
 
+import Data.Bool (bool)
+import qualified Data.ByteString.Lazy.Char8 as BS
+import qualified Data.Map as Map
+import qualified Data.Set as Set
 import Distribution.Backpack
 import Distribution.Compat.Stack
 import qualified Distribution.InstalledPackageInfo as IPI
@@ -61,6 +65,7 @@ import Distribution.Parsec (simpleParsec)
 import Distribution.Pretty (prettyShow)
 import Distribution.Simple.BuildPaths
 import Distribution.Simple.Compiler
+import Distribution.Simple.Errors
 import Distribution.Simple.Flag (Flag (NoFlag), maybeToFlag, toFlag)
 import Distribution.Simple.GHC.ImplInfo
 import Distribution.Simple.LocalBuildInfo
@@ -69,6 +74,7 @@ import Distribution.Simple.Program.GHC
 import Distribution.Simple.Setup.Common (extraCompilationArtifacts)
 import Distribution.Simple.Utils
 import Distribution.System
+import Distribution.Types.ComponentId (ComponentId)
 import Distribution.Types.ComponentLocalBuildInfo
 import Distribution.Types.LocalBuildInfo
 import Distribution.Types.TargetInfo
@@ -78,12 +84,6 @@ import Distribution.Utils.Path
 import Distribution.Verbosity
 import Distribution.Version (Version)
 import Language.Haskell.Extension
-
-import Data.Bool (bool)
-import qualified Data.ByteString.Lazy.Char8 as BS
-import qualified Data.Map as Map
-import qualified Data.Set as Set
-import Distribution.Types.ComponentId (ComponentId)
 import System.Directory (getDirectoryContents, getTemporaryDirectory)
 import System.Environment (getEnv)
 import System.FilePath
@@ -285,7 +285,7 @@ getGhcInfo verbosity _implInfo ghcProg = do
       | all isSpace ss ->
           return i
     _ ->
-      die' verbosity "Can't parse --info output of GHC"
+      dieWithException verbosity CantParseGHCOutput
 
 getExtensions
   :: Verbosity
@@ -753,15 +753,7 @@ checkPackageDbEnvVar verbosity compilerName packagePathEnvVar = do
       (Just `fmap` getEnv name)
         `catchIO` const (return Nothing)
     abort =
-      die' verbosity $
-        "Use of "
-          ++ compilerName
-          ++ "'s environment variable "
-          ++ packagePathEnvVar
-          ++ " is incompatible with Cabal. Use the "
-          ++ "flag --package-db to specify a package database (it can be "
-          ++ "used multiple times)."
-
+      dieWithException verbosity $ IncompatibleWithCabal compilerName packagePathEnvVar
     _ = callStack -- TODO: output stack when erroring
 
 profDetailLevelFlag :: Bool -> ProfDetailLevel -> Flag GhcProfAuto

diff --git a/Cabal/src/Distribution/Simple/Haddock.hs b/Cabal/src/Distribution/Simple/Haddock.hs
@@ -182,7 +182,6 @@ getHaddockProg verbosity programDb comp args quickJumpFlag = do
   -- various sanity checks
   when (hoogle && version < mkVersion [2, 2]) $
     dieWithException verbosity NoSupportForHoogle
-  -- "Haddock 2.0 and 2.1 do not support the --hoogle flag."
 
   when (fromFlag argQuickJump && version < mkVersion [2, 19]) $ do
     let msg = "Haddock prior to 2.19 does not support the --quickjump flag."
@@ -1116,7 +1115,7 @@ hscolour'
   -> HscolourFlags
   -> IO ()
 hscolour' onNoHsColour haddockTarget pkg_descr lbi suffixes flags =
-  either onNoHsColour (\(hscolourProg, _, _) -> go hscolourProg)
+  either (\excep -> onNoHsColour $ exceptionMessage excep) (\(hscolourProg, _, _) -> go hscolourProg)
     =<< lookupProgramVersion
       verbosity
       hscolourProgram

diff --git a/Cabal/src/Distribution/Simple/Program/Db.hs b/Cabal/src/Distribution/Simple/Program/Db.hs
@@ -63,7 +63,6 @@ module Distribution.Simple.Program.Db
 import Distribution.Compat.Prelude
 import Prelude ()
 
-import Distribution.Pretty
 import Distribution.Simple.Program.Builtin
 import Distribution.Simple.Program.Find
 import Distribution.Simple.Program.Types
@@ -75,6 +74,7 @@ import Distribution.Version
 import Data.Tuple (swap)
 
 import qualified Data.Map as Map
+import Distribution.Simple.Errors
 
 -- ------------------------------------------------------------
 
@@ -348,16 +348,8 @@ configureProgram verbosity prog progdb = do
         else
           findProgramOnSearchPath verbosity (progSearchPath progdb) path
             >>= maybe
-              (die' verbosity notFound)
+              (dieWithException verbosity $ ConfigureProgram name path)
               (return . Just . swap . fmap UserSpecified . swap)
-      where
-        notFound =
-          "Cannot find the program '"
-            ++ name
-            ++ "'. User-specified path '"
-            ++ path
-            ++ "' does not refer to an executable and "
-            ++ "the program is not on the system path."
   case maybeLocation of
     Nothing -> return progdb
     Just (location, triedLocations) -> do
@@ -437,10 +429,8 @@ requireProgram
 requireProgram verbosity prog progdb = do
   mres <- needProgram verbosity prog progdb
   case mres of
-    Nothing -> die' verbosity notFound
+    Nothing -> dieWithException verbosity $ RequireProgram (programName prog)
     Just res -> return res
-  where
-    notFound = "The program '" ++ programName prog ++ "' is required but it could not be found."
 
 -- | Check that a program is configured and available to be run.
 --
@@ -477,51 +467,24 @@ lookupProgramVersion
   -> Program
   -> VersionRange
   -> ProgramDb
-  -> IO (Either String (ConfiguredProgram, Version, ProgramDb))
+  -> IO (Either CabalException (ConfiguredProgram, Version, ProgramDb))
 lookupProgramVersion verbosity prog range programDb = do
   -- If it's not already been configured, try to configure it now
   programDb' <- case lookupProgram prog programDb of
     Nothing -> configureProgram verbosity prog programDb
     Just _ -> return programDb
 
   case lookupProgram prog programDb' of
-    Nothing -> return $! Left notFound
+    Nothing -> return $! Left $ NoProgramFound (programName prog) range
     Just configuredProg@ConfiguredProgram{programLocation = location} ->
       case programVersion configuredProg of
         Just version
           | withinRange version range ->
               return $! Right (configuredProg, version, programDb')
           | otherwise ->
-              return $! Left (badVersion version location)
+              return $! Left $ BadVersionDb (programName prog) version range (locationPath location)
         Nothing ->
-          return $! Left (unknownVersion location)
-  where
-    notFound =
-      "The program '"
-        ++ programName prog
-        ++ "'"
-        ++ versionRequirement
-        ++ " is required but it could not be found."
-    badVersion v l =
-      "The program '"
-        ++ programName prog
-        ++ "'"
-        ++ versionRequirement
-        ++ " is required but the version found at "
-        ++ locationPath l
-        ++ " is version "
-        ++ prettyShow v
-    unknownVersion l =
-      "The program '"
-        ++ programName prog
-        ++ "'"
-        ++ versionRequirement
-        ++ " is required but the version of "
-        ++ locationPath l
-        ++ " could not be determined."
-    versionRequirement
-      | isAnyVersion range = ""
-      | otherwise = " version " ++ prettyShow range
+          return $! Left $ UnknownVersionDb (programName prog) range (locationPath location)
 
 -- | Like 'lookupProgramVersion', but raises an exception in case of error
 -- instead of returning 'Left errMsg'.
@@ -533,5 +496,5 @@ requireProgramVersion
   -> IO (ConfiguredProgram, Version, ProgramDb)
 requireProgramVersion verbosity prog range programDb =
   join $
-    either (die' verbosity) return
+    either (dieWithException verbosity) return
       `fmap` lookupProgramVersion verbosity prog range programDb