diff --git a/Cabal/Distribution/PackageDescription/Parse.hs b/Cabal/Distribution/PackageDescription/Parse.hs index 1ea7e54a06015e08b8446db6d6bc41fb4374696d..1f237676f2f2957d447f0630fb147a79c6c49557 100644 --- a/Cabal/Distribution/PackageDescription/Parse.hs +++ b/Cabal/Distribution/PackageDescription/Parse.hs @@ -582,12 +582,13 @@ readAndParseFile :: (FilePath -> (String -> IO a) -> IO a) -> FilePath -> IO a readAndParseFile withFileContents' parser verbosity fpath = do exists <- doesFileExist fpath - unless exists - (die $ "Error Parsing: file \"" ++ fpath ++ "\" doesn't exist. Cannot continue.") + unless exists $ + die' verbosity $ + "Error Parsing: file \"" ++ fpath ++ "\" doesn't exist. Cannot continue." withFileContents' fpath $ \str -> case parser str of ParseFailed e -> do let (line, message) = locatedErrorMsg e - dieWithLocation fpath line message + dieWithLocation' verbosity fpath line message ParseOk warnings x -> do traverse_ (warn verbosity . showPWarning fpath) $ reverse warnings return x diff --git a/Cabal/Distribution/PackageDescription/Parsec.hs b/Cabal/Distribution/PackageDescription/Parsec.hs index f01a45b12e095d7b0c21bc4dd63edb4b2ce22743..9dcd6aa9403f8b87ac59af9bebfcc992ca7eb563 100644 --- a/Cabal/Distribution/PackageDescription/Parsec.hs +++ b/Cabal/Distribution/PackageDescription/Parsec.hs @@ -49,7 +49,7 @@ import Distribution.Parsec.Types.Field (getName) import Distribution.Parsec.Types.FieldDescr import Distribution.Parsec.Types.ParseResult import Distribution.Simple.Utils - (die, fromUTF8BS, warn) + (die', fromUTF8BS, warn) import Distribution.Text (display) import Distribution.Types.ForeignLib import Distribution.Types.CondTree @@ -80,14 +80,15 @@ readAndParseFile -> IO a readAndParseFile parser verbosity fpath = do exists <- doesFileExist fpath - unless exists - (die $ "Error Parsing: file \"" ++ fpath ++ "\" doesn't exist. Cannot continue.") + unless exists $ + die' verbosity $ + "Error Parsing: file \"" ++ fpath ++ "\" doesn't exist. Cannot continue." bs <- BS.readFile fpath let (warnings, errors, result) = runParseResult (parser bs) traverse_ (warn verbosity . showPWarning fpath) warnings traverse_ (warn verbosity . showPError fpath) errors case result of - Nothing -> die $ "Failing parsing \"" ++ fpath ++ "\"." + Nothing -> die' verbosity $ "Failing parsing \"" ++ fpath ++ "\"." Just x -> return x -- | Parse the given package file. diff --git a/Cabal/Distribution/Simple/Bench.hs b/Cabal/Distribution/Simple/Bench.hs index 8ab6c0c6d3645040059248c46296f83b3c8870be..775733f5fc6b3cec471be1cdd61de57ac61da244 100644 --- a/Cabal/Distribution/Simple/Bench.hs +++ b/Cabal/Distribution/Simple/Bench.hs @@ -58,7 +58,7 @@ bench args pkg_descr lbi flags = do benchmarkOptions flags -- Check that the benchmark executable exists. exists <- doesFileExist cmd - unless exists $ die $ + unless exists $ die' verbosity $ "Error: Could not find benchmark program \"" ++ cmd ++ "\". Did you build the package first?" @@ -81,7 +81,7 @@ bench args pkg_descr lbi flags = do exitSuccess when (PD.hasBenchmarks pkg_descr && null enabledBenchmarks) $ - die $ "No benchmarks enabled. Did you remember to configure with " + die' verbosity $ "No benchmarks enabled. Did you remember to configure with " ++ "\'--enable-benchmarks\'?" bmsToRun <- case benchmarkNames of @@ -93,9 +93,9 @@ bench args pkg_descr lbi flags = do in case lookup (mkUnqualComponentName bmName) benchmarkMap of Just t -> return t _ | mkUnqualComponentName bmName `elem` allNames -> - die $ "Package configured with benchmark " + die' verbosity $ "Package configured with benchmark " ++ bmName ++ " disabled." - | otherwise -> die $ "no such benchmark: " ++ bmName + | otherwise -> die' verbosity $ "no such benchmark: " ++ bmName let totalBenchmarks = length bmsToRun notice verbosity $ "Running " ++ show totalBenchmarks ++ " benchmarks..." diff --git a/Cabal/Distribution/Simple/Build.hs b/Cabal/Distribution/Simple/Build.hs index 725d70b1b4c662b80fa188d6dedd0330c2bf55b8..d3dd8368a3d252e93b26b77bd8fa2c96cd9ece19 100644 --- a/Cabal/Distribution/Simple/Build.hs +++ b/Cabal/Distribution/Simple/Build.hs @@ -139,7 +139,7 @@ repl pkg_descr lbi flags suffixes args = do -- This seems DEEPLY questionable. [] -> return (head (allTargetsInBuildOrder' pkg_descr lbi)) [target] -> return target - _ -> die $ "The 'repl' command does not support multiple targets at once." + _ -> die' verbosity $ "The 'repl' command does not support multiple targets at once." let componentsToBuild = neededTargetsInBuildOrder' pkg_descr lbi [nodeKey target] debug verbosity $ "Component build order: " ++ intercalate ", " @@ -180,7 +180,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 "A REPL is not supported with this compiler." + _ -> die' verbosity "A REPL is not supported with this compiler." buildComponent :: Verbosity -> Flag (Maybe Int) @@ -194,7 +194,7 @@ buildComponent :: Verbosity buildComponent verbosity numJobs pkg_descr lbi suffixes comp@(CLib lib) clbi distPref = do preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes - extras <- preprocessExtras comp lbi + extras <- preprocessExtras verbosity comp lbi setupMessage' verbosity "Building" (packageId pkg_descr) (componentLocalName clbi) (maybeComponentInstantiatedWith clbi) let libbi = libBuildInfo lib @@ -234,7 +234,7 @@ buildComponent verbosity numJobs pkg_descr lbi suffixes buildComponent verbosity numJobs pkg_descr lbi suffixes comp@(CExe exe) clbi _ = do preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes - extras <- preprocessExtras comp lbi + extras <- preprocessExtras verbosity comp lbi setupMessage' verbosity "Building" (packageId pkg_descr) (componentLocalName clbi) (maybeComponentInstantiatedWith clbi) let ebi = buildInfo exe @@ -248,7 +248,7 @@ buildComponent verbosity numJobs pkg_descr lbi suffixes clbi _distPref = do let exe = testSuiteExeV10AsExe test preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes - extras <- preprocessExtras comp lbi + extras <- preprocessExtras verbosity comp lbi setupMessage' verbosity "Building" (packageId pkg_descr) (componentLocalName clbi) (maybeComponentInstantiatedWith clbi) let ebi = buildInfo exe @@ -270,7 +270,7 @@ buildComponent verbosity numJobs pkg_descr lbi0 suffixes let (pkg, lib, libClbi, lbi, ipi, exe, exeClbi) = testSuiteLibV09AsLibAndExe pkg_descr test clbi lbi0 distPref pwd preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes - extras <- preprocessExtras comp lbi + extras <- preprocessExtras verbosity comp lbi setupMessage' verbosity "Building" (packageId pkg_descr) (componentLocalName clbi) (maybeComponentInstantiatedWith clbi) buildLib verbosity numJobs pkg lbi lib libClbi @@ -285,10 +285,10 @@ buildComponent verbosity numJobs pkg_descr lbi0 suffixes return Nothing -- Can't depend on test suite -buildComponent _ _ _ _ _ +buildComponent verbosity _ _ _ _ (CTest TestSuite { testInterface = TestSuiteUnsupported tt }) _ _ = - die $ "No support for building test suite type " ++ display tt + die' verbosity $ "No support for building test suite type " ++ display tt buildComponent verbosity numJobs pkg_descr lbi suffixes @@ -296,7 +296,7 @@ buildComponent verbosity numJobs pkg_descr lbi suffixes clbi _ = do let (exe, exeClbi) = benchmarkExeV10asExe bm clbi preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes - extras <- preprocessExtras comp lbi + extras <- preprocessExtras verbosity comp lbi setupMessage' verbosity "Building" (packageId pkg_descr) (componentLocalName clbi) (maybeComponentInstantiatedWith clbi) let ebi = buildInfo exe @@ -305,10 +305,10 @@ buildComponent verbosity numJobs pkg_descr lbi suffixes return Nothing -buildComponent _ _ _ _ _ +buildComponent verbosity _ _ _ _ (CBench Benchmark { benchmarkInterface = BenchmarkUnsupported tt }) _ _ = - die $ "No support for building benchmark type " ++ display tt + die' verbosity $ "No support for building benchmark type " ++ display tt -- | Add extra C sources generated by preprocessing to build @@ -331,7 +331,7 @@ replComponent :: Verbosity replComponent verbosity pkg_descr lbi suffixes comp@(CLib lib) clbi _ = do preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes - extras <- preprocessExtras comp lbi + extras <- preprocessExtras verbosity comp lbi let libbi = libBuildInfo lib lib' = lib { libBuildInfo = libbi { cSources = cSources libbi ++ extras } } replLib verbosity pkg_descr lbi lib' clbi @@ -344,7 +344,7 @@ replComponent verbosity pkg_descr lbi suffixes replComponent verbosity pkg_descr lbi suffixes comp@(CExe exe) clbi _ = do preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes - extras <- preprocessExtras comp lbi + extras <- preprocessExtras verbosity comp lbi let ebi = buildInfo exe exe' = exe { buildInfo = ebi { cSources = cSources ebi ++ extras } } replExe verbosity pkg_descr lbi exe' clbi @@ -355,7 +355,7 @@ replComponent verbosity pkg_descr lbi suffixes clbi _distPref = do let exe = testSuiteExeV10AsExe test preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes - extras <- preprocessExtras comp lbi + extras <- preprocessExtras verbosity comp lbi let ebi = buildInfo exe exe' = exe { buildInfo = ebi { cSources = cSources ebi ++ extras } } replExe verbosity pkg_descr lbi exe' clbi @@ -369,16 +369,16 @@ replComponent verbosity pkg_descr lbi0 suffixes let (pkg, lib, libClbi, lbi, _, _, _) = testSuiteLibV09AsLibAndExe pkg_descr test clbi lbi0 distPref pwd preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes - extras <- preprocessExtras comp lbi + extras <- preprocessExtras verbosity comp lbi let libbi = libBuildInfo lib lib' = lib { libBuildInfo = libbi { cSources = cSources libbi ++ extras } } replLib verbosity pkg lbi lib' libClbi -replComponent _ _ _ _ +replComponent verbosity _ _ _ (CTest TestSuite { testInterface = TestSuiteUnsupported tt }) _ _ = - die $ "No support for building test suite type " ++ display tt + die' verbosity $ "No support for building test suite type " ++ display tt replComponent verbosity pkg_descr lbi suffixes @@ -386,16 +386,16 @@ replComponent verbosity pkg_descr lbi suffixes clbi _ = do let (exe, exeClbi) = benchmarkExeV10asExe bm clbi preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes - extras <- preprocessExtras comp lbi + extras <- preprocessExtras verbosity comp lbi let ebi = buildInfo exe exe' = exe { buildInfo = ebi { cSources = cSources ebi ++ extras } } replExe verbosity pkg_descr lbi exe' exeClbi -replComponent _ _ _ _ +replComponent verbosity _ _ _ (CBench Benchmark { benchmarkInterface = BenchmarkUnsupported tt }) _ _ = - die $ "No support for building benchmark type " ++ display tt + die' verbosity $ "No support for building benchmark type " ++ display tt ---------------------------------------------------- -- Shared code for buildComponent and replComponent @@ -561,7 +561,7 @@ buildLib verbosity numJobs pkg_descr lbi lib clbi = LHC -> LHC.buildLib verbosity pkg_descr lbi lib clbi UHC -> UHC.buildLib verbosity pkg_descr lbi lib clbi HaskellSuite {} -> HaskellSuite.buildLib verbosity pkg_descr lbi lib clbi - _ -> die "Building is not supported with this compiler." + _ -> die' verbosity "Building is not supported with this compiler." -- | Build a foreign library -- @@ -573,7 +573,7 @@ buildFLib :: Verbosity -> Flag (Maybe Int) buildFLib verbosity numJobs pkg_descr lbi flib clbi = case compilerFlavor (compiler lbi) of GHC -> GHC.buildFLib verbosity numJobs pkg_descr lbi flib clbi - _ -> die "Building is not supported with this compiler." + _ -> die' verbosity "Building is not supported with this compiler." buildExe :: Verbosity -> Flag (Maybe Int) -> PackageDescription -> LocalBuildInfo @@ -585,7 +585,7 @@ buildExe verbosity numJobs pkg_descr lbi exe clbi = JHC -> JHC.buildExe verbosity pkg_descr lbi exe clbi LHC -> LHC.buildExe verbosity pkg_descr lbi exe clbi UHC -> UHC.buildExe verbosity pkg_descr lbi exe clbi - _ -> die "Building is not supported with this compiler." + _ -> die' verbosity "Building is not supported with this compiler." replLib :: Verbosity -> PackageDescription -> LocalBuildInfo -> Library -> ComponentLocalBuildInfo -> IO () @@ -595,7 +595,7 @@ replLib verbosity pkg_descr lbi lib clbi = -- NoFlag as the numJobs parameter. GHC -> GHC.replLib verbosity NoFlag pkg_descr lbi lib clbi GHCJS -> GHCJS.replLib verbosity NoFlag pkg_descr lbi lib clbi - _ -> die "A REPL is not supported for this compiler." + _ -> die' verbosity "A REPL is not supported for this compiler." replExe :: Verbosity -> PackageDescription -> LocalBuildInfo -> Executable -> ComponentLocalBuildInfo -> IO () @@ -603,14 +603,14 @@ replExe verbosity pkg_descr lbi exe clbi = case compilerFlavor (compiler lbi) of GHC -> GHC.replExe verbosity NoFlag pkg_descr lbi exe clbi GHCJS -> GHCJS.replExe verbosity NoFlag pkg_descr lbi exe clbi - _ -> die "A REPL is not supported for this compiler." + _ -> die' verbosity "A REPL is not supported for this compiler." replFLib :: Verbosity -> PackageDescription -> LocalBuildInfo -> ForeignLib -> ComponentLocalBuildInfo -> IO () replFLib verbosity pkg_descr lbi exe clbi = case compilerFlavor (compiler lbi) of GHC -> GHC.replFLib verbosity NoFlag pkg_descr lbi exe clbi - _ -> die "A REPL is not supported for this compiler." + _ -> die' verbosity "A REPL is not supported for this compiler." -- | Runs 'componentInitialBuildSteps' on every configured component. initialBuildSteps :: FilePath -- ^"dist" prefix diff --git a/Cabal/Distribution/Simple/BuildTarget.hs b/Cabal/Distribution/Simple/BuildTarget.hs index 7c2814cb0a1c63ae4ffa51554ba9ce6070d1df80..08d58ffb64a5531ebd944cdfb7d0a721aa09897f 100644 --- a/Cabal/Distribution/Simple/BuildTarget.hs +++ b/Cabal/Distribution/Simple/BuildTarget.hs @@ -70,7 +70,7 @@ import qualified Data.Map as Map -- into actual 'TargetInfo's to be built/registered/whatever. readTargetInfos :: Verbosity -> PackageDescription -> LocalBuildInfo -> [String] -> IO [TargetInfo] readTargetInfos verbosity pkg_descr lbi args = do - build_targets <- readBuildTargets pkg_descr args + build_targets <- readBuildTargets verbosity pkg_descr args checkBuildTargets verbosity pkg_descr lbi build_targets -- ------------------------------------------------------------ @@ -142,15 +142,15 @@ buildTargetComponentName (BuildTargetFile cn _) = cn -- 'BuildTarget's according to a 'PackageDescription'. If there are problems -- with any of the targets e.g. they don't exist or are misformatted, throw an -- 'IOException'. -readBuildTargets :: PackageDescription -> [String] -> IO [BuildTarget] -readBuildTargets pkg targetStrs = do +readBuildTargets :: Verbosity -> PackageDescription -> [String] -> IO [BuildTarget] +readBuildTargets verbosity pkg targetStrs = do let (uproblems, utargets) = readUserBuildTargets targetStrs - reportUserBuildTargetProblems uproblems + reportUserBuildTargetProblems verbosity uproblems utargets' <- traverse checkTargetExistsAsFile utargets let (bproblems, btargets) = resolveBuildTargets pkg utargets' - reportBuildTargetProblems bproblems + reportBuildTargetProblems verbosity bproblems return btargets @@ -212,12 +212,12 @@ data UserBuildTargetProblem = UserBuildTargetUnrecognised String deriving Show -reportUserBuildTargetProblems :: [UserBuildTargetProblem] -> IO () -reportUserBuildTargetProblems problems = do +reportUserBuildTargetProblems :: Verbosity -> [UserBuildTargetProblem] -> IO () +reportUserBuildTargetProblems verbosity problems = do case [ target | UserBuildTargetUnrecognised target <- problems ] of [] -> return () target -> - die $ unlines + die' verbosity $ unlines [ "Unrecognised build target '" ++ name ++ "'." | name <- target ] ++ "Examples:\n" @@ -360,13 +360,13 @@ renderBuildTarget ql target pkgid = dispCName = componentStringName pkgid dispKind = showComponentKindShort . componentKind -reportBuildTargetProblems :: [BuildTargetProblem] -> IO () -reportBuildTargetProblems problems = do +reportBuildTargetProblems :: Verbosity -> [BuildTargetProblem] -> IO () +reportBuildTargetProblems verbosity problems = do case [ (t, e, g) | BuildTargetExpected t e g <- problems ] of [] -> return () targets -> - die $ unlines + die' verbosity $ unlines [ "Unrecognised build target '" ++ showUserBuildTarget target ++ "'.\n" ++ "Expected a " ++ intercalate " or " expected @@ -376,7 +376,7 @@ reportBuildTargetProblems problems = do case [ (t, e) | BuildTargetNoSuch t e <- problems ] of [] -> return () targets -> - die $ unlines + die' verbosity $ unlines [ "Unknown build target '" ++ showUserBuildTarget target ++ "'.\nThere is no " ++ intercalate " or " [ mungeThing thing ++ " '" ++ got ++ "'" @@ -389,7 +389,7 @@ reportBuildTargetProblems problems = do case [ (t, ts) | BuildTargetAmbiguous t ts <- problems ] of [] -> return () targets -> - die $ unlines + die' verbosity $ unlines [ "Ambiguous build target '" ++ showUserBuildTarget target ++ "'. It could be:\n " ++ unlines [ " "++ showUserBuildTarget ut ++ @@ -996,7 +996,7 @@ checkBuildTargets verbosity pkg_descr lbi targets = do case disabled of [] -> return () - ((cname,reason):_) -> die $ formatReason (showComponentName cname) reason + ((cname,reason):_) -> die' verbosity $ formatReason (showComponentName cname) reason for_ [ (c, t) | (c, Just t) <- enabled ] $ \(c, t) -> warn verbosity $ "Ignoring '" ++ either display id t ++ ". The whole " diff --git a/Cabal/Distribution/Simple/Command.hs b/Cabal/Distribution/Simple/Command.hs index 58e7883d56a358759e8284fa6308a061ef81db5b..4a8dd4cc91842398e79352aaf41c93b48dd4a7ac 100644 --- a/Cabal/Distribution/Simple/Command.hs +++ b/Cabal/Distribution/Simple/Command.hs @@ -585,7 +585,7 @@ commandsRun globalCommand commands args = noExtraFlags :: [String] -> IO () noExtraFlags [] = return () noExtraFlags extraFlags = - die $ "Unrecognised flags: " ++ intercalate ", " extraFlags + dieNoVerbosity $ "Unrecognised flags: " ++ intercalate ", " extraFlags --TODO: eliminate this function and turn it into a variant on commandAddAction -- instead like commandAddActionNoArgs that doesn't supply the [String] diff --git a/Cabal/Distribution/Simple/Configure.hs b/Cabal/Distribution/Simple/Configure.hs index 9ef9eae25d71ac31007f2f5fc8754690df34c7dd..d739311ededa4d9a7818320e9efefc781fcd362b 100644 --- a/Cabal/Distribution/Simple/Configure.hs +++ b/Cabal/Distribution/Simple/Configure.hs @@ -349,14 +349,14 @@ configure (pkg_descr0', pbi) cfg = do -- configure everything (the old behavior). (mb_cname :: Maybe ComponentName) <- do let flat_pkg_descr = flattenPackageDescription pkg_descr0 - targets <- readBuildTargets flat_pkg_descr (configArgs cfg) + targets <- readBuildTargets verbosity flat_pkg_descr (configArgs cfg) -- TODO: bleat if you use the module/file syntax let targets' = [ cname | BuildTargetComponent cname <- targets ] case targets' of _ | null (configArgs cfg) -> return Nothing [cname] -> return (Just cname) - [] -> die "No valid component targets found" - _ -> die "Can only configure either single component or all of them" + [] -> die' verbosity "No valid component targets found" + _ -> die' verbosity "Can only configure either single component or all of them" let use_external_internal_deps = isJust mb_cname case mb_cname of @@ -366,10 +366,10 @@ configure (pkg_descr0', pbi) cfg = do -- configCID is only valid for per-component configure when (isJust (flagToMaybe (configCID cfg)) && isNothing mb_cname) $ - die "--cid is only supported for per-component configure" + die' verbosity "--cid is only supported for per-component configure" checkDeprecatedFlags verbosity cfg - checkExactConfiguration pkg_descr0 cfg + checkExactConfiguration verbosity pkg_descr0 cfg -- Where to build the package let buildDir :: FilePath -- e.g. dist/build @@ -427,7 +427,7 @@ configure (pkg_descr0', pbi) cfg = do -- Some sanity checks related to enabling components. when (isJust mb_cname && (fromFlag (configTests cfg) || fromFlag (configBenchmarks cfg))) $ - die $ "--enable-tests/--enable-benchmarks are incompatible with" ++ + die' verbosity $ "--enable-tests/--enable-benchmarks are incompatible with" ++ " explicitly specifying a component to configure." -- allConstraints: The set of all 'Dependency's we have. Used ONLY @@ -445,7 +445,7 @@ configure (pkg_descr0', pbi) cfg = do -- version of a dependency, and the executable to use another. (allConstraints :: [Dependency], requiredDepsMap :: Map PackageName InstalledPackageInfo) - <- either die return $ + <- either (die' verbosity) return $ combinedConstraints (configConstraints cfg) (configDependencies cfg) installedPackageSet @@ -492,7 +492,7 @@ configure (pkg_descr0', pbi) cfg = do debug verbosity $ "Finalized build-depends: " ++ intercalate ", " (map display (buildDepends pkg_descr)) - checkCompilerProblems comp pkg_descr enabled + checkCompilerProblems verbosity comp pkg_descr enabled checkPackageProblems verbosity pkg_descr0 (updatePackageDescription pbi pkg_descr) @@ -545,14 +545,14 @@ configure (pkg_descr0', pbi) cfg = do (enabledBuildInfos pkg_descr enabled) let langs = unsupportedLanguages comp langlist when (not (null langs)) $ - die $ "The package " ++ display (packageId pkg_descr0) + die' verbosity $ "The package " ++ display (packageId pkg_descr0) ++ " requires the following languages which are not " ++ "supported by " ++ display (compilerId comp) ++ ": " ++ intercalate ", " (map display langs) let extlist = nub $ concatMap allExtensions (enabledBuildInfos pkg_descr enabled) let exts = unsupportedExtensions comp extlist when (not (null exts)) $ - die $ "The package " ++ display (packageId pkg_descr0) + die' verbosity $ "The package " ++ display (packageId pkg_descr0) ++ " requires the following language extensions which are not " ++ "supported by " ++ display (compilerId comp) ++ ": " ++ intercalate ", " (map display exts) @@ -561,7 +561,7 @@ configure (pkg_descr0', pbi) cfg = do let flibs = [flib | CFLib flib <- enabledComponents pkg_descr enabled] let unsupportedFLibs = unsupportedForeignLibs comp compPlatform flibs when (not (null unsupportedFLibs)) $ - die $ "Cannot build some foreign libraries: " + die' verbosity $ "Cannot build some foreign libraries: " ++ intercalate "," unsupportedFLibs -- Configure certain external build tools, see below for which ones. @@ -735,7 +735,7 @@ configure (pkg_descr0', pbi) cfg = do let dirs = absoluteInstallDirs pkg_descr lbi NoCopyDest relative = prefixRelativeInstallDirs (packageId pkg_descr) lbi - unless (isAbsolute (prefix dirs)) $ die $ + unless (isAbsolute (prefix dirs)) $ die' verbosity $ "expected an absolute directory name for --prefix: " ++ prefix dirs info verbosity $ "Using " ++ display currentCabalId @@ -800,14 +800,14 @@ checkDeprecatedFlags verbosity cfg = do -- | Sanity check: if '--exact-configuration' was given, ensure that the -- complete flag assignment was specified on the command line. -checkExactConfiguration :: GenericPackageDescription -> ConfigFlags -> IO () -checkExactConfiguration pkg_descr0 cfg = do +checkExactConfiguration :: Verbosity -> GenericPackageDescription -> ConfigFlags -> IO () +checkExactConfiguration verbosity pkg_descr0 cfg = do when (fromFlagOrDefault False (configExactConfiguration cfg)) $ do let cmdlineFlags = map fst (configConfigurationsFlags cfg) allFlags = map flagName . genPackageFlags $ pkg_descr0 diffFlags = allFlags \\ cmdlineFlags when (not . null $ diffFlags) $ - die $ "'--exact-configuration' was given, " + die' verbosity $ "'--exact-configuration' was given, " ++ "but the following flags were not specified: " ++ intercalate ", " (map show diffFlags) @@ -951,7 +951,7 @@ configureFinalizedPackage verbosity cfg enabled pkg_descr0 of Right r -> return r Left missing -> - die $ "Encountered missing dependencies:\n" + die' verbosity $ "Encountered missing dependencies:\n" ++ (render . nest 4 . sep . punctuate comma . map (disp . simplifyDependency) $ missing) @@ -981,23 +981,23 @@ configureFinalizedPackage verbosity cfg enabled executables pkg_descr} -- | Check for use of Cabal features which require compiler support -checkCompilerProblems :: Compiler -> PackageDescription -> ComponentRequestedSpec -> IO () -checkCompilerProblems comp pkg_descr enabled = do +checkCompilerProblems :: Verbosity -> Compiler -> PackageDescription -> ComponentRequestedSpec -> IO () +checkCompilerProblems verbosity comp pkg_descr enabled = do unless (renamingPackageFlagsSupported comp || all (all (isDefaultIncludeRenaming . mixinIncludeRenaming) . mixins) (enabledBuildInfos pkg_descr enabled)) $ - die $ "Your compiler does not support thinning and renaming on " + die' verbosity $ "Your compiler does not support thinning and renaming on " ++ "package flags. To use this feature you must use " ++ "GHC 7.9 or later." when (any (not.null.PD.reexportedModules) (PD.allLibraries pkg_descr) && not (reexportedModulesSupported comp)) $ do - die $ "Your compiler does not support module re-exports. To use " + die' verbosity $ "Your compiler does not support module re-exports. To use " ++ "this feature you must use GHC 7.9 or later." when (any (not.null.PD.signatures) (PD.allLibraries pkg_descr) && not (backpackSupported comp)) $ do - die $ "Your compiler does not support Backpack. To use " + die' verbosity $ "Your compiler does not support Backpack. To use " ++ "this feature you must use GHC 8.1 or later." -- | Select dependencies for the package. @@ -1032,13 +1032,13 @@ configureDependencies verbosity use_external_internal_deps when (not (null internalPkgDeps) && not (newPackageDepsBehaviour pkg_descr)) $ - die $ "The field 'build-depends: " + die' verbosity $ "The field 'build-depends: " ++ intercalate ", " (map (display . packageName) internalPkgDeps) ++ "' refers to a library which is defined within the same " ++ "package. To use this feature the package must specify at " ++ "least 'cabal-version: >= 1.8'." - reportFailedDependencies failedDeps + reportFailedDependencies verbosity failedDeps reportSelectedDependencies verbosity allPkgDeps return externalPkgDeps @@ -1241,10 +1241,10 @@ reportSelectedDependencies verbosity deps = ExternalDependency dep' pkg' -> (dep', packageId pkg') InternalDependency dep' pkgid' -> (dep', pkgid') ] -reportFailedDependencies :: [FailedDependency] -> IO () -reportFailedDependencies [] = return () -reportFailedDependencies failed = - die (intercalate "\n\n" (map reportFailedDependency failed)) +reportFailedDependencies :: Verbosity -> [FailedDependency] -> IO () +reportFailedDependencies _ [] = return () +reportFailedDependencies verbosity failed = + die' verbosity (intercalate "\n\n" (map reportFailedDependency failed)) where reportFailedDependency (DependencyNotExists pkgname) = @@ -1268,7 +1268,7 @@ getInstalledPackages :: Verbosity -> Compiler -> IO InstalledPackageIndex getInstalledPackages verbosity comp packageDBs progdb = do when (null packageDBs) $ - die $ "No package databases have been specified. If you use " + die' verbosity $ "No package databases have been specified. If you use " ++ "--package-db=clear, you must follow it with --package-db= " ++ "with 'global', 'user' or a specific file." @@ -1281,7 +1281,7 @@ getInstalledPackages verbosity comp packageDBs progdb = do UHC -> UHC.getInstalledPackages verbosity comp packageDBs progdb HaskellSuite {} -> HaskellSuite.getInstalledPackages verbosity packageDBs progdb - flv -> die $ "don't know how to find the installed packages for " + flv -> die' verbosity $ "don't know how to find the installed packages for " ++ display flv -- | Like 'getInstalledPackages', but for a single package DB. @@ -1491,11 +1491,11 @@ configurePkgconfigPackages verbosity pkg_descr progdb enabled requirePkg dep@(PkgconfigDependency pkgn range) = do version <- pkgconfig ["--modversion", pkg] - `catchIO` (\_ -> die notFound) - `catchExit` (\_ -> die notFound) + `catchIO` (\_ -> die' verbosity notFound) + `catchExit` (\_ -> die' verbosity notFound) case simpleParse version of - Nothing -> die "parsing output of pkg-config --modversion failed" - Just v | not (withinRange v range) -> die (badVersion v) + Nothing -> die' verbosity "parsing output of pkg-config --modversion failed" + Just v | not (withinRange v range) -> die' verbosity (badVersion v) | otherwise -> info verbosity (depSatisfied v) where notFound = "The pkg-config package '" ++ pkg ++ "'" @@ -1582,7 +1582,7 @@ configCompilerAuxEx cfg = configCompilerEx (flagToMaybe $ configHcFlavor cfg) configCompilerEx :: Maybe CompilerFlavor -> Maybe FilePath -> Maybe FilePath -> ProgramDb -> Verbosity -> IO (Compiler, Platform, ProgramDb) -configCompilerEx Nothing _ _ _ _ = die "Unknown compiler" +configCompilerEx Nothing _ _ _ verbosity = die' verbosity "Unknown compiler" configCompilerEx (Just hcFlavor) hcPath hcPkg progdb verbosity = do (comp, maybePlatform, programDb) <- case hcFlavor of GHC -> GHC.configure verbosity hcPath hcPkg progdb @@ -1592,7 +1592,7 @@ configCompilerEx (Just hcFlavor) hcPath hcPkg progdb verbosity = do LHC.configure verbosity hcPath Nothing ghcConf UHC -> UHC.configure verbosity hcPath hcPkg progdb HaskellSuite {} -> HaskellSuite.configure verbosity hcPath hcPkg progdb - _ -> die "Unknown compiler" + _ -> die' verbosity "Unknown compiler" return (comp, fromMaybe buildPlatform maybePlatform, programDb) -- Ideally we would like to not have separate configCompiler* and @@ -1724,14 +1724,14 @@ checkForeignDeps pkg lbi verbosity = do explainErrors _ _ | isNothing . lookupProgram gccProgram . withPrograms $ lbi - = die $ unlines $ + = die' verbosity $ unlines $ [ "No working gcc", "This package depends on foreign library but we cannot " ++ "find a working C compiler. If you have it in a " ++ "non-standard location you can use the --with-gcc " ++ "flag to specify it." ] - explainErrors hdr libs = die $ unlines $ + explainErrors hdr libs = die' verbosity $ unlines $ [ if plural then "Missing dependencies on foreign libraries:" else "Missing dependency on a foreign library:" @@ -1793,7 +1793,7 @@ checkPackageProblems verbosity gpkg pkg = do warnings = [ w | PackageBuildWarning w <- pureChecks ++ ioChecks ] if null errors then traverse_ (warn verbosity) warnings - else die (intercalate "\n\n" errors) + else die' verbosity (intercalate "\n\n" errors) -- | Preform checks if a relocatable build is allowed checkRelocatable :: Verbosity @@ -1814,7 +1814,7 @@ checkRelocatable verbosity pkg lbi -- Distribution.Simple.GHC.getRPaths checkOS = unless (os `elem` [ OSX, Linux ]) - $ die $ "Operating system: " ++ display os ++ + $ die' verbosity $ "Operating system: " ++ display os ++ ", does not support relocatable builds" where (Platform _ os) = hostPlatform lbi @@ -1822,7 +1822,7 @@ checkRelocatable verbosity pkg lbi -- Check if the Compiler support relocatable builds checkCompiler = unless (compilerFlavor comp `elem` [ GHC ]) - $ die $ "Compiler: " ++ show comp ++ + $ die' verbosity $ "Compiler: " ++ show comp ++ ", does not support relocatable builds" where comp = compiler lbi @@ -1830,7 +1830,7 @@ checkRelocatable verbosity pkg lbi -- Check if all the install dirs are relative to same prefix packagePrefixRelative = unless (relativeInstallDirs installDirs) - $ die $ "Installation directories are not prefix_relative:\n" ++ + $ die' verbosity $ "Installation directories are not prefix_relative:\n" ++ show installDirs where -- NB: should be good enough to check this against the default @@ -1853,7 +1853,7 @@ checkRelocatable verbosity pkg lbi where doCheck pkgr ipkg | maybe False (== pkgr) (Installed.pkgRoot ipkg) - = traverse_ (\l -> when (isNothing $ stripPrefix p l) (die (msg l))) + = traverse_ (\l -> when (isNothing $ stripPrefix p l) (die' verbosity (msg l))) (Installed.libraryDirs ipkg) | otherwise = return () diff --git a/Cabal/Distribution/Simple/GHC.hs b/Cabal/Distribution/Simple/GHC.hs index aeaa338254a04f7948acc0f614ebf9e6dc3dde02..3b5ab22a5f84347c654c370f358464ad820a9813 100644 --- a/Cabal/Distribution/Simple/GHC.hs +++ b/Cabal/Distribution/Simple/GHC.hs @@ -138,7 +138,7 @@ configure verbosity hcPath hcPkgPath conf0 = do } anyVersion (userMaybeSpecifyPath "ghc-pkg" hcPkgPath progdb1) - when (ghcVersion /= ghcPkgVersion) $ die $ + when (ghcVersion /= ghcPkgVersion) $ die' verbosity $ "Version mismatch between ghc and ghc-pkg: " ++ programPath ghcProg ++ " is version " ++ display ghcVersion ++ " " ++ programPath ghcPkgProg ++ " is version " ++ display ghcPkgVersion @@ -316,8 +316,8 @@ getInstalledPackages :: Verbosity -> Compiler -> PackageDBStack -> ProgramDb -> IO InstalledPackageIndex getInstalledPackages verbosity comp packagedbs progdb = do - checkPackageDbEnvVar - checkPackageDbStack comp packagedbs + checkPackageDbEnvVar verbosity + checkPackageDbStack verbosity comp packagedbs pkgss <- getInstalledPackages' verbosity packagedbs progdb index <- toPackageIndex verbosity pkgss progdb return $! hackRtsPackage index @@ -383,35 +383,36 @@ getUserPackageDB _verbosity ghcProg platform = do | otherwise = "package.conf" Just ghcVersion = programVersion ghcProg -checkPackageDbEnvVar :: IO () -checkPackageDbEnvVar = - Internal.checkPackageDbEnvVar "GHC" "GHC_PACKAGE_PATH" +checkPackageDbEnvVar :: Verbosity -> IO () +checkPackageDbEnvVar verbosity = + Internal.checkPackageDbEnvVar verbosity "GHC" "GHC_PACKAGE_PATH" -checkPackageDbStack :: Compiler -> PackageDBStack -> IO () -checkPackageDbStack comp = if flagPackageConf implInfo - then checkPackageDbStackPre76 - else checkPackageDbStackPost76 +checkPackageDbStack :: Verbosity -> Compiler -> PackageDBStack -> IO () +checkPackageDbStack verbosity comp = + if flagPackageConf implInfo + then checkPackageDbStackPre76 verbosity + else checkPackageDbStackPost76 verbosity where implInfo = ghcVersionImplInfo (compilerVersion comp) -checkPackageDbStackPost76 :: PackageDBStack -> IO () -checkPackageDbStackPost76 (GlobalPackageDB:rest) +checkPackageDbStackPost76 :: Verbosity -> PackageDBStack -> IO () +checkPackageDbStackPost76 _ (GlobalPackageDB:rest) | GlobalPackageDB `notElem` rest = return () -checkPackageDbStackPost76 rest +checkPackageDbStackPost76 verbosity rest | GlobalPackageDB `elem` rest = - die $ "If the global package db is specified, it must be " + die' verbosity $ "If the global package db is specified, it must be " ++ "specified first and cannot be specified multiple times" -checkPackageDbStackPost76 _ = return () +checkPackageDbStackPost76 _ _ = return () -checkPackageDbStackPre76 :: PackageDBStack -> IO () -checkPackageDbStackPre76 (GlobalPackageDB:rest) +checkPackageDbStackPre76 :: Verbosity -> PackageDBStack -> IO () +checkPackageDbStackPre76 _ (GlobalPackageDB:rest) | GlobalPackageDB `notElem` rest = return () -checkPackageDbStackPre76 rest +checkPackageDbStackPre76 verbosity rest | GlobalPackageDB `notElem` rest = - die $ "With current ghc versions the global package db is always used " + die' verbosity $ "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 http://hackage.haskell.org/trac/ghc/ticket/5977" -checkPackageDbStackPre76 _ = - die $ "If the global package db is specified, it must be " +checkPackageDbStackPre76 verbosity _ = + die' verbosity $ "If the global package db is specified, it must be " ++ "specified first and cannot be specified multiple times" -- GHC < 6.10 put "$topdir/include/mingw" in rts's installDirs. This @@ -446,7 +447,7 @@ getInstalledPackages' verbosity packagedbs progdb = do (UserPackageDB, _global:user:_) -> return $ Just user (UserPackageDB, _global:_) -> return $ Nothing (SpecificPackageDB specific, _) -> return $ Just specific - _ -> die "cannot read ghc-pkg package listing" + _ -> die' verbosity "cannot read ghc-pkg package listing" pkgFiles' <- traverse dbFile packagedbs sequenceA [ withFileContents file $ \content -> do pkgs <- readPackages file content @@ -466,7 +467,7 @@ getInstalledPackages' verbosity packagedbs progdb = do = \file _ -> failToRead file Just ghcProg = lookupProgram ghcProgram progdb Just ghcVersion = programVersion ghcProg - failToRead file = die $ "cannot read ghc package database " ++ file + failToRead file = die' verbosity $ "cannot read ghc package database " ++ file getInstalledPackagesMonitorFiles :: Verbosity -> Platform -> ProgramDb @@ -810,7 +811,7 @@ startInterpreter verbosity progdb comp platform packageDBs = do ghcOptMode = toFlag GhcModeInteractive, ghcOptPackageDBs = packageDBs } - checkPackageDbStack comp packageDBs + checkPackageDbStack verbosity comp packageDBs (ghcProg, _) <- requireProgram verbosity ghcProgram progdb runGHC verbosity ghcProg comp platform replOpts @@ -1519,7 +1520,7 @@ installFLib verbosity lbi targetDir builtDir _pkg flib = -- Now install appropriate symlinks if library is versioned let (Platform _ os) = hostPlatform lbi when (not (null (foreignLibVersion flib os))) $ do - when (os /= Linux) $ die + when (os /= Linux) $ die' verbosity -- It should be impossible to get here. "Can't install foreign-library symlink on non-Linux OS" #ifndef mingw32_HOST_OS diff --git a/Cabal/Distribution/Simple/GHC/Internal.hs b/Cabal/Distribution/Simple/GHC/Internal.hs index 3e7af3f35d4b955ccc82f65437e6149132e09812..ea3c2bd2bc5e9193b05e6933aed69fa66b8cbbf4 100644 --- a/Cabal/Distribution/Simple/GHC/Internal.hs +++ b/Cabal/Distribution/Simple/GHC/Internal.hs @@ -228,7 +228,7 @@ getGhcInfo verbosity _implInfo ghcProg = do | all isSpace ss -> return i _ -> - die "Can't parse --info output of GHC" + die' verbosity "Can't parse --info output of GHC" getExtensions :: Verbosity -> GhcImplInfo -> ConfiguredProgram -> IO [(Extension, String)] @@ -441,8 +441,8 @@ substTopDir topDir ipo -- CABAL_SANDBOX_PACKAGE_PATH to the same value that it set -- GHC{,JS}_PACKAGE_PATH to. If that is the case it is OK to allow -- GHC{,JS}_PACKAGE_PATH. -checkPackageDbEnvVar :: String -> String -> IO () -checkPackageDbEnvVar compilerName packagePathEnvVar = do +checkPackageDbEnvVar :: Verbosity -> String -> String -> IO () +checkPackageDbEnvVar verbosity compilerName packagePathEnvVar = do mPP <- lookupEnv packagePathEnvVar when (isJust mPP) $ do mcsPP <- lookupEnv "CABAL_SANDBOX_PACKAGE_PATH" @@ -452,7 +452,7 @@ checkPackageDbEnvVar compilerName packagePathEnvVar = do lookupEnv name = (Just `fmap` getEnv name) `catchIO` const (return Nothing) abort = - die $ "Use of " ++ compilerName ++ "'s environment variable " + die' verbosity $ "Use of " ++ compilerName ++ "'s environment variable " ++ packagePathEnvVar ++ " is incompatible with Cabal. Use the " ++ "flag --package-db to specify a package database (it can be " ++ "used multiple times)." diff --git a/Cabal/Distribution/Simple/GHCJS.hs b/Cabal/Distribution/Simple/GHCJS.hs index 58b92779597ebbfb00ecd9da419344e8f1c421d2..629725afa4f35479a5609a6222ed586db28d3172 100644 --- a/Cabal/Distribution/Simple/GHCJS.hs +++ b/Cabal/Distribution/Simple/GHCJS.hs @@ -76,12 +76,12 @@ configure verbosity hcPath hcPkgPath progdb0 = do Just ghcjsPkgGhcjsVersion <- findGhcjsPkgGhcjsVersion verbosity (programPath ghcjsPkgProg) - when (ghcjsVersion /= ghcjsPkgGhcjsVersion) $ die $ + when (ghcjsVersion /= ghcjsPkgGhcjsVersion) $ die' verbosity $ "Version mismatch between ghcjs and ghcjs-pkg: " ++ programPath ghcjsProg ++ " is version " ++ display ghcjsVersion ++ " " ++ programPath ghcjsPkgProg ++ " is version " ++ display ghcjsPkgGhcjsVersion - when (ghcjsGhcVersion /= ghcjsPkgVersion) $ die $ + when (ghcjsGhcVersion /= ghcjsPkgVersion) $ die' verbosity $ "Version mismatch between ghcjs and ghcjs-pkg: " ++ programPath ghcjsProg ++ " was built with GHC version " ++ display ghcjsGhcVersion ++ " " @@ -190,8 +190,8 @@ getPackageDBContents verbosity packagedb progdb = do getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramDb -> IO InstalledPackageIndex getInstalledPackages verbosity packagedbs progdb = do - checkPackageDbEnvVar - checkPackageDbStack packagedbs + checkPackageDbEnvVar verbosity + checkPackageDbStack verbosity packagedbs pkgss <- getInstalledPackages' verbosity packagedbs progdb index <- toPackageIndex verbosity pkgss progdb return $! index @@ -212,20 +212,20 @@ toPackageIndex verbosity pkgss progdb = do where Just ghcjsProg = lookupProgram ghcjsProgram progdb -checkPackageDbEnvVar :: IO () -checkPackageDbEnvVar = - Internal.checkPackageDbEnvVar "GHCJS" "GHCJS_PACKAGE_PATH" +checkPackageDbEnvVar :: Verbosity -> IO () +checkPackageDbEnvVar verbosity = + Internal.checkPackageDbEnvVar verbosity "GHCJS" "GHCJS_PACKAGE_PATH" -checkPackageDbStack :: PackageDBStack -> IO () -checkPackageDbStack (GlobalPackageDB:rest) +checkPackageDbStack :: Verbosity -> PackageDBStack -> IO () +checkPackageDbStack _ (GlobalPackageDB:rest) | GlobalPackageDB `notElem` rest = return () -checkPackageDbStack rest +checkPackageDbStack verbosity rest | GlobalPackageDB `notElem` rest = - die $ "With current ghc versions the global package db is always used " + die' verbosity $ "With current ghc versions the global package db is always used " ++ "and must be listed first. This ghc limitation may be lifted in " ++ "future, see http://hackage.haskell.org/trac/ghc/ticket/5977" -checkPackageDbStack _ = - die $ "If the global package db is specified, it must be " +checkPackageDbStack verbosity _ = + die' verbosity $ "If the global package db is specified, it must be " ++ "specified first and cannot be specified multiple times" getInstalledPackages' :: Verbosity -> [PackageDB] -> ProgramDb @@ -499,7 +499,7 @@ startInterpreter verbosity progdb comp platform packageDBs = do ghcOptMode = toFlag GhcModeInteractive, ghcOptPackageDBs = packageDBs } - checkPackageDbStack packageDBs + checkPackageDbStack verbosity packageDBs (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram progdb runGHC verbosity ghcjsProg comp platform replOpts diff --git a/Cabal/Distribution/Simple/Haddock.hs b/Cabal/Distribution/Simple/Haddock.hs index c2aed09b7298e8ef7c78de6ecb49c36e570b8008..413fd2e84989ebbf2be909e65a14b01faa094524 100644 --- a/Cabal/Distribution/Simple/Haddock.hs +++ b/Cabal/Distribution/Simple/Haddock.hs @@ -166,16 +166,16 @@ haddock pkg_descr lbi suffixes flags' = do -- various sanity checks when ( flag haddockHoogle && version < mkVersion [2,2]) $ - die "haddock 2.0 and 2.1 do not support the --hoogle flag." + die' verbosity "haddock 2.0 and 2.1 do not support the --hoogle flag." haddockGhcVersionStr <- getProgramOutput verbosity haddockProg ["--ghc-version"] case (simpleParse haddockGhcVersionStr, compilerCompatVersion GHC comp) of - (Nothing, _) -> die "Could not get GHC version from Haddock" - (_, Nothing) -> die "Could not get GHC version from compiler" + (Nothing, _) -> die' verbosity "Could not get GHC version from Haddock" + (_, Nothing) -> die' verbosity "Could not get GHC version from compiler" (Just haddockGhcVersion, Just ghcVersion) | haddockGhcVersion == ghcVersion -> return () - | otherwise -> die $ + | otherwise -> die' verbosity $ "Haddock's internal GHC version must match the configured " ++ "GHC version.\n" ++ "The GHC version is " ++ display ghcVersion ++ " but " @@ -328,9 +328,9 @@ mkHaddockArgs verbosity tmp lbi clbi htmlTemplate haddockVersion inFiles bi = do then return vanillaOpts else if withSharedLib lbi then return sharedOpts - else die $ "Must have vanilla or shared libraries " + else die' verbosity $ "Must have vanilla or shared libraries " ++ "enabled in order to run haddock" - ghcVersion <- maybe (die "Compiler has no GHC version") + ghcVersion <- maybe (die' verbosity "Compiler has no GHC version") return (compilerCompatVersion GHC (compiler lbi)) @@ -348,7 +348,7 @@ fromLibrary :: Verbosity -> Library -> IO HaddockArgs fromLibrary verbosity tmp lbi clbi htmlTemplate haddockVersion lib = do - inFiles <- map snd `fmap` getLibSourceFiles lbi lib clbi + inFiles <- map snd `fmap` getLibSourceFiles verbosity lbi lib clbi args <- mkHaddockArgs verbosity tmp lbi clbi htmlTemplate haddockVersion inFiles (libBuildInfo lib) return args { @@ -364,7 +364,7 @@ fromExecutable :: Verbosity -> Executable -> IO HaddockArgs fromExecutable verbosity tmp lbi clbi htmlTemplate haddockVersion exe = do - inFiles <- map snd `fmap` getExeSourceFiles lbi exe clbi + inFiles <- map snd `fmap` getExeSourceFiles verbosity lbi exe clbi args <- mkHaddockArgs verbosity tmp lbi clbi htmlTemplate haddockVersion inFiles (buildInfo exe) return args { @@ -381,7 +381,7 @@ fromForeignLib :: Verbosity -> ForeignLib -> IO HaddockArgs fromForeignLib verbosity tmp lbi clbi htmlTemplate haddockVersion flib = do - inFiles <- map snd `fmap` getFLibSourceFiles lbi flib clbi + inFiles <- map snd `fmap` getFLibSourceFiles verbosity lbi flib clbi args <- mkHaddockArgs verbosity tmp lbi clbi htmlTemplate haddockVersion inFiles (foreignLibBuildInfo flib) return args { @@ -413,7 +413,7 @@ getInterfaces :: Verbosity -> Maybe PathTemplate -- ^ template for HTML location -> IO HaddockArgs getInterfaces verbosity lbi clbi htmlTemplate = do - (packageFlags, warnings) <- haddockPackageFlags lbi clbi htmlTemplate + (packageFlags, warnings) <- haddockPackageFlags verbosity lbi clbi htmlTemplate traverse_ (warn verbosity) warnings return $ mempty { argInterfaces = packageFlags @@ -634,16 +634,17 @@ haddockPackagePaths ipkgs mkHtmlPath = do fixFileUrl f | isAbsolute f = "file://" ++ f | otherwise = f -haddockPackageFlags :: LocalBuildInfo +haddockPackageFlags :: Verbosity + -> LocalBuildInfo -> ComponentLocalBuildInfo -> Maybe PathTemplate -> IO ([(FilePath, Maybe FilePath)], Maybe String) -haddockPackageFlags lbi clbi htmlTemplate = do +haddockPackageFlags verbosity lbi clbi htmlTemplate = do let allPkgs = installedPkgs lbi directDeps = map fst (componentPackageDeps clbi) transitiveDeps <- case PackageIndex.dependencyClosure allPkgs directDeps of Left x -> return x - Right inf -> die $ "internal error when calculating transitive " + Right inf -> die' verbosity $ "internal error when calculating transitive " ++ "package dependencies.\nDebug info: " ++ show inf haddockPackagePaths (PackageIndex.allPackages transitiveDeps) mkHtmlPath where @@ -669,7 +670,7 @@ hscolour :: PackageDescription -> [PPSuffixHandler] -> HscolourFlags -> IO () -hscolour = hscolour' die ForDevelopment +hscolour = hscolour' dieNoVerbosity ForDevelopment hscolour' :: (String -> IO ()) -- ^ Called when the 'hscolour' exe is not found. -> HaddockTarget @@ -697,7 +698,7 @@ hscolour' onNoHsColour haddockTarget pkg_descr lbi suffixes flags = Just exe -> do let outputDir = hscolourPref haddockTarget distPref pkg_descr </> unUnqualComponentName (exeName exe) </> "src" - runHsColour hscolourProg outputDir =<< getExeSourceFiles lbi exe clbi + runHsColour hscolourProg outputDir =<< getExeSourceFiles verbosity lbi exe clbi Nothing -> do warn (fromFlag $ hscolourVerbosity flags) "Unsupported component, skipping..." @@ -705,11 +706,11 @@ hscolour' onNoHsColour haddockTarget pkg_descr lbi suffixes flags = case comp of CLib lib -> do let outputDir = hscolourPref haddockTarget distPref pkg_descr </> "src" - runHsColour hscolourProg outputDir =<< getLibSourceFiles lbi lib clbi + runHsColour hscolourProg outputDir =<< getLibSourceFiles verbosity lbi lib clbi CFLib flib -> do let outputDir = hscolourPref haddockTarget distPref pkg_descr </> unUnqualComponentName (foreignLibName flib) </> "src" - runHsColour hscolourProg outputDir =<< getFLibSourceFiles lbi flib clbi + runHsColour hscolourProg outputDir =<< getFLibSourceFiles verbosity lbi flib clbi CExe _ -> when (fromFlag (hscolourExecutables flags)) $ doExe comp CTest _ -> when (fromFlag (hscolourTestSuites flags)) $ doExe comp CBench _ -> when (fromFlag (hscolourBenchmarks flags)) $ doExe comp @@ -750,11 +751,12 @@ haddockToHscolour flags = --------------------------------------------------------------------------------- -- TODO these should be moved elsewhere. -getLibSourceFiles :: LocalBuildInfo +getLibSourceFiles :: Verbosity + -> LocalBuildInfo -> Library -> ComponentLocalBuildInfo -> IO [(ModuleName.ModuleName, FilePath)] -getLibSourceFiles lbi lib clbi = getSourceFiles searchpaths modules +getLibSourceFiles verbosity lbi lib clbi = getSourceFiles verbosity searchpaths modules where bi = libBuildInfo lib modules = allLibModules lib clbi @@ -762,12 +764,13 @@ getLibSourceFiles lbi lib clbi = getSourceFiles searchpaths modules [ autogenComponentModulesDir lbi clbi , autogenPackageModulesDir lbi ] -getExeSourceFiles :: LocalBuildInfo +getExeSourceFiles :: Verbosity + -> LocalBuildInfo -> Executable -> ComponentLocalBuildInfo -> IO [(ModuleName.ModuleName, FilePath)] -getExeSourceFiles lbi exe clbi = do - moduleFiles <- getSourceFiles searchpaths modules +getExeSourceFiles verbosity lbi exe clbi = do + moduleFiles <- getSourceFiles verbosity searchpaths modules srcMainPath <- findFile (hsSourceDirs bi) (modulePath exe) return ((ModuleName.main, srcMainPath) : moduleFiles) where @@ -777,11 +780,12 @@ getExeSourceFiles lbi exe clbi = do : autogenPackageModulesDir lbi : exeBuildDir lbi exe : hsSourceDirs bi -getFLibSourceFiles :: LocalBuildInfo +getFLibSourceFiles :: Verbosity + -> LocalBuildInfo -> ForeignLib -> ComponentLocalBuildInfo -> IO [(ModuleName.ModuleName, FilePath)] -getFLibSourceFiles lbi flib clbi = getSourceFiles searchpaths modules +getFLibSourceFiles verbosity lbi flib clbi = getSourceFiles verbosity searchpaths modules where bi = foreignLibBuildInfo flib modules = otherModules bi @@ -789,14 +793,14 @@ getFLibSourceFiles lbi flib clbi = getSourceFiles searchpaths modules : autogenPackageModulesDir lbi : flibBuildDir lbi flib : hsSourceDirs bi -getSourceFiles :: [FilePath] +getSourceFiles :: Verbosity -> [FilePath] -> [ModuleName.ModuleName] -> IO [(ModuleName.ModuleName, FilePath)] -getSourceFiles dirs modules = flip traverse modules $ \m -> fmap ((,) m) $ +getSourceFiles verbosity dirs modules = flip traverse modules $ \m -> fmap ((,) m) $ findFileWithExtension ["hs", "lhs", "hsig", "lhsig"] dirs (ModuleName.toFilePath m) >>= maybe (notFound m) (return . normalise) where - notFound module_ = die $ "haddock: can't find source for module " ++ display module_ + notFound module_ = die' verbosity $ "haddock: can't find source for module " ++ display module_ -- | The directory where we put build results for an executable exeBuildDir :: LocalBuildInfo -> Executable -> FilePath diff --git a/Cabal/Distribution/Simple/HaskellSuite.hs b/Cabal/Distribution/Simple/HaskellSuite.hs index 3dd567703a0710d95048d663152abcb5f6cb5e80..c5a87210becb6abc8922b78483d511b6e2febd6e 100644 --- a/Cabal/Distribution/Simple/HaskellSuite.hs +++ b/Cabal/Distribution/Simple/HaskellSuite.hs @@ -34,7 +34,7 @@ configure verbosity mbHcPath hcPkgPath progdb0 = do -- least some information from the user. hcPath <- let msg = "You have to provide name or path of a haskell-suite tool (-w PATH)" - in maybe (die msg) return mbHcPath + in maybe (die' verbosity msg) return mbHcPath when (isJust hcPkgPath) $ warn verbosity "--with-hc-pkg option is ignored for haskell-suite" @@ -98,7 +98,7 @@ getCompilerVersion verbosity prog = do name = concat $ init parts -- there shouldn't be any spaces in the name anyway versionStr = last parts version <- - maybe (die "haskell-suite: couldn't determine compiler version") return $ + maybe (die' verbosity "haskell-suite: couldn't determine compiler version") return $ simpleParse versionStr return (name, version) @@ -127,10 +127,10 @@ getInstalledPackages verbosity packagedbs progdb = do str <- getDbProgramOutput verbosity haskellSuitePkgProgram progdb ["dump", packageDbOpt packagedb] - `catchExit` \_ -> die $ "pkg dump failed" + `catchExit` \_ -> die' verbosity $ "pkg dump failed" case parsePackages str of Right ok -> return ok - _ -> die "failed to parse output of 'pkg dump'" + _ -> die' verbosity "failed to parse output of 'pkg dump'" where parsePackages str = diff --git a/Cabal/Distribution/Simple/Install.hs b/Cabal/Distribution/Simple/Install.hs index a6b783b8b632264cb4ef4d577e0a70bae79190b1..c2065b4909c5ed8eae2b462ec4b5fbe3684721a8 100644 --- a/Cabal/Distribution/Simple/Install.hs +++ b/Cabal/Distribution/Simple/Install.hs @@ -35,7 +35,7 @@ import Distribution.Simple.BuildPaths (haddockName, haddockPref) import Distribution.Simple.Utils ( createDirectoryIfMissingVerbose , installDirectoryContents, installOrdinaryFile, isInSearchPath - , die, info, noticeNoWrap, warn, matchDirFileGlob ) + , die', info, noticeNoWrap, warn, matchDirFileGlob ) import Distribution.Simple.Compiler ( CompilerFlavor(..), compilerFlavor ) import Distribution.Simple.Setup @@ -87,7 +87,7 @@ install pkg_descr lbi flags = do checkHasLibsOrExes = unless (hasLibs pkg_descr || hasForeignLibs pkg_descr || hasExes pkg_descr) $ - die "No executables and no library found. Nothing to do." + die' verbosity "No executables and no library found. Nothing to do." -- | Copy package global files. copyPackage :: Verbosity -> PackageDescription @@ -180,7 +180,7 @@ copyComponent verbosity pkg_descr lbi (CLib lib) clbi copydest = do UHC -> UHC.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr lib clbi HaskellSuite _ -> HaskellSuite.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr lib clbi - _ -> die $ "installing with " + _ -> die' verbosity $ "installing with " ++ display (compilerFlavor (compiler lbi)) ++ " is not implemented" @@ -194,7 +194,7 @@ copyComponent verbosity pkg_descr lbi (CFLib flib) clbi copydest = do case compilerFlavor (compiler lbi) of GHC -> GHC.installFLib verbosity lbi flibPref buildPref pkg_descr flib - _ -> die $ "installing foreign lib with " + _ -> die' verbosity $ "installing foreign lib with " ++ display (compilerFlavor (compiler lbi)) ++ " is not implemented" @@ -220,7 +220,7 @@ copyComponent verbosity pkg_descr lbi (CExe exe) clbi copydest = do JHC -> JHC.installExe verbosity binPref buildPref (progPrefixPref, progSuffixPref) pkg_descr exe UHC -> return () HaskellSuite {} -> return () - _ -> die $ "installing with " + _ -> die' verbosity $ "installing with " ++ display (compilerFlavor (compiler lbi)) ++ " is not implemented" @@ -256,7 +256,7 @@ installIncludeFiles verbosity lib destIncludeDir = do destDir = takeDirectory destFile ] where - findInc [] file = die ("can't find include file " ++ file) + findInc [] file = die' verbosity ("can't find include file " ++ file) findInc (dir:dirs) file = do let path = dir </> file exists <- doesFileExist path diff --git a/Cabal/Distribution/Simple/LHC.hs b/Cabal/Distribution/Simple/LHC.hs index ef78311cd62b299cc9e18cfd77d84a7d351e8cc9..c328979fd46ef2059c4d8962e0a0235e5fe9e5c2 100644 --- a/Cabal/Distribution/Simple/LHC.hs +++ b/Cabal/Distribution/Simple/LHC.hs @@ -92,7 +92,7 @@ configure verbosity hcPath hcPkgPath progdb = do (orLaterVersion (mkVersion [0,7])) (userMaybeSpecifyPath "lhc-pkg" hcPkgPath progdb') - when (lhcVersion /= lhcPkgVersion) $ die $ + when (lhcVersion /= lhcPkgVersion) $ die' verbosity $ "Version mismatch between lhc and lhc-pkg: " ++ programPath lhcProg ++ " is version " ++ display lhcVersion ++ " " ++ programPath lhcPkgProg ++ " is version " ++ display lhcPkgVersion @@ -200,7 +200,7 @@ getExtensions verbosity lhcProg = do getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramDb -> IO InstalledPackageIndex getInstalledPackages verbosity packagedbs progdb = do - checkPackageDbStack packagedbs + checkPackageDbStack verbosity packagedbs pkgss <- getInstalledPackages' lhcPkg verbosity packagedbs progdb let indexes = [ PackageIndex.fromList (map (substTopDir topDir) pkgs) | (_, pkgs) <- pkgss ] @@ -215,11 +215,12 @@ getInstalledPackages verbosity packagedbs progdb = do compilerDir = takeDirectory (programPath ghcProg) topDir = takeDirectory compilerDir -checkPackageDbStack :: PackageDBStack -> IO () -checkPackageDbStack (GlobalPackageDB:rest) +checkPackageDbStack :: Verbosity -> PackageDBStack -> IO () +checkPackageDbStack _ (GlobalPackageDB:rest) | GlobalPackageDB `notElem` rest = return () -checkPackageDbStack _ = - die $ "GHC.getInstalledPackages: the global package db must be " +checkPackageDbStack verbosity _ = + die' verbosity $ + "GHC.getInstalledPackages: the global package db must be " ++ "specified first and cannot be specified multiple times" -- | Get the packages from specific PackageDBs, not cumulative. @@ -232,10 +233,10 @@ getInstalledPackages' lhcPkg verbosity packagedbs progdb sequenceA [ do str <- getDbProgramOutput verbosity lhcPkgProgram progdb ["dump", packageDbGhcPkgFlag packagedb] - `catchExit` \_ -> die $ "ghc-pkg dump failed" + `catchExit` \_ -> die' verbosity $ "ghc-pkg dump failed" case parsePackages str of Left ok -> return (packagedb, ok) - _ -> die "failed to parse output of 'ghc-pkg dump'" + _ -> die' verbosity "failed to parse output of 'ghc-pkg dump'" | packagedb <- packagedbs ] where diff --git a/Cabal/Distribution/Simple/PreProcess.hs b/Cabal/Distribution/Simple/PreProcess.hs index 34e1f1d8d3514202da1b74c571858dcfaba38f5d..6835cf55f374dc7ed610ed5c7b68358d4f409d23 100644 --- a/Cabal/Distribution/Simple/PreProcess.hs +++ b/Cabal/Distribution/Simple/PreProcess.hs @@ -188,15 +188,17 @@ preprocessComponent pd comp lbi clbi isSrcDist verbosity handlers = do </> stubName test ++ "-tmp" writeSimpleTestStub test testDir preProcessTest test (stubFilePath test) testDir - TestSuiteUnsupported tt -> die $ "No support for preprocessing test " - ++ "suite type " ++ display tt + TestSuiteUnsupported tt -> + die' verbosity $ "No support for preprocessing test " + ++ "suite type " ++ display tt CBench bm@Benchmark{ benchmarkName = nm } -> do let nm' = unUnqualComponentName nm case benchmarkInterface bm of BenchmarkExeV10 _ f -> preProcessBench bm f $ buildDir lbi </> nm' </> nm' ++ "-tmp" - BenchmarkUnsupported tt -> die $ "No support for preprocessing benchmark " - ++ "type " ++ display tt + BenchmarkUnsupported tt -> + die' verbosity $ "No support for preprocessing benchmark " + ++ "type " ++ display tt where builtinHaskellSuffixes = ["hs", "lhs", "hsig", "lhsig"] builtinCSuffixes = cSourceExtensions @@ -250,8 +252,9 @@ preprocessFile searchLoc buildLoc forSDist baseFile verbosity builtinSuffixes ha Nothing -> do bsrcFiles <- findFileWithExtension builtinSuffixes (buildLoc : searchLoc) baseFile case bsrcFiles of - Nothing -> die $ "can't find source for " ++ baseFile - ++ " in " ++ intercalate ", " searchLoc + Nothing -> + die' verbosity $ "can't find source for " ++ baseFile + ++ " in " ++ intercalate ", " searchLoc _ -> return () -- found a pre-processable file in one of the source dirs Just (psrcLoc, psrcRelFile) -> do @@ -329,9 +332,9 @@ ppUnlit :: PreProcessor ppUnlit = PreProcessor { platformIndependent = True, - runPreProcessor = mkSimplePreProcessor $ \inFile outFile _verbosity -> + runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> withUTF8FileContents inFile $ \contents -> - either (writeUTF8File outFile) die (unlit inFile contents) + either (writeUTF8File outFile) (die' verbosity) (unlit inFile contents) } ppCpp :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor @@ -653,10 +656,11 @@ knownExtrasHandlers = [ ppC2hsExtras, ppHsc2hsExtras ] -- | Find any extra C sources generated by preprocessing that need to -- be added to the component (addresses issue #238). -preprocessExtras :: Component +preprocessExtras :: Verbosity + -> Component -> LocalBuildInfo -> IO [FilePath] -preprocessExtras comp lbi = case comp of +preprocessExtras verbosity comp lbi = case comp of CLib _ -> pp $ buildDir lbi (CExe Executable { exeName = nm }) -> do let nm' = unUnqualComponentName nm @@ -671,15 +675,16 @@ preprocessExtras comp lbi = case comp of pp $ buildDir lbi </> nm' </> nm' ++ "-tmp" TestSuiteLibV09 _ _ -> pp $ buildDir lbi </> stubName test </> stubName test ++ "-tmp" - TestSuiteUnsupported tt -> die $ "No support for preprocessing test " + TestSuiteUnsupported tt -> die' verbosity $ "No support for preprocessing test " ++ "suite type " ++ display tt CBench bm -> do let nm' = unUnqualComponentName $ benchmarkName bm case benchmarkInterface bm of BenchmarkExeV10 _ _ -> pp $ buildDir lbi </> nm' </> nm' ++ "-tmp" - BenchmarkUnsupported tt -> die $ "No support for preprocessing benchmark " - ++ "type " ++ display tt + BenchmarkUnsupported tt -> + die' verbosity $ "No support for preprocessing benchmark " + ++ "type " ++ display tt where pp :: FilePath -> IO [FilePath] pp dir = (map (dir </>) . filter not_sub . concat) diff --git a/Cabal/Distribution/Simple/Program.hs b/Cabal/Distribution/Simple/Program.hs index aafa4aa9f03623388d3fcdee3ca9bc848403a5f9..ce10570e130dcabfc7a9f7207215b5194dbca294 100644 --- a/Cabal/Distribution/Simple/Program.hs +++ b/Cabal/Distribution/Simple/Program.hs @@ -173,7 +173,7 @@ runDbProgram :: Verbosity -- ^verbosity -> IO () runDbProgram verbosity prog programDb args = case lookupProgram prog programDb of - Nothing -> die notFound + Nothing -> die' verbosity notFound Just configuredProg -> runProgram verbosity configuredProg args where notFound = "The program '" ++ programName prog @@ -188,7 +188,7 @@ getDbProgramOutput :: Verbosity -- ^verbosity -> IO String getDbProgramOutput verbosity prog programDb args = case lookupProgram prog programDb of - Nothing -> die notFound + Nothing -> die' verbosity notFound Just configuredProg -> getProgramOutput verbosity configuredProg args where notFound = "The program '" ++ programName prog diff --git a/Cabal/Distribution/Simple/Program/Ar.hs b/Cabal/Distribution/Simple/Program/Ar.hs index 11650dc2fae13493fccde34c0360796c179bd3a5..b9399d886a2db7c8a05203ceb861c742c09f6080 100644 --- a/Cabal/Distribution/Simple/Program/Ar.hs +++ b/Cabal/Distribution/Simple/Program/Ar.hs @@ -31,7 +31,7 @@ import Distribution.Simple.Program.Run ( programInvocation, multiStageProgramInvocation , runProgramInvocation ) import Distribution.Simple.Utils - ( dieWithLocation, withTempDirectory ) + ( dieWithLocation', withTempDirectory ) import Distribution.System ( Arch(..), OS(..), Platform(..) ) import Distribution.Verbosity @@ -90,7 +90,7 @@ createArLibArchive verbosity lbi targetPath files = do unless (hostArch == Arm -- See #1537 || hostOS == AIX) $ -- AIX uses its own "ar" format variant - wipeMetadata tmpPath + wipeMetadata verbosity tmpPath equal <- filesEqual tmpPath targetPath unless equal $ renameFile tmpPath targetPath @@ -107,15 +107,15 @@ createArLibArchive verbosity lbi targetPath files = do -- (@-D@) flag that always writes zero for the mtime, UID and GID, and 0644 -- for the file mode. However detecting whether @-D@ is supported seems -- rather harder than just re-implementing this feature. -wipeMetadata :: FilePath -> IO () -wipeMetadata path = do +wipeMetadata :: Verbosity -> FilePath -> IO () +wipeMetadata verbosity path = do -- Check for existence first (ReadWriteMode would create one otherwise) exists <- doesFileExist path unless exists $ wipeError "Temporary file disappeared" withBinaryFile path ReadWriteMode $ \ h -> hFileSize h >>= wipeArchive h where - wipeError msg = dieWithLocation path Nothing $ + wipeError msg = dieWithLocation' verbosity path Nothing $ "Distribution.Simple.Program.Ar.wipeMetadata: " ++ msg archLF = "!<arch>\x0a" -- global magic, 8 bytes x60LF = "\x60\x0a" -- header magic, 2 bytes diff --git a/Cabal/Distribution/Simple/Program/Db.hs b/Cabal/Distribution/Simple/Program/Db.hs index 18c35ce9b0956e8df46f0cea3af69993023a9bcc..4aba5e8ae8a6eea986bcb5950afa8660fb102ad1 100644 --- a/Cabal/Distribution/Simple/Program/Db.hs +++ b/Cabal/Distribution/Simple/Program/Db.hs @@ -331,7 +331,7 @@ configureProgram verbosity prog progdb = do if absolute then return (Just (UserSpecified path, [])) else findProgramOnSearchPath verbosity (progSearchPath progdb) path - >>= maybe (die notFound) + >>= maybe (die' verbosity notFound) (return . Just . swap . fmap UserSpecified . swap) where notFound = "Cannot find the program '" ++ name ++ "'. User-specified path '" @@ -420,7 +420,7 @@ requireProgram verbosity prog progdb = do Just _ -> return progdb case lookupProgram prog progdb' of - Nothing -> die notFound + Nothing -> die' verbosity notFound Just configuredProg -> return (configuredProg, progdb') where notFound = "The program '" ++ programName prog @@ -481,5 +481,5 @@ requireProgramVersion :: Verbosity -> Program -> VersionRange -> ProgramDb -> IO (ConfiguredProgram, Version, ProgramDb) requireProgramVersion verbosity prog range programDb = - join $ either die return `fmap` + join $ either (die' verbosity) return `fmap` lookupProgramVersion verbosity prog range programDb diff --git a/Cabal/Distribution/Simple/Program/HcPkg.hs b/Cabal/Distribution/Simple/Program/HcPkg.hs index c84a60d78d10e8ac85ba7c8edb27f379fab8d439..729d9a327e94fafd200704cb76061051d078a1a1 100644 --- a/Cabal/Distribution/Simple/Program/HcPkg.hs +++ b/Cabal/Distribution/Simple/Program/HcPkg.hs @@ -149,29 +149,30 @@ registerMultiInstance hpi verbosity packagedbs pkgInfo -- | recacheMultiInstance hpi = do let pkgdb = last packagedbs - writeRegistrationFileDirectly hpi pkgdb pkgInfo + writeRegistrationFileDirectly verbosity hpi pkgdb pkgInfo recache hpi verbosity pkgdb | otherwise - = die $ "HcPkg.registerMultiInstance: the compiler does not support " + = die' verbosity $ "HcPkg.registerMultiInstance: the compiler does not support " ++ "registering multiple instances of packages." -writeRegistrationFileDirectly :: HcPkgInfo +writeRegistrationFileDirectly :: Verbosity + -> HcPkgInfo -> PackageDB -> InstalledPackageInfo -> IO () -writeRegistrationFileDirectly hpi (SpecificPackageDB dir) pkgInfo +writeRegistrationFileDirectly verbosity hpi (SpecificPackageDB dir) pkgInfo | supportsDirDbs hpi = do let pkgfile = dir </> display (installedUnitId pkgInfo) <.> "conf" writeUTF8File pkgfile (showInstalledPackageInfo pkgInfo) | otherwise - = die $ "HcPkg.writeRegistrationFileDirectly: compiler does not support dir style package dbs" + = die' verbosity $ "HcPkg.writeRegistrationFileDirectly: compiler does not support dir style package dbs" -writeRegistrationFileDirectly _ _ _ = +writeRegistrationFileDirectly verbosity _ _ _ = -- We don't know here what the dir for the global or user dbs are, -- if that's needed it'll require a bit more plumbing to support. - die $ "HcPkg.writeRegistrationFileDirectly: only supports SpecificPackageDB for now" + die' verbosity $ "HcPkg.writeRegistrationFileDirectly: only supports SpecificPackageDB for now" -- | Call @hc-pkg@ to unregister a package @@ -216,7 +217,7 @@ describe hpi verbosity packagedb pid = do case parsePackages output of Left ok -> return ok - _ -> die $ "failed to parse output of '" + _ -> die' verbosity $ "failed to parse output of '" ++ programId (hcPkgProgram hpi) ++ " describe " ++ display pid ++ "'" -- | Call @hc-pkg@ to hide a package. @@ -237,12 +238,12 @@ dump hpi verbosity packagedb = do output <- getProgramInvocationOutput verbosity (dumpInvocation hpi verbosity packagedb) - `catchIO` \e -> die $ programId (hcPkgProgram hpi) ++ " dump failed: " + `catchIO` \e -> die' verbosity $ programId (hcPkgProgram hpi) ++ " dump failed: " ++ displayException e case parsePackages output of Left ok -> return ok - _ -> die $ "failed to parse output of '" + _ -> die' verbosity $ "failed to parse output of '" ++ programId (hcPkgProgram hpi) ++ " dump'" parsePackages :: String -> Either [InstalledPackageInfo] [PError] @@ -338,11 +339,11 @@ list hpi verbosity packagedb = do output <- getProgramInvocationOutput verbosity (listInvocation hpi verbosity packagedb) - `catchIO` \_ -> die $ programId (hcPkgProgram hpi) ++ " list failed" + `catchIO` \_ -> die' verbosity $ programId (hcPkgProgram hpi) ++ " list failed" case parsePackageIds output of Just ok -> return ok - _ -> die $ "failed to parse output of '" + _ -> die' verbosity $ "failed to parse output of '" ++ programId (hcPkgProgram hpi) ++ " list'" where diff --git a/Cabal/Distribution/Simple/Program/Run.hs b/Cabal/Distribution/Simple/Program/Run.hs index 44b7f2b33c3bf21e51912b9b991bfe83fd21702a..77b8d79282abec8c21a73904807697e2d9cebdc8 100644 --- a/Cabal/Distribution/Simple/Program/Run.hs +++ b/Cabal/Distribution/Simple/Program/Run.hs @@ -139,7 +139,7 @@ runProgramInvocation verbosity mcwd menv (Just input) True when (exitCode /= ExitSuccess) $ - die $ "'" ++ path ++ "' exited with an error:\n" ++ errors + die' verbosity $ "'" ++ path ++ "' exited with an error:\n" ++ errors where input = case encoding of IOEncodingText -> (inputStr, False) @@ -168,7 +168,7 @@ getProgramInvocationOutput verbosity mcwd menv input utf8 when (exitCode /= ExitSuccess) $ - die $ "'" ++ path ++ "' exited with an error:\n" ++ errors + die' verbosity $ "'" ++ path ++ "' exited with an error:\n" ++ errors return (decode output) where input = diff --git a/Cabal/Distribution/Simple/Register.hs b/Cabal/Distribution/Simple/Register.hs index bb89424f8780decd0535019f44b0b81c413ac138..136618adac1c993f588397a97a003d11256eeffd 100644 --- a/Cabal/Distribution/Simple/Register.hs +++ b/Cabal/Distribution/Simple/Register.hs @@ -205,7 +205,7 @@ registerAll pkg lbi regFlags ipis case compilerFlavor (compiler lbi) of JHC -> notice verbosity "Registration scripts not needed for jhc" UHC -> notice verbosity "Registration scripts not needed for uhc" - _ -> withHcPkg + _ -> withHcPkg verbosity "Registration scripts are not implemented for this compiler" (compiler lbi) (withPrograms lbi) (writeHcPkgRegisterScript verbosity ipis packageDbs) @@ -278,7 +278,8 @@ relocRegistrationInfo verbosity pkg lib lbi clbi abi_hash packageDb = GHC -> do fs <- GHC.pkgRoot verbosity lbi packageDb return (relocatableInstalledPackageInfo pkg abi_hash lib lbi clbi fs) - _ -> die "Distribution.Simple.Register.relocRegistrationInfo: \ + _ -> die' verbosity + "Distribution.Simple.Register.relocRegistrationInfo: \ \not implemented for this compiler" initPackageDB :: Verbosity -> Compiler -> ProgramDb -> FilePath -> IO () @@ -295,7 +296,8 @@ createPackageDB verbosity comp progdb preferCompat dbPath = LHC -> HcPkg.init (LHC.hcPkgInfo progdb) verbosity False dbPath UHC -> return () HaskellSuite _ -> HaskellSuite.initPackageDB verbosity progdb dbPath - _ -> die $ "Distribution.Simple.Register.createPackageDB: " + _ -> die' verbosity $ + "Distribution.Simple.Register.createPackageDB: " ++ "not implemented for this compiler" doesPackageDBExist :: FilePath -> NoCallStackIO Bool @@ -320,17 +322,17 @@ deletePackageDB dbPath = do invokeHcPkg :: Verbosity -> Compiler -> ProgramDb -> PackageDBStack -> [String] -> IO () invokeHcPkg verbosity comp progdb dbStack extraArgs = - withHcPkg "invokeHcPkg" comp progdb + withHcPkg verbosity "invokeHcPkg" comp progdb (\hpi -> HcPkg.invoke hpi verbosity dbStack extraArgs) -withHcPkg :: String -> Compiler -> ProgramDb +withHcPkg :: Verbosity -> String -> Compiler -> ProgramDb -> (HcPkg.HcPkgInfo -> IO a) -> IO a -withHcPkg name comp progdb f = +withHcPkg verbosity name comp progdb f = case compilerFlavor comp of GHC -> f (GHC.hcPkgInfo progdb) GHCJS -> f (GHCJS.hcPkgInfo progdb) LHC -> f (LHC.hcPkgInfo progdb) - _ -> die ("Distribution.Simple.Register." ++ name ++ ":\ + _ -> die' verbosity ("Distribution.Simple.Register." ++ name ++ ":\ \not implemented for this compiler") registerPackage :: Verbosity @@ -345,13 +347,13 @@ registerPackage verbosity comp progdb multiInstance packageDbs installedPkgInfo GHC -> GHC.registerPackage verbosity progdb multiInstance packageDbs installedPkgInfo GHCJS -> GHCJS.registerPackage verbosity progdb multiInstance packageDbs installedPkgInfo _ | HcPkg.MultiInstance == multiInstance - -> die "Registering multiple package instances is not yet supported for this compiler" + -> die' verbosity "Registering multiple package instances is not yet supported for this compiler" LHC -> LHC.registerPackage verbosity progdb packageDbs installedPkgInfo UHC -> UHC.registerPackage verbosity comp progdb packageDbs installedPkgInfo JHC -> notice verbosity "Registering for jhc (nothing to do)" HaskellSuite {} -> HaskellSuite.registerPackage verbosity progdb packageDbs installedPkgInfo - _ -> die "Registering is not implemented for this compiler" + _ -> die' verbosity "Registering is not implemented for this compiler" writeHcPkgRegisterScript :: Verbosity -> [InstalledPackageInfo] @@ -573,7 +575,7 @@ unregister pkg lbi regFlags = do (BS.Char8.pack $ invocationAsSystemScript buildOS invocation) else runProgramInvocation verbosity invocation setupMessage verbosity "Unregistering" pkgid - withHcPkg "unregistering is only implemented for GHC and GHCJS" + withHcPkg verbosity "unregistering is only implemented for GHC and GHCJS" (compiler lbi) (withPrograms lbi) unreg unregScriptFileName :: FilePath diff --git a/Cabal/Distribution/Simple/SrcDist.hs b/Cabal/Distribution/Simple/SrcDist.hs index c32bb4cb7555ea588b036a79e755d02e8798ac5d..90a6323cb68f576065e087e0202eaa0f2e0b4b8d 100644 --- a/Cabal/Distribution/Simple/SrcDist.hs +++ b/Cabal/Distribution/Simple/SrcDist.hs @@ -163,19 +163,19 @@ listPackageSourcesOrdinary verbosity pkg_descr pps = signatures = sigs, libBuildInfo = libBi } -> - allSourcesBuildInfo libBi pps (modules ++ sigs) + allSourcesBuildInfo verbosity libBi pps (modules ++ sigs) -- Executables sources. , fmap concat . withAllExe $ \Executable { modulePath = mainPath, buildInfo = exeBi } -> do - biSrcs <- allSourcesBuildInfo exeBi pps [] + biSrcs <- allSourcesBuildInfo verbosity exeBi pps [] mainSrc <- findMainExeFile exeBi pps mainPath return (mainSrc:biSrcs) -- Foreign library sources , fmap concat . withAllFLib $ \flib@(ForeignLib { foreignLibBuildInfo = flibBi }) -> do - biSrcs <- allSourcesBuildInfo flibBi pps [] + biSrcs <- allSourcesBuildInfo verbosity flibBi pps [] defFiles <- mapM (findModDefFile flibBi pps) (foreignLibModDefFile flib) return (defFiles ++ biSrcs) @@ -185,12 +185,12 @@ listPackageSourcesOrdinary verbosity pkg_descr pps = let bi = testBuildInfo t case testInterface t of TestSuiteExeV10 _ mainPath -> do - biSrcs <- allSourcesBuildInfo bi pps [] + biSrcs <- allSourcesBuildInfo verbosity bi pps [] srcMainFile <- findMainExeFile bi pps mainPath return (srcMainFile:biSrcs) TestSuiteLibV09 _ m -> - allSourcesBuildInfo bi pps [m] - TestSuiteUnsupported tp -> die $ "Unsupported test suite type: " + allSourcesBuildInfo verbosity bi pps [m] + TestSuiteUnsupported tp -> die' verbosity $ "Unsupported test suite type: " ++ show tp -- Benchmarks sources. @@ -199,10 +199,10 @@ listPackageSourcesOrdinary verbosity pkg_descr pps = let bi = benchmarkBuildInfo bm case benchmarkInterface bm of BenchmarkExeV10 _ mainPath -> do - biSrcs <- allSourcesBuildInfo bi pps [] + biSrcs <- allSourcesBuildInfo verbosity bi pps [] srcMainFile <- findMainExeFile bi pps mainPath return (srcMainFile:biSrcs) - BenchmarkUnsupported tp -> die $ "Unsupported benchmark type: " + BenchmarkUnsupported tp -> die' verbosity $ "Unsupported benchmark type: " ++ show tp -- Data files. @@ -223,7 +223,7 @@ listPackageSourcesOrdinary verbosity pkg_descr pps = . withAllLib $ \ l -> do let lbi = libBuildInfo l relincdirs = "." : filter isRelative (includeDirs lbi) - traverse (fmap snd . findIncludeFile relincdirs) (installIncludes lbi) + traverse (fmap snd . findIncludeFile verbosity relincdirs) (installIncludes lbi) -- Setup script, if it exists. , fmap (maybe [] (\f -> [f])) $ findSetupFile "" @@ -311,12 +311,12 @@ findModDefFile flibBi _pps modDefPath = -- | Given a list of include paths, try to find the include file named -- @f@. Return the name of the file and the full path, or exit with error if -- there's no such file. -findIncludeFile :: [FilePath] -> String -> IO (String, FilePath) -findIncludeFile [] f = die ("can't find include file " ++ f) -findIncludeFile (d:ds) f = do +findIncludeFile :: Verbosity -> [FilePath] -> String -> IO (String, FilePath) +findIncludeFile verbosity [] f = die' verbosity ("can't find include file " ++ f) +findIncludeFile verbosity (d:ds) f = do let path = (d </> f) b <- doesFileExist path - if b then return (f,path) else findIncludeFile ds f + if b then return (f,path) else findIncludeFile verbosity ds f -- | Remove the auto-generated modules (like 'Paths_*') from 'exposed-modules' -- and 'other-modules'. @@ -426,11 +426,12 @@ createArchive verbosity pkg_descr mb_lbi tmpDir targetPref = do return tarBallFilePath -- | Given a buildinfo, return the names of all source files. -allSourcesBuildInfo :: BuildInfo +allSourcesBuildInfo :: Verbosity + -> BuildInfo -> [PPSuffixHandler] -- ^ Extra preprocessors -> [ModuleName] -- ^ Exposed modules -> IO [FilePath] -allSourcesBuildInfo bi pps modules = do +allSourcesBuildInfo verbosity bi pps modules = do let searchDirs = hsSourceDirs bi sources <- fmap concat $ sequenceA $ [ let file = ModuleName.toFilePath module_ @@ -452,7 +453,7 @@ allSourcesBuildInfo bi pps modules = do nonEmpty x _ [] = x nonEmpty _ f xs = f xs suffixes = ppSuffixes pps ++ ["hs", "lhs", "hsig", "lhsig"] - notFound m = die $ "Error: Could not find module: " ++ display m + notFound m = die' verbosity $ "Error: Could not find module: " ++ display m ++ " with any suffix: " ++ show suffixes ++ ". If the module " ++ "is autogenerated it should be added to 'autogen-modules'." diff --git a/Cabal/Distribution/Simple/Test.hs b/Cabal/Distribution/Simple/Test.hs index 8706aa782be8687db8f9dd4c1faf5c67e711b5f7..dc2b06a3ed6e9db3dc5776b9cdb1176f318ff5d2 100644 --- a/Cabal/Distribution/Simple/Test.hs +++ b/Cabal/Distribution/Simple/Test.hs @@ -85,8 +85,9 @@ test args pkg_descr lbi flags = do exitWith ExitSuccess when (PD.hasTests pkg_descr && null enabledTests) $ - die $ "No test suites enabled. Did you remember to configure with " - ++ "\'--enable-tests\'?" + die' verbosity $ + "No test suites enabled. Did you remember to configure with " + ++ "\'--enable-tests\'?" testsToRun <- case testNames of [] -> return $ zip enabledTests $ repeat Nothing @@ -98,9 +99,9 @@ test args pkg_descr lbi flags = do in case lookup tCompName testMap of Just t -> return (t, Nothing) _ | tCompName `elem` allNames -> - die $ "Package configured with test suite " + die' verbosity $ "Package configured with test suite " ++ tName ++ " disabled." - | otherwise -> die $ "no such test: " ++ tName + | otherwise -> die' verbosity $ "no such test: " ++ tName createDirectoryIfMissing True testLogDir diff --git a/Cabal/Distribution/Simple/Test/ExeV10.hs b/Cabal/Distribution/Simple/Test/ExeV10.hs index 96771281b4812317098f5c520a5ae2a59a44f7c6..a969f3eefdca03cf4b5767dbc11709667f500f24 100644 --- a/Cabal/Distribution/Simple/Test/ExeV10.hs +++ b/Cabal/Distribution/Simple/Test/ExeV10.hs @@ -53,7 +53,7 @@ runTest pkg_descr lbi clbi flags suite = do </> testName' <.> exeExtension -- Check that the test executable exists. exists <- doesFileExist cmd - unless exists $ die $ "Error: Could not find test program \"" ++ cmd + unless exists $ die' verbosity $ "Error: Could not find test program \"" ++ cmd ++ "\". Did you build the package first?" -- Remove old .tix files if appropriate. diff --git a/Cabal/Distribution/Simple/Test/LibV09.hs b/Cabal/Distribution/Simple/Test/LibV09.hs index a191ea370af404fccc99c9bfc23e145ca4562df6..51eb3312ea38b1b3fe584a3865f088f47a27e323 100644 --- a/Cabal/Distribution/Simple/Test/LibV09.hs +++ b/Cabal/Distribution/Simple/Test/LibV09.hs @@ -60,8 +60,9 @@ runTest pkg_descr lbi clbi flags suite = do </> stubName suite <.> exeExtension -- Check that the test executable exists. exists <- doesFileExist cmd - unless exists $ die $ "Error: Could not find test program \"" ++ cmd - ++ "\". Did you build the package first?" + unless exists $ + die' verbosity $ "Error: Could not find test program \"" ++ cmd + ++ "\". Did you build the package first?" -- Remove old .tix files if appropriate. unless (fromFlag $ testKeepTix flags) $ do diff --git a/Cabal/Distribution/Simple/Utils.hs b/Cabal/Distribution/Simple/Utils.hs index 5e4f5a3a0b0aa3b5c5e4e92d80ecda1de8f4cd51..973cbabb275393b26851fb8c323879f797c077c7 100644 --- a/Cabal/Distribution/Simple/Utils.hs +++ b/Cabal/Distribution/Simple/Utils.hs @@ -25,9 +25,12 @@ module Distribution.Simple.Utils ( cabalVersion, -- * logging and errors - die, - dieWithLocation, - dieMsg, dieMsgNoWrap, + -- Old style + die, dieWithLocation, + -- New style + dieNoVerbosity, + die', dieWithLocation', + dieNoWrap, topHandler, topHandlerWith, warn, notice, noticeNoWrap, noticeDoc, @@ -213,12 +216,8 @@ import System.Directory ( createDirectory, removeDirectoryRecursive ) import System.IO ( Handle, hSetBinaryMode, hGetContents, stderr, stdout, hPutStr, hFlush - , hClose, hPutStrLn ) -import System.IO.Error as IO.Error - ( isDoesNotExistError, isAlreadyExistsError - , ioeSetFileName, ioeGetFileName, ioeGetErrorString ) + , hClose ) import System.IO.Error - ( ioeSetLocation, ioeGetLocation ) import System.IO.Unsafe ( unsafeInterleaveIO ) import qualified Control.Exception as Exception @@ -246,6 +245,57 @@ cabalVersion = mkVersion [1,9999] --used when bootstrapping -- ---------------------------------------------------------------------------- -- Exception and logging utils +-- Cabal's logging infrastructure has a few constraints: +-- +-- * We must make all logging formatting and emissions decisions based +-- on the 'Verbosity' parameter, which is the only parameter that is +-- plumbed to enough call-sites to actually be used for this matter. +-- (One of Cabal's "big mistakes" is to have never have defined a +-- monad of its own.) +-- +-- * When we 'die', we must raise an IOError. This a backwards +-- compatibility consideration, because that's what we've raised +-- previously, and if we change to any other exception type, +-- exception handlers which match on IOError will no longer work. +-- One case where it is known we rely on IOError being catchable +-- is 'readPkgConfigDb' in cabal-install; there may be other +-- user code that also assumes this. +-- +-- * The 'topHandler' does not know what 'Verbosity' is, because +-- it gets called before we've done command line parsing (where +-- the 'Verbosity' parameter would come from). +-- +-- This leads to two big architectural choices: +-- +-- * Although naively we might imagine 'Verbosity' to be a simple +-- enumeration type, actually it is a full-on abstract data type +-- that may contain arbitrarily complex information. At the +-- moment, it is fully representable as a string, but we might +-- eventually also use verbosity to let users register their +-- own logging handler. +-- +-- * When we call 'die', we perform all the formatting and addition +-- of extra information we need, and then ship this in the IOError +-- to the top-level handler. Here are alternate designs that +-- don't work: +-- +-- a) Ship the unformatted info to the handler. This doesn't +-- work because at the point the handler gets the message, +-- we've lost call stacks, and even if we did, we don't have access +-- to 'Verbosity' to decide whether or not to render it. +-- +-- b) Print the information at the 'die' site, then raise an +-- error. This means that if the exception is subsequently +-- caught by a handler, we will still have emitted the output, +-- which is not the correct behavior. +-- +-- For the top-level handler to "know" that an error message +-- contains one of these fully formatted packets, we set a sentinel +-- in one of IOError's extra fields. This is handled by +-- 'ioeSetVerbatim' and 'ioeGetVerbatim'. +-- + +{-# DEPRECATED dieWithLocation "Messages thrown with dieWithLocation can't be controlled with Verbosity; use dieWithLocation' instead" #-} dieWithLocation :: FilePath -> Maybe Int -> String -> IO a dieWithLocation filename lineno msg = ioError . setLocation lineno @@ -256,11 +306,56 @@ dieWithLocation filename lineno msg = setLocation (Just n) err = ioeSetLocation err (show n) _ = callStack -- TODO: Attach CallStack to exception +{-# DEPRECATED die "Messages thrown with die can't be controlled with Verbosity; use die' instead, or dieNoVerbosity if Verbosity truly is not available" #-} die :: String -> IO a -die msg = ioError (userError msg) +die = dieNoVerbosity + +dieNoVerbosity :: String -> IO a +dieNoVerbosity msg + = ioError (userError msg) where _ = callStack -- TODO: Attach CallStack to exception +-- | Tag an 'IOError' whose error string should be output to the screen +-- verbatim. +ioeSetVerbatim :: IOError -> IOError +ioeSetVerbatim e = ioeSetLocation e "dieVerbatim" + +-- | Check if an 'IOError' should be output verbatim to screen. +ioeGetVerbatim :: IOError -> Bool +ioeGetVerbatim e = ioeGetLocation e == "dieVerbatim" + +-- | Create a 'userError' whose error text will be output verbatim +verbatimUserError :: String -> IOError +verbatimUserError = ioeSetVerbatim . userError + +dieWithLocation' :: Verbosity -> FilePath -> Maybe Int -> String -> IO a +dieWithLocation' verbosity filename mb_lineno msg = withFrozenCallStack $ do + pname <- getProgName + ioError . verbatimUserError + . withMetadata True verbosity + . wrapTextVerbosity verbosity + $ pname ++ ": " ++ + filename ++ (case mb_lineno of + Just lineno -> ":" ++ show lineno + Nothing -> "") ++ + ": " ++ msg + +die' :: Verbosity -> String -> IO a +die' verbosity msg = withFrozenCallStack $ do + pname <- getProgName + ioError . verbatimUserError + . withMetadata True verbosity + . wrapTextVerbosity verbosity + $ pname ++ ": " ++ msg + +dieNoWrap :: Verbosity -> String -> IO a +dieNoWrap verbosity msg = withFrozenCallStack $ do + -- TODO: should this have program name or not? + ioError . verbatimUserError + . withMetadata True verbosity + $ msg + topHandlerWith :: forall a. (Exception.SomeException -> IO a) -> IO a -> IO a topHandlerWith cont prog = Exception.catches prog [ @@ -282,13 +377,17 @@ topHandlerWith cont prog = handle se = do hFlush stdout pname <- getProgName - hPutStr stderr (wrapText (message pname se)) + hPutStr stderr (message pname se) cont se message :: String -> Exception.SomeException -> String message pname (Exception.SomeException se) = case cast se :: Maybe Exception.IOException of - Just ioe -> + Just ioe + | ioeGetVerbatim ioe -> + -- Use the message verbatim + ioeGetErrorString ioe + | isUserError ioe -> let file = case ioeGetFileName ioe of Nothing -> "" Just path -> path ++ location ++ ": " @@ -296,48 +395,19 @@ topHandlerWith cont prog = l@(n:_) | isDigit n -> ':' : l _ -> "" detail = ioeGetErrorString ioe - in pname ++ ": " ++ file ++ detail - Nothing -> + in wrapText (pname ++ ": " ++ file ++ detail) + _ -> + -- Why not use the default handler? Because we want + -- to wrap the error message output. #if __GLASGOW_HASKELL__ < 710 - show se + wrapText (show se) #else - Exception.displayException se + wrapText (Exception.displayException se) #endif topHandler :: IO a -> IO a topHandler prog = topHandlerWith (const $ exitWith (ExitFailure 1)) prog --- | Print out a call site/stack according to 'Verbosity'. -hPutCallStackPrefix :: Handle -> Verbosity -> IO () -hPutCallStackPrefix h verbosity = withFrozenCallStack $ do - when (isVerboseCallSite verbosity) $ - hPutStr h parentSrcLocPrefix - when (isVerboseCallStack verbosity) $ - hPutStr h ("----\n" ++ prettyCallStack callStack ++ "\n") - --- | This can be used to help produce formatted messages as part of a fatal --- error condition, prior to using 'die' or 'exitFailure'. --- --- For fatal conditions we normally simply use 'die' which throws an --- exception. Sometimes however 'die' is not sufficiently flexible to --- produce the desired output. --- --- Like 'die', these messages are always displayed on @stderr@, irrespective --- of the 'Verbosity' level. The 'Verbosity' parameter is needed though to --- decide how to format the output (e.g. line-wrapping). --- -dieMsg :: Verbosity -> String -> NoCallStackIO () -dieMsg verbosity msg = do - hFlush stdout - errWithMarker verbosity (wrapTextVerbosity verbosity msg) - --- | As 'dieMsg' but with pre-formatted text. --- -dieMsgNoWrap :: Verbosity -> String -> NoCallStackIO () -dieMsgNoWrap verbosity msg = do - hFlush stdout - errWithMarker verbosity msg - -- | Non fatal conditions that may be indicative of an error or problem. -- -- We display these at the 'normal' verbosity level. @@ -346,8 +416,9 @@ warn :: Verbosity -> String -> IO () warn verbosity msg = withFrozenCallStack $ do when (verbosity >= normal) $ do hFlush stdout - hPutCallStackPrefix stderr verbosity - errWithMarker verbosity (wrapTextVerbosity verbosity ("Warning: " ++ msg)) + hPutStr stderr . withMetadata True verbosity + . wrapTextVerbosity verbosity + $ "Warning: " ++ msg -- | Useful status messages. -- @@ -359,14 +430,17 @@ warn verbosity msg = withFrozenCallStack $ do notice :: Verbosity -> String -> IO () notice verbosity msg = withFrozenCallStack $ do when (verbosity >= normal) $ do - hPutCallStackPrefix stdout verbosity - outWithMarker verbosity (wrapTextVerbosity verbosity msg) + hPutStr stdout . withMetadata True verbosity + . wrapTextVerbosity verbosity + $ msg +-- | Display a message at 'normal' verbosity level, but without +-- wrapping. +-- noticeNoWrap :: Verbosity -> String -> IO () noticeNoWrap verbosity msg = withFrozenCallStack $ do when (verbosity >= normal) $ do - hPutCallStackPrefix stdout verbosity - outWithMarker verbosity msg + hPutStr stdout . withMetadata True verbosity $ msg -- | Pretty-print a 'Disp.Doc' status message at 'normal' verbosity -- level. Use this if you need fancy formatting. @@ -374,24 +448,15 @@ noticeNoWrap verbosity msg = withFrozenCallStack $ do noticeDoc :: Verbosity -> Disp.Doc -> IO () noticeDoc verbosity msg = withFrozenCallStack $ do when (verbosity >= normal) $ do - hPutCallStackPrefix stdout verbosity - outWithMarker verbosity (Disp.renderStyle defaultStyle msg ++ "\n") - -hWithMarker :: Handle -> Verbosity -> String -> NoCallStackIO () -hWithMarker h v xs | not (isVerboseMarkOutput v) = hPutStr h xs -hWithMarker _ _ [] = return () -hWithMarker h _ xs = do - hPutStrLn h "-----BEGIN CABAL OUTPUT-----" - hPutStr h (if last xs == '\n' then xs else xs ++ "\n") - hPutStrLn h "-----END CABAL OUTPUT-----" - -outWithMarker, errWithMarker :: Verbosity -> String -> IO () -outWithMarker = hWithMarker stdout -errWithMarker = hWithMarker stderr + hPutStr stdout . withMetadata True verbosity + . Disp.renderStyle defaultStyle $ msg +-- | Display a "setup status message". Prefer using setupMessage' +-- if possible. +-- setupMessage :: Verbosity -> String -> PackageIdentifier -> IO () setupMessage verbosity msg pkgid = withFrozenCallStack $ do - noticeNoWrap verbosity (msg ++ ' ': display pkgid ++ "...\n") + noticeNoWrap verbosity (msg ++ ' ': display pkgid ++ "...") -- | More detail on the operation of some action. -- @@ -400,14 +465,15 @@ setupMessage verbosity msg pkgid = withFrozenCallStack $ do info :: Verbosity -> String -> IO () info verbosity msg = withFrozenCallStack $ when (verbosity >= verbose) $ do - hPutCallStackPrefix stdout verbosity - putStr (wrapTextVerbosity verbosity msg) + hPutStr stdout . withMetadata False verbosity + . wrapTextVerbosity verbosity + $ msg infoNoWrap :: Verbosity -> String -> IO () infoNoWrap verbosity msg = withFrozenCallStack $ when (verbosity >= verbose) $ do - hPutCallStackPrefix stdout verbosity - putStrLn msg + hPutStr stdout . withMetadata False verbosity + $ msg -- | Detailed internal debugging information -- @@ -416,8 +482,10 @@ infoNoWrap verbosity msg = withFrozenCallStack $ debug :: Verbosity -> String -> IO () debug verbosity msg = withFrozenCallStack $ when (verbosity >= deafening) $ do - hPutCallStackPrefix stdout verbosity - putStr (wrapTextVerbosity verbosity msg) + hPutStr stdout . withMetadata False verbosity + . wrapTextVerbosity verbosity + $ msg + -- ensure that we don't lose output if we segfault/infinite loop hFlush stdout -- | A variant of 'debug' that doesn't perform the automatic line @@ -425,8 +493,9 @@ debug verbosity msg = withFrozenCallStack $ debugNoWrap :: Verbosity -> String -> IO () debugNoWrap verbosity msg = withFrozenCallStack $ when (verbosity >= deafening) $ do - hPutCallStackPrefix stdout verbosity - putStrLn msg + hPutStr stdout . withMetadata False verbosity + $ msg + -- ensure that we don't lose output if we segfault/infinite loop hFlush stdout -- | Perform an IO action, catching any IO exceptions and printing an error @@ -452,9 +521,65 @@ handleDoesNotExist e = -- | Wraps text unless the @+nowrap@ verbosity flag is active wrapTextVerbosity :: Verbosity -> String -> String wrapTextVerbosity verb - | isVerboseNoWrap verb = unlines . lines -- makes sure there's a trailing LF + | isVerboseNoWrap verb = withTrailingNewline | otherwise = wrapText +-- | Wrap output with a marker if @+markoutput@ verbosity flag is set. +-- +-- NB: Why is markoutput done with start/end markers, and not prefixes? +-- Markers are more convenient to add (if we want to add prefixes, +-- we have to 'lines' and then 'map'; here's it's just some +-- concatenates). Note that even in the prefix case, we can't +-- guarantee that the markers are unambiguous, because some of +-- Cabal's output comes straight from external programs, where +-- we don't have the ability to interpose on the output. +-- +withOutputMarker :: Verbosity -> String -> String +withOutputMarker v xs | not (isVerboseMarkOutput v) = xs +withOutputMarker _ "" = "" -- Minor optimization, don't mark uselessly +withOutputMarker _ xs = + "-----BEGIN CABAL OUTPUT-----\n" ++ + withTrailingNewline xs ++ + "-----END CABAL OUTPUT-----\n" + +-- | Append a trailing newline to a string if it does not +-- already have a trailing newline. +-- +withTrailingNewline :: String -> String +withTrailingNewline "" = "" +withTrailingNewline (x:xs) = x : go x xs + where + go _ (c:cs) = c : go c cs + go '\n' "" = "" + go _ "" = "\n" + +-- | Prepend a call-site and/or call-stack based on Verbosity +-- +withCallStackPrefix :: Verbosity -> String -> String +withCallStackPrefix verbosity s = withFrozenCallStack $ + (if isVerboseCallSite verbosity + then parentSrcLocPrefix ++ + -- Hack: need a newline before starting output marker :( + if isVerboseMarkOutput verbosity + then "\n" + else "" + else "") ++ + (if isVerboseCallStack verbosity + then "----\n" ++ prettyCallStack callStack ++ "\n" + else "") ++ + s + +-- | Add all necessary metadata to a logging message +-- +withMetadata :: Bool -> Verbosity -> String -> String +withMetadata marker verbosity x = withFrozenCallStack $ + -- NB: order matters. Output marker first because we + -- don't want to capture call stacks. + withTrailingNewline + . withCallStackPrefix verbosity + . (if marker then withOutputMarker verbosity else id) + $ x + -- ----------------------------------------------------------------------------- -- rawSystem variants maybeExit :: IO ExitCode -> IO () @@ -471,16 +596,11 @@ printRawCommandAndArgsAndEnv :: Verbosity -> [String] -> Maybe [(String, String)] -> IO () -printRawCommandAndArgsAndEnv verbosity path args menv - | verbosity >= deafening = do - traverse_ (putStrLn . ("Environment: " ++) . show) menv - hPutCallStackPrefix stdout verbosity - print (path, args) - | verbosity >= verbose = do - hPutCallStackPrefix stdout verbosity - putStrLn $ showCommandForUser path args - | otherwise = return () - +printRawCommandAndArgsAndEnv verbosity path args menv = do + case menv of + Just env -> debugNoWrap verbosity ("Environment: " ++ show env) + Nothing -> return () + infoNoWrap verbosity (showCommandForUser path args) -- Exit with the same exit code if the subcommand fails rawSystemExit :: Verbosity -> FilePath -> [String] -> IO () diff --git a/Cabal/Distribution/Utils/LogProgress.hs b/Cabal/Distribution/Utils/LogProgress.hs index 12953aaac7b867f470d631266d52cc890d303e35..5ee2de833a04ec1c8edff1dbbe849f550ddb4088 100644 --- a/Cabal/Distribution/Utils/LogProgress.hs +++ b/Cabal/Distribution/Utils/LogProgress.hs @@ -58,8 +58,7 @@ runLogProgress verbosity (LogProgress m) = go fail_fn :: Doc -> NoCallStackIO a fail_fn doc = do - dieMsgNoWrap verbosity (render doc ++ "\n") - die "Configuration failed" + dieNoWrap verbosity (render doc) -- | Output a warning trace message in 'LogProgress'. warnProgress :: Doc -> LogProgress () diff --git a/cabal-install/Distribution/Client/BuildReports/Upload.hs b/cabal-install/Distribution/Client/BuildReports/Upload.hs index c42af3a068f69b437348d083df415a101eda3543..5665ce3f63425f01eeebb7ca6ac802bc31e7cff8 100644 --- a/cabal-install/Distribution/Client/BuildReports/Upload.hs +++ b/cabal-install/Distribution/Client/BuildReports/Upload.hs @@ -25,7 +25,7 @@ import qualified Distribution.Client.BuildReports.Anonymous as BuildReport import Distribution.Client.BuildReports.Anonymous (BuildReport) import Distribution.Text (display) import Distribution.Verbosity (Verbosity) -import Distribution.Simple.Utils (die) +import Distribution.Simple.Utils (die') import Distribution.Client.HttpUtils import Distribution.Client.Setup ( RepoContext(..) ) @@ -48,7 +48,7 @@ postBuildReport verbosity repoCtxt auth uri buildReport = do res <- postHttp transport verbosity fullURI (BuildReport.show buildReport) (Just auth) case res of (303, redir) -> return $ undefined redir --TODO parse redir - _ -> die "unrecognized response" -- give response + _ -> die' verbosity "unrecognized response" -- give response {- setAllowRedirects False @@ -89,4 +89,4 @@ putBuildLog verbosity repoCtxt auth reportId buildLog = do res <- postHttp transport verbosity fullURI buildLog (Just auth) case res of (200, _) -> return () - _ -> die "unrecognized response" -- give response + _ -> die' verbosity "unrecognized response" -- give response diff --git a/cabal-install/Distribution/Client/BuildTarget.hs b/cabal-install/Distribution/Client/BuildTarget.hs index 9db90b7e3e8b745e9ff4688d9f437ccf3f40d41e..b0d4c40174d82e3a161619837a20f23ab759d10e 100644 --- a/cabal-install/Distribution/Client/BuildTarget.hs +++ b/cabal-install/Distribution/Client/BuildTarget.hs @@ -47,6 +47,7 @@ import Distribution.Types.UnqualComponentName ( unUnqualComponentName ) import Distribution.Client.Types ( PackageLocation(..) ) +import Distribution.Verbosity import Distribution.PackageDescription ( PackageDescription , Executable(..) @@ -63,7 +64,7 @@ import Distribution.Types.ForeignLib import Distribution.Text ( display, simpleParse ) import Distribution.Simple.Utils - ( die, lowercase ) + ( die', lowercase ) import Distribution.Client.Utils ( makeRelativeToCwd ) @@ -256,10 +257,10 @@ buildTargetComponentName (BuildTargetFile _p cn _fn) = Just cn -- | Parse a bunch of command line args as user build targets, failing with an -- error if any targets are unrecognised. -- -readUserBuildTargets :: [String] -> IO [UserBuildTarget] -readUserBuildTargets targetStrs = do +readUserBuildTargets :: Verbosity -> [String] -> IO [UserBuildTarget] +readUserBuildTargets verbosity targetStrs = do let (uproblems, utargets) = parseUserBuildTargets targetStrs - reportUserBuildTargetProblems uproblems + reportUserBuildTargetProblems verbosity uproblems return utargets @@ -271,9 +272,10 @@ readUserBuildTargets targetStrs = do -- locations). It fails with an error if any user string cannot be matched to -- a valid target. -- -resolveUserBuildTargets :: [(PackageDescription, PackageLocation a)] +resolveUserBuildTargets :: Verbosity + -> [(PackageDescription, PackageLocation a)] -> [UserBuildTarget] -> IO [BuildTarget PackageName] -resolveUserBuildTargets pkgs utargets = do +resolveUserBuildTargets verbosity pkgs utargets = do utargets' <- mapM getUserTargetFileStatus utargets pkgs' <- mapM (uncurry selectPackageInfo) pkgs pwd <- getCurrentDirectory @@ -294,7 +296,7 @@ resolveUserBuildTargets pkgs utargets = do | otherwise = btargets - reportBuildTargetProblems bproblems + reportBuildTargetProblems verbosity bproblems return (map (fmap packageName) btargets') where selectPrimaryLocalPackage :: FilePath @@ -408,12 +410,12 @@ data UserBuildTargetProblem -- | Throw an exception with a formatted message if there are any problems. -- -reportUserBuildTargetProblems :: [UserBuildTargetProblem] -> IO () -reportUserBuildTargetProblems problems = do +reportUserBuildTargetProblems :: Verbosity -> [UserBuildTargetProblem] -> IO () +reportUserBuildTargetProblems verbosity problems = do case [ target | UserBuildTargetUnrecognised target <- problems ] of [] -> return () target -> - die $ unlines + die' verbosity $ unlines [ "Unrecognised build target syntax for '" ++ name ++ "'." | name <- target ] ++ "Syntax:\n" @@ -691,13 +693,13 @@ renderBuildTarget ql t = -- | Throw an exception with a formatted message if there are any problems. -- -reportBuildTargetProblems :: [BuildTargetProblem] -> IO () -reportBuildTargetProblems problems = do +reportBuildTargetProblems :: Verbosity -> [BuildTargetProblem] -> IO () +reportBuildTargetProblems verbosity problems = do case [ (t, m, ms) | MatchingInternalError t m ms <- problems ] of [] -> return () ((target, originalMatch, renderingsAndMatches):_) -> - die $ "Internal error in build target matching. It should always be " + die' verbosity $ "Internal error in build target matching. It should always be " ++ "possible to find a syntax that's sufficiently qualified to " ++ "give an unambigious match. However when matching '" ++ showUserBuildTarget target ++ "' we found " @@ -716,7 +718,7 @@ reportBuildTargetProblems problems = do case [ (t, e, g) | BuildTargetExpected t e g <- problems ] of [] -> return () targets -> - die $ unlines + die' verbosity $ unlines [ "Unrecognised build target '" ++ showUserBuildTarget target ++ "'.\n" ++ "Expected a " ++ intercalate " or " expected @@ -726,7 +728,7 @@ reportBuildTargetProblems problems = do case [ (t, e) | BuildTargetNoSuch t e <- problems ] of [] -> return () targets -> - die $ unlines + die' verbosity $ unlines [ "Unknown build target '" ++ showUserBuildTarget target ++ "'.\n" ++ unlines [ (case inside of @@ -759,7 +761,7 @@ reportBuildTargetProblems problems = do case [ (t, ts) | BuildTargetAmbiguous t ts <- problems ] of [] -> return () targets -> - die $ unlines + die' verbosity $ unlines [ "Ambiguous build target '" ++ showUserBuildTarget target ++ "'. It could be:\n " ++ unlines [ " "++ showUserBuildTarget ut ++ diff --git a/cabal-install/Distribution/Client/CmdBuild.hs b/cabal-install/Distribution/Client/CmdBuild.hs index 72669c63154ed0f4b2e13df5bd0b1a1b0b564103..fc9c41ce49bda8bf83ae5ada8a6bba7f7e59e0fe 100644 --- a/cabal-install/Distribution/Client/CmdBuild.hs +++ b/cabal-install/Distribution/Client/CmdBuild.hs @@ -60,7 +60,7 @@ buildAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) buildAction (configFlags, configExFlags, installFlags, haddockFlags) targetStrings globalFlags = do - userTargets <- readUserBuildTargets targetStrings + userTargets <- readUserBuildTargets verbosity targetStrings buildCtx <- runProjectPreBuildPhase diff --git a/cabal-install/Distribution/Client/CmdFreeze.hs b/cabal-install/Distribution/Client/CmdFreeze.hs index 2a3ad2aa4f2718b4f8a979a1a5fa43bf825503db..0736069ba05ca0e0eee5ab0903814f193f2537af 100644 --- a/cabal-install/Distribution/Client/CmdFreeze.hs +++ b/cabal-install/Distribution/Client/CmdFreeze.hs @@ -37,7 +37,7 @@ import Distribution.Client.Setup import Distribution.Simple.Setup ( HaddockFlags, fromFlagOrDefault ) import Distribution.Simple.Utils - ( die, notice ) + ( die', notice ) import Distribution.Verbosity ( normal ) @@ -83,7 +83,7 @@ freezeAction (configFlags, configExFlags, installFlags, haddockFlags) extraArgs globalFlags = do unless (null extraArgs) $ - die $ "'freeze' doesn't take any extra arguments: " + die' verbosity $ "'freeze' doesn't take any extra arguments: " ++ unwords extraArgs cabalDir <- defaultCabalDir diff --git a/cabal-install/Distribution/Client/CmdHaddock.hs b/cabal-install/Distribution/Client/CmdHaddock.hs index bbdbd94578d7d22bee90fa7df72219c4bcb886fe..540fde52fe3ee701d166487dbb465f46705939e5 100644 --- a/cabal-install/Distribution/Client/CmdHaddock.hs +++ b/cabal-install/Distribution/Client/CmdHaddock.hs @@ -54,7 +54,7 @@ haddockAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) haddockAction (configFlags, configExFlags, installFlags, haddockFlags) targetStrings globalFlags = do - userTargets <- readUserBuildTargets targetStrings + userTargets <- readUserBuildTargets verbosity targetStrings buildCtx <- runProjectPreBuildPhase diff --git a/cabal-install/Distribution/Client/CmdRepl.hs b/cabal-install/Distribution/Client/CmdRepl.hs index 304243e47b1eb8f1b19e60ab01dfd88ea13dc208..ec36923477dcdc4efd9dcf3df1ea685516f4372b 100644 --- a/cabal-install/Distribution/Client/CmdRepl.hs +++ b/cabal-install/Distribution/Client/CmdRepl.hs @@ -27,7 +27,7 @@ import Control.Monad (when) import Distribution.Simple.Command ( CommandUI(..), usageAlternatives ) import Distribution.Simple.Utils - ( wrapText, die ) + ( wrapText, die' ) import qualified Distribution.Client.Setup as Client replCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) @@ -61,7 +61,7 @@ replAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) replAction (configFlags, configExFlags, installFlags, haddockFlags) targetStrings globalFlags = do - userTargets <- readUserBuildTargets targetStrings + userTargets <- readUserBuildTargets verbosity targetStrings buildCtx <- runProjectPreBuildPhase @@ -73,7 +73,7 @@ replAction (configFlags, configExFlags, installFlags, haddockFlags) hookSelectPlanSubset = \buildSettings elaboratedPlan -> do when (buildSettingOnlyDeps buildSettings) $ - die $ "The repl command does not support '--only-dependencies'. " + die' verbosity $ "The repl command does not support '--only-dependencies'. " ++ "You may wish to use 'build --only-dependencies' and then " ++ "use 'repl'." -- Interpret the targets on the command line as repl targets diff --git a/cabal-install/Distribution/Client/CmdTest.hs b/cabal-install/Distribution/Client/CmdTest.hs index 15810911f3c9378979a699ff62932ac4615cb9d3..2fd3252822c3c45a387fcebffc1826fc1d9cc315 100644 --- a/cabal-install/Distribution/Client/CmdTest.hs +++ b/cabal-install/Distribution/Client/CmdTest.hs @@ -52,7 +52,7 @@ testAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) testAction (configFlags, configExFlags, installFlags, haddockFlags) targetStrings globalFlags = do - userTargets <- readUserBuildTargets targetStrings + userTargets <- readUserBuildTargets verbosity targetStrings buildCtx <- runProjectPreBuildPhase diff --git a/cabal-install/Distribution/Client/Config.hs b/cabal-install/Distribution/Client/Config.hs index f3fef8f7276af9be20069883d6e6e38f532d1c5c..cbc0a3262dd368e60e235fa0309619a6135196b9 100644 --- a/cabal-install/Distribution/Client/Config.hs +++ b/cabal-install/Distribution/Client/Config.hs @@ -91,7 +91,7 @@ import Distribution.Simple.Command import Distribution.Simple.Program ( defaultProgramDb ) import Distribution.Simple.Utils - ( die, notice, warn, lowercase, cabalVersion ) + ( die', notice, warn, lowercase, cabalVersion ) import Distribution.Compiler ( CompilerFlavor(..), defaultCompilerFlavor ) import Distribution.Verbosity @@ -615,7 +615,7 @@ loadRawConfig verbosity configFileFlag = do return conf Just (ParseFailed err) -> do let (line, msg) = locatedErrorMsg err - die $ + die' verbosity $ "Error parsing config file " ++ configFile ++ maybe "" (\n -> ':' : show n) line ++ ":\n" ++ msg diff --git a/cabal-install/Distribution/Client/Configure.hs b/cabal-install/Distribution/Client/Configure.hs index 7658249735337adba53fca510d00e5dad63abddd..5124e9ea2a1774424e67b27e1ad24706332f79b4 100644 --- a/cabal-install/Distribution/Client/Configure.hs +++ b/cabal-install/Distribution/Client/Configure.hs @@ -81,7 +81,7 @@ import Distribution.Version ( Version, mkVersion, anyVersion, thisVersion , VersionRange, orLaterVersion ) import Distribution.Simple.Utils as Utils - ( warn, notice, debug, die ) + ( warn, notice, debug, die' ) import Distribution.Simple.Setup ( isRelaxDeps ) import Distribution.System @@ -156,7 +156,7 @@ configure verbosity packageDBs repoCtxt comp platform progdb (setupScriptOptions installedPkgIndex (Just pkg)) configFlags pkg extraArgs - _ -> die $ "internal error: configure install plan should have exactly " + _ -> die' verbosity $ "internal error: configure install plan should have exactly " ++ "one local ready package." where diff --git a/cabal-install/Distribution/Client/Exec.hs b/cabal-install/Distribution/Client/Exec.hs index a3952d803406a3b6604fbaf5f8db6acaee419d1f..03d1c0d2db056a0ba521125fffe98a74cf8beb03 100644 --- a/cabal-install/Distribution/Client/Exec.hs +++ b/cabal-install/Distribution/Client/Exec.hs @@ -27,7 +27,7 @@ import Distribution.Simple.Program.Db (ProgramDb, requireProgram, modifyProgram import Distribution.Simple.Program.Find (ProgramSearchPathEntry(..)) import Distribution.Simple.Program.Run (programInvocation, runProgramInvocation) import Distribution.Simple.Program.Types ( simpleProgram, ConfiguredProgram(..) ) -import Distribution.Simple.Utils (die, warn) +import Distribution.Simple.Utils (die', warn) import Distribution.System (Platform(..), OS(..)) import Distribution.Verbosity (Verbosity) @@ -58,7 +58,7 @@ exec verbosity useSandbox comp platform programDb extraArgs = args runProgramInvocation verbosity invocation - [] -> die "Please specify an executable to run" + [] -> die' verbosity "Please specify an executable to run" where environmentOverrides env = case useSandbox of @@ -81,7 +81,7 @@ sandboxEnvironment verbosity sandboxDir comp platform programDb iEnv = case compilerFlavor comp of GHC -> env GHC.getGlobalPackageDB ghcProgram "GHC_PACKAGE_PATH" GHCJS -> env GHCJS.getGlobalPackageDB ghcjsProgram "GHCJS_PACKAGE_PATH" - _ -> die "exec only works with GHC and GHCJS" + _ -> die' verbosity "exec only works with GHC and GHCJS" where (Platform _ os) = platform ldPath = case os of diff --git a/cabal-install/Distribution/Client/Fetch.hs b/cabal-install/Distribution/Client/Fetch.hs index 4dd8def24b437b81565c9886b0634b793119e824..af7fa851755ed8cfe6e9f1b1c52b73a4108be8c9 100644 --- a/cabal-install/Distribution/Client/Fetch.hs +++ b/cabal-install/Distribution/Client/Fetch.hs @@ -39,7 +39,7 @@ import Distribution.Simple.Program import Distribution.Simple.Setup ( fromFlag ) import Distribution.Simple.Utils - ( die, notice, debug ) + ( die', notice, debug ) import Distribution.System ( Platform ) import Distribution.Text @@ -82,7 +82,7 @@ fetch verbosity _ _ _ _ _ _ _ [] = fetch verbosity packageDBs repoCtxt comp platform progdb globalFlags fetchFlags userTargets = do - mapM_ checkTarget userTargets + mapM_ (checkTarget verbosity) userTargets installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb sourcePkgDb <- getSourcePackages verbosity repoCtxt @@ -131,7 +131,7 @@ planPackages verbosity comp platform fetchFlags solver <- chooseSolver verbosity (fromFlag (fetchSolver fetchFlags)) (compilerInfo comp) notice verbosity "Resolving dependencies..." - installPlan <- foldProgress logMsg die return $ + installPlan <- foldProgress logMsg (die' verbosity) return $ resolveDependencies platform (compilerInfo comp) pkgConfigDb solver @@ -145,7 +145,7 @@ planPackages verbosity comp platform fetchFlags <- SolverInstallPlan.toList installPlan ] | otherwise = - either (die . unlines . map show) return $ + either (die' verbosity . unlines . map show) return $ resolveWithoutDependencies resolverParams where @@ -188,10 +188,10 @@ planPackages verbosity comp platform fetchFlags allowBootLibInstalls = fromFlag (fetchAllowBootLibInstalls fetchFlags) -checkTarget :: UserTarget -> IO () -checkTarget target = case target of +checkTarget :: Verbosity -> UserTarget -> IO () +checkTarget verbosity target = case target of UserTargetRemoteTarball _uri - -> die $ "The 'fetch' command does not yet support remote tarballs. " + -> die' verbosity $ "The 'fetch' command does not yet support remote tarballs. " ++ "In the meantime you can use the 'unpack' commands." _ -> return () @@ -201,7 +201,7 @@ fetchPackage verbosity repoCtxt pkgsrc = case pkgsrc of LocalTarballPackage _file -> return () RemoteTarballPackage _uri _ -> - die $ "The 'fetch' command does not yet support remote tarballs. " + die' verbosity $ "The 'fetch' command does not yet support remote tarballs. " ++ "In the meantime you can use the 'unpack' commands." RepoTarballPackage repo pkgid _ -> do diff --git a/cabal-install/Distribution/Client/FetchUtils.hs b/cabal-install/Distribution/Client/FetchUtils.hs index e10a0d2e83ee675dc9b8c0f578d12ff1d1748315..26e577e5e9dddbe47b4a132ed25b71cfaa047c91 100644 --- a/cabal-install/Distribution/Client/FetchUtils.hs +++ b/cabal-install/Distribution/Client/FetchUtils.hs @@ -140,7 +140,7 @@ fetchPackage verbosity repoCtxt loc = case loc of where downloadTarballPackage uri = do transport <- repoContextGetTransport repoCtxt - transportCheckHttps transport uri + transportCheckHttps verbosity transport uri notice verbosity ("Downloading " ++ show uri) tmpdir <- getTemporaryDirectory (path, hnd) <- openTempFile tmpdir "cabal-.tar.gz" @@ -165,7 +165,7 @@ fetchRepoTarball verbosity repoCtxt repo pkgid = do RepoRemote{..} -> do transport <- repoContextGetTransport repoCtxt - remoteRepoCheckHttps transport repoRemote + remoteRepoCheckHttps verbosity transport repoRemote let uri = packageURI repoRemote pkgid dir = packageDir repo pkgid path = packageFile repo pkgid @@ -188,7 +188,7 @@ fetchRepoTarball verbosity repoCtxt repo pkgid = do -- downloadIndex :: HttpTransport -> Verbosity -> RemoteRepo -> FilePath -> IO DownloadResult downloadIndex transport verbosity remoteRepo cacheDir = do - remoteRepoCheckHttps transport remoteRepo + remoteRepoCheckHttps verbosity transport remoteRepo let uri = (remoteRepoURI remoteRepo) { uriPath = uriPath (remoteRepoURI remoteRepo) `FilePath.Posix.combine` "00-index.tar.gz" diff --git a/cabal-install/Distribution/Client/Freeze.hs b/cabal-install/Distribution/Client/Freeze.hs index 13a9389012499af8355edd579d97da4a2964ba38..08444de3d0933e5c74147405862a09efdd0b88e6 100644 --- a/cabal-install/Distribution/Client/Freeze.hs +++ b/cabal-install/Distribution/Client/Freeze.hs @@ -52,7 +52,7 @@ import Distribution.Simple.Program import Distribution.Simple.Setup ( fromFlag, fromFlagOrDefault, flagToMaybe ) import Distribution.Simple.Utils - ( die, notice, debug, writeFileAtomic ) + ( die', notice, debug, writeFileAtomic ) import Distribution.System ( Platform ) import Distribution.Text @@ -132,10 +132,10 @@ getFreezePkgs verbosity packageDBs repoCtxt comp platform progdb mSandboxPkgInfo where sanityCheck pkgSpecifiers = do when (not . null $ [n | n@(NamedPackage _ _) <- pkgSpecifiers]) $ - die $ "internal error: 'resolveUserTargets' returned " + die' verbosity $ "internal error: 'resolveUserTargets' returned " ++ "unexpected named package specifiers!" when (length pkgSpecifiers /= 1) $ - die $ "internal error: 'resolveUserTargets' returned " + die' verbosity $ "internal error: 'resolveUserTargets' returned " ++ "unexpected source package specifiers!" planPackages :: Verbosity @@ -155,7 +155,7 @@ planPackages verbosity comp platform mSandboxPkgInfo freezeFlags (fromFlag (freezeSolver freezeFlags)) (compilerInfo comp) notice verbosity "Resolving dependencies..." - installPlan <- foldProgress logMsg die return $ + installPlan <- foldProgress logMsg (die' verbosity) return $ resolveDependencies platform (compilerInfo comp) pkgConfigDb solver diff --git a/cabal-install/Distribution/Client/Get.hs b/cabal-install/Distribution/Client/Get.hs index b5bc5b4046bd0a1cae49ad0d10efa15ac47e3e21..42ebac1ba83f46f1b9b423e7b23ea4db640b6774 100644 --- a/cabal-install/Distribution/Client/Get.hs +++ b/cabal-install/Distribution/Client/Get.hs @@ -25,7 +25,7 @@ import Distribution.Package import Distribution.Simple.Setup ( Flag(..), fromFlag, fromFlagOrDefault ) import Distribution.Simple.Utils - ( notice, die, info, rawSystemExitCode, writeFileAtomic ) + ( notice, die', info, rawSystemExitCode, writeFileAtomic ) import Distribution.Verbosity ( Verbosity ) import Distribution.Text(display) @@ -80,7 +80,7 @@ get verbosity repoCtxt globalFlags getFlags userTargets = do _ -> True unless useFork $ - mapM_ checkTarget userTargets + mapM_ (checkTarget verbosity) userTargets let idxState = fromFlagOrDefault IndexStateHead $ getIndexState getFlags @@ -92,7 +92,7 @@ get verbosity repoCtxt globalFlags getFlags userTargets = do (packageIndex sourcePkgDb) userTargets - pkgs <- either (die . unlines . map show) return $ + pkgs <- either (die' verbosity . unlines . map show) return $ resolveWithoutDependencies (resolverParams sourcePkgDb pkgSpecifiers) @@ -138,10 +138,10 @@ get verbosity repoCtxt globalFlags getFlags userTargets = do where usePristine = fromFlagOrDefault False (getPristine getFlags) -checkTarget :: UserTarget -> IO () -checkTarget target = case target of - UserTargetLocalDir dir -> die (notTarball dir) - UserTargetLocalCabalFile file -> die (notTarball file) +checkTarget :: Verbosity -> UserTarget -> IO () +checkTarget verbosity target = case target of + UserTargetLocalDir dir -> die' verbosity (notTarball dir) + UserTargetLocalCabalFile file -> die' verbosity (notTarball file) _ -> return () where notTarball t = @@ -160,10 +160,10 @@ unpackPackage verbosity prefix pkgid descOverride pkgPath = do pkgdir = prefix </> pkgdirname pkgdir' = addTrailingPathSeparator pkgdir existsDir <- doesDirectoryExist pkgdir - when existsDir $ die $ + when existsDir $ die' verbosity $ "The directory \"" ++ pkgdir' ++ "\" already exists, not unpacking." existsFile <- doesFileExist pkgdir - when existsFile $ die $ + when existsFile $ die' verbosity $ "A file \"" ++ pkgdir ++ "\" is in the way, not unpacking." notice verbosity $ "Unpacking to " ++ pkgdir' Tar.extractTarGzFile prefix pkgdirname pkgPath @@ -234,11 +234,11 @@ forkPackage verbosity branchers prefix kind src = do destDirExists <- doesDirectoryExist destdir when destDirExists $ do - die ("The directory " ++ show destdir ++ " already exists, not forking.") + die' verbosity ("The directory " ++ show destdir ++ " already exists, not forking.") destFileExists <- doesFileExist destdir when destFileExists $ do - die ("A file " ++ show destdir ++ " is in the way, not forking.") + die' verbosity ("A file " ++ show destdir ++ " is in the way, not forking.") let repos = PD.sourceRepos desc case findBranchCmd branchers repos kind of @@ -246,11 +246,11 @@ forkPackage verbosity branchers prefix kind src = do exitCode <- io verbosity destdir case exitCode of ExitSuccess -> return () - ExitFailure _ -> die ("Couldn't fork package " ++ pkgid) + ExitFailure _ -> die' verbosity ("Couldn't fork package " ++ pkgid) Nothing -> case repos of - [] -> die ("Package " ++ pkgid + [] -> die' verbosity ("Package " ++ pkgid ++ " does not have any source repositories.") - _ -> die ("Package " ++ pkgid + _ -> die' verbosity ("Package " ++ pkgid ++ " does not have any usable source repositories.") -- | Given a set of possible branchers, and a set of possible source diff --git a/cabal-install/Distribution/Client/HttpUtils.hs b/cabal-install/Distribution/Client/HttpUtils.hs index ce5be0207aa8bb87fe82049d6fb1e2e2fad2438e..5a01d826312c1f5c842f59aeba0b705d6ca1c26d 100644 --- a/cabal-install/Distribution/Client/HttpUtils.hs +++ b/cabal-install/Distribution/Client/HttpUtils.hs @@ -37,7 +37,7 @@ import qualified Data.ByteString.Lazy.Char8 as BS import qualified Paths_cabal_install (version) import Distribution.Verbosity (Verbosity) import Distribution.Simple.Utils - ( die, info, warn, debug, notice, writeFileAtomic + ( die', info, warn, debug, notice, writeFileAtomic , copyFileVerbose, withTempFile , rawSystemStdInOut, toUTF8, fromUTF8, normaliseLineEndings ) import Distribution.Client.Utils @@ -131,26 +131,26 @@ downloadURI transport verbosity uri path = do 304 -> do notice verbosity "Skipping download: local and remote files match." return FileAlreadyInCache - errCode -> die $ "Failed to download " ++ show uri + errCode -> die' verbosity $ "Failed to download " ++ show uri ++ " : HTTP code " ++ show errCode ------------------------------------------------------------------------------ -- Utilities for repo url management -- -remoteRepoCheckHttps :: HttpTransport -> RemoteRepo -> IO () -remoteRepoCheckHttps transport repo +remoteRepoCheckHttps :: Verbosity -> HttpTransport -> RemoteRepo -> IO () +remoteRepoCheckHttps verbosity transport repo | uriScheme (remoteRepoURI repo) == "https:" , not (transportSupportsHttps transport) - = die $ "The remote repository '" ++ remoteRepoName repo + = die' verbosity $ "The remote repository '" ++ remoteRepoName repo ++ "' specifies a URL that " ++ requiresHttpsErrorMessage | otherwise = return () -transportCheckHttps :: HttpTransport -> URI -> IO () -transportCheckHttps transport uri +transportCheckHttps :: Verbosity -> HttpTransport -> URI -> IO () +transportCheckHttps verbosity transport uri | uriScheme uri == "https:" , not (transportSupportsHttps transport) - = die $ "The URL " ++ show uri + = die' verbosity $ "The URL " ++ show uri ++ " " ++ requiresHttpsErrorMessage | otherwise = return () @@ -164,13 +164,13 @@ requiresHttpsErrorMessage = ++ "external program is available, or one can be selected specifically " ++ "with the global flag --http-transport=" -remoteRepoTryUpgradeToHttps :: HttpTransport -> RemoteRepo -> IO RemoteRepo -remoteRepoTryUpgradeToHttps transport repo +remoteRepoTryUpgradeToHttps :: Verbosity -> HttpTransport -> RemoteRepo -> IO RemoteRepo +remoteRepoTryUpgradeToHttps verbosity transport repo | remoteRepoShouldTryHttps repo , uriScheme (remoteRepoURI repo) == "http:" , not (transportSupportsHttps transport) , not (transportManuallySelected transport) - = die $ "The builtin HTTP implementation does not support HTTPS, but using " + = die' verbosity $ "The builtin HTTP implementation does not support HTTPS, but using " ++ "HTTPS for authenticated uploads is recommended. " ++ "The transport implementations with HTTPS support are " ++ intercalate ", " [ name | (name, _, True, _ ) <- supportedTransports ] @@ -246,7 +246,7 @@ type Auth = (String, String) noPostYet :: Verbosity -> URI -> String -> Maybe (String, String) -> IO (Int, String) -noPostYet _ _ _ _ = die "Posting (for report upload) is not implemented yet" +noPostYet verbosity _ _ _ = die' verbosity "Posting (for report upload) is not implemented yet" supportedTransports :: [(String, Maybe Program, Bool, ProgramDb -> Maybe HttpTransport)] @@ -284,7 +284,7 @@ configureTransport verbosity (Just name) = let Just transport = mkTrans progdb return transport { transportManuallySelected = True } - Nothing -> die $ "Unknown HTTP transport specified: " ++ name + Nothing -> die' verbosity $ "Unknown HTTP transport specified: " ++ name ++ ". The supported transports are " ++ intercalate ", " [ name' | (name', _, _, _ ) <- supportedTransports ] @@ -341,7 +341,7 @@ curlTransport prog = (programInvocation prog args) withFile tmpFile ReadMode $ \hnd -> do headers <- hGetContents hnd - (code, _err, etag') <- parseResponse uri resp headers + (code, _err, etag') <- parseResponse verbosity uri resp headers evaluate $ force (code, etag') posthttp = noPostYet @@ -367,7 +367,7 @@ curlTransport prog = ] resp <- getProgramInvocationOutput verbosity $ addAuthConfig auth (programInvocation prog args) - (code, err, _etag) <- parseResponse uri resp "" + (code, err, _etag) <- parseResponse verbosity uri resp "" return (code, err) puthttpfile verbosity uri path auth headers = do @@ -384,13 +384,13 @@ curlTransport prog = | Header name value <- headers ] resp <- getProgramInvocationOutput verbosity $ addAuthConfig auth (programInvocation prog args) - (code, err, _etag) <- parseResponse uri resp "" + (code, err, _etag) <- parseResponse verbosity uri resp "" return (code, err) -- on success these curl invocations produces an output like "200" -- and on failure it has the server error response first - parseResponse :: URI -> String -> String -> IO (Int, String, Maybe ETag) - parseResponse uri resp headers = + parseResponse :: Verbosity -> URI -> String -> String -> IO (Int, String, Maybe ETag) + parseResponse verbosity uri resp headers = let codeerr = case reverse (lines resp) of (codeLine:rerrLines) -> @@ -409,7 +409,7 @@ curlTransport prog = in case codeerr of Just (i, err) -> return (i, err, mb_etag) - _ -> statusParseFail uri resp + _ -> statusParseFail verbosity uri resp wgetTransport :: ConfiguredProgram -> HttpTransport @@ -431,7 +431,7 @@ wgetTransport prog = ++ " support HTTPS.\n" when (hasRangeHeader) $ warn verbosity warningMsg - (code, etag') <- parseOutput uri resp + (code, etag') <- parseOutput verbosity uri resp return (code, etag') where args = [ "--output-document=" ++ destPath @@ -471,7 +471,7 @@ wgetTransport prog = , "--header=Content-type: multipart/form-data; " ++ "boundary=" ++ boundary ] out <- runWGet verbosity (addUriAuth auth uri) args - (code, _etag) <- parseOutput uri out + (code, _etag) <- parseOutput verbosity uri out withFile responseFile ReadMode $ \hnd -> do resp <- hGetContents hnd evaluate $ force (code, resp) @@ -489,7 +489,7 @@ wgetTransport prog = | Header name value <- headers ] out <- runWGet verbosity (addUriAuth auth uri) args - (code, _etag) <- parseOutput uri out + (code, _etag) <- parseOutput verbosity uri out withFile responseFile ReadMode $ \hnd -> do resp <- hGetContents hnd evaluate $ force (code, resp) @@ -515,14 +515,14 @@ wgetTransport prog = -- wget returns exit code 8 for server "errors" like "304 not modified" if exitCode == ExitSuccess || exitCode == ExitFailure 8 then return resp - else die $ "'" ++ programPath prog + else die' verbosity $ "'" ++ programPath prog ++ "' exited with an error:\n" ++ resp -- With the --server-response flag, wget produces output with the full -- http server response with all headers, we want to find a line like -- "HTTP/1.1 200 OK", but only the last one, since we can have multiple -- requests due to redirects. - parseOutput uri resp = + parseOutput verbosity uri resp = let parsedCode = listToMaybe [ code | (protocol:codestr:_err) <- map words (reverse (lines resp)) @@ -534,7 +534,7 @@ wgetTransport prog = | ["ETag:", etag] <- map words (reverse (lines resp)) ] in case parsedCode of Just i -> return (i, mb_etag) - _ -> statusParseFail uri resp + _ -> statusParseFail verbosity uri resp powershellTransport :: ConfiguredProgram -> HttpTransport @@ -554,7 +554,7 @@ powershellTransport prog = where parseResponse x = case readMaybe . unlines . take 1 . lines $ trim x of Just i -> return (i, Nothing) -- TODO extract real etag - Nothing -> statusParseFail uri x + Nothing -> statusParseFail verbosity uri x etagHeader = [ Header HdrIfNoneMatch t | t <- maybeToList etag ] posthttp = noPostYet @@ -572,14 +572,14 @@ powershellTransport prog = resp <- runPowershellScript verbosity $ webclientScript (setupHeaders (contentHeader : extraHeaders) ++ setupAuth auth) (uploadFileAction "POST" uri fullPath) - parseUploadResponse uri resp + parseUploadResponse verbosity uri resp puthttpfile verbosity uri path auth headers = do fullPath <- canonicalizePath path resp <- runPowershellScript verbosity $ webclientScript (setupHeaders (extraHeaders ++ headers) ++ setupAuth auth) (uploadFileAction "PUT" uri fullPath) - parseUploadResponse uri resp + parseUploadResponse verbosity uri resp runPowershellScript verbosity script = do let args = @@ -618,10 +618,10 @@ powershellTransport prog = , "Write-Host (-join [System.Text.Encoding]::UTF8.GetChars($bodyBytes));" ] - parseUploadResponse uri resp = case lines (trim resp) of + parseUploadResponse verbosity uri resp = case lines (trim resp) of (codeStr : message) | Just code <- readMaybe codeStr -> return (code, unlines message) - _ -> statusParseFail uri resp + _ -> statusParseFail verbosity uri resp webclientScript setup action = unlines [ "$wc = new-object system.net.webclient;" @@ -715,7 +715,7 @@ plainHttpTransport = p <- fixupEmptyProxy <$> fetchProxy True Exception.handleJust (guard . isDoesNotExistError) - (const . die $ "Couldn't establish HTTP connection. " + (const . die' verbosity $ "Couldn't establish HTTP connection. " ++ "Possible cause: HTTP proxy server is down.") $ browse $ do setProxy p @@ -739,9 +739,9 @@ userAgent = concat [ "cabal-install/", display Paths_cabal_install.version , " (", display buildOS, "; ", display buildArch, ")" ] -statusParseFail :: URI -> String -> IO a -statusParseFail uri r = - die $ "Failed to download " ++ show uri ++ " : " +statusParseFail :: Verbosity -> URI -> String -> IO a +statusParseFail verbosity uri r = + die' verbosity $ "Failed to download " ++ show uri ++ " : " ++ "No Status Code could be parsed from response: " ++ r -- Trim diff --git a/cabal-install/Distribution/Client/IndexUtils.hs b/cabal-install/Distribution/Client/IndexUtils.hs index f78d8b2fa4f35d9fdc5fc048d8181bc4ecc09944..ebeb3868048161bf290c56fbebcdbbf9175f9c2d 100644 --- a/cabal-install/Distribution/Client/IndexUtils.hs +++ b/cabal-install/Distribution/Client/IndexUtils.hs @@ -46,6 +46,7 @@ import qualified Codec.Archive.Tar.Index as Tar import qualified Distribution.Client.Tar as Tar import Distribution.Client.IndexUtils.Timestamp import Distribution.Client.Types +import Distribution.Verbosity import Distribution.Package ( PackageId, PackageIdentifier(..), mkPackageName @@ -64,10 +65,8 @@ import Distribution.Version ( mkVersion, intersectVersionRanges ) import Distribution.Text ( display, simpleParse ) -import Distribution.Verbosity - ( Verbosity, normal, lessVerbose ) import Distribution.Simple.Utils - ( die, warn, info ) + ( die', warn, info ) import Distribution.Client.Setup ( RepoContext(..) ) @@ -271,7 +270,7 @@ readCacheStrict verbosity index mkPkg = do updateRepoIndexCache verbosity index cache <- readIndexCache verbosity index withFile (indexFile index) ReadMode $ \indexHnd -> - packageListFromCache mkPkg indexHnd cache ReadPackageIndexStrict + packageListFromCache verbosity mkPkg indexHnd cache ReadPackageIndexStrict -- | Read a repository index from disk, from the local file specified by -- the 'Repo'. @@ -409,14 +408,14 @@ data PackageOrDep = Pkg PackageEntry | Dep Dependency -- function over this to translate it to a list of IO actions returning -- 'PackageOrDep's. We can use 'lazySequence' to turn this into a list of -- 'PackageOrDep's, still maintaining the lazy nature of the original tar read. -parsePackageIndex :: ByteString -> [IO (Maybe PackageOrDep)] -parsePackageIndex = concatMap (uncurry extract) . tarEntriesList . Tar.read +parsePackageIndex :: Verbosity -> ByteString -> [IO (Maybe PackageOrDep)] +parsePackageIndex verbosity = concatMap (uncurry extract) . tarEntriesList . Tar.read where extract :: BlockNo -> Tar.Entry -> [IO (Maybe PackageOrDep)] extract blockNo entry = tryExtractPkg ++ tryExtractPrefs where tryExtractPkg = do - mkPkgEntry <- maybeToList $ extractPkg entry blockNo + mkPkgEntry <- maybeToList $ extractPkg verbosity entry blockNo return $ fmap (fmap Pkg) mkPkgEntry tryExtractPrefs = do @@ -435,8 +434,8 @@ tarEntriesList = go 0 go !_ (Tar.Fail e) = error ("tarEntriesList: " ++ show e) go !n (Tar.Next e es') = (n, e) : go (Tar.nextEntryOffset e n) es' -extractPkg :: Tar.Entry -> BlockNo -> Maybe (IO (Maybe PackageEntry)) -extractPkg entry blockNo = case Tar.entryContent entry of +extractPkg :: Verbosity -> Tar.Entry -> BlockNo -> Maybe (IO (Maybe PackageEntry)) +extractPkg verbosity entry blockNo = case Tar.entryContent entry of Tar.NormalFile content _ | takeExtension fileName == ".cabal" -> case splitDirectories (normalise fileName) of @@ -468,7 +467,7 @@ extractPkg entry blockNo = case Tar.entryContent entry of dirExists <- doesDirectoryExist path result <- if not dirExists then return Nothing else do - cabalFile <- tryFindAddSourcePackageDesc path "Error reading package index." + cabalFile <- tryFindAddSourcePackageDesc verbosity path "Error reading package index." descr <- PackageDesc.Parse.readGenericPackageDescription normal cabalFile return . Just $ BuildTreeRef (refTypeFromTypeCode typeCode) (packageId descr) descr path blockNo @@ -554,7 +553,7 @@ is01Index (SandboxIndex _) = False updatePackageIndexCacheFile :: Verbosity -> Index -> IO () updatePackageIndexCacheFile verbosity index = do info verbosity ("Updating index cache file " ++ cacheFile index ++ " ...") - withIndexEntries index $ \entries -> do + withIndexEntries verbosity index $ \entries -> do let !maxTs = maximumTimestamp (map cacheEntryTimestamp entries) cache = Cache { cacheHeadTs = maxTs , cacheEntries = entries @@ -583,8 +582,8 @@ updatePackageIndexCacheFile verbosity index = do -- TODO: It would be nicer if we actually incrementally updated @cabal@'s -- cache, rather than reconstruct it from zero on each update. However, this -- would require a change in the cache format. -withIndexEntries :: Index -> ([IndexCacheEntry] -> IO a) -> IO a -withIndexEntries (RepoIndex repoCtxt repo@RepoSecure{..}) callback = +withIndexEntries :: Verbosity -> Index -> ([IndexCacheEntry] -> IO a) -> IO a +withIndexEntries _ (RepoIndex repoCtxt repo@RepoSecure{..}) callback = repoContextWithSecureRepo repoCtxt repo $ \repoSecure -> Sec.withIndex repoSecure $ \Sec.IndexCallbacks{..} -> do -- Incrementally (lazily) read all the entries in the tar file in order, @@ -611,10 +610,10 @@ withIndexEntries (RepoIndex repoCtxt repo@RepoSecure{..}) callback = timestamp = fromMaybe (error "withIndexEntries: invalid timestamp") $ epochTimeToTimestamp $ Sec.indexEntryTime sie -withIndexEntries index callback = do -- non-secure repositories +withIndexEntries verbosity index callback = do -- non-secure repositories withFile (indexFile index) ReadMode $ \h -> do bs <- maybeDecompress `fmap` BS.hGetContents h - pkgsOrPrefs <- lazySequence $ parsePackageIndex bs + pkgsOrPrefs <- lazySequence $ parsePackageIndex verbosity bs callback $ map toCache (catMaybes pkgsOrPrefs) where toCache :: PackageOrDep -> IndexCacheEntry @@ -635,18 +634,19 @@ readPackageIndexCacheFile verbosity mkPkg index idxState = do cache0 <- readIndexCache verbosity index indexHnd <- openFile (indexFile index) ReadMode let (cache,isi) = filterCache idxState cache0 - (pkgs,deps) <- packageIndexFromCache mkPkg indexHnd cache ReadPackageIndexLazyIO + (pkgs,deps) <- packageIndexFromCache verbosity mkPkg indexHnd cache ReadPackageIndexLazyIO pure (pkgs,deps,isi) packageIndexFromCache :: Package pkg - => (PackageEntry -> pkg) + => Verbosity + -> (PackageEntry -> pkg) -> Handle -> Cache -> ReadPackageIndexMode -> IO (PackageIndex pkg, [Dependency]) -packageIndexFromCache mkPkg hnd cache mode = do - (pkgs, prefs) <- packageListFromCache mkPkg hnd cache mode +packageIndexFromCache verbosity mkPkg hnd cache mode = do + (pkgs, prefs) <- packageListFromCache verbosity mkPkg hnd cache mode pkgIndex <- evaluate $ PackageIndex.fromList pkgs return (pkgIndex, prefs) @@ -659,12 +659,13 @@ packageIndexFromCache mkPkg hnd cache mode = do -- all .cabal edits and preference-updates. The masking happens -- here, i.e. the semantics that later entries in a tar file mask -- earlier ones is resolved in this function. -packageListFromCache :: (PackageEntry -> pkg) +packageListFromCache :: Verbosity + -> (PackageEntry -> pkg) -> Handle -> Cache -> ReadPackageIndexMode -> IO ([pkg], [Dependency]) -packageListFromCache mkPkg hnd Cache{..} mode = accum mempty [] mempty cacheEntries +packageListFromCache verbosity mkPkg hnd Cache{..} mode = accum mempty [] mempty cacheEntries where accum !srcpkgs btrs !prefs [] = return (Map.elems srcpkgs ++ btrs, Map.elems prefs) @@ -691,7 +692,7 @@ packageListFromCache mkPkg hnd Cache{..} mode = accum mempty [] mempty cacheEntr -- file after the reference was added to the index. path <- liftM byteStringToFilePath . getEntryContent $ blockno pkg <- do let err = "Error reading package index from cache." - file <- tryFindAddSourcePackageDesc path err + file <- tryFindAddSourcePackageDesc verbosity path err PackageDesc.Parse.readGenericPackageDescription normal file let srcpkg = mkPkg (BuildTreeRef refType (packageId pkg) pkg path blockno) accum srcpkgs (srcpkg:btrs) prefs entries @@ -721,7 +722,8 @@ packageListFromCache mkPkg hnd Cache{..} mode = accum mempty [] mempty cacheEntr _ -> interror "failed to parse .cabal file" #endif - interror msg = die $ "internal error when reading package index: " ++ msg + interror :: String -> IO a + interror msg = die' verbosity $ "internal error when reading package index: " ++ msg ++ "The package index or index cache is probably " ++ "corrupt. Running cabal update might fix it." @@ -746,7 +748,7 @@ readIndexCache verbosity index = do updatePackageIndexCacheFile verbosity index - either die (return . hashConsCache) =<< readIndexCache' index + either (die' verbosity) (return . hashConsCache) =<< readIndexCache' index Right res -> return (hashConsCache res) diff --git a/cabal-install/Distribution/Client/Install.hs b/cabal-install/Distribution/Client/Install.hs index 074d35df68e55a06a45d8015644040d6f62ad097..7966193229a063c62dac2c518a6a160b3bfd96b1 100644 --- a/cabal-install/Distribution/Client/Install.hs +++ b/cabal-install/Distribution/Client/Install.hs @@ -158,7 +158,7 @@ import Distribution.ParseUtils import Distribution.Version ( Version, VersionRange, foldVersionRange ) import Distribution.Simple.Utils as Utils - ( notice, info, warn, debug, debugNoWrap, die + ( notice, info, warn, debug, debugNoWrap, die' , withTempDirectory ) import Distribution.Client.Utils ( determineNumJobs, logDirChange, mergeBy, MergeResult(..) @@ -226,7 +226,7 @@ install verbosity packageDBs repos comp platform progdb useSandbox mSandboxPkgIn case planResult of Left message -> do reportPlanningFailure verbosity args installContext message - die' message + die'' message Right installPlan -> processInstallPlan verbosity args installContext installPlan where @@ -235,7 +235,7 @@ install verbosity packageDBs repos comp platform progdb useSandbox mSandboxPkgIn mSandboxPkgInfo, globalFlags, configFlags, configExFlags, installFlags, haddockFlags) - die' message = die (message ++ if isUseSandbox useSandbox + die'' message = die' verbosity (message ++ if isUseSandbox useSandbox then installFailedInSandbox else []) -- TODO: use a better error message, remove duplication. installFailedInSandbox = @@ -563,7 +563,7 @@ checkPrintPlan verbosity installed installPlan sourcePkgDb when containsReinstalls $ do if breaksPkgs then do - (if dryRun || overrideReinstall then warn verbosity else die) $ unlines $ + (if dryRun || overrideReinstall then warn else die') verbosity $ unlines $ "The following packages are likely to be broken by the reinstalls:" : map (display . Installed.sourcePackageId) newBrokenPkgs ++ if overrideReinstall @@ -585,7 +585,7 @@ checkPrintPlan verbosity installed installPlan sourcePkgDb . filterM (fmap isNothing . checkFetched . packageSource) $ pkgs unless (null notFetched) $ - die $ "Can't download packages in offline mode. " + die' verbosity $ "Can't download packages in offline mode. " ++ "Must download the following packages to proceed:\n" ++ intercalate ", " (map display notFetched) ++ "\nTry using 'cabal fetch'." @@ -843,9 +843,9 @@ postInstallActions verbosity symlinkBinaries verbosity platform comp configFlags installFlags installPlan buildOutcomes - printBuildFailures buildOutcomes + printBuildFailures verbosity buildOutcomes - updateSandboxTimestampsFile useSandbox mSandboxPkgInfo + updateSandboxTimestampsFile verbosity useSandbox mSandboxPkgInfo comp platform installPlan buildOutcomes where @@ -984,12 +984,12 @@ symlinkBinaries verbosity platform comp configFlags installFlags bindir = fromFlag (installSymlinkBinDir installFlags) -printBuildFailures :: BuildOutcomes -> IO () -printBuildFailures buildOutcomes = +printBuildFailures :: Verbosity -> BuildOutcomes -> IO () +printBuildFailures verbosity buildOutcomes = case [ (pkgid, failure) | (pkgid, Left failure) <- Map.toList buildOutcomes ] of [] -> return () - failed -> die . unlines + failed -> die' verbosity . unlines $ "Error: some packages failed to install:" : [ display pkgid ++ printFailureReason reason | (pkgid, reason) <- failed ] @@ -1027,15 +1027,15 @@ printBuildFailures buildOutcomes = -- | If we're working inside a sandbox and some add-source deps were installed, -- update the timestamps of those deps. -updateSandboxTimestampsFile :: UseSandbox -> Maybe SandboxPackageInfo +updateSandboxTimestampsFile :: Verbosity -> UseSandbox -> Maybe SandboxPackageInfo -> Compiler -> Platform -> InstallPlan -> BuildOutcomes -> IO () -updateSandboxTimestampsFile (UseSandbox sandboxDir) +updateSandboxTimestampsFile verbosity (UseSandbox sandboxDir) (Just (SandboxPackageInfo _ _ _ allAddSourceDeps)) comp platform installPlan buildOutcomes = - withUpdateTimestamps sandboxDir (compilerId comp) platform $ \_ -> do + withUpdateTimestamps verbosity sandboxDir (compilerId comp) platform $ \_ -> do let allInstalled = [ pkg | InstallPlan.Configured pkg <- InstallPlan.toList installPlan @@ -1049,7 +1049,7 @@ updateSandboxTimestampsFile (UseSandbox sandboxDir) allPathsCanonical <- mapM tryCanonicalizePath allPaths return $! filter (`S.member` allAddSourceDeps) allPathsCanonical -updateSandboxTimestampsFile _ _ _ _ _ _ = return () +updateSandboxTimestampsFile _ _ _ _ _ _ _ = return () -- ------------------------------------------------------------ -- * Actually do the installations @@ -1314,7 +1314,7 @@ installLocalTarballPackage verbosity pkgid extractTarGzFile tmpDirPath relUnpackedPath tarballPath exists <- doesFileExist descFilePath when (not exists) $ - die $ "Package .cabal file not found: " ++ show descFilePath + die' verbosity $ "Package .cabal file not found: " ++ show descFilePath maybeRenameDistDir absUnpackedPath installPkg (Just absUnpackedPath) @@ -1524,7 +1524,7 @@ installUnpackedPackage verbosity installLock numJobs pkgConfParseFailed :: Installed.PError -> IO a pkgConfParseFailed perror = - die $ "Couldn't parse the output of 'setup register --gen-pkg-config':" + die' verbosity $ "Couldn't parse the output of 'setup register --gen-pkg-config':" ++ show perror maybeLogPath :: IO (Maybe FilePath) diff --git a/cabal-install/Distribution/Client/List.hs b/cabal-install/Distribution/Client/List.hs index 751d28ef277dc5749cf661035fd88be873e345e0..b92151ac0cdc0e784d1be9657e714452a1d0aa7b 100644 --- a/cabal-install/Distribution/Client/List.hs +++ b/cabal-install/Distribution/Client/List.hs @@ -31,7 +31,7 @@ import Distribution.Simple.Compiler ( Compiler, PackageDBStack ) import Distribution.Simple.Program (ProgramDb) import Distribution.Simple.Utils - ( equating, comparing, die, notice ) + ( equating, comparing, die', notice ) import Distribution.Simple.Setup (fromFlag) import Distribution.Simple.PackageIndex (InstalledPackageIndex) import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex @@ -197,7 +197,7 @@ info verbosity packageDBs repoCtxt comp progdb sourcePkgs' userTargets pkgsinfo <- sequence - [ do pkginfo <- either die return $ + [ do pkginfo <- either (die' verbosity) return $ gatherPkgInfo prefs installedPkgIndex sourcePkgIndex pkgSpecifier diff --git a/cabal-install/Distribution/Client/Outdated.hs b/cabal-install/Distribution/Client/Outdated.hs index a5a1bf8438587902e0d96bbb91c53050e52c2089..f853693281fefb5457b4d91210f879093ad2fac9 100644 --- a/cabal-install/Distribution/Client/Outdated.hs +++ b/cabal-install/Distribution/Client/Outdated.hs @@ -32,7 +32,7 @@ import Distribution.PackageDescription.Configuration (finalizePD) import Distribution.Simple.Compiler (Compiler, compilerInfo) import Distribution.Simple.Setup (fromFlagOrDefault) import Distribution.Simple.Utils - (die, notice, debug, tryFindPackageDesc) + (die', notice, debug, tryFindPackageDesc) import Distribution.System (Platform) import Distribution.Text (display) import Distribution.Types.ComponentRequestedSpec (ComponentRequestedSpec(..)) @@ -145,7 +145,7 @@ depsFromPkgDesc verbosity comp platform = do epd = finalizePD [] (ComponentRequestedSpec True True) (const True) platform cinfo [] gpd case epd of - Left _ -> die "finalizePD failed" + Left _ -> die' verbosity "finalizePD failed" Right (pd, _) -> do let bd = buildDepends pd debug verbosity diff --git a/cabal-install/Distribution/Client/ProjectBuilding.hs b/cabal-install/Distribution/Client/ProjectBuilding.hs index 8733dbe8ee1605aec6bf954c123887c2c61e11d7..667c2d0cd6c4bdfccc4785a26dd6fa9ef4350566 100644 --- a/cabal-install/Distribution/Client/ProjectBuilding.hs +++ b/cabal-install/Distribution/Client/ProjectBuilding.hs @@ -796,7 +796,7 @@ unpackPackageTarball verbosity tarball parentdir pkgid pkgTextOverride = -- exists <- doesFileExist cabalFile when (not exists) $ - die $ "Package .cabal file not found in the tarball: " ++ cabalFile + die' verbosity $ "Package .cabal file not found in the tarball: " ++ cabalFile -- Overwrite the .cabal with the one from the index, when appropriate -- @@ -1226,7 +1226,7 @@ withTempInstalledPackageInfoFile verbosity tempdir action = where pkgConfParseFailed :: Installed.PError -> IO a pkgConfParseFailed perror = - die $ "Couldn't parse the output of 'setup register --gen-pkg-config':" + die' verbosity $ "Couldn't parse the output of 'setup register --gen-pkg-config':" ++ show perror readPkgConf pkgConfDir pkgConfFile = do diff --git a/cabal-install/Distribution/Client/ProjectConfig.hs b/cabal-install/Distribution/Client/ProjectConfig.hs index e432afa341fc3ae9e5a322985cbb26319a064c91..be96da88c7d187d4f7e9ddf769739ea995209f0a 100644 --- a/cabal-install/Distribution/Client/ProjectConfig.hs +++ b/cabal-install/Distribution/Client/ProjectConfig.hs @@ -96,7 +96,7 @@ import Distribution.Simple.InstallDirs ( PathTemplate, fromPathTemplate , toPathTemplate, substPathTemplate, initialPathTemplateEnv ) import Distribution.Simple.Utils - ( die, warn ) + ( die', warn ) import Distribution.Client.Utils ( determineNumJobs ) import Distribution.Utils.NubList @@ -535,9 +535,9 @@ reportParseResult verbosity _filetype filename (ParseOk warnings x) = do let msg = unlines (map (showPWarning filename) warnings) in warn verbosity msg return x -reportParseResult _verbosity filetype filename (ParseFailed err) = +reportParseResult verbosity filetype filename (ParseFailed err) = let (line, msg) = locatedErrorMsg err - in die $ "Error parsing " ++ filetype ++ " " ++ filename + in die' verbosity $ "Error parsing " ++ filetype ++ " " ++ filename ++ maybe "" (\n -> ':' : show n) line ++ ":\n" ++ msg diff --git a/cabal-install/Distribution/Client/ProjectOrchestration.hs b/cabal-install/Distribution/Client/ProjectOrchestration.hs index e888b1f2115e6c0aee46af35c09e5e1ec0e52728..8847fc987e3327dfdbb3015ecb67f13083cca5c7 100644 --- a/cabal-install/Distribution/Client/ProjectOrchestration.hs +++ b/cabal-install/Distribution/Client/ProjectOrchestration.hs @@ -83,7 +83,7 @@ import qualified Distribution.Simple.Setup as Setup import Distribution.Simple.Command (commandShowOptions) import Distribution.Simple.Utils - ( die, dieMsg, dieMsgNoWrap, info + ( die', info , notice, noticeNoWrap, debug, debugNoWrap ) import Distribution.Verbosity import Distribution.Text @@ -351,7 +351,7 @@ selectTargets verbosity targetDefaultComponents targetSpecificComponent -- Match the user targets against the available targets. If no targets are -- given this uses the package in the current directory, if any. -- - buildTargets <- resolveUserBuildTargets localPackages userBuildTargets + buildTargets <- resolveUserBuildTargets verbosity localPackages userBuildTargets --TODO: [required eventually] report something if there are no targets --TODO: [required eventually] @@ -366,7 +366,7 @@ selectTargets verbosity targetDefaultComponents targetSpecificComponent -- project, but for now we just bail. This gives us back the ipkgid from -- the plan. -- - buildTargets' <- either reportBuildTargetProblems return + buildTargets' <- either (reportBuildTargetProblems verbosity) return $ resolveAndCheckTargets targetDefaultComponents targetSpecificComponent @@ -474,8 +474,8 @@ data BuildTargetProblem -- ^ @True@: explicitly disabled by user -- @False@: disabled by solver -reportBuildTargetProblems :: [BuildTargetProblem] -> IO a -reportBuildTargetProblems = die . unlines . map reportBuildTargetProblem +reportBuildTargetProblems :: Verbosity -> [BuildTargetProblem] -> IO a +reportBuildTargetProblems verbosity = die' verbosity . unlines . map reportBuildTargetProblem reportBuildTargetProblem :: BuildTargetProblem -> String reportBuildTargetProblem (BuildTargetNotInProject pn) = @@ -641,18 +641,17 @@ dieOnBuildFailures verbosity plan buildOutcomes | otherwise = do -- For failures where we have a build log, print the log plus a header sequence_ - [ do dieMsg verbosity $ + [ do notice verbosity $ '\n' : renderFailureDetail False pkg reason ++ "\nBuild log ( " ++ logfile ++ " ):" - readFile logfile >>= dieMsgNoWrap verbosity - | verbosity >= normal - , (pkg, ShowBuildSummaryAndLog reason logfile) + readFile logfile >>= noticeNoWrap verbosity + | (pkg, ShowBuildSummaryAndLog reason logfile) <- failuresClassification ] -- For all failures, print either a short summary (if we showed the -- build log) or all details - die $ unlines + die' verbosity $ unlines [ case failureClassification of ShowBuildSummaryAndLog reason _ | verbosity > normal diff --git a/cabal-install/Distribution/Client/ProjectPlanning.hs b/cabal-install/Distribution/Client/ProjectPlanning.hs index 672f143ac0c154eb640a3abf41830da56a5ae363..515a8d5a195d9013edc9c6e6713083bb7d33a96b 100644 --- a/cabal-install/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/Distribution/Client/ProjectPlanning.hs @@ -516,7 +516,7 @@ rebuildInstallPlan verbosity (compilerInfo compiler) notice verbosity "Resolving dependencies..." - plan <- foldProgress logMsg die return $ + plan <- foldProgress logMsg (die' verbosity) return $ planPackages verbosity compiler platform solver solverSettings installedPkgIndex sourcePkgDb pkgConfigDB localPackages localPackagesEnabledStanzas diff --git a/cabal-install/Distribution/Client/Run.hs b/cabal-install/Distribution/Client/Run.hs index 10eb3dd7a8bd63f3600f42980d79f9a128c1ee1d..0279074846c9a80a450ea3d893b5f44b36a00a30 100644 --- a/cabal-install/Distribution/Client/Run.hs +++ b/cabal-install/Distribution/Client/Run.hs @@ -30,7 +30,7 @@ import Distribution.Simple.BuildPaths (exeExtension) import Distribution.Simple.LocalBuildInfo (ComponentName (..), LocalBuildInfo (..), depLibraryPaths) -import Distribution.Simple.Utils (die, notice, warn, +import Distribution.Simple.Utils (die', notice, warn, rawSystemExitWithEnv, addLibraryPath) import Distribution.System (Platform (..)) @@ -52,7 +52,7 @@ splitRunArgs verbosity lbi args = case whichExecutable of -- Either err (wasManuallyChosen, exe, paramsRest) Left err -> do warn verbosity `traverse_` maybeWarning -- If there is a warning, print it. - die err + die' verbosity err Right (True, exe, xs) -> return (exe, xs) Right (False, exe, xs) -> do let addition = " Interpreting all parameters to `run` as a parameter to" @@ -134,8 +134,8 @@ run verbosity lbi exe exeArgs = do then do let (Platform _ os) = hostPlatform lbi clbi <- case componentNameTargets' pkg_descr lbi (CExeName (exeName exe)) of [target] -> return (targetCLBI target) - [] -> die "run: Could not find executable in LocalBuildInfo" - _ -> die "run: Found multiple matching exes in LocalBuildInfo" + [] -> die' verbosity "run: Could not find executable in LocalBuildInfo" + _ -> die' verbosity "run: Found multiple matching exes in LocalBuildInfo" paths <- depLibraryPaths True False lbi clbi return (addLibraryPath os paths env) else return env diff --git a/cabal-install/Distribution/Client/Sandbox.hs b/cabal-install/Distribution/Client/Sandbox.hs index 50fbf6e5a3f14fc7e185411952dcc56667b1b135..3616ecfe8ff3e1477cba13a67c659ff208553f12 100644 --- a/cabal-install/Distribution/Client/Sandbox.hs +++ b/cabal-install/Distribution/Client/Sandbox.hs @@ -97,7 +97,7 @@ import Distribution.Simple.Program ( ProgramDb ) import Distribution.Simple.Setup ( Flag(..), HaddockFlags(..) , fromFlagOrDefault, flagToMaybe ) import Distribution.Simple.SrcDist ( prepareTree ) -import Distribution.Simple.Utils ( die, debug, notice, info, warn +import Distribution.Simple.Utils ( die', debug, notice, info, warn , debugNoWrap, defaultPackageDesc , topHandlerWith , createDirectoryIfMissingVerbose ) @@ -211,16 +211,16 @@ tryLoadSandboxConfig verbosity globalFlags = do (globalConfigFile globalFlags) -- | Return the name of the package index file for this package environment. -tryGetIndexFilePath :: SavedConfig -> IO FilePath -tryGetIndexFilePath config = tryGetIndexFilePath' (savedGlobalFlags config) +tryGetIndexFilePath :: Verbosity -> SavedConfig -> IO FilePath +tryGetIndexFilePath verbosity config = tryGetIndexFilePath' verbosity (savedGlobalFlags config) -- | The same as 'tryGetIndexFilePath', but takes 'GlobalFlags' instead of -- 'SavedConfig'. -tryGetIndexFilePath' :: GlobalFlags -> IO FilePath -tryGetIndexFilePath' globalFlags = do +tryGetIndexFilePath' :: Verbosity -> GlobalFlags -> IO FilePath +tryGetIndexFilePath' verbosity globalFlags = do let paths = fromNubList $ globalLocalRepos globalFlags case paths of - [] -> die $ "Distribution.Client.Sandbox.tryGetIndexFilePath: " ++ + [] -> die' verbosity $ "Distribution.Client.Sandbox.tryGetIndexFilePath: " ++ "no local repos found. " ++ checkConfiguration _ -> return $ (last paths) </> Index.defaultIndexFileName where @@ -229,19 +229,19 @@ tryGetIndexFilePath' globalFlags = do -- | Try to extract a 'PackageDB' from 'ConfigFlags'. Gives a better error -- message than just pattern-matching. -getSandboxPackageDB :: ConfigFlags -> IO PackageDB -getSandboxPackageDB configFlags = do +getSandboxPackageDB :: Verbosity -> ConfigFlags -> IO PackageDB +getSandboxPackageDB verbosity configFlags = do case configPackageDBs configFlags of [Just sandboxDB@(SpecificPackageDB _)] -> return sandboxDB -- TODO: should we allow multiple package DBs (e.g. with 'inherit')? [] -> - die $ "Sandbox package DB is not specified. " ++ sandboxConfigCorrupt + die' verbosity $ "Sandbox package DB is not specified. " ++ sandboxConfigCorrupt [_] -> - die $ "Unexpected contents of the 'package-db' field. " + die' verbosity $ "Unexpected contents of the 'package-db' field. " ++ sandboxConfigCorrupt _ -> - die $ "Too many package DBs provided. " ++ sandboxConfigCorrupt + die' verbosity $ "Too many package DBs provided. " ++ sandboxConfigCorrupt where sandboxConfigCorrupt = "Your 'cabal.sandbox.config' is probably corrupt." @@ -252,7 +252,7 @@ getInstalledPackagesInSandbox :: Verbosity -> ConfigFlags -> Compiler -> ProgramDb -> IO InstalledPackageIndex getInstalledPackagesInSandbox verbosity configFlags comp progdb = do - sandboxDB <- getSandboxPackageDB configFlags + sandboxDB <- getSandboxPackageDB verbosity configFlags getPackageDBContents verbosity comp sandboxDB progdb -- | Temporarily add $SANDBOX_DIR/bin to $PATH. @@ -284,7 +284,7 @@ initPackageDBIfNeeded :: Verbosity -> ConfigFlags -> Compiler -> ProgramDb -> IO () initPackageDBIfNeeded verbosity configFlags comp progdb = do - SpecificPackageDB dbPath <- getSandboxPackageDB configFlags + SpecificPackageDB dbPath <- getSandboxPackageDB verbosity configFlags packageDBExists <- doesDirectoryExist dbPath unless packageDBExists $ Register.initPackageDB verbosity comp progdb dbPath @@ -329,7 +329,7 @@ sandboxInit verbosity sandboxFlags globalFlags = do configFlags = savedConfigureFlags config -- Create the index file if it doesn't exist. - indexFile <- tryGetIndexFilePath config + indexFile <- tryGetIndexFilePath verbosity config indexFileExists <- doesFileExist indexFile if indexFileExists then notice verbosity $ "Using an existing sandbox located at " ++ sandboxDir @@ -368,7 +368,7 @@ sandboxDelete verbosity _sandboxFlags globalFlags = do curDir </> defaultSandboxLocation when isNonDefaultSandboxLocation $ - die $ "Non-default sandbox location used: '" ++ sandboxDir + die' verbosity $ "Non-default sandbox location used: '" ++ sandboxDir ++ "'.\nAssuming a shared sandbox. Please delete '" ++ sandboxDir ++ "' manually." @@ -400,7 +400,7 @@ doAddSource :: Verbosity -> [FilePath] -> FilePath -> PackageEnvironment -> IO () doAddSource verbosity buildTreeRefs sandboxDir pkgEnv refType = do let savedConfig = pkgEnvSavedConfig pkgEnv - indexFile <- tryGetIndexFilePath savedConfig + indexFile <- tryGetIndexFilePath verbosity savedConfig -- If we're running 'sandbox add-source' for the first time for this compiler, -- we need to create an initial timestamp record. @@ -408,7 +408,7 @@ doAddSource verbosity buildTreeRefs sandboxDir pkgEnv refType = do maybeAddCompilerTimestampRecord verbosity sandboxDir indexFile (compilerId comp) platform - withAddTimestamps sandboxDir $ do + withAddTimestamps verbosity sandboxDir $ do -- Path canonicalisation is done in addBuildTreeRefs, but we do it -- twice because of the timestamps file. buildTreeRefs' <- mapM tryCanonicalizePath buildTreeRefs @@ -475,7 +475,7 @@ sandboxDeleteSource :: Verbosity -> [FilePath] -> SandboxFlags -> GlobalFlags -> IO () sandboxDeleteSource verbosity buildTreeRefs _sandboxFlags globalFlags = do (sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags - indexFile <- tryGetIndexFilePath (pkgEnvSavedConfig pkgEnv) + indexFile <- tryGetIndexFilePath verbosity (pkgEnvSavedConfig pkgEnv) (results, convDict) <- Index.removeBuildTreeRefs verbosity indexFile buildTreeRefs @@ -484,7 +484,7 @@ sandboxDeleteSource verbosity buildTreeRefs _sandboxFlags globalFlags = do removedRefs = fmap convDict removedPaths unless (null removedPaths) $ do - removeTimestamps sandboxDir removedPaths + removeTimestamps verbosity sandboxDir removedPaths notice verbosity $ "Success deleting sources: " ++ showL removedRefs ++ "\n\n" @@ -492,7 +492,7 @@ sandboxDeleteSource verbosity buildTreeRefs _sandboxFlags globalFlags = do unless (null failedPaths) $ do let groupedFailures = groupBy errorType failedPaths mapM_ handleErrors groupedFailures - die $ "The sources with the above errors were skipped. (" ++ + die' verbosity $ "The sources with the above errors were skipped. (" ++ showL (fmap getPath failedPaths) ++ ")" notice verbosity $ "Note: 'sandbox delete-source' only unregisters the " ++ @@ -530,7 +530,7 @@ sandboxListSources :: Verbosity -> SandboxFlags -> GlobalFlags -> IO () sandboxListSources verbosity _sandboxFlags globalFlags = do (sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags - indexFile <- tryGetIndexFilePath (pkgEnvSavedConfig pkgEnv) + indexFile <- tryGetIndexFilePath verbosity (pkgEnvSavedConfig pkgEnv) refs <- Index.listBuildTreeRefs verbosity Index.ListIgnored Index.LinksAndSnapshots indexFile @@ -636,7 +636,7 @@ loadConfigOrSandboxConfig verbosity globalFlags = do flag = (globalRequireSandbox . savedGlobalFlags $ config) `mappend` (globalRequireSandbox globalFlags) checkFlag (Flag True) = - die $ "'require-sandbox' is set to True, but no sandbox is present. " + die' verbosity $ "'require-sandbox' is set to True, but no sandbox is present. " ++ "Use '--no-require-sandbox' if you want to override " ++ "'require-sandbox' temporarily." checkFlag (Flag False) = return () @@ -695,7 +695,7 @@ reinstallAddSourceDeps verbosity configFlags' configExFlags -- might want to use some lower-level features this in the future. withSandboxBinDirOnSearchPath sandboxDir $ do installContext <- makeInstallContext verbosity args Nothing - installPlan <- foldProgress logMsg die' return =<< + installPlan <- foldProgress logMsg die'' return =<< makeInstallPlan verbosity args installContext processInstallPlan verbosity args installContext installPlan @@ -704,7 +704,7 @@ reinstallAddSourceDeps verbosity configFlags' configExFlags readIORef retVal where - die' message = die (message ++ installFailedInSandbox) + die'' message = die' verbosity (message ++ installFailedInSandbox) -- TODO: use a better error message, remove duplication. installFailedInSandbox = "Note: when using a sandbox, all packages are required to have " @@ -729,7 +729,7 @@ withSandboxPackageInfo :: Verbosity -> ConfigFlags -> GlobalFlags withSandboxPackageInfo verbosity configFlags globalFlags comp platform progdb sandboxDir cont = do -- List all add-source deps. - indexFile <- tryGetIndexFilePath' globalFlags + indexFile <- tryGetIndexFilePath' verbosity globalFlags buildTreeRefs <- Index.listBuildTreeRefs verbosity Index.DontListIgnored Index.OnlyLinks indexFile let allAddSourceDepsSet = S.fromList buildTreeRefs @@ -739,7 +739,7 @@ withSandboxPackageInfo verbosity configFlags globalFlags configFlags comp progdb let err = "Error reading sandbox package information." -- Get the package descriptions for all add-source deps. - depsCabalFiles <- mapM (flip tryFindAddSourcePackageDesc err) buildTreeRefs + depsCabalFiles <- mapM (flip (tryFindAddSourcePackageDesc verbosity) err) buildTreeRefs depsPkgDescs <- mapM (readGenericPackageDescription verbosity) depsCabalFiles let depsMap = M.fromList (zip buildTreeRefs depsPkgDescs) isInstalled pkgid = not . null diff --git a/cabal-install/Distribution/Client/Sandbox/Index.hs b/cabal-install/Distribution/Client/Sandbox/Index.hs index e96d8cd6cb02e866de507c432d678dee7e22000c..2105cedc205892b66f89dfef95305b73c3cb4c0c 100644 --- a/cabal-install/Distribution/Client/Sandbox/Index.hs +++ b/cabal-install/Distribution/Client/Sandbox/Index.hs @@ -34,7 +34,7 @@ import Distribution.Client.Utils ( byteStringToFilePath, filePathToByteString , makeAbsoluteToCwd, tryCanonicalizePath , tryFindAddSourcePackageDesc ) -import Distribution.Simple.Utils ( die, debug ) +import Distribution.Simple.Utils ( die', debug ) import Distribution.Compat.Exception ( tryIO ) import Distribution.Verbosity ( Verbosity ) @@ -61,12 +61,12 @@ defaultIndexFileName :: FilePath defaultIndexFileName = "00-index.tar" -- | Given a path, ensure that it refers to a local build tree. -buildTreeRefFromPath :: BuildTreeRefType -> FilePath -> IO (Maybe BuildTreeRef) -buildTreeRefFromPath refType dir = do +buildTreeRefFromPath :: Verbosity -> BuildTreeRefType -> FilePath -> IO (Maybe BuildTreeRef) +buildTreeRefFromPath verbosity refType dir = do dirExists <- doesDirectoryExist dir unless dirExists $ - die $ "directory '" ++ dir ++ "' does not exist" - _ <- tryFindAddSourcePackageDesc dir "Error adding source reference." + die' verbosity $ "directory '" ++ dir ++ "' does not exist" + _ <- tryFindAddSourcePackageDesc verbosity dir "Error adding source reference." return . Just $ BuildTreeRef refType dir -- | Given a tar archive entry, try to parse it as a local build tree reference. @@ -120,14 +120,14 @@ writeBuildTreeRef (BuildTreeRef refType path) = Tar.simpleEntry tarPath content -- | Check that the provided path is either an existing directory, or a tar -- archive in an existing directory. -validateIndexPath :: FilePath -> IO FilePath -validateIndexPath path' = do +validateIndexPath :: Verbosity -> FilePath -> IO FilePath +validateIndexPath verbosity path' = do path <- makeAbsoluteToCwd path' if (== ".tar") . takeExtension $ path then return path else do dirExists <- doesDirectoryExist path unless dirExists $ - die $ "directory does not exist: '" ++ path ++ "'" + die' verbosity $ "directory does not exist: '" ++ path ++ "'" return $ path </> defaultIndexFileName -- | Create an empty index file. @@ -149,11 +149,11 @@ addBuildTreeRefs :: Verbosity -> FilePath -> [FilePath] -> BuildTreeRefType addBuildTreeRefs _ _ [] _ = error "Distribution.Client.Sandbox.Index.addBuildTreeRefs: unexpected" addBuildTreeRefs verbosity path l' refType = do - checkIndexExists path + checkIndexExists verbosity path l <- liftM nub . mapM tryCanonicalizePath $ l' treesInIndex <- fmap (map buildTreePath) (readBuildTreeRefsFromFile path) -- Add only those paths that aren't already in the index. - treesToAdd <- mapM (buildTreeRefFromPath refType) (l \\ treesInIndex) + treesToAdd <- mapM (buildTreeRefFromPath verbosity refType) (l \\ treesInIndex) let entries = map writeBuildTreeRef (catMaybes treesToAdd) unless (null entries) $ do withBinaryFile path ReadWriteMode $ \h -> do @@ -176,7 +176,7 @@ removeBuildTreeRefs :: Verbosity -> FilePath -> [FilePath] removeBuildTreeRefs _ _ [] = error "Distribution.Client.Sandbox.Index.removeBuildTreeRefs: unexpected" removeBuildTreeRefs verbosity indexPath l = do - checkIndexExists indexPath + checkIndexExists verbosity indexPath let tmpFile = indexPath <.> "tmp" canonRes <- mapM (\btr -> do res <- tryIO $ canonicalizePath btr @@ -240,7 +240,7 @@ listBuildTreeRefs :: Verbosity -> ListIgnoredBuildTreeRefs -> RefTypesToList -> FilePath -> IO [FilePath] listBuildTreeRefs verbosity listIgnored refTypesToList path = do - checkIndexExists path + checkIndexExists verbosity path buildTreeRefs <- case listIgnored of DontListIgnored -> do @@ -274,8 +274,8 @@ listBuildTreeRefs verbosity listIgnored refTypesToList path = do -- | Check that the package index file exists and exit with error if it does not. -checkIndexExists :: FilePath -> IO () -checkIndexExists path = do +checkIndexExists :: Verbosity -> FilePath -> IO () +checkIndexExists verbosity path = do indexExists <- doesFileExist path unless indexExists $ - die $ "index does not exist: '" ++ path ++ "'" + die' verbosity $ "index does not exist: '" ++ path ++ "'" diff --git a/cabal-install/Distribution/Client/Sandbox/PackageEnvironment.hs b/cabal-install/Distribution/Client/Sandbox/PackageEnvironment.hs index b059faa9dab9b101e2b6e7df8076196d02ab23a8..059553d72a9655a3568341e83759a71d8e3b3d96 100644 --- a/cabal-install/Distribution/Client/Sandbox/PackageEnvironment.hs +++ b/cabal-install/Distribution/Client/Sandbox/PackageEnvironment.hs @@ -50,7 +50,7 @@ import Distribution.Simple.InstallDirs ( InstallDirs(..), PathTemplate import Distribution.Simple.Setup ( Flag(..) , ConfigFlags(..), HaddockFlags(..) , fromFlagOrDefault, toFlag, flagToMaybe ) -import Distribution.Simple.Utils ( die, info, notice, warn, debug ) +import Distribution.Simple.Utils ( die', info, notice, warn, debug ) import Distribution.Solver.Types.ConstraintSource import Distribution.ParseUtils ( FieldDescr(..), ParseResult(..) , commaListField, commaNewLineListField @@ -319,7 +319,7 @@ handleParseResult :: Verbosity -> FilePath -> IO PackageEnvironment handleParseResult verbosity path minp = case minp of - Nothing -> die $ + Nothing -> die' verbosity $ "The package environment file '" ++ path ++ "' doesn't exist" Just (ParseOk warns parseResult) -> do when (not $ null warns) $ warn verbosity $ @@ -327,7 +327,7 @@ handleParseResult verbosity path minp = return parseResult Just (ParseFailed err) -> do let (line, msg) = locatedErrorMsg err - die $ "Error parsing package environment file " ++ path + die' verbosity $ "Error parsing package environment file " ++ path ++ maybe "" (\n -> ":" ++ show n) line ++ ":\n" ++ msg -- | Try to load the given package environment file, exiting with error if it @@ -352,7 +352,7 @@ tryLoadSandboxPackageEnvironmentFile verbosity pkgEnvFile configFileFlag = do dirExists <- doesDirectoryExist sandboxDir -- TODO: Also check for an initialised package DB? unless dirExists $ - die ("No sandbox exists at " ++ sandboxDir) + die' verbosity ("No sandbox exists at " ++ sandboxDir) info verbosity $ "Using a sandbox located at " ++ sandboxDir let base = basePackageEnvironment diff --git a/cabal-install/Distribution/Client/Sandbox/Timestamp.hs b/cabal-install/Distribution/Client/Sandbox/Timestamp.hs index 576a49b304430c57340fd5951ea7d33f563cbfe2..66a63ffc051dc48c6fee6f34f79399e5fca209f6 100644 --- a/cabal-install/Distribution/Client/Sandbox/Timestamp.hs +++ b/cabal-install/Distribution/Client/Sandbox/Timestamp.hs @@ -29,7 +29,7 @@ import System.FilePath ((<.>), (</>)) import qualified Data.Map as M import Distribution.Compiler (CompilerId) -import Distribution.Simple.Utils (debug, die, warn) +import Distribution.Simple.Utils (debug, die', warn) import Distribution.System (Platform) import Distribution.Text (display) import Distribution.Verbosity (Verbosity) @@ -67,8 +67,8 @@ timestampFileName = "add-source-timestamps" -- | Read the timestamp file. Exits with error if the timestamp file is -- corrupted. Returns an empty list if the file doesn't exist. -readTimestampFile :: FilePath -> IO [TimestampFileRecord] -readTimestampFile timestampFile = do +readTimestampFile :: Verbosity -> FilePath -> IO [TimestampFileRecord] +readTimestampFile verbosity timestampFile = do timestampString <- readFile timestampFile `catchIO` \_ -> return "[]" case reads timestampString of [(version, s)] @@ -91,8 +91,8 @@ readTimestampFile timestampFile = do _ -> dieCorrupted _ -> dieCorrupted where - dieWrongFormat = die $ wrongFormat ++ deleteAndRecreate - dieCorrupted = die $ corrupted ++ deleteAndRecreate + dieWrongFormat = die' verbosity $ wrongFormat ++ deleteAndRecreate + dieCorrupted = die' verbosity $ corrupted ++ deleteAndRecreate wrongFormat = "The timestamps file is in the wrong format." corrupted = "The timestamps file is corrupted." deleteAndRecreate = " Please delete and recreate the sandbox." @@ -107,12 +107,12 @@ writeTimestampFile timestampFile timestamps = do timestampTmpFile = timestampFile <.> "tmp" -- | Read, process and write the timestamp file in one go. -withTimestampFile :: FilePath +withTimestampFile :: Verbosity -> FilePath -> ([TimestampFileRecord] -> IO [TimestampFileRecord]) -> IO () -withTimestampFile sandboxDir process = do +withTimestampFile verbosity sandboxDir process = do let timestampFile = sandboxDir </> timestampFileName - timestampRecords <- readTimestampFile timestampFile >>= process + timestampRecords <- readTimestampFile verbosity timestampFile >>= process writeTimestampFile timestampFile timestampRecords -- | Given a list of 'AddSourceTimestamp's, a list of paths to add-source deps @@ -156,7 +156,7 @@ maybeAddCompilerTimestampRecord :: Verbosity -> FilePath -> FilePath maybeAddCompilerTimestampRecord verbosity sandboxDir indexFile compId platform = do let key = timestampRecordKey compId platform - withTimestampFile sandboxDir $ \timestampRecords -> do + withTimestampFile verbosity sandboxDir $ \timestampRecords -> do case lookup key timestampRecords of Just _ -> return timestampRecords Nothing -> do @@ -168,21 +168,21 @@ maybeAddCompilerTimestampRecord verbosity sandboxDir indexFile -- | Given an IO action that returns a list of build tree refs, add those -- build tree refs to the timestamps file (for all compilers). -withAddTimestamps :: FilePath -> IO [FilePath] -> IO () -withAddTimestamps sandboxDir act = do +withAddTimestamps :: Verbosity -> FilePath -> IO [FilePath] -> IO () +withAddTimestamps verbosity sandboxDir act = do let initialTimestamp = minBound - withActionOnAllTimestamps (addTimestamps initialTimestamp) sandboxDir act + withActionOnAllTimestamps (addTimestamps initialTimestamp) verbosity sandboxDir act -- | Given a list of build tree refs, remove those -- build tree refs from the timestamps file (for all compilers). -removeTimestamps :: FilePath -> [FilePath] -> IO () -removeTimestamps idxFile = - withActionOnAllTimestamps removeTimestamps' idxFile . return +removeTimestamps :: Verbosity -> FilePath -> [FilePath] -> IO () +removeTimestamps verbosity idxFile = + withActionOnAllTimestamps removeTimestamps' verbosity idxFile . return -- | Given an IO action that returns a list of build tree refs, update the -- timestamps of the returned build tree refs to the current time (only for the -- given compiler & platform). -withUpdateTimestamps :: FilePath -> CompilerId -> Platform +withUpdateTimestamps :: Verbosity -> FilePath -> CompilerId -> Platform ->([AddSourceTimestamp] -> IO [FilePath]) -> IO () withUpdateTimestamps = @@ -194,11 +194,12 @@ withUpdateTimestamps = -- updates the timestamp file. The IO action is run only once. withActionOnAllTimestamps :: ([AddSourceTimestamp] -> [FilePath] -> [AddSourceTimestamp]) + -> Verbosity -> FilePath -> IO [FilePath] -> IO () -withActionOnAllTimestamps f sandboxDir act = - withTimestampFile sandboxDir $ \timestampRecords -> do +withActionOnAllTimestamps f verbosity sandboxDir act = + withTimestampFile verbosity sandboxDir $ \timestampRecords -> do paths <- act return [(key, f timestamps paths) | (key, timestamps) <- timestampRecords] @@ -208,14 +209,15 @@ withActionOnAllTimestamps f sandboxDir act = withActionOnCompilerTimestamps :: ([AddSourceTimestamp] -> [FilePath] -> ModTime -> [AddSourceTimestamp]) + -> Verbosity -> FilePath -> CompilerId -> Platform -> ([AddSourceTimestamp] -> IO [FilePath]) -> IO () -withActionOnCompilerTimestamps f sandboxDir compId platform act = do +withActionOnCompilerTimestamps f verbosity sandboxDir compId platform act = do let needle = timestampRecordKey compId platform - withTimestampFile sandboxDir $ \timestampRecords -> do + withTimestampFile verbosity sandboxDir $ \timestampRecords -> do timestampRecords' <- forM timestampRecords $ \r@(key, timestamps) -> if key == needle then do paths <- act timestamps @@ -255,7 +257,7 @@ listModifiedDeps :: Verbosity -> FilePath -> CompilerId -> Platform -- ^ The set of all installed add-source deps. -> IO [FilePath] listModifiedDeps verbosity sandboxDir compId platform installedDepsMap = do - timestampRecords <- readTimestampFile (sandboxDir </> timestampFileName) + timestampRecords <- readTimestampFile verbosity (sandboxDir </> timestampFileName) let needle = timestampRecordKey compId platform timestamps <- maybe noTimestampRecord return (lookup needle timestampRecords) @@ -265,7 +267,7 @@ listModifiedDeps verbosity sandboxDir compId platform installedDepsMap = do $ timestamps where - noTimestampRecord = die $ "Сouldn't find a timestamp record for the given " + noTimestampRecord = die' verbosity $ "Сouldn't find a timestamp record for the given " ++ "compiler/platform pair. " ++ "Please report this on the Cabal bug tracker: " ++ "https://github.com/haskell/cabal/issues/new ." diff --git a/cabal-install/Distribution/Client/SetupWrapper.hs b/cabal-install/Distribution/Client/SetupWrapper.hs index 44fa1407ea9d8d86db46cdc5f9c71e2afb1088c4..5b0f47cc4867164c5330ae7d65ff9b22c6e15439 100644 --- a/cabal-install/Distribution/Client/SetupWrapper.hs +++ b/cabal-install/Distribution/Client/SetupWrapper.hs @@ -86,7 +86,7 @@ import Distribution.Client.JobControl import Distribution.Simple.Setup ( Flag(..) ) import Distribution.Simple.Utils - ( die, debug, info, infoNoWrap, cabalVersion, tryFindPackageDesc, comparing + ( die', debug, info, infoNoWrap, cabalVersion, tryFindPackageDesc, comparing , createDirectoryIfMissingVerbose, installExecutableFile , copyFileVerbose, rewriteFile ) import Distribution.Client.Utils @@ -314,7 +314,7 @@ getSetup verbosity options mpkg = do >>= return . packageDescription checkBuildType (UnknownBuildType name) = - die $ "The build-type '" ++ name ++ "' is not known. Use one of: " + die' verbosity $ "The build-type '" ++ name ++ "' is not known. Use one of: " ++ intercalate ", " (map display knownBuildTypes) ++ "." checkBuildType _ = return () @@ -680,7 +680,7 @@ getExternalSetupMethod verbosity options pkg bt = do updateSetupScript _ Custom = do useHs <- doesFileExist customSetupHs useLhs <- doesFileExist customSetupLhs - unless (useHs || useLhs) $ die + unless (useHs || useLhs) $ die' verbosity "Using 'build-type: Custom' but there is no Setup.hs or Setup.lhs script." let src = (if useHs then customSetupHs else customSetupLhs) srcNewer <- src `moreRecentFile` setupHs @@ -713,7 +713,7 @@ getExternalSetupMethod verbosity options pkg bt = do let cabalDep = Dependency (mkPackageName "Cabal") (useCabalVersion options') options'' = options' { usePackageIndex = Just index } case PackageIndex.lookupDependency index cabalDep of - [] -> die $ "The package '" ++ display (packageName pkg) + [] -> die' verbosity $ "The package '" ++ display (packageName pkg) ++ "' requires Cabal library version " ++ display (useCabalVersion options) ++ " but no suitable version is installed." diff --git a/cabal-install/Distribution/Client/SrcDist.hs b/cabal-install/Distribution/Client/SrcDist.hs index e656c7fb1a59662f468520e19244aa7503a04061..99d0023e4ef629bbd8371d5922441725ae0df09f 100644 --- a/cabal-install/Distribution/Client/SrcDist.hs +++ b/cabal-install/Distribution/Client/SrcDist.hs @@ -29,7 +29,7 @@ import Distribution.PackageDescription.Parse #endif import Distribution.Simple.Utils ( createDirectoryIfMissingVerbose, defaultPackageDesc - , warn, die, notice, withTempDirectory ) + , warn, die', notice, withTempDirectory ) import Distribution.Client.Setup ( SDistFlags(..), SDistExFlags(..), ArchiveFormat(..) ) import Distribution.Simple.Setup @@ -148,7 +148,7 @@ createZipArchive verbosity pkg tmpDir targetPref = do Nothing Nothing Nothing Nothing exitCode <- waitForProcess hnd unless (exitCode == ExitSuccess) $ - die $ "Generating the zip file failed " + die' verbosity $ "Generating the zip file failed " ++ "(zip returned exit code " ++ show exitCode ++ ")" notice verbosity $ "Source zip archive created: " ++ zipfile where @@ -161,7 +161,7 @@ allPackageSourceFiles :: Verbosity -> SetupScriptOptions -> FilePath allPackageSourceFiles verbosity setupOpts0 packageDir = do pkg <- do let err = "Error reading source files of package." - desc <- tryFindAddSourcePackageDesc packageDir err + desc <- tryFindAddSourcePackageDesc verbosity packageDir err flattenPackageDescription `fmap` readGenericPackageDescription verbosity desc globalTmp <- getTemporaryDirectory withTempDirectory verbosity globalTmp "cabal-list-sources." $ \tempDir -> do diff --git a/cabal-install/Distribution/Client/Targets.hs b/cabal-install/Distribution/Client/Targets.hs index 5557f56a618bccbc6ca1d017283e421ad9fc1ab5..52c1fa7a916d51a88989fec430c934ea981b01b5 100644 --- a/cabal-install/Distribution/Client/Targets.hs +++ b/cabal-install/Distribution/Client/Targets.hs @@ -89,7 +89,7 @@ import Distribution.Text ( Text(..), display ) import Distribution.Verbosity (Verbosity) import Distribution.Simple.Utils - ( die, warn, lowercase ) + ( die', warn, lowercase ) #ifdef CABAL_PARSEC import Distribution.PackageDescription.Parsec @@ -223,10 +223,10 @@ pkgSpecifierConstraints (SpecificSourcePackage pkg) = -- ------------------------------------------------------------ readUserTargets :: Verbosity -> [String] -> IO [UserTarget] -readUserTargets _verbosity targetStrs = do +readUserTargets verbosity targetStrs = do (problems, targets) <- liftM partitionEithers (mapM readUserTarget targetStrs) - reportUserTargetProblems problems + reportUserTargetProblems verbosity problems return targets @@ -314,11 +314,11 @@ readUserTarget targetstr = | otherwise -> Dependency (packageName p) (thisVersion v) -reportUserTargetProblems :: [UserTargetProblem] -> IO () -reportUserTargetProblems problems = do +reportUserTargetProblems :: Verbosity -> [UserTargetProblem] -> IO () +reportUserTargetProblems verbosity problems = do case [ target | UserTargetUnrecognised target <- problems ] of [] -> return () - target -> die + target -> die' verbosity $ unlines [ "Unrecognised target '" ++ name ++ "'." | name <- target ] @@ -330,18 +330,18 @@ reportUserTargetProblems problems = do case [ () | UserTargetBadWorldPkg <- problems ] of [] -> return () - _ -> die "The special 'world' target does not take any version." + _ -> die' verbosity "The special 'world' target does not take any version." case [ target | UserTargetNonexistantFile target <- problems ] of [] -> return () - target -> die + target -> die' verbosity $ unlines [ "The file does not exist '" ++ name ++ "'." | name <- target ] case [ target | UserTargetUnexpectedFile target <- problems ] of [] -> return () - target -> die + target -> die' verbosity $ unlines [ "Unrecognised file target '" ++ name ++ "'." | name <- target ] @@ -350,7 +350,7 @@ reportUserTargetProblems problems = do case [ target | UserTargetUnexpectedUriScheme target <- problems ] of [] -> return () - target -> die + target -> die' verbosity $ unlines [ "URL target not supported '" ++ name ++ "'." | name <- target ] @@ -358,7 +358,7 @@ reportUserTargetProblems problems = do case [ target | UserTargetUnrecognisedUri target <- problems ] of [] -> return () - target -> die + target -> die' verbosity $ unlines [ "Unrecognise URL target '" ++ name ++ "'." | name <- target ] @@ -385,7 +385,7 @@ resolveUserTargets verbosity repoCtxt worldFile available userTargets = do -- package references packageTargets <- mapM (readPackageTarget verbosity) =<< mapM (fetchPackageTarget verbosity repoCtxt) . concat - =<< mapM (expandUserTarget worldFile) userTargets + =<< mapM (expandUserTarget verbosity worldFile) userTargets -- users are allowed to give package names case-insensitively, so we must -- disambiguate named package references @@ -425,10 +425,11 @@ data PackageTarget pkg = -- | Given a user-specified target, expand it to a bunch of package targets -- (each of which refers to only one package). -- -expandUserTarget :: FilePath +expandUserTarget :: Verbosity + -> FilePath -> UserTarget -> IO [PackageTarget (PackageLocation ())] -expandUserTarget worldFile userTarget = case userTarget of +expandUserTarget verbosity worldFile userTarget = case userTarget of UserTargetNamed (Dependency name vrange) -> let props = [ PackagePropertyVersion vrange @@ -436,7 +437,7 @@ expandUserTarget worldFile userTarget = case userTarget of in return [PackageTargetNamedFuzzy name props userTarget] UserTargetWorld -> do - worldPkgs <- World.getContents worldFile + worldPkgs <- World.getContents verbosity worldFile --TODO: should we warn if there are no world targets? return [ PackageTargetNamed name props userTarget | World.WorldPkgInfo (Dependency name vrange) flags <- worldPkgs @@ -450,7 +451,7 @@ expandUserTarget worldFile userTarget = case userTarget of UserTargetLocalCabalFile file -> do let dir = takeDirectory file - _ <- tryFindPackageDesc dir (localPackageError dir) -- just as a check + _ <- tryFindPackageDesc verbosity dir (localPackageError dir) -- just as a check return [ PackageTargetLocation (LocalUnpackedPackage dir) ] UserTargetLocalTarball tarballFile -> @@ -490,7 +491,7 @@ readPackageTarget verbosity = traverse modifyLocation modifyLocation location = case location of LocalUnpackedPackage dir -> do - pkg <- tryFindPackageDesc dir (localPackageError dir) >>= + pkg <- tryFindPackageDesc verbosity dir (localPackageError dir) >>= readGenericPackageDescription verbosity return $ SourcePackage { packageInfoId = packageId pkg, @@ -513,7 +514,7 @@ readPackageTarget verbosity = traverse modifyLocation (filename, content) <- extractTarballPackageCabalFile tarballFile tarballOriginalLoc case parsePackageDescription' content of - Nothing -> die $ "Could not parse the cabal file " + Nothing -> die' verbosity $ "Could not parse the cabal file " ++ filename ++ " in " ++ tarballFile Just pkg -> return $ SourcePackage { @@ -526,7 +527,7 @@ readPackageTarget verbosity = traverse modifyLocation extractTarballPackageCabalFile :: FilePath -> String -> IO (FilePath, BS.ByteString) extractTarballPackageCabalFile tarballFile tarballOriginalLoc = - either (die . formatErr) return + either (die' verbosity . formatErr) return . check . accumEntryMap . Tar.filterEntries isCabalFile @@ -619,7 +620,7 @@ reportPackageTargetProblems verbosity problems = do case [ pkg | PackageNameUnknown pkg originalTarget <- problems , not (isUserTagetWorld originalTarget) ] of [] -> return () - pkgs -> die $ unlines + pkgs -> die' verbosity $ unlines [ "There is no package named '" ++ display name ++ "'. " | name <- pkgs ] ++ "You may need to run 'cabal update' to get the latest " @@ -627,7 +628,7 @@ reportPackageTargetProblems verbosity problems = do case [ (pkg, matches) | PackageNameAmbiguous pkg matches _ <- problems ] of [] -> return () - ambiguities -> die $ unlines + ambiguities -> die' verbosity $ unlines [ "The package name '" ++ display name ++ "' is ambiguous. It could be: " ++ intercalate ", " (map display matches) diff --git a/cabal-install/Distribution/Client/Upload.hs b/cabal-install/Distribution/Client/Upload.hs index 5348b00bf1a7d4b0d18da05c9eb13a6950380bfe..74659e1a3ba0779702a7a851226c9d9db773af95 100644 --- a/cabal-install/Distribution/Client/Upload.hs +++ b/cabal-install/Distribution/Client/Upload.hs @@ -7,7 +7,7 @@ import Distribution.Client.HttpUtils import Distribution.Client.Setup ( IsCandidate(..), RepoContext(..) ) -import Distribution.Simple.Utils (notice, warn, info, die) +import Distribution.Simple.Utils (notice, warn, info, die') import Distribution.Verbosity (Verbosity) import Distribution.Text (display) import Distribution.Client.Config @@ -49,8 +49,8 @@ upload verbosity repoCtxt mUsername mPassword isCandidate paths = do transport <- repoContextGetTransport repoCtxt targetRepo <- case [ remoteRepo | Just remoteRepo <- map maybeRepoRemote repos ] of - [] -> die "Cannot upload. No remote repositories are configured." - rs -> remoteRepoTryUpgradeToHttps transport (last rs) + [] -> die' verbosity "Cannot upload. No remote repositories are configured." + rs -> remoteRepoTryUpgradeToHttps verbosity transport (last rs) let targetRepoURI = remoteRepoURI targetRepo rootIfEmpty x = if null x then "/" else x uploadURI = targetRepoURI { @@ -78,7 +78,7 @@ upload verbosity repoCtxt mUsername mPassword isCandidate paths = do (packageURI pkgid) auth isCandidate path -- This case shouldn't really happen, since we check in Main that we -- only pass tar.gz files to upload. - Nothing -> die $ "Not a tar.gz file: " ++ path + Nothing -> die' verbosity $ "Not a tar.gz file: " ++ path uploadDoc :: Verbosity -> RepoContext -> Maybe Username -> Maybe Password -> IsCandidate -> FilePath @@ -88,8 +88,8 @@ uploadDoc verbosity repoCtxt mUsername mPassword isCandidate path = do transport <- repoContextGetTransport repoCtxt targetRepo <- case [ remoteRepo | Just remoteRepo <- map maybeRepoRemote repos ] of - [] -> die $ "Cannot upload. No remote repositories are configured." - rs -> remoteRepoTryUpgradeToHttps transport (last rs) + [] -> die' verbosity $ "Cannot upload. No remote repositories are configured." + rs -> remoteRepoTryUpgradeToHttps verbosity transport (last rs) let targetRepoURI = remoteRepoURI targetRepo rootIfEmpty x = if null x then "/" else x uploadURI = targetRepoURI { @@ -107,7 +107,7 @@ uploadDoc verbosity repoCtxt mUsername mPassword isCandidate path = do pkgid = reverse $ tail reversePkgid when (reverse reverseSuffix /= "docs.tar.gz" || null reversePkgid || head reversePkgid /= '-') $ - die "Expected a file name matching the pattern <pkgid>-docs.tar.gz" + die' verbosity "Expected a file name matching the pattern <pkgid>-docs.tar.gz" Username username <- maybe promptUsername return mUsername Password password <- maybe promptPassword return mPassword diff --git a/cabal-install/Distribution/Client/Utils.hs b/cabal-install/Distribution/Client/Utils.hs index 47c74542134402cb0da933a098bac9f84ccf93c1..b16613e6d66729f79597f3f9e3ae7945cd3fec4d 100644 --- a/cabal-install/Distribution/Client/Utils.hs +++ b/cabal-install/Distribution/Client/Utils.hs @@ -26,7 +26,8 @@ import Distribution.Compat.Environment import Distribution.Compat.Exception ( catchIO ) import Distribution.Compat.Time ( getModTime ) import Distribution.Simple.Setup ( Flag(..) ) -import Distribution.Simple.Utils ( die, findPackageDesc ) +import Distribution.Verbosity +import Distribution.Simple.Utils ( die', findPackageDesc ) import qualified Data.ByteString.Lazy as BS import Data.Bits ( (.|.), shiftL, shiftR ) @@ -297,17 +298,17 @@ relaxEncodingErrors handle = do return () -- |Like 'tryFindPackageDesc', but with error specific to add-source deps. -tryFindAddSourcePackageDesc :: FilePath -> String -> IO FilePath -tryFindAddSourcePackageDesc depPath err = tryFindPackageDesc depPath $ +tryFindAddSourcePackageDesc :: Verbosity -> FilePath -> String -> IO FilePath +tryFindAddSourcePackageDesc verbosity depPath err = tryFindPackageDesc verbosity depPath $ err ++ "\n" ++ "Failed to read cabal file of add-source dependency: " ++ depPath -- |Try to find a @.cabal@ file, in directory @depPath@. Fails if one cannot be -- found, with @err@ prefixing the error message. This function simply allows -- us to give a more descriptive error than that provided by @findPackageDesc@. -tryFindPackageDesc :: FilePath -> String -> IO FilePath -tryFindPackageDesc depPath err = do +tryFindPackageDesc :: Verbosity -> FilePath -> String -> IO FilePath +tryFindPackageDesc verbosity depPath err = do errOrCabalFile <- findPackageDesc depPath case errOrCabalFile of Right file -> return file - Left _ -> die err + Left _ -> die' verbosity err diff --git a/cabal-install/Distribution/Client/Win32SelfUpgrade.hs b/cabal-install/Distribution/Client/Win32SelfUpgrade.hs index ddb08c353e9c4dd15d8f1f1186c7c1901689b03f..ec93969f4d4bc1f884a0f9cffc061a1e96edb876 100644 --- a/cabal-install/Distribution/Client/Win32SelfUpgrade.hs +++ b/cabal-install/Distribution/Client/Win32SelfUpgrade.hs @@ -212,7 +212,7 @@ setEvent handle = #else import Distribution.Verbosity (Verbosity) -import Distribution.Simple.Utils (die) +import Distribution.Simple.Utils (die') possibleSelfUpgrade :: Verbosity -> [FilePath] @@ -220,6 +220,6 @@ possibleSelfUpgrade :: Verbosity possibleSelfUpgrade _ _ action = action deleteOldExeFile :: Verbosity -> Int -> FilePath -> IO () -deleteOldExeFile _ _ _ = die "win32selfupgrade not needed except on win32" +deleteOldExeFile verbosity _ _ = die' verbosity "win32selfupgrade not needed except on win32" #endif diff --git a/cabal-install/Distribution/Client/World.hs b/cabal-install/Distribution/Client/World.hs index 848fbf4b6c511c4c68e67f10ba7abca6565a7ded..385c8d9779a9af01a8eb28f3930646f52fdc6173 100644 --- a/cabal-install/Distribution/Client/World.hs +++ b/cabal-install/Distribution/Client/World.hs @@ -35,7 +35,7 @@ import Distribution.PackageDescription import Distribution.Verbosity ( Verbosity ) import Distribution.Simple.Utils - ( die, info, chattyTry, writeFileAtomic ) + ( die', info, chattyTry, writeFileAtomic ) import Distribution.Text ( Text(..), display, simpleParse ) import qualified Distribution.Compat.ReadP as Parse @@ -90,7 +90,7 @@ modifyWorld :: ([WorldPkgInfo] -> [WorldPkgInfo] modifyWorld _ _ _ [] = return () modifyWorld f verbosity world pkgs = chattyTry "Error while updating world-file. " $ do - pkgsOldWorld <- getContents world + pkgsOldWorld <- getContents verbosity world -- Filter out packages that are not in the world file: let pkgsNewWorld = nubBy equalUDep $ f pkgs pkgsOldWorld -- 'Dependency' is not an Ord instance, so we need to check for @@ -106,12 +106,12 @@ modifyWorld f verbosity world pkgs = -- | Returns the content of the world file as a list -getContents :: FilePath -> IO [WorldPkgInfo] -getContents world = do +getContents :: Verbosity -> FilePath -> IO [WorldPkgInfo] +getContents verbosity world = do content <- safelyReadFile world let result = map simpleParse (lines $ B.unpack content) case sequence result of - Nothing -> die "Could not parse world file." + Nothing -> die' verbosity "Could not parse world file." Just xs -> return xs where safelyReadFile :: FilePath -> IO B.ByteString diff --git a/cabal-install/main/Main.hs b/cabal-install/main/Main.hs index 5b58220fdcf2cce9b8118c8d3f4a5bee8d83d1c6..b4749aed061640d7851557e1069d2cfe52cbe00f 100644 --- a/cabal-install/main/Main.hs +++ b/cabal-install/main/Main.hs @@ -165,7 +165,7 @@ import Distribution.Simple.Program (defaultProgramDb import Distribution.Simple.Program.Db (reconfigurePrograms) import qualified Distribution.Simple.Setup as Cabal import Distribution.Simple.Utils - ( cabalVersion, die, info, notice, topHandler + ( cabalVersion, die', dieNoVerbosity, info, notice, topHandler , findPackageDesc, tryFindPackageDesc ) import Distribution.Text ( display ) @@ -239,7 +239,7 @@ mainWorker args = topHandler $ putStrLn $ "This file will be generated with sensible " ++ "defaults if you run 'cabal update'." printOptionsList = putStr . unlines - printErrors errs = die $ intercalate "\n" errs + printErrors errs = dieNoVerbosity $ intercalate "\n" errs printNumericVersion = putStrLn $ display Paths_cabal_install.version printVersion = putStrLn $ "cabal-install version " ++ display Paths_cabal_install.version @@ -365,7 +365,7 @@ configureAction (configFlags, configExFlags) extraArgs globalFlags = do -- 'cabal.sandbox.config' here because 'configure -w' must not affect -- subsequent 'install' (for UI compatibility with non-sandboxed mode). - indexFile <- tryGetIndexFilePath config + indexFile <- tryGetIndexFilePath verbosity config maybeAddCompilerTimestampRecord verbosity sandboxDir indexFile (compilerId comp) platform @@ -573,7 +573,7 @@ installAction whenUsingSandbox useSandbox $ \sandboxDir -> do initPackageDBIfNeeded verb configFlags'' comp progdb' - indexFile <- tryGetIndexFilePath config + indexFile <- tryGetIndexFilePath verb config maybeAddCompilerTimestampRecord verb sandboxDir indexFile (compilerId comp) platform @@ -664,7 +664,7 @@ componentNamesFromLBI verbosity distPref targetsDescr compPred = do -- script built against a different Cabal version, so it's crucial that -- we ignore the bad version error here. ConfigStateFileBadVersion _ _ _ -> return ComponentNamesUnknown - _ -> die (show err) + _ -> die' verbosity (show err) Right lbi -> do let pkgDescr = LBI.localPkgDescr lbi names = map LBI.componentName @@ -818,9 +818,9 @@ infoAction infoFlags extraArgs globalFlags = do updateAction :: Flag Verbosity -> [String] -> Action updateAction verbosityFlag extraArgs globalFlags = do - unless (null extraArgs) $ - die $ "'update' doesn't take any extra arguments: " ++ unwords extraArgs let verbosity = fromFlag verbosityFlag + unless (null extraArgs) $ + die' verbosity $ "'update' doesn't take any extra arguments: " ++ unwords extraArgs (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity (globalFlags { globalRequireSandbox = Flag False }) let globalFlags' = savedGlobalFlags config `mappend` globalFlags @@ -829,7 +829,7 @@ updateAction verbosityFlag extraArgs globalFlags = do upgradeAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) -> [String] -> Action -upgradeAction _ _ _ = die $ +upgradeAction (configFlags, _, _, _) _ _ = die' verbosity $ "Use the 'cabal install' command instead of 'cabal upgrade'.\n" ++ "You can install the latest version of a package using 'cabal install'. " ++ "The 'cabal upgrade' command has been removed because people found it " @@ -841,6 +841,8 @@ upgradeAction _ _ _ = die $ ++ "installed versions of all dependencies. If you do use " ++ "--upgrade-dependencies, it is recommended that you do not upgrade core " ++ "packages (e.g. by using appropriate --constraint= flags)." + where + verbosity = fromFlag (configVerbosity configFlags) fetchAction :: FetchFlags -> [String] -> Action fetchAction fetchFlags extraArgs globalFlags = do @@ -919,7 +921,7 @@ uploadAction uploadFlags extraArgs globalFlags = do globalFlags' = savedGlobalFlags config `mappend` globalFlags tarfiles = extraArgs when (null tarfiles && not (fromFlag (uploadDoc uploadFlags'))) $ - die "the 'upload' command expects at least one .tar.gz archive." + die' verbosity "the 'upload' command expects at least one .tar.gz archive." checkTarFiles extraArgs maybe_password <- case uploadPasswordCmd uploadFlags' @@ -931,7 +933,7 @@ uploadAction uploadFlags extraArgs globalFlags = do if fromFlag (uploadDoc uploadFlags') then do when (length tarfiles > 1) $ - die $ "the 'upload' command can only upload documentation " + die' verbosity $ "the 'upload' command can only upload documentation " ++ "for one package at a time." tarfile <- maybe (generateDocTarball config) return $ listToMaybe tarfiles Upload.uploadDoc verbosity @@ -951,11 +953,11 @@ uploadAction uploadFlags extraArgs globalFlags = do verbosity = fromFlag (uploadVerbosity uploadFlags) checkTarFiles tarfiles | not (null otherFiles) - = die $ "the 'upload' command expects only .tar.gz archives: " + = die' verbosity $ "the 'upload' command expects only .tar.gz archives: " ++ intercalate ", " otherFiles | otherwise = sequence_ [ do exists <- doesFileExist tarfile - unless exists $ die $ "file not found: " ++ tarfile + unless exists $ die' verbosity $ "file not found: " ++ tarfile | tarfile <- tarfiles ] where otherFiles = filter (not . isTarGzFile) tarfiles @@ -977,8 +979,9 @@ uploadAction uploadFlags extraArgs globalFlags = do checkAction :: Flag Verbosity -> [String] -> Action checkAction verbosityFlag extraArgs _globalFlags = do + let verbosity = fromFlag verbosityFlag unless (null extraArgs) $ - die $ "'check' doesn't take any extra arguments: " ++ unwords extraArgs + die' verbosity $ "'check' doesn't take any extra arguments: " ++ unwords extraArgs allOk <- Check.check (fromFlag verbosityFlag) unless allOk exitFailure @@ -994,11 +997,12 @@ formatAction verbosityFlag extraArgs _globalFlags = do writeGenericPackageDescription path pkgDesc uninstallAction :: Flag Verbosity -> [String] -> Action -uninstallAction _verbosityFlag extraArgs _globalFlags = do - let package = case extraArgs of +uninstallAction verbosityFlag extraArgs _globalFlags = do + let verbosity = fromFlag verbosityFlag + package = case extraArgs of p:_ -> p _ -> "PACKAGE_NAME" - die $ "This version of 'cabal-install' does not support the 'uninstall' " + die' verbosity $ "This version of 'cabal-install' does not support the 'uninstall' " ++ "operation. " ++ "It will likely be implemented at some point in the future; " ++ "in the meantime you're advised to use either 'ghc-pkg unregister " @@ -1007,9 +1011,9 @@ uninstallAction _verbosityFlag extraArgs _globalFlags = do sdistAction :: (SDistFlags, SDistExFlags) -> [String] -> Action sdistAction (sdistFlags, sdistExFlags) extraArgs globalFlags = do - unless (null extraArgs) $ - die $ "'sdist' doesn't take any extra arguments: " ++ unwords extraArgs let verbosity = fromFlag (sDistVerbosity sdistFlags) + unless (null extraArgs) $ + die' verbosity $ "'sdist' doesn't take any extra arguments: " ++ unwords extraArgs load <- try (loadConfigOrSandboxConfig verbosity globalFlags) let config = either (\(SomeException _) -> mempty) snd load distPref <- findSavedDistPref config (sDistDistPref sdistFlags) @@ -1018,10 +1022,9 @@ sdistAction (sdistFlags, sdistExFlags) extraArgs globalFlags = do reportAction :: ReportFlags -> [String] -> Action reportAction reportFlags extraArgs globalFlags = do - unless (null extraArgs) $ - die $ "'report' doesn't take any extra arguments: " ++ unwords extraArgs - let verbosity = fromFlag (reportVerbosity reportFlags) + unless (null extraArgs) $ + die' verbosity $ "'report' doesn't take any extra arguments: " ++ unwords extraArgs config <- loadConfig verbosity (globalConfigFile globalFlags) let globalFlags' = savedGlobalFlags config `mappend` globalFlags reportFlags' = savedReportFlags config `mappend` reportFlags @@ -1074,9 +1077,9 @@ unpackAction getFlags extraArgs globalFlags = do initAction :: InitFlags -> [String] -> Action initAction initFlags extraArgs globalFlags = do - when (extraArgs /= []) $ - die $ "'init' doesn't take any extra arguments: " ++ unwords extraArgs let verbosity = fromFlag (initVerbosity initFlags) + when (extraArgs /= []) $ + die' verbosity $ "'init' doesn't take any extra arguments: " ++ unwords extraArgs (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity (globalFlags { globalRequireSandbox = Flag False }) let configFlags = savedConfigureFlags config @@ -1099,11 +1102,11 @@ sandboxAction sandboxFlags extraArgs globalFlags = do ["delete"] -> sandboxDelete verbosity sandboxFlags globalFlags ("add-source":extra) -> do when (noExtraArgs extra) $ - die "The 'sandbox add-source' command expects at least one argument" + die' verbosity "The 'sandbox add-source' command expects at least one argument" sandboxAddSource verbosity extra sandboxFlags globalFlags ("delete-source":extra) -> do when (noExtraArgs extra) $ - die ("The 'sandbox delete-source' command expects " ++ + die' verbosity ("The 'sandbox delete-source' command expects " ++ "at least one argument") sandboxDeleteSource verbosity extra sandboxFlags globalFlags ["list-sources"] -> sandboxListSources verbosity sandboxFlags globalFlags @@ -1111,16 +1114,16 @@ sandboxAction sandboxFlags extraArgs globalFlags = do -- More advanced commands. ("hc-pkg":extra) -> do when (noExtraArgs extra) $ - die $ "The 'sandbox hc-pkg' command expects at least one argument" + die' verbosity $ "The 'sandbox hc-pkg' command expects at least one argument" sandboxHcPkg verbosity sandboxFlags globalFlags extra - ["buildopts"] -> die "Not implemented!" + ["buildopts"] -> die' verbosity "Not implemented!" -- Hidden commands. ["dump-pkgenv"] -> dumpPackageEnvironment verbosity sandboxFlags globalFlags -- Error handling. - [] -> die $ "Please specify a subcommand (see 'help sandbox')" - _ -> die $ "Unknown 'sandbox' subcommand: " ++ unwords extraArgs + [] -> die' verbosity $ "Please specify a subcommand (see 'help sandbox')" + _ -> die' verbosity $ "Unknown 'sandbox' subcommand: " ++ unwords extraArgs where noExtraArgs = (<1) . length @@ -1145,12 +1148,12 @@ userConfigAction ucflags extraArgs globalFlags = do fileExists <- doesFileExist path if (not fileExists || (fileExists && force)) then void $ createDefaultConfigFile verbosity path - else die $ path ++ " already exists." + else die' verbosity $ path ++ " already exists." ("diff":_) -> mapM_ putStrLn =<< userConfigDiff globalFlags ("update":_) -> userConfigUpdate verbosity globalFlags -- Error handling. - [] -> die $ "Please specify a subcommand (see 'help user-config')" - _ -> die $ "Unknown 'user-config' subcommand: " ++ unwords extraArgs + [] -> die' verbosity $ "Please specify a subcommand (see 'help user-config')" + _ -> die' verbosity $ "Unknown 'user-config' subcommand: " ++ unwords extraArgs where configFile = getConfigFilePath (globalConfigFile globalFlags) -- | See 'Distribution.Client.Install.withWin32SelfUpgrade' for details. @@ -1176,9 +1179,10 @@ actAsSetupAction actAsSetupFlags args _globalFlags = (UnknownBuildType _) -> error "actAsSetupAction UnknownBuildType" manpageAction :: [CommandSpec action] -> Flag Verbosity -> [String] -> Action -manpageAction commands _ extraArgs _ = do +manpageAction commands flagVerbosity extraArgs _ = do + let verbosity = fromFlag flagVerbosity unless (null extraArgs) $ - die $ "'manpage' doesn't take any extra arguments: " ++ unwords extraArgs + die' verbosity $ "'manpage' doesn't take any extra arguments: " ++ unwords extraArgs pname <- getProgName let cabalCmd = if takeExtension pname == ".exe" then dropExtension pname diff --git a/cabal-install/tests/IntegrationTests/new-build/T3978.err b/cabal-install/tests/IntegrationTests/new-build/T3978.err index dfc9c721ce8ec5070a2dd44ab4de2a28d05f6a1c..75c38e8c404b1f7357a01b69b0b9d7f48a6e19b2 100644 --- a/cabal-install/tests/IntegrationTests/new-build/T3978.err +++ b/cabal-install/tests/IntegrationTests/new-build/T3978.err @@ -2,4 +2,3 @@ Error: Dependency on unbuildable libraries: p-1.0 In the stanza 'library' In the inplace package 'q-1.0' -RE:^cabal(\.exe)?: Configuration failed diff --git a/cabal-install/tests/UnitTests/Distribution/Client/Sandbox/Timestamp.hs b/cabal-install/tests/UnitTests/Distribution/Client/Sandbox/Timestamp.hs index 2529d1b60081516eaf4c01a4e74c897e05574f40..68d7284c4770ebd2d7fe0c7001b49bfab0606672 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/Sandbox/Timestamp.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/Sandbox/Timestamp.hs @@ -44,7 +44,7 @@ timestampReadTest fileContent expected = withTempDirectory silent "." "cabal-timestamp-" $ \dir -> do let fileName = dir </> "timestamp-record" writeFile fileName fileContent - tRec <- readTimestampFile fileName + tRec <- readTimestampFile normal fileName assertEqual "expected timestamp records to be equal" expected tRec @@ -58,6 +58,6 @@ timestampReadWriteTest = withTempDirectory silent "." "cabal-timestamp-" $ \dir -> do let fileName = dir </> "timestamp-record" writeTimestampFile fileName timestampRecord - tRec <- readTimestampFile fileName + tRec <- readTimestampFile normal fileName assertEqual "expected timestamp records to be equal" timestampRecord tRec