Cabal Error Refactor

.github/workflows/fourmolu.yaml

@@ -0,0 +1,11 @@
+name: fourmolu
+on: push
+jobs:
+  format:
+    runs-on: ubuntu-latest
+    steps:
+      # Note that you must checkout your code before running haskell-actions/run-fourmolu
+      - uses: actions/checkout@v2
+      - uses: haskell-actions/run-fourmolu@v9
+        with:
+          version: "0.12.0.0"

.vscode/settings.json

@@ -0,0 +1,3 @@
+{
+    "haskell.formattingProvider": "fourmolu"
+}

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

Cabal/src/Distribution/Simple/Bench.hs

@@ -30,11 +30,13 @@ import Distribution.Simple.InstallDirs
 import qualified Distribution.Simple.LocalBuildInfo as LBI
 import Distribution.Simple.Setup.Benchmark
 import Distribution.Simple.UserHooks
-import Distribution.Simple.Utils
+import Distribution.Simple.Utils 
+
 import Distribution.Types.UnqualComponentName
 
 import System.Directory (doesFileExist)
 import System.FilePath ((<.>), (</>))
+import Distribution.Simple.Errors
 
 -- | Perform the \"@.\/setup bench@\" action.
 bench
@@ -65,11 +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
             -- stdout/stderr to the parent process.
@@ -92,9 +91,8 @@ 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,9 @@ 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 $ BenchMarkNameDisable bmName
+              | otherwise -> dieWithException verbosity $ NoBenchMark bmName
+
 
   let totalBenchmarks = length bmsToRun
   notice verbosity $ "Running " ++ show totalBenchmarks ++ " benchmarks..."

Cabal/src/Distribution/Simple/Errors.hs

@@ -0,0 +1,61 @@
+-----------------------------------------------------------------------------
+
+-- Module      :  Distribution.Simple.Errors
+-- Copyright   :  
+-- License     :  
+--
+-- Maintainer  :  
+-- Portability :  
+--
+-- A collection of Exception Types used throughout 
+--the rest of the Cabal library package
+
+module Distribution.Simple.Errors
+(
+ CabalException (..)
+ ,exceptionCode
+ ,exceptionMessage
+) where
+
+import Distribution.Compat.Prelude
+import Distribution.Compiler
+import Distribution.Pretty
+  ( prettyShow
+  )
+
+
+-- Types representing exceptions thrown by functions in all the modules of Cabal Package
+data CabalException =  NoBenchMarkProgram FilePath
+                    | EnableBenchMark
+                    | BenchMarkNameDisable String
+                    | NoBenchMark String            
+                    | NoLibraryFound
+                    | CompilerNotInstalled CompilerFlavor
+                    | CantFindIncludeFile String
+                    | SourceDistException String
+ deriving (Show,Typeable)
+
+exceptionCode :: CabalException -> Int
+exceptionCode e = case e of 
+  (NoBenchMarkProgram _)   -> 1678
+  EnableBenchMark          -> 1453
+  (BenchMarkNameDisable _) -> 2781
+  (NoBenchMark _)          -> 1654
+  NoLibraryFound           -> 2546
+  (CompilerNotInstalled _) -> 7465
+  (CantFindIncludeFile _)  -> 3876
+  (SourceDistException _ ) -> 3245
+
+exceptionMessage :: CabalException -> String
+exceptionMessage e = case e of
+    NoBenchMarkProgram cmd          -> "Could not find benchmark program \"" ++ cmd ++ "\". Did you build the package first?"
+    EnableBenchMark                 -> "No benchmarks enabled. Did you remember to configure with " ++ "\'--enable-benchmarks\'?"
+    BenchMarkNameDisable bmName     -> "Package configured with benchmark " ++ bmName ++ " disabled."
+    NoBenchMark bmName              -> "no such benchmark: " ++ bmName
+    NoLibraryFound                  -> "No executables and no library found. Nothing to do."
+    CompilerNotInstalled compilerFlavor -> "installing with " ++ prettyShow compilerFlavor ++ "is not implemented"
+    CantFindIncludeFile file        -> "can't find include file " ++ file
+    (SourceDistException _ )        -> "3245"
+
+
+

