Subsequent Cabal Exceptions

Cabal/src/Distribution/Simple/BuildTarget.hs

@@ -47,18 +47,18 @@ import Distribution.Types.LocalBuildInfo
 import Distribution.Types.TargetInfo
 import Distribution.Types.UnqualComponentName
 
+import qualified Distribution.Compat.CharParsing as P
 import Distribution.ModuleName
 import Distribution.Package
 import Distribution.PackageDescription
 import Distribution.Parsec
 import Distribution.Pretty
+import Distribution.Simple.Errors
 import Distribution.Simple.LocalBuildInfo
 import Distribution.Simple.Utils
 import Distribution.Utils.Path
 import Distribution.Verbosity
 
-import qualified Distribution.Compat.CharParsing as P
-
 import Control.Arrow ((&&&))
 import Control.Monad (msum)
 import Data.List (groupBy, stripPrefix)
@@ -246,19 +246,8 @@ reportUserBuildTargetProblems verbosity problems = do
   case [target | UserBuildTargetUnrecognised target <- problems] of
     [] -> return ()
     target ->
-      die' verbosity $
-        unlines
-          [ "Unrecognised build target '" ++ name ++ "'."
-          | name <- target
-          ]
-          ++ "Examples:\n"
-          ++ " - build foo          -- component name "
-          ++ "(library, executable, test-suite or benchmark)\n"
-          ++ " - build Data.Foo     -- module name\n"
-          ++ " - build Data/Foo.hsc -- file name\n"
-          ++ " - build lib:foo exe:foo   -- component qualified by kind\n"
-          ++ " - build foo:Data.Foo      -- module qualified by component\n"
-          ++ " - build foo:Data/Foo.hsc  -- file qualified by component"
+      dieWithException verbosity $
+        UnrecognisedBuildTarget target
 
 showUserBuildTarget :: UserBuildTarget -> String
 showUserBuildTarget = intercalate ":" . getComponents
@@ -407,57 +396,29 @@ reportBuildTargetProblems verbosity problems = do
   case [(t, e, g) | BuildTargetExpected t e g <- problems] of
     [] -> return ()
     targets ->
-      die' verbosity $
-        unlines
-          [ "Unrecognised build target '"
-            ++ showUserBuildTarget target
-            ++ "'.\n"
-            ++ "Expected a "
-            ++ intercalate " or " expected
-            ++ ", rather than '"
-            ++ got
-            ++ "'."
-          | (target, expected, got) <- targets
-          ]
+      dieWithException verbosity $
+        ReportBuildTargetProblems $
+          map (\(target, expected, got) -> (showUserBuildTarget target, expected, got)) targets
 
   case [(t, e) | BuildTargetNoSuch t e <- problems] of
     [] -> return ()
     targets ->
-      die' verbosity $
-        unlines
-          [ "Unknown build target '"
-            ++ showUserBuildTarget target
-            ++ "'.\nThere is no "
-            ++ intercalate
-              " or "
-              [ mungeThing thing ++ " '" ++ got ++ "'"
-              | (thing, got) <- nosuch
-              ]
-            ++ "."
-          | (target, nosuch) <- targets
-          ]
-      where
-        mungeThing "file" = "file target"
-        mungeThing thing = thing
+      dieWithException verbosity $
+        UnknownBuildTarget $
+          map (\(target, nosuch) -> (showUserBuildTarget target, nosuch)) targets
 
   case [(t, ts) | BuildTargetAmbiguous t ts <- problems] of
     [] -> return ()
     targets ->
-      die' verbosity $
-        unlines
-          [ "Ambiguous build target '"
-            ++ showUserBuildTarget target
-            ++ "'. It could be:\n "
-            ++ unlines
-              [ "   "
-                ++ showUserBuildTarget ut
-                ++ " ("
-                ++ showBuildTargetKind bt
-                ++ ")"
-              | (ut, bt) <- amb
-              ]
-          | (target, amb) <- targets
-          ]
+      dieWithException verbosity $
+        AmbiguousBuildTarget $
+          map
+            ( \(target, amb) ->
+                ( showUserBuildTarget target
+                , (map (\(ut, bt) -> (showUserBuildTarget ut, showBuildTargetKind bt)) amb)
+                )
+            )
+            targets
   where
     showBuildTargetKind (BuildTargetComponent _) = "component"
     showBuildTargetKind (BuildTargetModule _ _) = "module"
