Commit 6a652a87 authored by Edward Z. Yang's avatar Edward Z. Yang Committed by Edward Z. Yang

New variant of die which takes verbosity.

This flips error handling around, so that 'die' now can format
an error message with call stacks and markers before raising
it to the top handler.  The top handler detects "verbatim"
deaths and prints them without formatting.
Signed-off-by: default avatarEdward Z. Yang <ezyang@cs.stanford.edu>
parent afc23fdd
......@@ -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
......
......@@ -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.
......
......@@ -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..."
......
......@@ -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
......
......@@ -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 "
......
......@@ -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]
......
......@@ -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