Cabal/src/Distribution/Simple/Install.hs

@@ -49,8 +49,9 @@ import Distribution.Simple.Setup.Haddock
   ( HaddockTarget (ForDevelopment)
   )
 import Distribution.Simple.Utils
+
   ( createDirectoryIfMissingVerbose
-  , die'
+  , dieWithException
   , info
   , installDirectoryContents
   , installOrdinaryFile
@@ -65,6 +66,7 @@ import qualified Distribution.Simple.GHC as GHC
 import qualified Distribution.Simple.GHCJS as GHCJS
 import qualified Distribution.Simple.HaskellSuite as HaskellSuite
 import qualified Distribution.Simple.UHC as UHC
+import Distribution.Simple.Errors
 
 import System.Directory
   ( doesDirectoryExist
@@ -113,7 +115,8 @@ install pkg_descr lbi flags = do
 
     checkHasLibsOrExes =
       unless (hasLibs pkg_descr || hasForeignLibs pkg_descr || hasExes pkg_descr) $
-        die' verbosity "No executables and no library found. Nothing to do."
+        dieWithException verbosity NoLibraryFound 
+        -- InstallException "No executables and no library found. Nothing to do."
 
 -- | Copy package global files.
 copyPackage
@@ -223,10 +226,12 @@ copyComponent verbosity pkg_descr lbi (CLib lib) clbi copydest = do
         lib
         clbi
     _ ->
-      die' verbosity $
-        "installing with "
-          ++ prettyShow (compilerFlavor (compiler lbi))
-          ++ " is not implemented"
+      dieWithException verbosity $ CompilerNotInstalled (compilerFlavor (compiler lbi))
+       -- InstallException 
+        -- ("installing with "
+         -- ++ prettyShow (compilerFlavor (compiler lbi))
+         -- ++ " is not implemented")
+
 copyComponent verbosity pkg_descr lbi (CFLib flib) clbi copydest = do
   let InstallDirs
         { flibdir = flibPref
@@ -241,10 +246,11 @@ copyComponent verbosity pkg_descr lbi (CFLib flib) clbi copydest = do
     GHC -> GHC.installFLib verbosity lbi flibPref buildPref pkg_descr flib
     GHCJS -> GHCJS.installFLib verbosity lbi flibPref buildPref pkg_descr flib
     _ ->
-      die' verbosity $
-        "installing foreign lib with "
-          ++ prettyShow (compilerFlavor (compiler lbi))
-          ++ " is not implemented"
+      dieWithException verbosity $ CompilerNotInstalled (compilerFlavor (compiler lbi))
+       -- ("installing foreign lib with "
+       --   ++ prettyShow (compilerFlavor (compiler lbi))
+       --   ++ " is not implemented")
+
 copyComponent verbosity pkg_descr lbi (CExe exe) clbi copydest = do
   let installDirs = absoluteComponentInstallDirs pkg_descr lbi (componentUnitId clbi) copydest
       -- the installers know how to find the actual location of the
@@ -279,10 +285,10 @@ copyComponent verbosity pkg_descr lbi (CExe exe) clbi copydest = do
     UHC -> return ()
     HaskellSuite{} -> return ()
     _ ->
-      die' verbosity $
-        "installing with "
-          ++ prettyShow (compilerFlavor (compiler lbi))
-          ++ " is not implemented"
+      dieWithException verbosity $ CompilerNotInstalled (compilerFlavor (compiler lbi))
+       -- ("installing with "
+       --   ++ prettyShow (compilerFlavor (compiler lbi))
+        --  ++ " is not implemented")
 
 -- Nothing to do for benchmark/testsuite
 copyComponent _ _ _ (CBench _) _ _ = return ()
@@ -322,7 +328,8 @@ installIncludeFiles verbosity libBi lbi buildPref destIncludeDir = do
     ]
   where
     baseDir lbi' = fromMaybe "" (takeDirectory <$> cabalFilePath lbi')
-    findInc [] file = die' verbosity ("can't find include file " ++ file)
+    findInc [] file = dieWithException verbosity $ CantFindIncludeFile file
+    -- InstallException ("can't find include file " ++ file)
     findInc (dir : dirs) file = do
       let path = dir </> file
       exists <- doesFileExist path

Cabal/src/Distribution/Simple/SrcDist.hs

@@ -69,6 +69,7 @@ import Data.Time (UTCTime, getCurrentTime, toGregorian, utctDay)
 import System.Directory (doesFileExist)
 import System.FilePath (dropExtension, isRelative, (<.>), (</>))
 import System.IO (IOMode (WriteMode), hPutStrLn, withFile)
+import Distribution.Simple.Errors
 
 -- | Create a source distribution.
 sdist
@@ -165,9 +166,9 @@ listPackageSourcesWithDie
   -- ^ extra preprocessors (include suffixes)
   -> IO [FilePath]
   -- ^ relative paths
-listPackageSourcesWithDie verbosity rip cwd pkg_descr0 pps = do
+listPackageSourcesWithDie verbosity _rip cwd pkg_descr0 pps = do
   -- Call helpers that actually do all work.
-  listPackageSources' verbosity rip cwd pkg_descr pps
+  listPackageSources' verbosity _rip cwd pkg_descr pps
   where
     pkg_descr = filterAutogenModules pkg_descr0
 
@@ -187,7 +188,7 @@ listPackageSources'
   -- ^ extra preprocessors (include suffixes)
   -> IO [FilePath]
   -- ^ relative paths
-listPackageSources' verbosity rip cwd pkg_descr pps =
+listPackageSources' verbosity _rip cwd pkg_descr pps =
   fmap concat . sequenceA $
     [ -- Library sources.
       fmap concat
@@ -197,19 +198,19 @@ listPackageSources' verbosity rip cwd pkg_descr pps =
             , signatures = sigs
             , libBuildInfo = libBi
             } ->
-            allSourcesBuildInfo verbosity rip cwd libBi pps (modules ++ sigs)
+            allSourcesBuildInfo verbosity _rip cwd libBi pps (modules ++ sigs)
     , -- Executables sources.
       fmap concat
         . withAllExe
         $ \Executable{modulePath = mainPath, buildInfo = exeBi} -> do
-          biSrcs <- allSourcesBuildInfo verbosity rip cwd exeBi pps []
+          biSrcs <- allSourcesBuildInfo verbosity _rip cwd exeBi pps []
           mainSrc <- findMainExeFile verbosity cwd exeBi pps mainPath
           return (mainSrc : biSrcs)
     , -- Foreign library sources
       fmap concat
         . withAllFLib
         $ \flib@(ForeignLib{foreignLibBuildInfo = flibBi}) -> do
-          biSrcs <- allSourcesBuildInfo verbosity rip cwd flibBi pps []
+          biSrcs <- allSourcesBuildInfo verbosity _rip cwd flibBi pps []
           defFiles <-
             traverse
               (findModDefFile verbosity cwd flibBi pps)
@@ -222,25 +223,25 @@ listPackageSources' verbosity rip cwd pkg_descr pps =
           let bi = testBuildInfo t
           case testInterface t of
             TestSuiteExeV10 _ mainPath -> do
-              biSrcs <- allSourcesBuildInfo verbosity rip cwd bi pps []
+              biSrcs <- allSourcesBuildInfo verbosity _rip cwd bi pps []
               srcMainFile <- findMainExeFile verbosity cwd bi pps mainPath
               return (srcMainFile : biSrcs)
             TestSuiteLibV09 _ m ->
-              allSourcesBuildInfo verbosity rip cwd bi pps [m]
+              allSourcesBuildInfo verbosity _rip cwd bi pps [m]
             TestSuiteUnsupported tp ->
-              rip verbosity $ "Unsupported test suite type: " ++ show tp
+              dieWithException verbosity $ SourceDistException ("Unsupported test suite type: " ++ show tp)
     , -- Benchmarks sources.
       fmap concat
         . withAllBenchmark
         $ \bm -> do
           let bi = benchmarkBuildInfo bm
           case benchmarkInterface bm of
             BenchmarkExeV10 _ mainPath -> do
-              biSrcs <- allSourcesBuildInfo verbosity rip cwd bi pps []
+              biSrcs <- allSourcesBuildInfo verbosity _rip cwd bi pps []
               srcMainFile <- findMainExeFile verbosity cwd bi pps mainPath
               return (srcMainFile : biSrcs)
             BenchmarkUnsupported tp ->
-              rip verbosity $ "Unsupported benchmark type: " ++ show tp
+              dieWithException verbosity $ SourceDistException ("Unsupported benchmark type: " ++ show tp)
     , -- Data files.
       fmap concat
         . for (dataFiles pkg_descr)
@@ -249,15 +250,15 @@ listPackageSources' verbosity rip cwd pkg_descr pps =
               srcDataDir
                 | null srcDataDirRaw = "."
                 | otherwise = srcDataDirRaw
-          matchDirFileGlobWithDie verbosity rip (specVersion pkg_descr) cwd (srcDataDir </> filename)
+          matchDirFileGlobWithDie verbosity _rip (specVersion pkg_descr) cwd (srcDataDir </> filename)
     , -- Extra source files.
       fmap concat . for (extraSrcFiles pkg_descr) $ \fpath ->
-        matchDirFileGlobWithDie verbosity rip (specVersion pkg_descr) cwd fpath
+        matchDirFileGlobWithDie verbosity _rip (specVersion pkg_descr) cwd fpath
     , -- Extra doc files.
       fmap concat
         . for (extraDocFiles pkg_descr)
         $ \filename ->
-          matchDirFileGlobWithDie verbosity rip (specVersion pkg_descr) cwd filename
+          matchDirFileGlobWithDie verbosity _rip (specVersion pkg_descr) cwd filename
     , -- License file(s).
       return (map getSymbolicPath $ licenseFiles pkg_descr)
     , -- Install-include files, without autogen-include files
@@ -361,7 +362,7 @@ findModDefFile verbosity cwd flibBi _pps modDefPath =
 -- @f@. Return the name of the file and the full path, or exit with error if
 -- there's no such file.
 findIncludeFile :: Verbosity -> FilePath -> [FilePath] -> String -> IO (String, FilePath)
-findIncludeFile verbosity _ [] f = die' verbosity ("can't find include file " ++ f)
+findIncludeFile verbosity _ [] f = dieWithException verbosity $ SourceDistException ("can't find include file " ++ f)
 findIncludeFile verbosity cwd (d : ds) f = do
   let path = (d </> f)
   b <- doesFileExist (cwd </> path)
@@ -504,7 +505,7 @@ allSourcesBuildInfo
   -> [ModuleName]
   -- ^ Exposed modules
   -> IO [FilePath]
-allSourcesBuildInfo verbosity rip cwd bi pps modules = do
+allSourcesBuildInfo verbosity _rip cwd bi pps modules = do
   let searchDirs = map getSymbolicPath (hsSourceDirs bi)
   sources <-
     fmap concat $
@@ -542,13 +543,13 @@ allSourcesBuildInfo verbosity rip cwd bi pps modules = do
 
     notFound :: ModuleName -> IO [FilePath]
     notFound m =
-      rip verbosity $
-        "Could not find module: "
+      dieWithException verbosity $ SourceDistException
+        ("Could not find module: "
           ++ prettyShow m
           ++ " with any suffix: "
           ++ show suffixes
           ++ ". If the module "
-          ++ "is autogenerated it should be added to 'autogen-modules'."
+          ++ "is autogenerated it should be added to 'autogen-modules'.")
 
 -- | Note: must be called with the CWD set to the directory containing
 -- the '.cabal' file.