@@ -1093,7 +1054,7 @@ checkBuildTargets verbosity pkg_descr lbi targets = do
 
   case disabled of
     [] -> return ()
-    ((cname, reason) : _) -> die' verbosity $ formatReason (showComponentName cname) reason
+    ((cname, reason) : _) -> dieWithException verbosity $ CheckBuildTargets $ formatReason (showComponentName cname) reason
 
   for_ [(c, t) | (c, Just t) <- enabled] $ \(c, t) ->
     warn verbosity $

Cabal/src/Distribution/Simple/ConfigureScript.hs

@@ -22,13 +22,13 @@ import Prelude ()
 
 -- local
 import Distribution.PackageDescription
+import Distribution.Pretty
+import Distribution.Simple.Errors
+import Distribution.Simple.LocalBuildInfo
 import Distribution.Simple.Program
 import Distribution.Simple.Program.Db
 import Distribution.Simple.Setup.Common
 import Distribution.Simple.Setup.Config
-
-import Distribution.Pretty
-import Distribution.Simple.LocalBuildInfo
 import Distribution.Simple.Utils
 import Distribution.System (buildPlatform)
 import Distribution.Utils.NubList
@@ -182,18 +182,11 @@ runConfigureScript verbosity flags lbi = do
         (programInvocation (sh{programOverrideEnv = overEnv}) args')
           { progInvokeCwd = Just (buildDir lbi)
           }
-    Nothing -> die' verbosity notFoundMsg
+    Nothing -> dieWithException verbosity NotFoundMsg
   where
     args = configureArgs backwardsCompatHack flags
     backwardsCompatHack = False
 
-    notFoundMsg =
-      "The package has a './configure' script. "
-        ++ "If you are on Windows, This requires a "
-        ++ "Unix compatibility toolchain such as MinGW+MSYS or Cygwin. "
-        ++ "If you are not on Windows, ensure that an 'sh' command "
-        ++ "is discoverable in your path."
-
 -- | Convert Windows path to Unix ones
 toUnix :: String -> String
 #ifdef mingw32_HOST_OS

Cabal/src/Distribution/Simple/Errors.hs

@@ -70,12 +70,31 @@ data CabalException
   | PkgDumpFailed
   | FailedToParseOutput
   | CantFindSourceModule ModuleName
-  | VersionMisMatch FilePath Version FilePath Version
-  | VersionMisMatchGHC FilePath Version FilePath Version
+  | VersionMismatchJS FilePath Version FilePath Version
+  | VersionMismatchGHCJS FilePath Version FilePath Version
   | GlobalPackageDBLimitation
   | GlobalPackageDBSpecifiedFirst
   | MatchDirFileGlob String
   | MatchDirFileGlobErrors [String]
+  | ErrorParsingFileDoesntExist FilePath
+  | FailedParsing String
+  | NotFoundMsg
+  | UnrecognisedBuildTarget [String]
+  | ReportBuildTargetProblems [(String, [String], String)]
+  | UnknownBuildTarget [(String, [(String, String)])]
+  | AmbiguousBuildTarget [(String, [(String, String)])]
+  | CheckBuildTargets String
+  | VersionMismatchGHC FilePath Version FilePath Version
+  | CheckPackageDbStackPost76
+  | CheckPackageDbStackPre76
+  | GlobalPackageDbSpecifiedFirst
+  | CantInstallForeignLib
+  | NoSupportForPreProcessingTest TestType
+  | NoSupportForPreProcessingBenchmark BenchmarkType
+  | CantFindSourceForPreProcessFile String
+  | NoSupportPreProcessingTestExtras TestType
+  | NoSupportPreProcessingBenchmarkExtras BenchmarkType
+  | UnlitException String
   deriving (Show, Typeable)
 
 exceptionCode :: CabalException -> Int
@@ -120,12 +139,31 @@ exceptionCode e = case e of
   PkgDumpFailed{} -> 2290
   FailedToParseOutput{} -> 5500
   CantFindSourceModule{} -> 8870
-  VersionMisMatch{} -> 9001
-  VersionMisMatchGHC{} -> 4001
+  VersionMismatchJS{} -> 9001
+  VersionMismatchGHCJS{} -> 4001
   GlobalPackageDBLimitation{} -> 5002
   GlobalPackageDBSpecifiedFirst{} -> 3901
   MatchDirFileGlob{} -> 9760
   MatchDirFileGlobErrors{} -> 6661
+  ErrorParsingFileDoesntExist{} -> 1234
+  FailedParsing{} -> 6565
+  NotFoundMsg{} -> 8011
+  UnrecognisedBuildTarget{} -> 3410
+  ReportBuildTargetProblems{} -> 5504
+  UnknownBuildTarget{} -> 4444
+  AmbiguousBuildTarget{} -> 7865
+  CheckBuildTargets{} -> 4733
+  VersionMismatchGHC{} -> 4000
+  CheckPackageDbStackPost76{} -> 3000
+  CheckPackageDbStackPre76{} -> 5640
+  GlobalPackageDbSpecifiedFirst{} -> 2345
+  CantInstallForeignLib{} -> 8221
+  NoSupportForPreProcessingTest{} -> 3008
+  NoSupportForPreProcessingBenchmark{} -> 6990
+  CantFindSourceForPreProcessFile{} -> 7554
+  NoSupportPreProcessingTestExtras{} -> 7886
+  NoSupportPreProcessingBenchmarkExtras{} -> 9999
+  UnlitException{} -> 5454
 
 exceptionMessage :: CabalException -> String
 exceptionMessage e = case e of
@@ -186,7 +224,7 @@ exceptionMessage e = case e of
   PkgDumpFailed -> "pkg dump failed"
   FailedToParseOutput -> "failed to parse output of 'pkg dump'"
   CantFindSourceModule moduleName -> "can't find source for module " ++ prettyShow moduleName
-  VersionMisMatch ghcjsProgPath ghcjsVersion ghcjsPkgProgPath ghcjsPkgGhcjsVersion ->
+  VersionMismatchJS ghcjsProgPath ghcjsVersion ghcjsPkgProgPath ghcjsPkgGhcjsVersion ->
     "Version mismatch between ghcjs and ghcjs-pkg: "
       ++ show ghcjsProgPath
       ++ " is version "
@@ -195,7 +233,7 @@ exceptionMessage e = case e of
       ++ show ghcjsPkgProgPath
       ++ " is version "
       ++ prettyShow ghcjsPkgGhcjsVersion
-  VersionMisMatchGHC ghcjsProgPath ghcjsGhcVersion ghcjsPkgProgPath ghcjsPkgVersion ->
+  VersionMismatchGHCJS ghcjsProgPath ghcjsGhcVersion ghcjsPkgProgPath ghcjsPkgVersion ->
     "Version mismatch between ghcjs and ghcjs-pkg: "
       ++ show ghcjsProgPath
       ++ " was built with GHC version "
@@ -213,3 +251,105 @@ exceptionMessage e = case e of
       ++ "specified first and cannot be specified multiple times"
   MatchDirFileGlob pathError -> pathError
   MatchDirFileGlobErrors errors -> unlines errors
+  ErrorParsingFileDoesntExist filePath -> "Error Parsing: file \"" ++ filePath ++ "\" doesn't exist. Cannot continue."
+  FailedParsing name -> "Failed parsing \"" ++ name ++ "\"."
+  NotFoundMsg ->
+    "The package has a './configure' script. "
+      ++ "If you are on Windows, This requires a "
+      ++ "Unix compatibility toolchain such as MinGW+MSYS or Cygwin. "
+      ++ "If you are not on Windows, ensure that an 'sh' command "
+      ++ "is discoverable in your path."
+  UnrecognisedBuildTarget target ->
+    unlines
+      [ "Unrecognised build target '" ++ name ++ "'."
+      | name <- target
+      ]
+      ++ "Examples:\n"
+      ++ " - build foo          -- component name "
+      ++ "(library, executable, test-suite or benchmark)\n"
+      ++ " - build Data.Foo     -- module name\n"
+      ++ " - build Data/Foo.hsc -- file name\n"
+      ++ " - build lib:foo exe:foo   -- component qualified by kind\n"
+      ++ " - build foo:Data.Foo      -- module qualified by component\n"
+      ++ " - build foo:Data/Foo.hsc  -- file qualified by component"
+  ReportBuildTargetProblems targets ->
+    unlines
+      [ "Unrecognised build target '"
+        ++ target
+        ++ "'.\n"
+        ++ "Expected a "
+        ++ intercalate " or " expected
+        ++ ", rather than '"
+        ++ got
+        ++ "'."
+      | (target, expected, got) <- targets
+      ]
+  UnknownBuildTarget targets ->
+    unlines
+      [ "Unknown build target '"
+        ++ target
+        ++ "'.\nThere is no "
+        ++ intercalate
+          " or "
+          [ mungeThing thing ++ " '" ++ got ++ "'"
+          | (thing, got) <- nosuch
+          ]
+        ++ "."
+      | (target, nosuch) <- targets
+      ]
+    where
+      mungeThing "file" = "file target"
+      mungeThing thing = thing
+  AmbiguousBuildTarget targets ->
+    unlines
+      [ "Ambiguous build target '"
+        ++ target
+        ++ "'. It could be:\n "
+        ++ unlines
+          [ "   "
+            ++ ut
+            ++ " ("
+            ++ bt
+            ++ ")"
+          | (ut, bt) <- amb
+          ]
+      | (target, amb) <- targets
+      ]
+  CheckBuildTargets errorStr -> errorStr
+  VersionMismatchGHC ghcProgPath ghcVersion ghcPkgProgPath ghcPkgVersion ->
+    "Version mismatch between ghc and ghc-pkg: "
+      ++ ghcProgPath
+      ++ " is version "
+      ++ prettyShow ghcVersion
+      ++ " "
+      ++ ghcPkgProgPath
+      ++ " is version "
+      ++ prettyShow ghcPkgVersion
+  CheckPackageDbStackPost76 ->
+    "If the global package db is specified, it must be "
+      ++ "specified first and cannot be specified multiple times"
+  CheckPackageDbStackPre76 ->
+    "With current ghc versions the global package db is always used "
+      ++ "and must be listed first. This ghc limitation is lifted in GHC 7.6,"
+      ++ "see https://gitlab.haskell.org/ghc/ghc/-/issues/5977"
+  GlobalPackageDbSpecifiedFirst ->
+    "If the global package db is specified, it must be "
+      ++ "specified first and cannot be specified multiple times"
+  CantInstallForeignLib -> "Can't install foreign-library symlink on non-Linux OS"
+  NoSupportForPreProcessingTest tt ->
+    "No support for preprocessing test "
+      ++ "suite type "
+      ++ prettyShow tt
+  NoSupportForPreProcessingBenchmark tt ->
+    "No support for preprocessing benchmark "
+      ++ "type "
+      ++ prettyShow tt
+  CantFindSourceForPreProcessFile errorStr -> errorStr
+  NoSupportPreProcessingTestExtras tt ->
+    "No support for preprocessing test suite type "
+      ++ prettyShow tt
+  NoSupportPreProcessingBenchmarkExtras tt ->
+    "No support for preprocessing benchmark "
+      ++ "type "
+      ++ prettyShow tt
+  UnlitException str -> str