Cabal Error Refactor (#9018)

* I have added a function "dieWithException" which will replace the die' calls and throws Error types as exception. CabalException will hold all ErrorTypes, types will be incrementally added per module. The VerboseException a will have CabalException and cabalInstallException variously in the a position Utils.hs 1. Creation of Error data types 2. Diewithexception and exceptionCode function 3. Instance for VerboseException Bench.hs and install.hs 1. Replaced die' call sites with dieWithException Right now I have only added errors from two modules Distribtuion/Simple/Bench and Distribution/Simple/Install. Error types will be added incrementally. * Codebase is formatted with fourmolu and compiled without warnings. * Enabled fourmolu action * Running fourmolu through github action as the previous ones failed. * Function `exceptionWithMetadata` and constructors for each exception type * I have added a function "dieWithException" which will replace the die' calls and throws Error types as exception. CabalException will hold all ErrorTypes, types will be incrementally added per module. The VerboseException a will have CabalException and cabalInstallException variously in the a position Utils.hs 1. Creation of Error data types 2. Diewithexception and exceptionCode function 3. Instance for VerboseException Bench.hs and install.hs 1. Replaced die' call sites with dieWithException Right now I have only added errors from two modules Distribtuion/Simple/Bench and Distribution/Simple/Install. Error types will be added incrementally. * Codebase is formatted with fourmolu and compiled without warnings. * Enabled fourmolu action * Running fourmolu through github action as the previous ones failed. * Function `exceptionWithMetadata` and constructors for each exception type * Updated changelog * PatternMatching cases of diewithexception and displayexception reduced * Delete fourmolu.yaml This file is redundant. * Delete settings.json This file is redundant. * Replaced die' calls for modules srcDist.hs and HcPkg.hs * Replaced die' calls in modules `build.hs`,`Haddock.hs` and `Program.hs` * Replaced die' calls in modules `Build.hs`, `Haddock.hs` and `Program.hs` * Replaced die' calls in modules `GHCJS.hs`, `HaskellSuite.hs` and `BuildPaths.hs` * Formatted the codebase with Fourmolu * Accepted the new output with error codes and adding the file relevant to the test * Changes in `Utils.hs` and `Errors.hs` to reflect the new error codes * Keeping rip intact * test changes * CallStack unmarked from the error output * callstack unmarked from output * unmarked callstack in test output * Format the codebase with fourmolu * Changed to Error identifier to "Cabal-" * Updated Constructors as per review comments * Rectifying Hlint warning --------- Co-authored-by: Gershom Bazerman <gershom@arista.com>
haskell · Jul 20, 2023 · 667be46 · 667be46
1 parent baa767a
commit 667be46
Show file tree

Hide file tree

Showing 22 changed files with 402 additions and 178 deletions.
diff --git a/Cabal/Cabal.cabal b/Cabal/Cabal.cabal
@@ -98,6 +98,7 @@ library
     Distribution.Simple.Command
     Distribution.Simple.Compiler
     Distribution.Simple.Configure
+    Distribution.Simple.Errors
     Distribution.Simple.Flag
     Distribution.Simple.GHC
     Distribution.Simple.GHCJS

diff --git a/Cabal/src/Distribution/Simple/Bench.hs b/Cabal/src/Distribution/Simple/Bench.hs
@@ -31,8 +31,10 @@ import qualified Distribution.Simple.LocalBuildInfo as LBI
 import Distribution.Simple.Setup.Benchmark
 import Distribution.Simple.UserHooks
 import Distribution.Simple.Utils
+
 import Distribution.Types.UnqualComponentName
 
+import Distribution.Simple.Errors
 import System.Directory (doesFileExist)
 import System.FilePath ((<.>), (</>))
 
@@ -65,10 +67,8 @@ bench args pkg_descr lbi flags = do
             -- Check that the benchmark executable exists.
             exists <- doesFileExist cmd
             unless exists $
-              die' verbosity $
-                "Could not find benchmark program \""
-                  ++ cmd
-                  ++ "\". Did you build the package first?"
+              dieWithException verbosity $
+                NoBenchMarkProgram cmd
 
             notice verbosity $ startMessage name
             -- This will redirect the child process
@@ -92,9 +92,7 @@ bench args pkg_descr lbi flags = do
     exitSuccess
 
   when (PD.hasBenchmarks pkg_descr && null enabledBenchmarks) $
-    die' verbosity $
-      "No benchmarks enabled. Did you remember to configure with "
-        ++ "\'--enable-benchmarks\'?"
+    dieWithException verbosity EnableBenchMark
 
   bmsToRun <- case benchmarkNames of
     [] -> return enabledBenchmarks
@@ -106,11 +104,8 @@ bench args pkg_descr lbi flags = do
             Just t -> return t
             _
               | mkUnqualComponentName bmName `elem` allNames ->
-                  die' verbosity $
-                    "Package configured with benchmark "
-                      ++ bmName
-                      ++ " disabled."
-              | otherwise -> die' verbosity $ "no such benchmark: " ++ bmName
+                  dieWithException verbosity $ BenchMarkNameDisabled bmName
+              | otherwise -> dieWithException verbosity $ NoBenchMark bmName
 
   let totalBenchmarks = length bmsToRun
   notice verbosity $ "Running " ++ show totalBenchmarks ++ " benchmarks..."

diff --git a/Cabal/src/Distribution/Simple/Build.hs b/Cabal/src/Distribution/Simple/Build.hs
@@ -94,6 +94,7 @@ import Distribution.Compat.Graph (IsNode (..))
 
 import Control.Monad
 import qualified Data.ByteString.Lazy as LBS
+import Distribution.Simple.Errors
 import System.Directory (doesFileExist, getCurrentDirectory, removeFile)
 import System.FilePath (takeDirectory, (<.>), (</>))
 
@@ -220,9 +221,7 @@ dumpBuildInfo verbosity distPref dumpBuildInfoFlag pkg_descr lbi flags = do
 
     (compilerProg, _) <- case flavorToProgram (compilerFlavor (compiler lbi)) of
       Nothing ->
-        die' verbosity $
-          "dumpBuildInfo: Unknown compiler flavor: "
-            ++ show (compilerFlavor (compiler lbi))
+        dieWithException verbosity $ UnknownCompilerFlavor (compilerFlavor (compiler lbi))
       Just program -> requireProgram verbosity program (withPrograms lbi)
 
     let (warns, json) = mkBuildInfo pwd pkg_descr lbi flags (compilerProg, compiler lbi) activeTargets
@@ -270,9 +269,9 @@ repl pkg_descr lbi flags suffixes args = do
       -- This seems DEEPLY questionable.
       [] -> case allTargetsInBuildOrder' pkg_descr lbi of
         (target : _) -> return target
-        [] -> die' verbosity $ "Failed to determine target."
+        [] -> dieWithException verbosity $ FailedToDetermineTarget
       [target] -> return target
-      _ -> die' verbosity $ "The 'repl' command does not support multiple targets at once."
+      _ -> dieWithException verbosity $ NoMultipleTargets
   let componentsToBuild = neededTargetsInBuildOrder' pkg_descr lbi [nodeKey target]
   debug verbosity $
     "Component build order: "
@@ -335,7 +334,7 @@ startInterpreter verbosity programDb comp platform packageDBs =
   case compilerFlavor comp of
     GHC -> GHC.startInterpreter verbosity programDb comp platform packageDBs
     GHCJS -> GHCJS.startInterpreter verbosity programDb comp platform packageDBs
-    _ -> die' verbosity "A REPL is not supported with this compiler."
+    _ -> dieWithException verbosity REPLNotSupported
 
 buildComponent
   :: Verbosity
@@ -534,7 +533,7 @@ buildComponent
   (CTest TestSuite{testInterface = TestSuiteUnsupported tt})
   _
   _ =
-    die' verbosity $ "No support for building test suite type " ++ prettyShow tt
+    dieWithException verbosity $ NoSupportBuildingTestSuite tt
 buildComponent
   verbosity
   numJobs
@@ -566,7 +565,7 @@ buildComponent
   (CBench Benchmark{benchmarkInterface = BenchmarkUnsupported tt})
   _
   _ =
-    die' verbosity $ "No support for building benchmark type " ++ prettyShow tt
+    dieWithException verbosity $ NoSupportBuildingBenchMark tt
 
 generateCode
   :: [String]
@@ -739,7 +738,7 @@ replComponent
   (CTest TestSuite{testInterface = TestSuiteUnsupported tt})
   _
   _ =
-    die' verbosity $ "No support for building test suite type " ++ prettyShow tt
+    dieWithException verbosity $ NoSupportBuildingTestSuite tt
 replComponent
   replFlags
   verbosity
@@ -764,7 +763,7 @@ replComponent
   (CBench Benchmark{benchmarkInterface = BenchmarkUnsupported tt})
   _
   _ =
-    die' verbosity $ "No support for building benchmark type " ++ prettyShow tt
+    dieWithException verbosity $ NoSupportBuildingBenchMark tt
 
 ----------------------------------------------------
 -- Shared code for buildComponent and replComponent
@@ -960,7 +959,7 @@ buildLib verbosity numJobs pkg_descr lbi lib clbi =
     GHCJS -> GHCJS.buildLib verbosity numJobs pkg_descr lbi lib clbi
     UHC -> UHC.buildLib verbosity pkg_descr lbi lib clbi
     HaskellSuite{} -> HaskellSuite.buildLib verbosity pkg_descr lbi lib clbi
-    _ -> die' verbosity "Building is not supported with this compiler."
+    _ -> dieWithException verbosity BuildingNotSupportedWithCompiler
 
 -- | Build a foreign library
 --
@@ -977,7 +976,7 @@ buildFLib
 buildFLib verbosity numJobs pkg_descr lbi flib clbi =
   case compilerFlavor (compiler lbi) of
     GHC -> GHC.buildFLib verbosity numJobs pkg_descr lbi flib clbi
-    _ -> die' verbosity "Building is not supported with this compiler."
+    _ -> dieWithException verbosity BuildingNotSupportedWithCompiler
 
 buildExe
   :: Verbosity
@@ -992,7 +991,7 @@ buildExe verbosity numJobs pkg_descr lbi exe clbi =
     GHC -> GHC.buildExe verbosity numJobs pkg_descr lbi exe clbi
     GHCJS -> GHCJS.buildExe verbosity numJobs pkg_descr lbi exe clbi
     UHC -> UHC.buildExe verbosity pkg_descr lbi exe clbi
-    _ -> die' verbosity "Building is not supported with this compiler."
+    _ -> dieWithException verbosity BuildingNotSupportedWithCompiler
 
 replLib
   :: ReplOptions
@@ -1008,7 +1007,7 @@ replLib replFlags verbosity pkg_descr lbi lib clbi =
     -- NoFlag as the numJobs parameter.
     GHC -> GHC.replLib replFlags verbosity NoFlag pkg_descr lbi lib clbi
     GHCJS -> GHCJS.replLib (replOptionsFlags replFlags) verbosity NoFlag pkg_descr lbi lib clbi
-    _ -> die' verbosity "A REPL is not supported for this compiler."
+    _ -> dieWithException verbosity REPLNotSupported
 
 replExe
   :: ReplOptions
@@ -1022,7 +1021,7 @@ replExe replFlags verbosity pkg_descr lbi exe clbi =
   case compilerFlavor (compiler lbi) of
     GHC -> GHC.replExe replFlags verbosity NoFlag pkg_descr lbi exe clbi
     GHCJS -> GHCJS.replExe (replOptionsFlags replFlags) verbosity NoFlag pkg_descr lbi exe clbi
-    _ -> die' verbosity "A REPL is not supported for this compiler."
+    _ -> dieWithException verbosity REPLNotSupported
 
 replFLib
   :: ReplOptions
@@ -1035,7 +1034,7 @@ replFLib
 replFLib replFlags verbosity pkg_descr lbi exe clbi =
   case compilerFlavor (compiler lbi) of
     GHC -> GHC.replFLib replFlags verbosity NoFlag pkg_descr lbi exe clbi
-    _ -> die' verbosity "A REPL is not supported for this compiler."
+    _ -> dieWithException verbosity REPLNotSupported
 
 -- | Runs 'componentInitialBuildSteps' on every configured component.
 initialBuildSteps

diff --git a/Cabal/src/Distribution/Simple/BuildPaths.hs b/Cabal/src/Distribution/Simple/BuildPaths.hs
@@ -50,20 +50,20 @@ module Distribution.Simple.BuildPaths
 import Distribution.Compat.Prelude
 import Prelude ()
 
+import Data.List (stripPrefix)
 import Distribution.Compiler
 import Distribution.ModuleName as ModuleName
 import Distribution.Package
 import Distribution.PackageDescription
 import Distribution.Pretty
+import Distribution.Simple.Errors
 import Distribution.Simple.LocalBuildInfo
 import Distribution.Simple.Setup.Common (defaultDistPref)
 import Distribution.Simple.Setup.Haddock (HaddockTarget (..))
 import Distribution.Simple.Utils
 import Distribution.System
 import Distribution.Utils.Path
 import Distribution.Verbosity
-
-import Data.List (stripPrefix)
 import System.FilePath (normalise, (<.>), (</>))
 
 -- ---------------------------------------------------------------------------
@@ -192,7 +192,8 @@ getSourceFiles verbosity dirs modules = flip traverse modules $ \m ->
     findFileWithExtension ["hs", "lhs", "hsig", "lhsig"] dirs (ModuleName.toFilePath m)
       >>= maybe (notFound m) (return . normalise)
   where
-    notFound module_ = die' verbosity $ "can't find source for module " ++ prettyShow module_
+    notFound module_ =
+      dieWithException verbosity $ CantFindSourceModule module_
 
 -- | The directory where we put build results for an executable
 exeBuildDir :: LocalBuildInfo -> Executable -> FilePath