Merge pull request haskell#9276 from SuganyaAK/Subsequent-Cabal-Insta…

…ll-Errors

Subsequent Cabal-install package errors

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

@@ -26,6 +26,7 @@ import Distribution.Client.CmdErrorMessages
   , targetSelectorFilter
   , targetSelectorPluralPkgs
   )
+import Distribution.Client.Errors
 import Distribution.Client.NixStyleOptions
   ( NixStyleFlags (..)
   , defaultNixStyleFlags
@@ -50,7 +51,7 @@ import Distribution.Simple.Flag
   ( fromFlagOrDefault
   )
 import Distribution.Simple.Utils
-  ( die'
+  ( dieWithException
   , warn
   , wrapText
   )
@@ -119,10 +120,7 @@ benchAction flags@NixStyleFlags{..} targetStrings globalFlags = do
   buildCtx <-
     runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do
       when (buildSettingOnlyDeps (buildSettings baseCtx)) $
-        die' verbosity $
-          "The bench command does not support '--only-dependencies'. "
-            ++ "You may wish to use 'build --only-dependencies' and then "
-            ++ "use 'bench'."
+        dieWithException verbosity BenchActionException
 
       fullArgs <- getFullArgs
       when ("+RTS" `elem` fullArgs) $
@@ -251,7 +249,7 @@ isSubComponentProblem pkgid name subcomponent =
 
 reportTargetProblems :: Verbosity -> [BenchTargetProblem] -> IO a
 reportTargetProblems verbosity =
-  die' verbosity . unlines . map renderBenchTargetProblem
+  dieWithException verbosity . RenderBenchTargetProblem . map renderBenchTargetProblem
 
 renderBenchTargetProblem :: BenchTargetProblem -> String
 renderBenchTargetProblem (TargetProblemNoTargets targetSelector) =

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

@@ -26,6 +26,8 @@ import Distribution.Client.TargetProblem
   , TargetProblem'
   )
 
+import qualified Data.Map as Map
+import Distribution.Client.Errors
 import Distribution.Client.NixStyleOptions
   ( NixStyleFlags (..)
   , defaultNixStyleFlags
@@ -49,15 +51,13 @@ import Distribution.Simple.Command
   )
 import Distribution.Simple.Flag (Flag (..), fromFlag, fromFlagOrDefault, toFlag)
 import Distribution.Simple.Utils
-  ( die'
+  ( dieWithException
   , wrapText
   )
 import Distribution.Verbosity
   ( normal
   )
 
-import qualified Data.Map as Map
-
 buildCommand :: CommandUI (NixStyleFlags BuildFlags)
 buildCommand =
   CommandUI
@@ -237,4 +237,4 @@ reportBuildTargetProblems verbosity problems =
 
 reportCannotPruneDependencies :: Verbosity -> CannotPruneDependencies -> IO a
 reportCannotPruneDependencies verbosity =
-  die' verbosity . renderCannotPruneDependencies
+  dieWithException verbosity . ReportCannotPruneDependencies . renderCannotPruneDependencies

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

@@ -12,6 +12,7 @@ import Distribution.Client.DistDirLayout
   ( DistDirLayout (..)
   , defaultDistDirLayout
   )
+import Distribution.Client.Errors
 import Distribution.Client.ProjectConfig
   ( findProjectRoot
   )
@@ -35,7 +36,7 @@ import Distribution.Simple.Setup
   , toFlag
   )
 import Distribution.Simple.Utils
-  ( die'
+  ( dieWithException
   , handleDoesNotExist
   , info
   , wrapText
@@ -141,9 +142,8 @@ cleanAction CleanFlags{..} extraArgs _ = do
   -- For now assume all files passed are the names of scripts
   notScripts <- filterM (fmap not . doesFileExist) extraArgs
   unless (null notScripts) $
-    die' verbosity $
-      "'clean' extra arguments should be script files: "
-        ++ unwords notScripts
+    dieWithException verbosity $
+      CleanAction notScripts
 
   projectRoot <- either throwIO return =<< findProjectRoot verbosity mprojectDir mprojectFile
 

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

@@ -11,12 +11,13 @@ import Prelude ()
 
 import Network.URI (URI, parseURI)
 
+import Distribution.Client.Errors
 import Distribution.Client.TargetSelector
 import Distribution.Client.Types
 import Distribution.Compat.CharParsing (char, optional)
 import Distribution.Package
 import Distribution.Simple.LocalBuildInfo (ComponentName (CExeName))
-import Distribution.Simple.Utils (die')
+import Distribution.Simple.Utils (dieWithException)
 import Distribution.Solver.Types.PackageConstraint (PackageProperty (..))
 import Distribution.Version
 
@@ -32,7 +33,7 @@ parseWithoutProjectTargetSelector verbosity input =
     Right ts -> return ts
     Left err -> case parseURI input of
       Just uri -> return (WoURI uri)
-      Nothing -> die' verbosity $ "Invalid package ID: " ++ input ++ "\n" ++ err
+      Nothing -> dieWithException verbosity $ ProjectTargetSelector input err
   where
     parser :: CabalParsing m => m WithoutProjectTargetSelector
     parser = do

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

@@ -116,7 +116,7 @@ import Distribution.Simple.Setup
   )
 import Distribution.Simple.Utils
   ( debug
-  , die'
+  , dieWithException
   , notice
   , tryFindPackageDesc
   )
@@ -151,6 +151,7 @@ import Distribution.Version
   )
 
 import qualified Data.Set as S
+import Distribution.Client.Errors
 import System.Directory
   ( doesFileExist
   , getCurrentDirectory
@@ -315,8 +316,7 @@ outdatedAction (ProjectFlags{flagProjectDir, flagProjectFile}, OutdatedFlags{..}
       configFlags = savedConfigureFlags config
   withRepoContext verbosity globalFlags' $ \repoContext -> do
     when (not newFreezeFile && (isJust mprojectDir || isJust mprojectFile)) $
-      die' verbosity $
-        "--project-dir and --project-file must only be used with --v2-freeze-file."
+      dieWithException verbosity OutdatedAction
 
     sourcePkgDb <- IndexUtils.getSourcePackages verbosity repoContext
     (comp, platform, _progdb) <- configCompilerAux' configFlags
@@ -425,14 +425,9 @@ depsFromNewFreezeFile verbosity httpTransport compiler (Platform arch os) mproje
   freezeFileExists <- doesFileExist freezeFile
 
   unless freezeFileExists $
-    die' verbosity $
-      "Couldn't find a freeze file expected at: "
-        ++ freezeFile
-        ++ "\n\n"
-        ++ "We are looking for this file because you supplied '--project-file' or '--v2-freeze-file'. "
-        ++ "When one of these flags is given, we try to read the dependencies from a freeze file. "
-        ++ "If it is undesired behaviour, you should not use these flags, otherwise please generate "
-        ++ "a freeze file via 'cabal freeze'."
+    dieWithException verbosity $
+      FreezeFileExistsErr freezeFile
+
   debug verbosity $
     "Reading the list of dependencies from the new-style freeze file " ++ freezeFile
   return deps
@@ -454,7 +449,7 @@ depsFromPkgDesc verbosity comp platform = do
           []
           gpd
   case epd of
-    Left _ -> die' verbosity "finalizePD failed"
+    Left _ -> dieWithException verbosity FinalizePDFailed
     Right (pd, _) -> do
       let bd = allBuildDepends pd
       debug

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

@@ -38,6 +38,7 @@ import Distribution.Client.CmdErrorMessages
 import Distribution.Client.DistDirLayout
   ( DistDirLayout (..)
   )
+import Distribution.Client.Errors
 import qualified Distribution.Client.InstallPlan as InstallPlan
 import Distribution.Client.NixStyleOptions
   ( NixStyleFlags (..)
@@ -106,7 +107,7 @@ import Distribution.Simple.Setup
 import Distribution.Simple.Utils
   ( TempFileOptions (..)
   , debugNoWrap
-  , die'
+  , dieWithException
   , withTempDirectoryEx
   , wrapText
   )
@@ -284,21 +285,16 @@ replAction :: NixStyleFlags ReplFlags -> [String] -> GlobalFlags -> IO ()
 replAction flags@NixStyleFlags{extraFlags = r@ReplFlags{..}, ..} targetStrings globalFlags =
   withContextAndSelectors AcceptNoTargets (Just LibKind) flags targetStrings globalFlags ReplCommand $ \targetCtx ctx targetSelectors -> do
     when (buildSettingOnlyDeps (buildSettings ctx)) $
-      die' verbosity $
-        "The repl command does not support '--only-dependencies'. "
-          ++ "You may wish to use 'build --only-dependencies' and then "
-          ++ "use 'repl'."
-
+      dieWithException verbosity ReplCommandDoesn'tSupport
     let projectRoot = distProjectRootDirectory $ distDirLayout ctx
         distDir = distDirectory $ distDirLayout ctx
 
     baseCtx <- case targetCtx of
       ProjectContext -> return ctx
       GlobalContext -> do
         unless (null targetStrings) $
-          die' verbosity $
-            "'repl' takes no arguments or a script argument outside a project: " ++ unwords targetStrings
-
+          dieWithException verbosity $
+            ReplTakesNoArguments targetStrings
         let
           sourcePackage =
             fakeProjectSourcePackage projectRoot
@@ -315,12 +311,12 @@ replAction flags@NixStyleFlags{extraFlags = r@ReplFlags{..}, ..} targetStrings g
         updateContextAndWriteProjectFile' ctx sourcePackage
       ScriptContext scriptPath scriptExecutable -> do
         unless (length targetStrings == 1) $
-          die' verbosity $
-            "'repl' takes a single argument which should be a script: " ++ unwords targetStrings
+          dieWithException verbosity $
+            ReplTakesSingleArgument targetStrings
         existsScriptPath <- doesFileExist scriptPath
         unless existsScriptPath $
-          die' verbosity $
-            "'repl' takes a single argument which should be a script: " ++ unwords targetStrings
+          dieWithException verbosity $
+            ReplTakesSingleArgument targetStrings
 
         updateContextAndWriteProjectFile ctx scriptPath scriptExecutable
 
@@ -750,7 +746,7 @@ multipleTargetsProblem decision = CustomTargetProblem . TargetProblemMultipleTar
 
 reportTargetProblems :: Verbosity -> [TargetProblem ReplProblem] -> IO a
 reportTargetProblems verbosity =
-  die' verbosity . unlines . map renderReplTargetProblem
+  dieWithException verbosity . RenderReplTargetProblem . map renderReplTargetProblem
 
 renderReplTargetProblem :: TargetProblem ReplProblem -> String
 renderReplTargetProblem = renderTargetProblem "open a repl for" renderReplProblem

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

@@ -22,6 +22,8 @@ module Distribution.Client.CmdRun
 import Distribution.Client.Compat.Prelude hiding (toList)
 import Prelude ()
 
+import Data.List (group)
+import qualified Data.Set as Set
 import Distribution.Client.CmdErrorMessages
   ( plural
   , renderListCommaAnd
@@ -33,6 +35,7 @@ import Distribution.Client.CmdErrorMessages
   , targetSelectorFilter
   , targetSelectorPluralPkgs
   )
+import Distribution.Client.Errors
 import Distribution.Client.GlobalFlags
   ( defaultGlobalFlags
   )
@@ -85,7 +88,7 @@ import Distribution.Simple.Program.Run
   , runProgramInvocation
   )
 import Distribution.Simple.Utils
-  ( die'
+  ( dieWithException
   , info
   , notice
   , safeHead
@@ -106,9 +109,6 @@ import Distribution.Verbosity
   ( normal
   , silent
   )
-
-import Data.List (group)
-import qualified Data.Set as Set
 import GHC.Environment
   ( getFullArgs
   )
@@ -190,10 +190,7 @@ runAction flags@NixStyleFlags{..} targetAndArgs globalFlags =
     buildCtx <-
       runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do
         when (buildSettingOnlyDeps (buildSettings baseCtx)) $
-          die' verbosity $
-            "The run command does not support '--only-dependencies'. "
-              ++ "You may wish to use 'build --only-dependencies' and then "
-              ++ "use 'run'."
+          dieWithException verbosity NoSupportForRunCommand
 
         fullArgs <- getFullArgs
         when (occursOnlyOrBefore fullArgs "+RTS" "--") $
@@ -236,9 +233,7 @@ runAction flags@NixStyleFlags{..} targetAndArgs globalFlags =
     (selectedUnitId, selectedComponent) <-
       -- Slight duplication with 'runProjectPreBuildPhase'.
       singleExeOrElse
-        ( die' verbosity $
-            "No or multiple targets given, but the run "
-              ++ "phase has been reached. This is a bug."
+        ( dieWithException verbosity RunPhaseReached
         )
         $ targetsMap buildCtx
 
@@ -268,12 +263,7 @@ runAction flags@NixStyleFlags{..} targetAndArgs globalFlags =
     -- an error in all of these cases, even if some seem like they
     -- shouldn't happen.
     pkg <- case matchingElaboratedConfiguredPackages of
-      [] ->
-        die' verbosity $
-          "Unknown executable "
-            ++ exeName
-            ++ " in package "
-            ++ prettyShow selectedUnitId
+      [] -> dieWithException verbosity $ UnknownExecutable exeName selectedUnitId
       [elabPkg] -> do
         info verbosity $
           "Selecting "
@@ -282,11 +272,8 @@ runAction flags@NixStyleFlags{..} targetAndArgs globalFlags =
             ++ exeName
         return elabPkg
       elabPkgs ->
-        die' verbosity $
-          "Multiple matching executables found matching "
-            ++ exeName
-            ++ ":\n"
-            ++ unlines (fmap (\p -> " - in package " ++ prettyShow (elabUnitId p)) elabPkgs)
+        dieWithException verbosity $
+          MultipleMatchingExecutables exeName (fmap (\p -> " - in package " ++ prettyShow (elabUnitId p)) elabPkgs)
 
     let defaultExePath =
           binDirectoryFor
@@ -489,7 +476,7 @@ isSubComponentProblem pkgid name subcomponent =
 
 reportTargetProblems :: Verbosity -> [RunTargetProblem] -> IO a
 reportTargetProblems verbosity =
-  die' verbosity . unlines . map renderRunTargetProblem
+  dieWithException verbosity . CmdRunReportTargetProblems . unlines . map renderRunTargetProblem
 
 renderRunTargetProblem :: RunTargetProblem -> String
 renderRunTargetProblem (TargetProblemNoTargets targetSelector) =

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

@@ -72,7 +72,7 @@ import Distribution.Simple.Flag
   ( fromFlagOrDefault
   )
 import Distribution.Simple.Utils
-  ( die'
+  ( dieWithException
   , notice
   , noticeNoWrap
   , warn
@@ -97,6 +97,7 @@ import Distribution.Simple.Command
   )
 import System.FilePath (dropExtension, (<.>))
 
+import Distribution.Client.Errors
 import Distribution.Client.IndexUtils.Timestamp (nullTimestamp)
 import qualified Hackage.Security.Client as Sec
 
@@ -179,8 +180,7 @@ updateAction flags@NixStyleFlags{..} extraArgs globalFlags = do
           parseArg s = case simpleParsec s of
             Just r -> return r
             Nothing ->
-              die' verbosity $
-                "'v2-update' unable to parse repo: \"" ++ s ++ "\""
+              dieWithException verbosity $ UnableToParseRepo s
 
       updateRepoRequests <- traverse parseArg extraArgs
 
@@ -190,11 +190,8 @@ updateAction flags@NixStyleFlags{..} extraArgs globalFlags = do
               [ r | (UpdateRequest r _) <- updateRepoRequests, not (r `elem` remoteRepoNames)
               ]
         unless (null unknownRepos) $
-          die' verbosity $
-            "'v2-update' repo(s): \""
-              ++ intercalate "\", \"" (map unRepoName unknownRepos)
-              ++ "\" can not be found in known remote repo(s): "
-              ++ intercalate ", " (map unRepoName remoteRepoNames)
+          dieWithException verbosity $
+            NullUnknownrepos (map unRepoName unknownRepos) (map unRepoName remoteRepoNames)
 
       let reposToUpdate :: [(Repo, RepoIndexState)]
           reposToUpdate = case updateRepoRequests of