Merge pull request #9324 from SuganyaAK/Remaining-Cabal-Install-Errors

Remaining Cabal-Install package errors

cabal-install/src/Distribution/Client/CmdErrorMessages.hs

@@ -37,7 +37,7 @@ import Distribution.Package
   , packageName
   )
 import Distribution.Simple.Utils
-  ( die'
+  ( dieWithException
   )
 import Distribution.Solver.Types.OptionalStanza
   ( OptionalStanza (..)
@@ -51,6 +51,7 @@ import Distribution.Types.LibraryName
   )
 
 import qualified Data.List.NonEmpty as NE
+import Distribution.Client.Errors
 
 -----------------------
 -- Singular or plural
@@ -227,7 +228,7 @@ renderComponentKind Plural ckind = case ckind of
 -- | Default implementation of 'reportTargetProblems' simply renders one problem per line.
 reportTargetProblems :: Verbosity -> String -> [TargetProblem'] -> IO a
 reportTargetProblems verbosity verb =
-  die' verbosity . unlines . map (renderTargetProblem verb absurd)
+  dieWithException verbosity . CmdErrorMessages . map (renderTargetProblem verb absurd)
 
 -- | Default implementation of 'renderTargetProblem'.
 renderTargetProblem

cabal-install/src/Distribution/Client/CmdFreeze.hs

@@ -54,7 +54,7 @@ import Distribution.PackageDescription
   )
 import Distribution.Simple.Flag (Flag (..), fromFlagOrDefault)
 import Distribution.Simple.Utils
-  ( die'
+  ( dieWithException
   , notice
   , wrapText
   )
@@ -70,6 +70,7 @@ import Distribution.Version
 
 import qualified Data.Map as Map
 
+import Distribution.Client.Errors
 import Distribution.Simple.Command
   ( CommandUI (..)
   , usageAlternatives
@@ -125,9 +126,8 @@ freezeCommand =
 freezeAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO ()
 freezeAction flags@NixStyleFlags{..} extraArgs globalFlags = do
   unless (null extraArgs) $
-    die' verbosity $
-      "'freeze' doesn't take any extra arguments: "
-        ++ unwords extraArgs
+    dieWithException verbosity $
+      FreezeAction extraArgs
 
   ProjectBaseContext
     { distDirLayout

cabal-install/src/Distribution/Client/CmdHaddock.hs

@@ -60,14 +60,15 @@ import Distribution.Simple.Setup
   , trueArg
   )
 import Distribution.Simple.Utils
-  ( die'
+  ( dieWithException
   , notice
   , wrapText
   )
 import Distribution.Verbosity
   ( normal
   )
 
+import Distribution.Client.Errors
 import qualified System.Exit (exitSuccess)
 
 newtype ClientHaddockFlags = ClientHaddockFlags {openInBrowser :: Flag Bool}
@@ -167,9 +168,7 @@ haddockAction relFlags targetStrings globalFlags = do
   buildCtx <-
     runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do
       when (buildSettingOnlyDeps (buildSettings baseCtx)) $
-        die'
-          verbosity
-          "The haddock command does not support '--only-dependencies'."
+        dieWithException verbosity HaddockCommandDoesn'tSupport
 
       -- When we interpret the targets on the command line, interpret them as
       -- haddock targets

cabal-install/src/Distribution/Client/CmdHaddockProject.hs

@@ -84,7 +84,7 @@ import Distribution.Simple.Setup
 import Distribution.Simple.Utils
   ( copyDirectoryRecursive
   , createDirectoryIfMissingVerbose
-  , die'
+  , dieWithException
   , warn
   )
 import Distribution.Types.InstalledPackageInfo (InstalledPackageInfo (..))
@@ -97,6 +97,7 @@ import Distribution.Verbosity as Verbosity
   ( normal
   )
 
+import Distribution.Client.Errors
 import System.Directory (doesDirectoryExist, doesFileExist)
 import System.FilePath (normalise, takeDirectory, (<.>), (</>))
 
@@ -384,7 +385,7 @@ haddockProjectAction flags _extraArgs globalFlags = do
 
     reportTargetProblems :: Show x => [x] -> IO a
     reportTargetProblems =
-      die' verbosity . unlines . map show
+      dieWithException verbosity . CmdHaddockReportTargetProblems . map show
 
     -- TODO: this is just a sketch
     selectPackageTargets

cabal-install/src/Distribution/Client/CmdInstall.hs

@@ -162,7 +162,7 @@ import Distribution.Simple.Setup
   )
 import Distribution.Simple.Utils
   ( createDirectoryIfMissingVerbose
-  , die'
+  , dieWithException
   , notice
   , ordNub
   , safeHead
@@ -220,6 +220,7 @@ import Data.Ord
   ( Down (..)
   )
 import qualified Data.Set as S
+import Distribution.Client.Errors
 import Distribution.Utils.NubList
   ( fromNubList
   )
@@ -424,17 +425,13 @@ installAction flags@NixStyleFlags{extraFlags = clientInstallFlags', ..} targetSt
           let xs = searchByName packageIndex (unPackageName name)
           let emptyIf True _ = []
               emptyIf False zs = zs
-          die' verbosity $
-            concat $
-              [ "Unknown package \""
-              , unPackageName name
-              , "\". "
-              ]
-                ++ emptyIf
+              str2 =
+                emptyIf
                   (null xs)
                   [ "Did you mean any of the following?\n"
                   , unlines (("- " ++) . unPackageName . fst <$> xs)
                   ]
+          dieWithException verbosity $ WithoutProject (unPackageName name) str2
 
       let
         (uris, packageSpecifiers) = partitionEithers $ map woPackageSpecifiers tss
@@ -541,7 +538,7 @@ installAction flags@NixStyleFlags{extraFlags = clientInstallFlags', ..} targetSt
               let es = filter (\e -> not $ getPackageName e `S.member` nameIntersection) envSpecs
                   nge = map snd . filter (\e -> not $ fst e `S.member` nameIntersection) $ nonGlobalEnvEntries
                in pure (es, nge)
-            else die' verbosity $ "Packages requested to install already exist in environment file at " ++ envFile ++ ". Overwriting them may break other packages. Use --force-reinstalls to proceed anyway. Packages: " ++ intercalate ", " (map prettyShow $ S.toList nameIntersection)
+            else dieWithException verbosity $ PackagesAlreadyExistInEnvfile envFile (map prettyShow $ S.toList nameIntersection)
 
     -- we construct an installed index of files in the cleaned target environment (absent overwrites) so that we can solve with regards to packages installed locally but not in the upstream repo
     let installedPacks = PI.allPackagesByName installedIndex
@@ -617,20 +614,16 @@ addLocalConfigToTargets config targetStrings =
 
 -- | Verify that invalid config options were not passed to the install command.
 --
--- If an invalid configuration is found the command will @die'@.
+-- If an invalid configuration is found the command will @dieWithException@.
 verifyPreconditionsOrDie :: Verbosity -> ConfigFlags -> IO ()
 verifyPreconditionsOrDie verbosity configFlags = do
   -- We never try to build tests/benchmarks for remote packages.
   -- So we set them as disabled by default and error if they are explicitly
   -- enabled.
   when (configTests configFlags == Flag True) $
-    die' verbosity $
-      "--enable-tests was specified, but tests can't "
-        ++ "be enabled in a remote package"
+    dieWithException verbosity ConfigTests
   when (configBenchmarks configFlags == Flag True) $
-    die' verbosity $
-      "--enable-benchmarks was specified, but benchmarks can't "
-        ++ "be enabled in a remote package"
+    dieWithException verbosity ConfigBenchmarks
 
 getClientInstallFlags :: Verbosity -> GlobalFlags -> ClientInstallFlags -> IO ClientInstallFlags
 getClientInstallFlags verbosity globalFlags existingClientInstallFlags = do
@@ -733,13 +726,7 @@ partitionToKnownTargetsAndHackagePackages verbosity pkgDb elaboratedPlan targetS
           case searchByName (packageIndex pkgDb) (unPackageName hn) of
             [] -> return ()
             xs ->
-              die' verbosity . concat $
-                [ "Unknown package \""
-                , unPackageName hn
-                , "\". "
-                , "Did you mean any of the following?\n"
-                , unlines (("- " ++) . unPackageName . fst <$> xs)
-                ]
+              dieWithException verbosity $ UnknownPackage (unPackageName hn) (("- " ++) . unPackageName . fst <$> xs)
         _ -> return ()
 
       when (not . null $ errs') $ reportBuildTargetProblems verbosity errs'
@@ -1058,7 +1045,7 @@ installUnitExes
                   InstallMethodSymlink -> "Symlinking"
                   InstallMethodCopy ->
                     "Copying" <> " '" <> prettyShow exe <> "' failed."
-        unless success $ die' verbosity errorMessage
+        unless success $ dieWithException verbosity $ InstallUnitExes errorMessage
 
 -- | Install a specific exe.
 installBuiltExe
@@ -1265,4 +1252,4 @@ reportBuildTargetProblems verbosity problems = reportTargetProblems verbosity "b
 
 reportCannotPruneDependencies :: Verbosity -> CannotPruneDependencies -> IO a
 reportCannotPruneDependencies verbosity =
-  die' verbosity . renderCannotPruneDependencies
+  dieWithException verbosity . SelectComponentTargetError . renderCannotPruneDependencies

cabal-install/src/Distribution/Client/CmdSdist.hs

@@ -63,6 +63,7 @@ import Distribution.Solver.Types.SourcePackage
   ( SourcePackage (..)
   )
 
+import Distribution.Client.Errors
 import Distribution.Client.SrcDist
   ( packageDirToSdist
   )
@@ -106,8 +107,7 @@ import Distribution.Simple.SrcDist
   ( listPackageSourcesWithDie
   )
 import Distribution.Simple.Utils
-  ( die'
-  , dieWithException
+  ( dieWithException
   , notice
   , withOutputMarker
   , wrapText
@@ -258,12 +258,12 @@ sdistAction (pf@ProjectFlags{..}, SdistFlags{..}) targetStrings globalFlags = do
           | otherwise -> distSdistFile distDirLayout (packageId pkg)
 
   case reifyTargetSelectors localPkgs targetSelectors of
-    Left errs -> die' verbosity . unlines . fmap renderTargetProblem $ errs
+    Left errs -> dieWithException verbosity $ SdistActionException . fmap renderTargetProblem $ errs
     Right pkgs
       | length pkgs > 1
       , not listSources
       , Just "-" <- mOutputPath' ->
-          die' verbosity "Can't write multiple tarballs to standard output!"
+          dieWithException verbosity Can'tWriteMultipleTarballs
       | otherwise ->
           traverse_ (\pkg -> packageToSdist verbosity (distProjectRootDirectory distDirLayout) format (outputPath pkg) pkg) pkgs
   where
@@ -306,7 +306,7 @@ data OutputFormat
 
 packageToSdist :: Verbosity -> FilePath -> OutputFormat -> FilePath -> UnresolvedSourcePackage -> IO ()
 packageToSdist verbosity projectRootDir format outputFile pkg = do
-  let death = die' verbosity ("The impossible happened: a local package isn't local" <> (show pkg))
+  let death = dieWithException verbosity $ ImpossibleHappened (show pkg)
   dir0 <- case srcpkgSource pkg of
     LocalUnpackedPackage path -> pure (Right path)
     RemoteSourceRepoPackage _ (Just tgz) -> pure (Left tgz)
@@ -335,7 +335,7 @@ packageToSdist verbosity projectRootDir format outputFile pkg = do
       case format of
         TarGzArchive -> do
           writeLBS =<< BSL.readFile tgz
-        _ -> die' verbosity ("cannot convert tarball package to " ++ show format)
+        _ -> dieWithException verbosity $ CannotConvertTarballPackage (show format)
     Right dir -> case format of
       SourceList nulSep -> do
         let gpd :: GenericPackageDescription

cabal-install/src/Distribution/Client/Configure.hs

@@ -107,7 +107,7 @@ import Distribution.Simple.Setup
 import Distribution.Simple.Utils as Utils
   ( debug
   , defaultPackageDesc
-  , die'
+  , dieWithException
   , notice
   , warn
   )
@@ -128,6 +128,7 @@ import Distribution.Version
   , thisVersion
   )
 
+import Distribution.Client.Errors
 import System.FilePath ((</>))
 
 -- | Choose the Cabal version such that the setup scripts compiled against this
@@ -223,9 +224,7 @@ configure
                     pkg
                     extraArgs
               _ ->
-                die' verbosity $
-                  "internal error: configure install plan should have exactly "
-                    ++ "one local ready package."
+                dieWithException verbosity ConfigureInstallInternalError
     where
       setupScriptOptions
         :: InstalledPackageIndex