From edb808a0b8be67885876f998a3e89c0cd5e1c3f4 Mon Sep 17 00:00:00 2001 From: sheaf Date: Tue, 3 Feb 2026 14:42:05 +0100 Subject: [PATCH] Cabal library: allow setting the logging handle The goal of this patch is to allow the logging handle to be set when calling Cabal library functions, without having to spawn a separate process and redirect handles. This allows Cabal library functions to be called in a concurrent setting without spawning separate processes. To achieve this, this commit modifies Verbosity as follows: 1. The old Verbosity datatype becomes VerbosityFlags. This is what gets passed in the command-line interface, e.g. when running a Setup executable. 2. The new Verbosity datatype contains VerbosityFlags together with VerbosityHandles, which specify where to redirect stdout/stderr. Crucially, this allows us to get rid of the isJust (useLoggingHandle options) condition in 'getSetupMethod', which forced us to use the cabal-install "act as setup" mechanism instead of directly calling Cabal library functions. Tested in PackageTests/LoggingHandle. Fixes #9987 --- .../src/Test/QuickCheck/Instances/Cabal.hs | 4 +- Cabal-described/src/Distribution/Described.hs | 4 +- Cabal-tests/tests/UnitTests.hs | 2 +- .../UnitTests/Distribution/Compat/Time.hs | 5 +- .../tests/UnitTests/Distribution/Described.hs | 4 +- .../UnitTests/Distribution/Simple/Glob.hs | 4 +- .../UnitTests/Distribution/Simple/Utils.hs | 8 +- .../Distribution/Utils/Structured.hs | 3 +- .../tests/custom-setup/CabalDoctestSetup.hs | 7 +- Cabal-tests/tests/custom-setup/IdrisSetup.hs | 27 +- .../src/Data/TreeDiff/Instances/Cabal.hs | 2 +- Cabal/src/Distribution/Compat/Time.hs | 5 +- Cabal/src/Distribution/Make.hs | 94 ++--- Cabal/src/Distribution/Simple.hs | 336 +++++++++++------- Cabal/src/Distribution/Simple/Bench.hs | 6 +- Cabal/src/Distribution/Simple/Build.hs | 94 +++-- Cabal/src/Distribution/Simple/Build/Inputs.hs | 2 +- Cabal/src/Distribution/Simple/Configure.hs | 94 +++-- .../Distribution/Simple/ConfigureScript.hs | 8 +- Cabal/src/Distribution/Simple/GHC.hs | 40 ++- Cabal/src/Distribution/Simple/GHC/Build.hs | 13 +- .../Simple/GHC/Build/ExtraSources.hs | 20 +- .../src/Distribution/Simple/GHC/Build/Link.hs | 21 +- .../Distribution/Simple/GHC/Build/Modules.hs | 15 +- Cabal/src/Distribution/Simple/GHC/Internal.hs | 24 +- Cabal/src/Distribution/Simple/GHCJS.hs | 14 +- Cabal/src/Distribution/Simple/Glob.hs | 4 +- Cabal/src/Distribution/Simple/Haddock.hs | 37 +- Cabal/src/Distribution/Simple/Install.hs | 6 +- .../Distribution/Simple/PackageDescription.hs | 8 +- Cabal/src/Distribution/Simple/Program/Ar.hs | 10 +- .../Distribution/Simple/Program/Builtin.hs | 5 +- Cabal/src/Distribution/Simple/Program/GHC.hs | 8 +- .../src/Distribution/Simple/Program/HcPkg.hs | 48 +-- Cabal/src/Distribution/Simple/Program/Run.hs | 3 +- Cabal/src/Distribution/Simple/Register.hs | 47 ++- Cabal/src/Distribution/Simple/Setup.hs | 4 +- .../Distribution/Simple/Setup/Benchmark.hs | 2 +- Cabal/src/Distribution/Simple/Setup/Build.hs | 2 +- Cabal/src/Distribution/Simple/Setup/Clean.hs | 2 +- Cabal/src/Distribution/Simple/Setup/Common.hs | 6 +- Cabal/src/Distribution/Simple/Setup/Config.hs | 2 +- Cabal/src/Distribution/Simple/Setup/Copy.hs | 2 +- .../src/Distribution/Simple/Setup/Haddock.hs | 2 +- .../src/Distribution/Simple/Setup/Hscolour.hs | 2 +- .../src/Distribution/Simple/Setup/Install.hs | 2 +- .../src/Distribution/Simple/Setup/Register.hs | 2 +- Cabal/src/Distribution/Simple/Setup/Repl.hs | 2 +- Cabal/src/Distribution/Simple/Setup/SDist.hs | 2 +- Cabal/src/Distribution/Simple/Setup/Test.hs | 2 +- .../src/Distribution/Simple/ShowBuildInfo.hs | 2 +- Cabal/src/Distribution/Simple/SrcDist.hs | 9 +- Cabal/src/Distribution/Simple/Test.hs | 10 +- Cabal/src/Distribution/Simple/Test/ExeV10.hs | 33 +- Cabal/src/Distribution/Simple/Test/LibV09.hs | 13 +- Cabal/src/Distribution/Simple/UHC.hs | 4 +- Cabal/src/Distribution/Simple/Utils.hs | 259 +++++++++----- Cabal/src/Distribution/Utils/LogProgress.hs | 7 +- Cabal/src/Distribution/Verbosity.hs | 276 ++++++++------ .../src/Distribution/Solver/Modular.hs | 6 +- .../src/Distribution/Solver/Modular/Solver.hs | 2 +- .../parser-tests/Tests/ParserTests.hs | 4 +- .../src/Distribution/Client/CmdClean.hs | 9 +- .../src/Distribution/Client/CmdExec.hs | 1 - .../Distribution/Client/CmdHaddockProject.hs | 8 +- .../src/Distribution/Client/CmdInstall.hs | 7 +- .../src/Distribution/Client/CmdLegacy.hs | 13 +- .../src/Distribution/Client/CmdListBin.hs | 4 +- .../src/Distribution/Client/CmdOutdated.hs | 7 +- .../src/Distribution/Client/CmdPath.hs | 3 +- .../src/Distribution/Client/CmdRepl.hs | 5 +- .../src/Distribution/Client/CmdSdist.hs | 14 +- .../src/Distribution/Client/CmdTarget.hs | 8 +- .../src/Distribution/Client/CmdUpdate.hs | 5 +- .../src/Distribution/Client/Config.hs | 5 +- .../src/Distribution/Client/Configure.hs | 5 +- .../src/Distribution/Client/Dependency.hs | 8 +- .../src/Distribution/Client/Fetch.hs | 3 +- .../src/Distribution/Client/FetchUtils.hs | 7 +- .../src/Distribution/Client/Freeze.hs | 3 +- .../src/Distribution/Client/Haddock.hs | 2 +- .../src/Distribution/Client/IndexUtils.hs | 4 +- .../Distribution/Client/Init/FileCreators.hs | 3 +- .../Client/Init/Interactive/Command.hs | 3 +- .../Client/Init/NonInteractive/Command.hs | 5 +- .../src/Distribution/Client/Init/Simple.hs | 2 +- .../src/Distribution/Client/Init/Types.hs | 8 +- .../src/Distribution/Client/Init/Utils.hs | 4 +- .../src/Distribution/Client/Install.hs | 26 +- .../src/Distribution/Client/InstallSymlink.hs | 2 +- cabal-install/src/Distribution/Client/Main.hs | 131 +++++-- .../src/Distribution/Client/Manpage.hs | 6 +- .../src/Distribution/Client/ManpageFlags.hs | 4 +- .../Distribution/Client/NixStyleOptions.hs | 7 +- .../Distribution/Client/ProjectBuilding.hs | 2 +- .../Client/ProjectBuilding/UnpackedPackage.hs | 5 +- .../src/Distribution/Client/ProjectConfig.hs | 6 +- .../Distribution/Client/ProjectConfig/Lens.hs | 2 +- .../Client/ProjectConfig/Types.hs | 3 +- .../Client/ProjectOrchestration.hs | 12 +- .../Distribution/Client/ProjectPlanning.hs | 10 +- .../Client/ProjectPlanning/Types.hs | 6 +- .../src/Distribution/Client/Reconfigure.hs | 3 +- .../src/Distribution/Client/SavedFlags.hs | 2 +- .../src/Distribution/Client/Setup.hs | 27 +- .../src/Distribution/Client/SetupWrapper.hs | 40 ++- .../src/Distribution/Client/SourceFiles.hs | 9 +- .../src/Distribution/Client/Store.hs | 5 +- cabal-install/src/Distribution/Client/VCS.hs | 19 +- .../Distribution/Client/Win32SelfUpgrade.hs | 4 +- cabal-install/tests/IntegrationTests2.hs | 19 +- cabal-install/tests/LongTests.hs | 2 +- .../Distribution/Client/FetchUtils.hs | 2 +- .../Distribution/Client/FileMonitor.hs | 7 +- .../UnitTests/Distribution/Client/Get.hs | 2 +- .../UnitTests/Distribution/Client/Init.hs | 2 +- .../Distribution/Client/Init/FileCreators.hs | 2 +- .../Distribution/Client/Init/Golden.hs | 44 +-- .../Distribution/Client/Init/Interactive.hs | 16 +- .../Client/Init/NonInteractive.hs | 14 +- .../Distribution/Client/Init/Simple.hs | 12 +- .../Distribution/Client/ProjectConfig.hs | 8 +- .../UnitTests/Distribution/Client/Store.hs | 10 +- .../Distribution/Client/UserConfig.hs | 24 +- .../UnitTests/Distribution/Client/VCS.hs | 12 +- .../Distribution/Solver/Modular/DSL.hs | 2 +- .../Solver/Modular/DSL/TestCaseUtils.hs | 4 +- .../Distribution/Solver/Modular/QuickCheck.hs | 2 +- .../Solver/Modular/QuickCheck/Utils.hs | 2 +- .../AutoconfBadPaths/cabal.test.hs | 16 +- .../BuildToolPaths/pbts/SetupHooks.hs | 12 +- .../ExternalCommand/cabal.test.hs | 2 +- .../ExternalCommandEnv/cabal.test.hs | 2 +- .../ExternalCommandExitCode/cabal.test.hs | 2 +- .../ExternalCommandHelp/cabal.test.hs | 2 +- .../PackageTests/ForeignLibs/setup.test.hs | 3 +- .../Init/init-without-git.test.hs | 2 +- .../NonignoredConfigs/cabal.test.hs | 7 +- .../PackageTests/LoggingHandle/Setup.hs | 26 ++ .../PackageTests/LoggingHandle/bench/Main.hs | 11 + .../PackageTests/LoggingHandle/exe/Main.hs | 11 + .../PackageTests/LoggingHandle/lib/Lib.hs | 9 + .../PackageTests/LoggingHandle/setup.out | 4 + .../PackageTests/LoggingHandle/setup.test.hs | 51 +++ .../PackageTests/LoggingHandle/test-pkg.cabal | 45 +++ .../PackageTests/LoggingHandle/test/Main.hs | 11 + .../NewBuild/CmdRun/Terminate/cabal.test.hs | 2 +- .../SetupHooksC2HsRules/SetupHooks.hs | 22 +- .../SetupHooks.hs | 13 +- .../setup.out | 4 +- .../SetupHooksRuleOrdering/SetupHooks.hs | 12 +- .../ExeV10/cabal-with-hpc.multitest.hs | 2 +- cabal-testsuite/main/cabal-tests.hs | 12 +- cabal-testsuite/src/Test/Cabal/Monad.hs | 34 +- cabal-testsuite/src/Test/Cabal/Prelude.hs | 17 +- cabal-testsuite/src/Test/Cabal/Run.hs | 13 +- cabal-testsuite/src/Test/Cabal/Script.hs | 8 +- cabal-testsuite/src/Test/Cabal/Server.hs | 8 +- changelog.d/pr-11077 | 97 +++++ 159 files changed, 1790 insertions(+), 1024 deletions(-) create mode 100644 cabal-testsuite/PackageTests/LoggingHandle/Setup.hs create mode 100644 cabal-testsuite/PackageTests/LoggingHandle/bench/Main.hs create mode 100644 cabal-testsuite/PackageTests/LoggingHandle/exe/Main.hs create mode 100644 cabal-testsuite/PackageTests/LoggingHandle/lib/Lib.hs create mode 100644 cabal-testsuite/PackageTests/LoggingHandle/setup.out create mode 100644 cabal-testsuite/PackageTests/LoggingHandle/setup.test.hs create mode 100644 cabal-testsuite/PackageTests/LoggingHandle/test-pkg.cabal create mode 100644 cabal-testsuite/PackageTests/LoggingHandle/test/Main.hs create mode 100644 changelog.d/pr-11077 diff --git a/Cabal-QuickCheck/src/Test/QuickCheck/Instances/Cabal.hs b/Cabal-QuickCheck/src/Test/QuickCheck/Instances/Cabal.hs index cbfb8c079fe..23057aa7f3a 100644 --- a/Cabal-QuickCheck/src/Test/QuickCheck/Instances/Cabal.hs +++ b/Cabal-QuickCheck/src/Test/QuickCheck/Instances/Cabal.hs @@ -265,9 +265,9 @@ instance Arbitrary FlagAssignment where -- Verbosity ------------------------------------------------------------------------------- -instance Arbitrary Verbosity where +instance Arbitrary VerbosityFlags where arbitrary = do - v <- elements [minBound..maxBound] + v <- mkVerbosityFlags <$> elements [minBound..maxBound] -- verbose markoutput is left out on purpose flags <- listOf $ elements [ verboseCallSite diff --git a/Cabal-described/src/Distribution/Described.hs b/Cabal-described/src/Distribution/Described.hs index fa6e29b08e4..9ffa8bf7b62 100644 --- a/Cabal-described/src/Distribution/Described.hs +++ b/Cabal-described/src/Distribution/Described.hs @@ -99,7 +99,7 @@ import Distribution.Types.TestType (TestType) import Distribution.Types.UnitId (UnitId) import Distribution.Types.UnqualComponentName (UnqualComponentName) import Distribution.Utils.Path (SymbolicPath, RelativePath) -import Distribution.Verbosity (Verbosity) +import Distribution.Verbosity (VerbosityFlags) import Distribution.Version (Version, VersionRange) import Language.Haskell.Extension (Extension, Language, knownLanguages) @@ -493,7 +493,7 @@ instance Described RepoType where instance Described TestType where describe _ = REUnion ["exitcode-stdio-1.0", "detailed-0.9"] -instance Described Verbosity where +instance Described VerbosityFlags where describe _ = REUnion [ REUnion ["0", "1", "2", "3"] , REUnion ["silent", "normal", "verbose", "debug", "deafening"] diff --git a/Cabal-tests/tests/UnitTests.hs b/Cabal-tests/tests/UnitTests.hs index 4c26e3e92a8..27fe8811823 100644 --- a/Cabal-tests/tests/UnitTests.hs +++ b/Cabal-tests/tests/UnitTests.hs @@ -109,7 +109,7 @@ main = do (mtimeChange, mtimeChange') <- calibrateMtimeChangeDelay let toMillis :: Int -> Double toMillis x = fromIntegral x / 1000.0 - notice normal $ "File modification time resolution calibration completed, " + notice (mkVerbosity defaultVerbosityHandles normal) $ "File modification time resolution calibration completed, " ++ "maximum delay observed: " ++ (show . toMillis $ mtimeChange ) ++ " ms. " ++ "Will be using delay of " ++ (show . toMillis $ mtimeChange') diff --git a/Cabal-tests/tests/UnitTests/Distribution/Compat/Time.hs b/Cabal-tests/tests/UnitTests/Distribution/Compat/Time.hs index db656db0be0..a56d10472e2 100644 --- a/Cabal-tests/tests/UnitTests/Distribution/Compat/Time.hs +++ b/Cabal-tests/tests/UnitTests/Distribution/Compat/Time.hs @@ -4,7 +4,6 @@ import Control.Concurrent (threadDelay) import System.FilePath import Distribution.Simple.Utils (withTempDirectory) -import Distribution.Verbosity import Distribution.Compat.Time @@ -19,7 +18,7 @@ tests mtimeChange = getModTimeTest :: Int -> Assertion getModTimeTest mtimeChange = - withTempDirectory silent "." "getmodtime-" $ \dir -> do + withTempDirectory "." "getmodtime-" $ \dir -> do let fileName = dir "foo" writeFile fileName "bar" t0 <- getModTime fileName @@ -31,7 +30,7 @@ getModTimeTest mtimeChange = getCurTimeTest :: Int -> Assertion getCurTimeTest mtimeChange = - withTempDirectory silent "." "getmodtime-" $ \dir -> do + withTempDirectory "." "getmodtime-" $ \dir -> do let fileName = dir "foo" writeFile fileName "bar" t0 <- getModTime fileName diff --git a/Cabal-tests/tests/UnitTests/Distribution/Described.hs b/Cabal-tests/tests/UnitTests/Distribution/Described.hs index 9f1c70b51a7..fab7795a088 100644 --- a/Cabal-tests/tests/UnitTests/Distribution/Described.hs +++ b/Cabal-tests/tests/UnitTests/Distribution/Described.hs @@ -22,7 +22,7 @@ import Distribution.Types.PackageName (PackageName) import Distribution.Types.PackageVersionConstraint (PackageVersionConstraint) import Distribution.Types.Version (Version) import Distribution.Types.VersionRange (VersionRange) -import Distribution.Verbosity (Verbosity) +import Distribution.Verbosity (VerbosityFlags) -- instances import Test.QuickCheck.Instances.Cabal () @@ -45,5 +45,5 @@ tests = testGroup "Described" , testDescribed (Proxy :: Proxy ModuleRenaming) , testDescribed (Proxy :: Proxy IncludeRenaming) , testDescribed (Proxy :: Proxy Mixin) - , testDescribed (Proxy :: Proxy Verbosity) + , testDescribed (Proxy :: Proxy VerbosityFlags) ] diff --git a/Cabal-tests/tests/UnitTests/Distribution/Simple/Glob.hs b/Cabal-tests/tests/UnitTests/Distribution/Simple/Glob.hs index c07fbb38623..e853040c1d6 100644 --- a/Cabal-tests/tests/UnitTests/Distribution/Simple/Glob.hs +++ b/Cabal-tests/tests/UnitTests/Distribution/Simple/Glob.hs @@ -16,6 +16,7 @@ import System.FilePath ((), splitFileName, normalise) import System.IO.Temp (withSystemTempDirectory) import Test.Tasty import Test.Tasty.HUnit +import Distribution.Verbosity sampleFileNames :: [FilePath] sampleFileNames = @@ -100,6 +101,7 @@ testMatchesVersion version pat expected = do checkPure globPat checkIO globPat where + verbosity = mkVerbosity defaultVerbosityHandles Verbosity.normal isEqual = (==) `on` (sort . fmap (fmap normalise)) checkPure globPat = do let actual = mapMaybe (\p -> (p <$) <$> fileGlobMatches version globPat p) sampleFileNames @@ -111,7 +113,7 @@ testMatchesVersion version pat expected = do checkIO globPat = withSystemTempDirectory "globstar-sample" $ \tmpdir -> do makeSampleFiles tmpdir - actual <- runDirFileGlob Verbosity.normal (Just version) tmpdir globPat + actual <- runDirFileGlob verbosity (Just version) tmpdir globPat unless (isEqual actual expected) $ assertFailure $ "Unexpected result (impure matcher): " ++ show actual ++ "\nExpected: " ++ show expected diff --git a/Cabal-tests/tests/UnitTests/Distribution/Simple/Utils.hs b/Cabal-tests/tests/UnitTests/Distribution/Simple/Utils.hs index 48e8aae9c1d..92ff229ccb4 100644 --- a/Cabal-tests/tests/UnitTests/Distribution/Simple/Utils.hs +++ b/Cabal-tests/tests/UnitTests/Distribution/Simple/Utils.hs @@ -38,7 +38,7 @@ withTempDirTest :: Assertion withTempDirTest = do dirName <- newIORef "" tempDir <- getTemporaryDirectory - withTempDirectory normal tempDir "foo" $ \dirName' -> do + withTempDirectory tempDir "foo" $ \dirName' -> do writeIORef dirName dirName' dirExists <- readIORef dirName >>= doesDirectoryExist assertBool "Temporary directory not deleted by 'withTempDirectory'!" @@ -47,7 +47,7 @@ withTempDirTest = do withTempDirRemovedTest :: Assertion withTempDirRemovedTest = do tempDir <- getTemporaryDirectory - withTempDirectory normal tempDir "foo" $ \dirPath -> do + withTempDirectory tempDir "foo" $ \dirPath -> do removeDirectoryRecursive dirPath rawSystemStdInOutTextDecodingTest :: FilePath -> Assertion @@ -67,7 +67,7 @@ rawSystemStdInOutTextDecodingTest ghcPath hClose handleExe -- Compile - (resOutput, resErrors, resExitCode) <- rawSystemStdInOut normal + (resOutput, resErrors, resExitCode) <- rawSystemStdInOut (mkVerbosity defaultVerbosityHandles normal) ghcPath ["-o", filenameExe, filenameHs] Nothing Nothing Nothing IODataModeText @@ -75,7 +75,7 @@ rawSystemStdInOutTextDecodingTest ghcPath -- Execute Exception.try $ do - rawSystemStdInOut normal + rawSystemStdInOut (mkVerbosity defaultVerbosityHandles normal) filenameExe [] Nothing Nothing Nothing IODataModeText -- not binary mode output, ie utf8 text mode so try to decode diff --git a/Cabal-tests/tests/UnitTests/Distribution/Utils/Structured.hs b/Cabal-tests/tests/UnitTests/Distribution/Utils/Structured.hs index d2bad7284a8..f8cb6cd3651 100644 --- a/Cabal-tests/tests/UnitTests/Distribution/Utils/Structured.hs +++ b/Cabal-tests/tests/UnitTests/Distribution/Utils/Structured.hs @@ -33,4 +33,5 @@ md5CheckGenericPackageDescription proxy = md5Check proxy md5CheckLocalBuildInfo :: Proxy LocalBuildInfo -> Assertion md5CheckLocalBuildInfo proxy = md5Check proxy - 0xc35a236a684a15b35690edb21c305eba + 0xe9c033a98273061c4a4cc8f9653193a2 + diff --git a/Cabal-tests/tests/custom-setup/CabalDoctestSetup.hs b/Cabal-tests/tests/custom-setup/CabalDoctestSetup.hs index eef12903766..6ff7df26ec6 100644 --- a/Cabal-tests/tests/custom-setup/CabalDoctestSetup.hs +++ b/Cabal-tests/tests/custom-setup/CabalDoctestSetup.hs @@ -1,6 +1,7 @@ -- This is Distribution.Extra.Doctest module from cabal-doctest-1.0.4 -- This isn't technically a Custom-Setup script, but it /was/. +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {- @@ -322,7 +323,11 @@ generateBuildModule -> BuildFlags -> PackageDescription -> LocalBuildInfo -> IO () {- FOURMOLU_DISABLE -} generateBuildModule testSuiteName flags pkg lbi = do - let verbosity = fromFlag (buildVerbosity flags) + let verbosity = +#if MIN_VERSION_Cabal(3,17,0) + mkVerbosity defaultVerbosityHandles $ +#endif + fromFlag (buildVerbosity flags) let distPref = fromFlag (buildDistPref flags) -- Package DBs & environments diff --git a/Cabal-tests/tests/custom-setup/IdrisSetup.hs b/Cabal-tests/tests/custom-setup/IdrisSetup.hs index 149f03706fa..0ba17cab011 100644 --- a/Cabal-tests/tests/custom-setup/IdrisSetup.hs +++ b/Cabal-tests/tests/custom-setup/IdrisSetup.hs @@ -56,6 +56,7 @@ import Distribution.Simple.InstallDirs as I import Distribution.Simple.LocalBuildInfo as L import qualified Distribution.Simple.Setup as S import qualified Distribution.Simple.Program as P +import qualified Distribution.Verbosity as V import Distribution.Simple.Utils (createDirectoryIfMissingVerbose, notice, installOrdinaryFiles) import Distribution.Simple.Utils (rewriteFileEx) import Distribution.Compiler @@ -156,12 +157,26 @@ mkFlagName :: String -> FlagName mkFlagName = FlagName #endif +mkVerbosity + :: +#if MIN_VERSION_Cabal(3,17,0) + S.Flag V.VerbosityFlags +#else + S.Flag V.Verbosity +#endif + -> V.Verbosity +mkVerbosity v = +#if MIN_VERSION_Cabal(3,17,0) + V.mkVerbosity V.defaultVerbosityHandles $ +#endif + S.fromFlag v + -- ----------------------------------------------------------------------------- -- Clean idrisClean _ flags _ _ = cleanStdLib where - verbosity = S.fromFlag $ S.cleanVerbosity flags + verbosity = mkVerbosity $ S.cleanVerbosity flags cleanStdLib = makeClean "libs" @@ -247,7 +262,7 @@ idrisConfigure _ flags pkgdesc local = do else generateToolchainModule verbosity libAutogenDir Nothing where - verbosity = S.fromFlag $ S.configVerbosity flags + verbosity = mkVerbosity $ S.configVerbosity flags version = pkgVersion . package $ localPkgDescr local -- This is a hack. I don't know how to tell cabal that a data file needs @@ -307,7 +322,7 @@ idrisPreBuild args flags = do windres verbosity ["icons/idris_icon.rc","-o", dir++"/idris_icon.o"] return (Nothing, [(fromString "idris", emptyBuildInfo { ldOptions = [dir ++ "/idris_icon.o"] })]) where - verbosity = S.fromFlag $ S.buildVerbosity flags + verbosity = mkVerbosity $ S.buildVerbosity flags dir = #if MIN_VERSION_Cabal(3,11,0) @@ -325,7 +340,7 @@ idrisBuild _ flags _ local else do buildStdLib buildRTS where - verbosity = S.fromFlag $ S.buildVerbosity flags + verbosity = mkVerbosity $ S.buildVerbosity flags buildStdLib = do putStrLn "Building libraries..." @@ -396,10 +411,10 @@ main = defaultMainWithHooks $ simpleUserHooks , preBuild = idrisPreBuild , postBuild = idrisBuild , postCopy = \_ flags pkg local -> - idrisInstall (S.fromFlag $ S.copyVerbosity flags) + idrisInstall (mkVerbosity $ S.copyVerbosity flags) (S.fromFlag $ S.copyDest flags) pkg local , postInst = \_ flags pkg local -> - idrisInstall (S.fromFlag $ S.installVerbosity flags) + idrisInstall (mkVerbosity $ S.installVerbosity flags) NoCopyDest pkg local #if !MIN_VERSION_Cabal(3,0,0) , preSDist = idrisPreSDist diff --git a/Cabal-tree-diff/src/Data/TreeDiff/Instances/Cabal.hs b/Cabal-tree-diff/src/Data/TreeDiff/Instances/Cabal.hs index afa7ea8a4a0..3f2f2aca9b0 100644 --- a/Cabal-tree-diff/src/Data/TreeDiff/Instances/Cabal.hs +++ b/Cabal-tree-diff/src/Data/TreeDiff/Instances/Cabal.hs @@ -151,7 +151,7 @@ instance ToExpr TestSuiteInterface instance ToExpr TestType instance ToExpr UnitId instance ToExpr UnqualComponentName -instance ToExpr Verbosity +instance ToExpr VerbosityFlags instance ToExpr VerbosityFlag instance ToExpr VerbosityLevel diff --git a/Cabal/src/Distribution/Compat/Time.hs b/Cabal/src/Distribution/Compat/Time.hs index cc280b67930..751b7920c4c 100644 --- a/Cabal/src/Distribution/Compat/Time.hs +++ b/Cabal/src/Distribution/Compat/Time.hs @@ -23,7 +23,6 @@ import System.Directory (getModificationTime) import Distribution.Simple.Utils (withTempDirectoryCwd) import Distribution.Utils.Path (getSymbolicPath, sameDirectory) -import Distribution.Verbosity (silent) import System.FilePath @@ -156,8 +155,8 @@ getCurTime = posixTimeToModTime `fmap` getPOSIXTime -- Uses 'gettimeofday'. -- The returned delay is never smaller -- than 10 ms, but never larger than 1 second. calibrateMtimeChangeDelay :: IO (Int, Int) -calibrateMtimeChangeDelay = - withTempDirectoryCwd silent Nothing sameDirectory "calibration-" $ \dir -> do +calibrateMtimeChangeDelay = do + withTempDirectoryCwd Nothing sameDirectory "calibration-" $ \dir -> do let fileName = getSymbolicPath dir "probe" mtimes <- for [1 .. 25] $ \(i :: Int) -> time $ do writeFile fileName $ show i diff --git a/Cabal/src/Distribution/Make.hs b/Cabal/src/Distribution/Make.hs index 1568abaac60..0c0bfa99d28 100644 --- a/Cabal/src/Distribution/Make.hs +++ b/Cabal/src/Distribution/Make.hs @@ -62,6 +62,7 @@ module Distribution.Make , Version , defaultMain , defaultMainArgs + , defaultMainArgsWithHandles ) where import Distribution.Compat.Prelude @@ -75,9 +76,11 @@ import Distribution.Simple.Command import Distribution.Simple.Program import Distribution.Simple.Setup import Distribution.Simple.Utils +import Distribution.Verbosity import Distribution.Version import System.Environment (getArgs, getProgName) +import System.IO (hPutStr, hPutStrLn) defaultMain :: IO () defaultMain = getArgs >>= defaultMainArgs @@ -85,8 +88,14 @@ defaultMain = getArgs >>= defaultMainArgs defaultMainArgs :: [String] -> IO () defaultMainArgs = defaultMainHelper +defaultMainArgsWithHandles :: VerbosityHandles -> [String] -> IO () +defaultMainArgsWithHandles = defaultMainHelperWithHandles + defaultMainHelper :: [String] -> IO () -defaultMainHelper args = do +defaultMainHelper = defaultMainHelperWithHandles defaultVerbosityHandles + +defaultMainHelperWithHandles :: VerbosityHandles -> [String] -> IO () +defaultMainHelperWithHandles verbHandles args = do command <- commandsRun (globalCommand commands) commands args case command of CommandHelp help -> printHelp help @@ -102,33 +111,34 @@ defaultMainHelper args = do CommandErrors errs -> printErrors errs CommandReadyToGo action -> action where - printHelp help = getProgName >>= putStr . help - printOptionsList = putStr . unlines + outHandle = vStdoutHandle verbHandles + printHelp help = getProgName >>= hPutStr outHandle . help + printOptionsList = hPutStr outHandle . unlines printErrors errs = do - putStr (intercalate "\n" errs) + hPutStr outHandle (intercalate "\n" errs) exitWith (ExitFailure 1) - printNumericVersion = putStrLn $ prettyShow cabalVersion + printNumericVersion = hPutStrLn outHandle $ prettyShow cabalVersion printVersion = - putStrLn $ + hPutStrLn outHandle $ "Cabal library version " ++ prettyShow cabalVersion progs = defaultProgramDb commands = - [ configureCommand progs `commandAddAction` configureAction - , buildCommand progs `commandAddAction` buildAction - , installCommand `commandAddAction` installAction - , copyCommand `commandAddAction` copyAction - , haddockCommand `commandAddAction` haddockAction - , cleanCommand `commandAddAction` cleanAction - , sdistCommand `commandAddAction` sdistAction - , registerCommand `commandAddAction` registerAction - , unregisterCommand `commandAddAction` unregisterAction + [ configureCommand progs `commandAddAction` configureAction verbHandles + , buildCommand progs `commandAddAction` buildAction verbHandles + , installCommand `commandAddAction` installAction verbHandles + , copyCommand `commandAddAction` copyAction verbHandles + , haddockCommand `commandAddAction` haddockAction verbHandles + , cleanCommand `commandAddAction` cleanAction verbHandles + , sdistCommand `commandAddAction` sdistAction verbHandles + , registerCommand `commandAddAction` registerAction verbHandles + , unregisterCommand `commandAddAction` unregisterAction verbHandles ] -configureAction :: ConfigFlags -> [String] -> IO () -configureAction flags args = do +configureAction :: VerbosityHandles -> ConfigFlags -> [String] -> IO () +configureAction verbHandles flags args = do noExtraFlags args - let verbosity = fromFlag $ configVerbosity flags + let verbosity = mkVerbosity verbHandles $ fromFlag $ configVerbosity flags mbWorkDir = flagToMaybe $ configWorkingDir flags rawSystemExit verbosity mbWorkDir "sh" $ "configure" @@ -136,10 +146,10 @@ configureAction flags args = do where backwardsCompatHack = True -copyAction :: CopyFlags -> [String] -> IO () -copyAction flags args = do +copyAction :: VerbosityHandles -> CopyFlags -> [String] -> IO () +copyAction verbHandles flags args = do noExtraFlags args - let verbosity = fromFlag $ copyVerbosity flags + let verbosity = mkVerbosity verbHandles $ fromFlag $ copyVerbosity flags mbWorkDir = flagToMaybe $ copyWorkingDir flags destArgs = case fromFlag $ copyDest flags of NoCopyDest -> ["install"] @@ -148,54 +158,54 @@ copyAction flags args = do rawSystemExit verbosity mbWorkDir "make" destArgs -installAction :: InstallFlags -> [String] -> IO () -installAction flags args = do +installAction :: VerbosityHandles -> InstallFlags -> [String] -> IO () +installAction verbHandles flags args = do noExtraFlags args - let verbosity = fromFlag $ installVerbosity flags + let verbosity = mkVerbosity verbHandles $ fromFlag $ installVerbosity flags mbWorkDir = flagToMaybe $ installWorkingDir flags rawSystemExit verbosity mbWorkDir "make" ["install"] rawSystemExit verbosity mbWorkDir "make" ["register"] -haddockAction :: HaddockFlags -> [String] -> IO () -haddockAction flags args = do +haddockAction :: VerbosityHandles -> HaddockFlags -> [String] -> IO () +haddockAction verbHandles flags args = do noExtraFlags args - let verbosity = fromFlag $ haddockVerbosity flags + let verbosity = mkVerbosity verbHandles $ fromFlag $ haddockVerbosity flags mbWorkDir = flagToMaybe $ haddockWorkingDir flags rawSystemExit verbosity mbWorkDir "make" ["docs"] `catchIO` \_ -> rawSystemExit verbosity mbWorkDir "make" ["doc"] -buildAction :: BuildFlags -> [String] -> IO () -buildAction flags args = do +buildAction :: VerbosityHandles -> BuildFlags -> [String] -> IO () +buildAction verbHandles flags args = do noExtraFlags args - let verbosity = fromFlag $ buildVerbosity flags + let verbosity = mkVerbosity verbHandles $ fromFlag $ buildVerbosity flags mbWorkDir = flagToMaybe $ buildWorkingDir flags rawSystemExit verbosity mbWorkDir "make" [] -cleanAction :: CleanFlags -> [String] -> IO () -cleanAction flags args = do +cleanAction :: VerbosityHandles -> CleanFlags -> [String] -> IO () +cleanAction verbHandles flags args = do noExtraFlags args - let verbosity = fromFlag $ cleanVerbosity flags + let verbosity = mkVerbosity verbHandles $ fromFlag $ cleanVerbosity flags mbWorkDir = flagToMaybe $ cleanWorkingDir flags rawSystemExit verbosity mbWorkDir "make" ["clean"] -sdistAction :: SDistFlags -> [String] -> IO () -sdistAction flags args = do +sdistAction :: VerbosityHandles -> SDistFlags -> [String] -> IO () +sdistAction verbHandles flags args = do noExtraFlags args - let verbosity = fromFlag $ sDistVerbosity flags + let verbosity = mkVerbosity verbHandles $ fromFlag $ sDistVerbosity flags mbWorkDir = flagToMaybe $ sDistWorkingDir flags rawSystemExit verbosity mbWorkDir "make" ["dist"] -registerAction :: RegisterFlags -> [String] -> IO () -registerAction flags args = do +registerAction :: VerbosityHandles -> RegisterFlags -> [String] -> IO () +registerAction verbHandles flags args = do noExtraFlags args - let verbosity = fromFlag $ registerVerbosity flags + let verbosity = mkVerbosity verbHandles $ fromFlag $ registerVerbosity flags mbWorkDir = flagToMaybe $ registerWorkingDir flags rawSystemExit verbosity mbWorkDir "make" ["register"] -unregisterAction :: RegisterFlags -> [String] -> IO () -unregisterAction flags args = do +unregisterAction :: VerbosityHandles -> RegisterFlags -> [String] -> IO () +unregisterAction verbHandles flags args = do noExtraFlags args - let verbosity = fromFlag $ registerVerbosity flags + let verbosity = mkVerbosity verbHandles $ fromFlag $ registerVerbosity flags mbWorkDir = flagToMaybe $ registerWorkingDir flags rawSystemExit verbosity mbWorkDir "make" ["unregister"] diff --git a/Cabal/src/Distribution/Simple.hs b/Cabal/src/Distribution/Simple.hs index 3a7ffbfdf39..b273881352c 100644 --- a/Cabal/src/Distribution/Simple.hs +++ b/Cabal/src/Distribution/Simple.hs @@ -52,6 +52,7 @@ module Distribution.Simple , defaultMain , defaultMainNoRead , defaultMainArgs + , defaultMainArgsWithHandles -- * Customization , UserHooks (..) @@ -65,9 +66,25 @@ module Distribution.Simple -- ** Standard sets of hooks , simpleUserHooks + , simpleUserHooksWithHandles , autoconfUserHooks , autoconfSetupHooks , emptyUserHooks + + -- ** Simple actions (library interface) + , configureAction + , buildAction + , replAction + , installAction + , copyAction + , haddockAction + , cleanAction + , sdistAction + , hscolourAction + , registerAction + , unregisterAction + , testAction + , benchAction ) where import Control.Exception (try) @@ -125,6 +142,7 @@ import System.Directory , removeFile ) import System.Environment (getArgs, getProgName) +import System.IO (hPutStr, hPutStrLn) -- | A simple implementation of @main@ for a Cabal setup script. -- It reads the package description file using IO, and performs the @@ -137,12 +155,17 @@ defaultMain = getArgs >>= defaultMainHelper simpleUserHooks defaultMainArgs :: [String] -> IO () defaultMainArgs = defaultMainHelper simpleUserHooks +-- | A version of 'defaultMainArgs' that allows passing explicit verbosity handles. +defaultMainArgsWithHandles :: VerbosityHandles -> [String] -> IO () +defaultMainArgsWithHandles verbHandles = + defaultMainHelperWithHandles verbHandles simpleUserHooks + defaultMainWithSetupHooks :: SetupHooks -> IO () -defaultMainWithSetupHooks setup_hooks = - getArgs >>= defaultMainWithSetupHooksArgs setup_hooks +defaultMainWithSetupHooks setupHooks = + getArgs >>= defaultMainWithSetupHooksArgs setupHooks defaultVerbosityHandles -defaultMainWithSetupHooksArgs :: SetupHooks -> [String] -> IO () -defaultMainWithSetupHooksArgs setupHooks = +defaultMainWithSetupHooksArgs :: SetupHooks -> VerbosityHandles -> [String] -> IO () +defaultMainWithSetupHooksArgs setupHooks verbHandles = defaultMainHelper $ simpleUserHooks { confHook = setup_confHook @@ -158,9 +181,11 @@ defaultMainWithSetupHooksArgs setupHooks = :: (GenericPackageDescription, HookedBuildInfo) -> ConfigFlags -> IO LocalBuildInfo - setup_confHook = + setup_confHook p = configure_setupHooks (SetupHooks.configureHooks setupHooks) + p + verbHandles setup_buildHook :: PackageDescription @@ -171,6 +196,7 @@ defaultMainWithSetupHooksArgs setupHooks = setup_buildHook pkg_descr lbi hooks flags = build_setupHooks (SetupHooks.buildHooks setupHooks) + verbHandles pkg_descr lbi flags @@ -185,6 +211,7 @@ defaultMainWithSetupHooksArgs setupHooks = setup_copyHook pkg_descr lbi _hooks flags = install_setupHooks (SetupHooks.installHooks setupHooks) + verbHandles pkg_descr lbi flags @@ -198,6 +225,7 @@ defaultMainWithSetupHooksArgs setupHooks = setup_installHook = defaultInstallHook_setupHooks (SetupHooks.installHooks setupHooks) + verbHandles setup_replHook :: PackageDescription @@ -209,6 +237,7 @@ defaultMainWithSetupHooksArgs setupHooks = setup_replHook pkg_descr lbi hooks flags args = repl_setupHooks (SetupHooks.buildHooks setupHooks) + verbHandles pkg_descr lbi flags @@ -224,6 +253,7 @@ defaultMainWithSetupHooksArgs setupHooks = setup_haddockHook pkg_descr lbi hooks flags = haddock_setupHooks (SetupHooks.buildHooks setupHooks) + verbHandles pkg_descr lbi (allSuffixHandlers hooks) @@ -238,6 +268,7 @@ defaultMainWithSetupHooksArgs setupHooks = setup_hscolourHook pkg_descr lbi hooks flags = hscolour_setupHooks (SetupHooks.buildHooks setupHooks) + verbHandles pkg_descr lbi (allSuffixHandlers hooks) @@ -282,38 +313,49 @@ defaultMainWithHooksNoReadArgs hooks pkg_descr = -- getting 'CommandParse' data back, which is then pattern-matched into -- IO actions for execution, with arguments applied by the parser. defaultMainHelper :: UserHooks -> Args -> IO () -defaultMainHelper hooks args = topHandler (isUserException (Proxy @(VerboseException CabalException))) $ do - args' <- expandResponse args - command <- commandsRun (globalCommand commands) commands args' - case command of - CommandHelp help -> printHelp help - CommandList opts -> printOptionsList opts - CommandErrors errs -> printErrors errs - CommandReadyToGo (globalFlags, commandParse) -> - case commandParse of - _ - | fromFlag (globalVersion globalFlags) -> printVersion - | fromFlag (globalNumericVersion globalFlags) -> printNumericVersion - CommandHelp help -> printHelp help - CommandList opts -> printOptionsList opts - CommandErrors errs -> printErrors errs - CommandReadyToGo action -> action globalFlags +defaultMainHelper = defaultMainHelperWithHandles defaultVerbosityHandles + +-- | A version of 'defaultMainHelper' that allows setting the logging handles. +defaultMainHelperWithHandles :: VerbosityHandles -> UserHooks -> Args -> IO () +defaultMainHelperWithHandles verbHandles hooks args = + topHandler (isUserException (Proxy @(VerboseException CabalException))) $ do + args' <- expandResponse args + command <- commandsRun (globalCommand commands) commands args' + case command of + CommandHelp help -> printHelp help + CommandList opts -> printOptionsList opts + CommandErrors errs -> printErrors errs + CommandReadyToGo (globalFlags, commandParse) -> + case commandParse of + _ + | fromFlag (globalVersion globalFlags) -> printVersion + | fromFlag (globalNumericVersion globalFlags) -> printNumericVersion + CommandHelp help -> printHelp help + CommandList opts -> printOptionsList opts + CommandErrors errs -> printErrors errs + CommandReadyToGo action -> action globalFlags where - printHelp help = getProgName >>= putStr . help - printOptionsList = putStr . unlines + outHandle = vStdoutHandle verbHandles + printHelp help = getProgName >>= hPutStr outHandle . help + printOptionsList = hPutStr outHandle . unlines printErrors errs = do - putStr (intercalate "\n" errs) + hPutStr outHandle (intercalate "\n" errs) exitWith (ExitFailure 1) - printNumericVersion = putStrLn $ prettyShow cabalVersion + printNumericVersion = + hPutStrLn outHandle $ prettyShow cabalVersion printVersion = - putStrLn $ + hPutStrLn outHandle $ "Cabal library version " ++ prettyShow cabalVersion progs = addKnownPrograms (hookedPrograms hooks) defaultProgramDb - addAction :: CommandUI flags -> (GlobalFlags -> UserHooks -> flags -> [String] -> IO res) -> Command (GlobalFlags -> IO ()) + addAction + :: CommandUI flags + -> (VerbosityHandles -> GlobalFlags -> UserHooks -> flags -> [String] -> IO res) + -> Command (GlobalFlags -> IO ()) addAction cmd action = - cmd `commandAddAction` \flags as globalFlags -> void $ action globalFlags hooks flags as + cmd `commandAddAction` \flags as globalFlags -> + void $ action verbHandles globalFlags hooks flags as commands :: [Command (GlobalFlags -> IO ())] commands = [ configureCommand progs `addAction` configureAction @@ -342,8 +384,8 @@ allSuffixHandlers hooks = overridesPP :: [PPSuffixHandler] -> [PPSuffixHandler] -> [PPSuffixHandler] overridesPP = unionBy (\x y -> fst x == fst y) -configureAction :: GlobalFlags -> UserHooks -> ConfigFlags -> Args -> IO LocalBuildInfo -configureAction globalFlags hooks flags args = do +configureAction :: VerbosityHandles -> GlobalFlags -> UserHooks -> ConfigFlags -> Args -> IO LocalBuildInfo +configureAction verbHandles globalFlags hooks flags args = do distPref <- findDistPrefOrDefault (setupDistPref $ configCommonFlags flags) let commonFlags = configCommonFlags flags commonFlags' = @@ -357,7 +399,7 @@ configureAction globalFlags hooks flags args = do { configCommonFlags = commonFlags' } mbWorkDir = flagToMaybe $ setupWorkingDir commonFlags' - verbosity = fromFlag $ setupVerbosity commonFlags' + verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity commonFlags') -- See docs for 'HookedBuildInfo' pbi <- preConf hooks args flags' @@ -405,14 +447,15 @@ confPkgDescr hooks verbosity cwd mb_path = do return (Just pdfile, descr) getCommonFlags - :: GlobalFlags + :: VerbosityHandles + -> GlobalFlags -> UserHooks -> CommonSetupFlags -> Args -> IO (LocalBuildInfo, CommonSetupFlags) -getCommonFlags globalFlags hooks commonFlags args = do +getCommonFlags verbHandles globalFlags hooks commonFlags args = do distPref <- findDistPrefOrDefault (setupDistPref commonFlags) - let verbosity = fromFlag $ setupVerbosity commonFlags + let verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity commonFlags) lbi <- getBuildConfig globalFlags hooks verbosity distPref let common' = configCommonFlags $ configFlags lbi return $ @@ -428,11 +471,11 @@ getCommonFlags globalFlags hooks commonFlags args = do } ) -buildAction :: GlobalFlags -> UserHooks -> BuildFlags -> Args -> IO () -buildAction globalFlags hooks flags args = do +buildAction :: VerbosityHandles -> GlobalFlags -> UserHooks -> BuildFlags -> Args -> IO () +buildAction verbHandles globalFlags hooks flags args = do let common = buildCommonFlags flags - verbosity = fromFlag $ setupVerbosity common - (lbi, common') <- getCommonFlags globalFlags hooks common args + verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common) + (lbi, common') <- getCommonFlags verbHandles globalFlags hooks common args let flags' = flags{buildCommonFlags = common'} progs <- @@ -452,11 +495,11 @@ buildAction globalFlags hooks flags args = do flags' args -replAction :: GlobalFlags -> UserHooks -> ReplFlags -> Args -> IO () -replAction globalFlags hooks flags args = do +replAction :: VerbosityHandles -> GlobalFlags -> UserHooks -> ReplFlags -> Args -> IO () +replAction verbHandles globalFlags hooks flags args = do let common = replCommonFlags flags - verbosity = fromFlag $ setupVerbosity common - (lbi, common') <- getCommonFlags globalFlags hooks common args + verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common) + (lbi, common') <- getCommonFlags verbHandles globalFlags hooks common args let flags' = flags{replCommonFlags = common'} progs <- reconfigurePrograms @@ -480,11 +523,11 @@ replAction globalFlags hooks flags args = do replHook hooks pkg_descr lbi' hooks flags' args postRepl hooks args flags' pkg_descr lbi' -hscolourAction :: GlobalFlags -> UserHooks -> HscolourFlags -> Args -> IO () -hscolourAction globalFlags hooks flags args = do +hscolourAction :: VerbosityHandles -> GlobalFlags -> UserHooks -> HscolourFlags -> Args -> IO () +hscolourAction verbHandles globalFlags hooks flags args = do let common = hscolourCommonFlags flags - verbosity = fromFlag $ setupVerbosity common - (_lbi, common') <- getCommonFlags globalFlags hooks common args + verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common) + (_lbi, common') <- getCommonFlags verbHandles globalFlags hooks common args let flags' = flags{hscolourCommonFlags = common'} distPref = fromFlag $ setupDistPref common' @@ -498,11 +541,11 @@ hscolourAction globalFlags hooks flags args = do flags' args -haddockAction :: GlobalFlags -> UserHooks -> HaddockFlags -> Args -> IO () -haddockAction globalFlags hooks flags args = do +haddockAction :: VerbosityHandles -> GlobalFlags -> UserHooks -> HaddockFlags -> Args -> IO () +haddockAction verbHandles globalFlags hooks flags args = do let common = haddockCommonFlags flags - verbosity = fromFlag $ setupVerbosity common - (lbi, common') <- getCommonFlags globalFlags hooks common args + verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common) + (lbi, common') <- getCommonFlags verbHandles globalFlags hooks common args let flags' = flags{haddockCommonFlags = common'} progs <- @@ -522,10 +565,10 @@ haddockAction globalFlags hooks flags args = do flags' args -cleanAction :: GlobalFlags -> UserHooks -> CleanFlags -> Args -> IO () -cleanAction globalFlags hooks flags args = do +cleanAction :: VerbosityHandles -> GlobalFlags -> UserHooks -> CleanFlags -> Args -> IO () +cleanAction verbHandles globalFlags hooks flags args = do let common = cleanCommonFlags flags - verbosity = fromFlag $ setupVerbosity common + verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common) distPref <- findDistPrefOrDefault (setupDistPref common) elbi <- tryGetBuildConfig globalFlags hooks verbosity distPref let common' = @@ -570,11 +613,11 @@ cleanAction globalFlags hooks flags args = do cleanHook hooks pkg_descr () hooks flags' postClean hooks args flags' pkg_descr () -copyAction :: GlobalFlags -> UserHooks -> CopyFlags -> Args -> IO () -copyAction globalFlags hooks flags args = do +copyAction :: VerbosityHandles -> GlobalFlags -> UserHooks -> CopyFlags -> Args -> IO () +copyAction verbHandles globalFlags hooks flags args = do let common = copyCommonFlags flags - verbosity = fromFlag $ setupVerbosity common - (_lbi, common') <- getCommonFlags globalFlags hooks common args + verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common) + (_lbi, common') <- getCommonFlags verbHandles globalFlags hooks common args let flags' = flags{copyCommonFlags = common'} distPref = fromFlag $ setupDistPref common' hookedAction @@ -587,11 +630,11 @@ copyAction globalFlags hooks flags args = do flags' args -installAction :: GlobalFlags -> UserHooks -> InstallFlags -> Args -> IO () -installAction globalFlags hooks flags args = do +installAction :: VerbosityHandles -> GlobalFlags -> UserHooks -> InstallFlags -> Args -> IO () +installAction verbHandles globalFlags hooks flags args = do let common = installCommonFlags flags - verbosity = fromFlag $ setupVerbosity common - (_lbi, common') <- getCommonFlags globalFlags hooks common args + verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common) + (_lbi, common') <- getCommonFlags verbHandles globalFlags hooks common args let flags' = flags{installCommonFlags = common'} distPref = fromFlag $ setupDistPref common' hookedAction @@ -605,20 +648,20 @@ installAction globalFlags hooks flags args = do args -- Since Cabal-3.4 UserHooks are completely ignored -sdistAction :: GlobalFlags -> UserHooks -> SDistFlags -> Args -> IO () -sdistAction _globalFlags _hooks flags _args = do +sdistAction :: VerbosityHandles -> GlobalFlags -> UserHooks -> SDistFlags -> Args -> IO () +sdistAction verbHandles _globalFlags _hooks flags _args = do let mbWorkDir = flagToMaybe $ sDistWorkingDir flags (_, ppd) <- confPkgDescr emptyUserHooks verbosity mbWorkDir Nothing let pkg_descr = flattenPackageDescription ppd - sdist pkg_descr flags srcPref knownSuffixHandlers + sdist verbHandles pkg_descr flags srcPref knownSuffixHandlers where - verbosity = fromFlag (setupVerbosity $ sDistCommonFlags flags) + verbosity = mkVerbosity verbHandles $ fromFlag (setupVerbosity $ sDistCommonFlags flags) -testAction :: GlobalFlags -> UserHooks -> TestFlags -> Args -> IO () -testAction globalFlags hooks flags args = do +testAction :: VerbosityHandles -> GlobalFlags -> UserHooks -> TestFlags -> Args -> IO () +testAction verbHandles globalFlags hooks flags args = do let common = testCommonFlags flags - verbosity = fromFlag $ setupVerbosity common - (_lbi, common') <- getCommonFlags globalFlags hooks common args + verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common) + (_lbi, common') <- getCommonFlags verbHandles globalFlags hooks common args let flags' = flags{testCommonFlags = common'} distPref = fromFlag $ setupDistPref common' hookedActionWithArgs @@ -631,11 +674,11 @@ testAction globalFlags hooks flags args = do flags' args -benchAction :: GlobalFlags -> UserHooks -> BenchmarkFlags -> Args -> IO () -benchAction globalFlags hooks flags args = do +benchAction :: VerbosityHandles -> GlobalFlags -> UserHooks -> BenchmarkFlags -> Args -> IO () +benchAction verbHandles globalFlags hooks flags args = do let common = benchmarkCommonFlags flags - verbosity = fromFlag $ setupVerbosity common - (_lbi, common') <- getCommonFlags globalFlags hooks common args + verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common) + (_lbi, common') <- getCommonFlags verbHandles globalFlags hooks common args let flags' = flags{benchmarkCommonFlags = common'} distPref = fromFlag $ setupDistPref common' hookedActionWithArgs @@ -648,11 +691,11 @@ benchAction globalFlags hooks flags args = do flags' args -registerAction :: GlobalFlags -> UserHooks -> RegisterFlags -> Args -> IO () -registerAction globalFlags hooks flags args = do +registerAction :: VerbosityHandles -> GlobalFlags -> UserHooks -> RegisterFlags -> Args -> IO () +registerAction verbHandles globalFlags hooks flags args = do let common = registerCommonFlags flags - verbosity = fromFlag $ setupVerbosity common - (_lbi, common') <- getCommonFlags globalFlags hooks common args + verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common) + (_lbi, common') <- getCommonFlags verbHandles globalFlags hooks common args let flags' = flags{registerCommonFlags = common'} distPref = fromFlag $ setupDistPref common' hookedAction @@ -665,11 +708,11 @@ registerAction globalFlags hooks flags args = do flags' args -unregisterAction :: GlobalFlags -> UserHooks -> RegisterFlags -> Args -> IO () -unregisterAction globalFlags hooks flags args = do +unregisterAction :: VerbosityHandles -> GlobalFlags -> UserHooks -> RegisterFlags -> Args -> IO () +unregisterAction verbHandles globalFlags hooks flags args = do let common = registerCommonFlags flags - verbosity = fromFlag $ setupVerbosity common - (_lbi, common') <- getCommonFlags globalFlags hooks common args + verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common) + (_lbi, common') <- getCommonFlags verbHandles globalFlags hooks common args let flags' = flags{registerCommonFlags = common'} distPref = fromFlag $ setupDistPref common' hookedAction @@ -827,18 +870,18 @@ getBuildConfig globalFlags hooks verbosity distPref = do , configCommonFlags = (configCommonFlags cFlags) { -- Use the current, not saved verbosity level: - setupVerbosity = Flag verbosity + setupVerbosity = Flag $ verbosityFlags verbosity } } - configureAction globalFlags hooks cFlags' (extraConfigArgs lbi) + configureAction (verbosityHandles verbosity) globalFlags hooks cFlags' (extraConfigArgs lbi) -- -------------------------------------------------------------------------- -- Cleaning -clean :: PackageDescription -> CleanFlags -> IO () -clean pkg_descr flags = do +clean :: VerbosityHandles -> PackageDescription -> CleanFlags -> IO () +clean verbHandles pkg_descr flags = do let common = cleanCommonFlags flags - verbosity = fromFlag (setupVerbosity common) + verbosity = mkVerbosity verbHandles (fromFlag (setupVerbosity common)) distPref = fromFlagOrDefault defaultDistPref $ setupDistPref common mbWorkDir = flagToMaybe $ setupWorkingDir common i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path @@ -852,7 +895,7 @@ clean pkg_descr flags = do -- remove the whole dist/ directory rather than tracking exactly what files -- we created in there. - chattyTry "removing dist/" $ do + chattyTry verbosity "removing dist/" $ do exists <- doesDirectoryExist distPath when exists (removeDirectoryRecursive distPath) @@ -876,28 +919,34 @@ clean pkg_descr flags = do -- | Hooks that correspond to a plain instantiation of the -- \"simple\" build system simpleUserHooks :: UserHooks -simpleUserHooks = +simpleUserHooks = simpleUserHooksWithHandles defaultVerbosityHandles + +-- | A version of 'simpleUserHooks' that allows setting custom logging handles. +simpleUserHooksWithHandles :: VerbosityHandles -> UserHooks +simpleUserHooksWithHandles verbHandles = emptyUserHooks - { confHook = configure + { confHook = \p -> configure_setupHooks SetupHooks.noConfigureHooks p verbHandles , postConf = finalChecks - , buildHook = defaultBuildHook - , replHook = defaultReplHook - , copyHook = \desc lbi _ f -> install desc lbi f + , buildHook = defaultBuildHook verbHandles + , replHook = defaultReplHook verbHandles + , copyHook = \desc lbi _ f -> install_setupHooks SetupHooks.noInstallHooks verbHandles desc lbi f , -- 'install' has correct 'copy' behavior with params - instHook = defaultInstallHook - , testHook = defaultTestHook - , benchHook = defaultBenchHook - , cleanHook = \p _ _ f -> clean p f - , hscolourHook = \p l h f -> hscolour p l (allSuffixHandlers h) f - , haddockHook = \p l h f -> haddock p l (allSuffixHandlers h) f - , regHook = defaultRegHook - , unregHook = \p l _ f -> unregister p l f + instHook = defaultInstallHook verbHandles + , testHook = defaultTestHook verbHandles + , benchHook = defaultBenchHook verbHandles + , cleanHook = \p _ _ f -> clean verbHandles p f + , hscolourHook = \p l h f -> hscolour_setupHooks SetupHooks.noBuildHooks verbHandles p l (allSuffixHandlers h) f + , haddockHook = \p l h f -> haddock_setupHooks SetupHooks.noBuildHooks verbHandles p l (allSuffixHandlers h) f + , regHook = defaultRegHook verbHandles + , unregHook = \p l _ f -> unregisterWithHandles verbHandles p l f } where finalChecks _args flags pkg_descr lbi = - checkForeignDeps pkg_descr lbi (lessVerbose verbosity) + checkForeignDeps pkg_descr lbi (modifyVerbosityFlags lessVerbose verbosity) where - verbosity = fromFlag (setupVerbosity $ configCommonFlags flags) + verbosity = + mkVerbosity verbHandles $ + fromFlag (setupVerbosity $ configCommonFlags flags) -- | Basic autoconf 'UserHooks': -- @@ -934,9 +983,10 @@ autoconfUserHooks = defaultPostConf args flags pkg_descr lbi = do let common = configCommonFlags flags - verbosity = fromFlag $ setupVerbosity common + verbosity = mkVerbosity defaultVerbosityHandles (fromFlag $ setupVerbosity common) mbWorkDir = flagToMaybe $ setupWorkingDir common runConfigureScript + defaultVerbosityHandles flags (flagAssignment lbi) (withPrograms lbi) @@ -954,7 +1004,7 @@ autoconfUserHooks = -> IO HookedBuildInfo readHookWithArgs get_common_flags _args flags = do let common = get_common_flags flags - verbosity = fromFlag (setupVerbosity common) + verbosity = mkVerbosity defaultVerbosityHandles (fromFlag (setupVerbosity common)) mbWorkDir = flagToMaybe $ setupWorkingDir common distPref = setupDistPref common dist_dir <- findDistPrefOrDefault distPref @@ -967,7 +1017,7 @@ autoconfUserHooks = -> IO HookedBuildInfo readHook get_common_flags args flags = do let common = get_common_flags flags - verbosity = fromFlag (setupVerbosity common) + verbosity = mkVerbosity defaultVerbosityHandles (fromFlag (setupVerbosity common)) mbWorkDir = flagToMaybe $ setupWorkingDir common distPref = setupDistPref common noExtraFlags args @@ -1011,7 +1061,7 @@ autoconfSetupHooks = , LBC.hostPlatform = plat } } - ) = runConfigureScript cfg flags progs plat + ) = runConfigureScript defaultVerbosityHandles cfg flags progs plat pre_conf_comp :: SetupHooks.PreConfComponentInputs @@ -1026,7 +1076,7 @@ autoconfSetupHooks = , SetupHooks.component = component } ) = do - let verbosity = fromFlag $ configVerbosity cfg + let verbosity = mkVerbosity defaultVerbosityHandles (fromFlag $ configVerbosity cfg) mbWorkDir = flagToMaybe $ configWorkingDir cfg distPref = configDistPref cfg dist_dir <- findDistPrefOrDefault distPref @@ -1047,48 +1097,52 @@ autoconfSetupHooks = } defaultTestHook - :: Args + :: VerbosityHandles + -> Args -> PackageDescription -> LocalBuildInfo -> UserHooks -> TestFlags -> IO () -defaultTestHook args pkg_descr localbuildinfo _ flags = - test args pkg_descr localbuildinfo flags +defaultTestHook verbHandles args pkg_descr localbuildinfo _ flags = + test args verbHandles pkg_descr localbuildinfo flags defaultBenchHook - :: Args + :: VerbosityHandles + -> Args -> PackageDescription -> LocalBuildInfo -> UserHooks -> BenchmarkFlags -> IO () -defaultBenchHook args pkg_descr localbuildinfo _ flags = - bench args pkg_descr localbuildinfo flags +defaultBenchHook verbHandles args pkg_descr localbuildinfo _ flags = + bench args verbHandles pkg_descr localbuildinfo flags defaultInstallHook - :: PackageDescription + :: VerbosityHandles + -> PackageDescription -> LocalBuildInfo -> UserHooks -> InstallFlags -> IO () -defaultInstallHook = - defaultInstallHook_setupHooks SetupHooks.noInstallHooks +defaultInstallHook verbHandles = + defaultInstallHook_setupHooks SetupHooks.noInstallHooks verbHandles defaultInstallHook_setupHooks :: SetupHooks.InstallHooks + -> VerbosityHandles -> PackageDescription -> LocalBuildInfo -> UserHooks -> InstallFlags -> IO () -defaultInstallHook_setupHooks inst_hooks pkg_descr localbuildinfo _ flags = do +defaultInstallHook_setupHooks inst_hooks verbHandles pkg_descr localbuildinfo _ flags = do let copyFlags = defaultCopyFlags { copyDest = installDest flags , copyCommonFlags = installCommonFlags flags } - install_setupHooks inst_hooks pkg_descr localbuildinfo copyFlags + install_setupHooks inst_hooks verbHandles pkg_descr localbuildinfo copyFlags let registerFlags = defaultRegisterFlags { regInPlace = installInPlace flags @@ -1096,38 +1150,58 @@ defaultInstallHook_setupHooks inst_hooks pkg_descr localbuildinfo _ flags = do , registerCommonFlags = installCommonFlags flags } when (hasLibs pkg_descr) $ - register pkg_descr localbuildinfo registerFlags + registerWithHandles verbHandles pkg_descr localbuildinfo registerFlags defaultBuildHook - :: PackageDescription + :: VerbosityHandles + -> PackageDescription -> LocalBuildInfo -> UserHooks -> BuildFlags -> IO () -defaultBuildHook pkg_descr localbuildinfo hooks flags = - build pkg_descr localbuildinfo flags (allSuffixHandlers hooks) +defaultBuildHook verbHandles pkg_descr localbuildinfo hooks flags = + build_setupHooks + SetupHooks.noBuildHooks + verbHandles + pkg_descr + localbuildinfo + flags + (allSuffixHandlers hooks) defaultReplHook - :: PackageDescription + :: VerbosityHandles + -> PackageDescription -> LocalBuildInfo -> UserHooks -> ReplFlags -> [String] -> IO () -defaultReplHook pkg_descr localbuildinfo hooks flags args = - repl pkg_descr localbuildinfo flags (allSuffixHandlers hooks) args +defaultReplHook verbHandles pkg_descr localbuildinfo hooks flags args = + repl_setupHooks + SetupHooks.noBuildHooks + verbHandles + pkg_descr + localbuildinfo + flags + (allSuffixHandlers hooks) + args defaultRegHook - :: PackageDescription + :: VerbosityHandles + -> PackageDescription -> LocalBuildInfo -> UserHooks -> RegisterFlags -> IO () -defaultRegHook pkg_descr localbuildinfo _ flags = - if hasLibs pkg_descr - then register pkg_descr localbuildinfo flags - else +defaultRegHook verbHandles pkg_descr localbuildinfo _ flags + | hasLibs pkg_descr = + registerWithHandles verbHandles pkg_descr localbuildinfo flags + | otherwise = setupMessage - (fromFlag (setupVerbosity $ registerCommonFlags flags)) + verbosity "Package contains no library to register:" (packageId pkg_descr) + where + verbosity = + mkVerbosity verbHandles $ + fromFlag (setupVerbosity $ registerCommonFlags flags) diff --git a/Cabal/src/Distribution/Simple/Bench.hs b/Cabal/src/Distribution/Simple/Bench.hs index c4b4dbd2f6c..991a11f74b3 100644 --- a/Cabal/src/Distribution/Simple/Bench.hs +++ b/Cabal/src/Distribution/Simple/Bench.hs @@ -41,6 +41,7 @@ import Distribution.System (Platform (Platform)) import Distribution.Types.Benchmark (Benchmark (benchmarkBuildInfo)) import Distribution.Types.UnqualComponentName import Distribution.Utils.Path +import Distribution.Verbosity import System.Directory (doesFileExist) @@ -48,6 +49,7 @@ import System.Directory (doesFileExist) bench :: Args -- ^ positional command-line arguments + -> VerbosityHandles -> PD.PackageDescription -- ^ information from the .cabal file -> LBI.LocalBuildInfo @@ -55,9 +57,9 @@ bench -> BenchmarkFlags -- ^ flags sent to benchmark -> IO () -bench args pkg_descr lbi flags = do +bench args verbHandles pkg_descr lbi flags = do curDir <- LBI.absoluteWorkingDirLBI lbi - let verbosity = fromFlag $ benchmarkVerbosity flags + let verbosity = mkVerbosity verbHandles (fromFlag $ benchmarkVerbosity flags) benchmarkNames = args pkgBenchmarks = PD.benchmarks pkg_descr enabledBenchmarks = LBI.enabledBenchLBIs pkg_descr lbi diff --git a/Cabal/src/Distribution/Simple/Build.hs b/Cabal/src/Distribution/Simple/Build.hs index 0d41eadb2c4..0a17df22323 100644 --- a/Cabal/src/Distribution/Simple/Build.hs +++ b/Cabal/src/Distribution/Simple/Build.hs @@ -91,6 +91,7 @@ import Distribution.Simple.BuildPaths import Distribution.Simple.BuildTarget import Distribution.Simple.BuildToolDepends import Distribution.Simple.Configure +import Distribution.Simple.Errors import Distribution.Simple.Flag import Distribution.Simple.LocalBuildInfo import Distribution.Simple.PreProcess @@ -126,7 +127,7 @@ import Distribution.Compat.Graph (IsNode (..)) import Control.Monad import qualified Data.ByteString.Lazy as LBS import qualified Data.Map as Map -import Distribution.Simple.Errors + import System.Directory (doesFileExist, removeFile) import System.FilePath (takeDirectory) @@ -143,10 +144,11 @@ build -> [PPSuffixHandler] -- ^ preprocessors to run before compiling -> IO () -build = build_setupHooks noBuildHooks +build = build_setupHooks noBuildHooks defaultVerbosityHandles build_setupHooks :: BuildHooks + -> VerbosityHandles -> PackageDescription -- ^ Mostly information from the .cabal file -> LocalBuildInfo @@ -158,12 +160,15 @@ build_setupHooks -> IO () build_setupHooks (BuildHooks{preBuildComponentRules = mbPbcRules, postBuildComponentHook = mbPostBuild}) + verbHandles pkg_descr lbi flags suffixHandlers = do checkSemaphoreSupport verbosity (compiler lbi) flags + targets <- readTargetInfos verbosity pkg_descr lbi (buildTargets flags) + let componentsToBuild = neededTargetsInBuildOrder' pkg_descr lbi (map nodeKey targets) info verbosity $ "Component build order: " @@ -225,6 +230,7 @@ build_setupHooks NoFlag -> Serial mb_ipi <- buildComponent + verbHandles flags par_strat pkg_descr @@ -245,7 +251,7 @@ build_setupHooks return () where distPref = fromFlag (buildDistPref flags) - verbosity = fromFlag (buildVerbosity flags) + verbosity = mkVerbosity verbHandles (fromFlag (buildVerbosity flags)) -- | Check for conditions that would prevent the build from succeeding. checkSemaphoreSupport @@ -329,11 +335,12 @@ repl -- ^ preprocessors to run before compiling -> [String] -> IO () -repl = repl_setupHooks noBuildHooks +repl = repl_setupHooks noBuildHooks defaultVerbosityHandles repl_setupHooks :: BuildHooks -- ^ build hook + -> VerbosityHandles -> PackageDescription -- ^ Mostly information from the .cabal file -> LocalBuildInfo @@ -346,13 +353,14 @@ repl_setupHooks -> IO () repl_setupHooks (BuildHooks{preBuildComponentRules = mbPbcRules}) + verbHandles pkg_descr lbi flags suffixHandlers args = do let distPref = fromFlag (replDistPref flags) - verbosity = fromFlag (replVerbosity flags) + verbosity = mkVerbosity verbHandles $ fromFlag (replVerbosity flags) target <- readTargetInfos verbosity pkg_descr lbi args >>= \r -> case r of @@ -408,7 +416,8 @@ repl_setupHooks lbi' <- lbiForComponent comp lbi preBuildComponent runPreBuildHooks verbosity lbi' subtarget buildComponent - (mempty{buildCommonFlags = mempty{setupVerbosity = toFlag verbosity}}) + verbHandles + (mempty{buildCommonFlags = mempty{setupVerbosity = toFlag $ verbosityFlags verbosity}}) NoFlag pkg_descr lbi' @@ -441,7 +450,8 @@ startInterpreter verbosity programDb comp platform packageDBs = _ -> dieWithException verbosity REPLNotSupported buildComponent - :: BuildFlags + :: VerbosityHandles + -> BuildFlags -> Flag ParStrat -> PackageDescription -> LocalBuildInfo @@ -450,13 +460,14 @@ buildComponent -> ComponentLocalBuildInfo -> SymbolicPath Pkg (Dir Dist) -> IO (Maybe InstalledPackageInfo) -buildComponent flags _ _ _ _ (CTest TestSuite{testInterface = TestSuiteUnsupported tt}) _ _ = - dieWithException (fromFlag $ buildVerbosity flags) $ +buildComponent verbHandles flags _ _ _ _ (CTest TestSuite{testInterface = TestSuiteUnsupported tt}) _ _ = + dieWithException (mkVerbosity verbHandles $ fromFlag $ buildVerbosity flags) $ NoSupportBuildingTestSuite tt -buildComponent flags _ _ _ _ (CBench Benchmark{benchmarkInterface = BenchmarkUnsupported tt}) _ _ = - dieWithException (fromFlag $ buildVerbosity flags) $ +buildComponent verbHandles flags _ _ _ _ (CBench Benchmark{benchmarkInterface = BenchmarkUnsupported tt}) _ _ = + dieWithException (mkVerbosity verbHandles $ fromFlag $ buildVerbosity flags) $ NoSupportBuildingBenchMark tt buildComponent + verbHandles flags numJobs pkg_descr @@ -473,7 +484,7 @@ buildComponent distPref = do inplaceDir <- absoluteWorkingDirLBI lbi0 - let verbosity = fromFlag $ buildVerbosity flags + let verbosity = mkVerbosity verbHandles $ fromFlag $ buildVerbosity flags let (pkg, lib, libClbi, lbi, ipi, exe, exeClbi) = testSuiteLibV09AsLibAndExe pkg_descr test clbi lbi0 inplaceDir distPref preprocessComponent pkg_descr comp lbi clbi False verbosity suffixHandlers @@ -487,7 +498,7 @@ buildComponent (maybeComponentInstantiatedWith clbi) let libbi = libBuildInfo lib lib' = lib{libBuildInfo = addSrcDir (addExtraOtherModules libbi generatedExtras) genDir} - buildLib flags numJobs pkg lbi lib' libClbi + buildLib verbHandles flags numJobs pkg lbi lib' libClbi -- NB: need to enable multiple instances here, because on 7.10+ -- the package name is the same as the library, and we still -- want the registration to go through. @@ -509,6 +520,7 @@ buildComponent buildExe verbosity numJobs pkg_descr lbi exe' exeClbi return Nothing -- Can't depend on test suite buildComponent + verbHandles flags numJobs pkg_descr @@ -518,7 +530,7 @@ buildComponent clbi distPref = do - let verbosity = fromFlag $ buildVerbosity flags + let verbosity = mkVerbosity verbHandles $ fromFlag $ buildVerbosity flags preprocessComponent pkg_descr comp lbi clbi False verbosity suffixHandlers extras <- preprocessExtras verbosity comp lbi setupMessage' @@ -541,7 +553,7 @@ buildComponent libbi } - buildLib flags numJobs pkg_descr lbi lib' clbi + buildLib verbHandles flags numJobs pkg_descr lbi lib' clbi let oneComponentRequested (OneComponentRequestedSpec _) = True oneComponentRequested _ = False @@ -625,6 +637,7 @@ generateCode codeGens nm pdesc bi lbi clbi verbosity = do mbWorkDir = mbWorkDirLBI lbi i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path tgtDir = buildDir lbi makeRelativePathEx (nm' nm' ++ "-gen") + verbLevel = verbosityLevel verbosity go :: String -> IO [ModuleName.ModuleName] go codeGenProg = fmap fromString . lines @@ -635,7 +648,7 @@ generateCode codeGens nm pdesc bi lbi clbi verbosity = do (withPrograms lbi) ( map interpretSymbolicPathCWD (tgtDir : srcDirs) ++ ( "--" - : GHC.renderGhcOptions (compiler lbi) (hostPlatform lbi) (GHC.componentGhcOptions verbosity lbi bi clbi tgtDir) + : GHC.renderGhcOptions (compiler lbi) (hostPlatform lbi) (GHC.componentGhcOptions verbLevel lbi bi clbi tgtDir) ) ) @@ -719,7 +732,7 @@ replComponent extras <- preprocessExtras verbosity comp lbi let libbi = libBuildInfo lib lib' = lib{libBuildInfo = libbi{cSources = cSources libbi ++ extras}} - replLib replFlags pkg lbi lib' libClbi + replLib (verbosityHandles verbosity) replFlags pkg lbi lib' libClbi replComponent replFlags verbosity @@ -730,29 +743,30 @@ replComponent clbi _ = do + let verbHandles = verbosityHandles verbosity preprocessComponent pkg_descr comp lbi clbi False verbosity suffixHandlers extras <- preprocessExtras verbosity comp lbi case comp of CLib lib -> do let libbi = libBuildInfo lib lib' = lib{libBuildInfo = libbi{cSources = cSources libbi ++ extras}} - replLib replFlags pkg_descr lbi lib' clbi + replLib verbHandles replFlags pkg_descr lbi lib' clbi CFLib flib -> - replFLib replFlags pkg_descr lbi flib clbi + replFLib verbHandles replFlags pkg_descr lbi flib clbi CExe exe -> do let ebi = buildInfo exe exe' = exe{buildInfo = ebi{cSources = cSources ebi ++ extras}} - replExe replFlags pkg_descr lbi exe' clbi + replExe verbHandles replFlags pkg_descr lbi exe' clbi CTest test@TestSuite{testInterface = TestSuiteExeV10{}} -> do let exe = testSuiteExeV10AsExe test let ebi = buildInfo exe exe' = exe{buildInfo = ebi{cSources = cSources ebi ++ extras}} - replExe replFlags pkg_descr lbi exe' clbi + replExe verbHandles replFlags pkg_descr lbi exe' clbi CBench bm@Benchmark{benchmarkInterface = BenchmarkExeV10{}} -> do let exe = benchmarkExeV10asExe bm let ebi = buildInfo exe exe' = exe{buildInfo = ebi{cSources = cSources ebi ++ extras}} - replExe replFlags pkg_descr lbi exe' clbi + replExe verbHandles replFlags pkg_descr lbi exe' clbi #if __GLASGOW_HASKELL__ < 811 -- silence pattern-match warnings prior to GHC 9.0 _ -> error "impossible" @@ -961,17 +975,18 @@ addInternalBuildTools pwd pkg lbi bi progs = -- TODO: build separate libs in separate dirs so that we can build -- multiple libs, e.g. for 'LibTest' library-style test suites buildLib - :: BuildFlags + :: VerbosityHandles + -> BuildFlags -> Flag ParStrat -> PackageDescription -> LocalBuildInfo -> Library -> ComponentLocalBuildInfo -> IO () -buildLib flags numJobs pkg_descr lbi lib clbi = - let verbosity = fromFlag $ buildVerbosity flags +buildLib verbHandles flags numJobs pkg_descr lbi lib clbi = + let verbosity = mkVerbosity verbHandles $ fromFlag $ buildVerbosity flags in case compilerFlavor (compiler lbi) of - GHC -> GHC.buildLib flags numJobs pkg_descr lbi lib clbi + GHC -> GHC.buildLib verbHandles flags numJobs pkg_descr lbi lib clbi GHCJS -> GHCJS.buildLib verbosity numJobs pkg_descr lbi lib clbi UHC -> UHC.buildLib verbosity pkg_descr lbi lib clbi _ -> dieWithException verbosity BuildingNotSupportedWithCompiler @@ -1009,33 +1024,35 @@ buildExe verbosity numJobs pkg_descr lbi exe clbi = _ -> dieWithException verbosity BuildingNotSupportedWithCompiler replLib - :: ReplFlags + :: VerbosityHandles + -> ReplFlags -> PackageDescription -> LocalBuildInfo -> Library -> ComponentLocalBuildInfo -> IO () -replLib replFlags pkg_descr lbi lib clbi = - let verbosity = fromFlag $ replVerbosity replFlags +replLib verbHandles replFlags pkg_descr lbi lib clbi = + let verbosity = mkVerbosity verbHandles (fromFlag $ replVerbosity replFlags) opts = replReplOptions replFlags in case compilerFlavor (compiler lbi) of -- 'cabal repl' doesn't need to support 'ghc --make -j', so we just pass -- NoFlag as the numJobs parameter. - GHC -> GHC.replLib replFlags NoFlag pkg_descr lbi lib clbi + GHC -> GHC.replLib verbHandles replFlags NoFlag pkg_descr lbi lib clbi GHCJS -> GHCJS.replLib (replOptionsFlags opts) verbosity NoFlag pkg_descr lbi lib clbi _ -> dieWithException verbosity REPLNotSupported replExe - :: ReplFlags + :: VerbosityHandles + -> ReplFlags -> PackageDescription -> LocalBuildInfo -> Executable -> ComponentLocalBuildInfo -> IO () -replExe flags pkg_descr lbi exe clbi = - let verbosity = fromFlag $ replVerbosity flags +replExe verbHandles flags pkg_descr lbi exe clbi = + let verbosity = mkVerbosity verbHandles $ fromFlag $ replVerbosity flags in case compilerFlavor (compiler lbi) of - GHC -> GHC.replExe flags NoFlag pkg_descr lbi exe clbi + GHC -> GHC.replExe verbHandles flags NoFlag pkg_descr lbi exe clbi GHCJS -> GHCJS.replExe (replOptionsFlags $ replReplOptions flags) @@ -1048,16 +1065,17 @@ replExe flags pkg_descr lbi exe clbi = _ -> dieWithException verbosity REPLNotSupported replFLib - :: ReplFlags + :: VerbosityHandles + -> ReplFlags -> PackageDescription -> LocalBuildInfo -> ForeignLib -> ComponentLocalBuildInfo -> IO () -replFLib flags pkg_descr lbi exe clbi = - let verbosity = fromFlag $ replVerbosity flags +replFLib verbHandles flags pkg_descr lbi exe clbi = + let verbosity = mkVerbosity verbHandles (fromFlag $ replVerbosity flags) in case compilerFlavor (compiler lbi) of - GHC -> GHC.replFLib flags NoFlag pkg_descr lbi exe clbi + GHC -> GHC.replFLib verbHandles flags NoFlag pkg_descr lbi exe clbi _ -> dieWithException verbosity REPLNotSupported -- | Runs 'componentInitialBuildSteps' on every configured component. diff --git a/Cabal/src/Distribution/Simple/Build/Inputs.hs b/Cabal/src/Distribution/Simple/Build/Inputs.hs index 7fc6faeb192..bf48b6829be 100644 --- a/Cabal/src/Distribution/Simple/Build/Inputs.hs +++ b/Cabal/src/Distribution/Simple/Build/Inputs.hs @@ -44,7 +44,7 @@ data PreBuildComponentInputs = PreBuildComponentInputs } -- | Get the @'Verbosity'@ from the context the component being built is in. -buildVerbosity :: PreBuildComponentInputs -> Verbosity +buildVerbosity :: PreBuildComponentInputs -> VerbosityFlags buildVerbosity = buildingWhatVerbosity . buildingWhat -- | Get the @'Component'@ being built. diff --git a/Cabal/src/Distribution/Simple/Configure.hs b/Cabal/src/Distribution/Simple/Configure.hs index 73c1df20247..30a1cbb3db4 100644 --- a/Cabal/src/Distribution/Simple/Configure.hs +++ b/Cabal/src/Distribution/Simple/Configure.hs @@ -449,22 +449,24 @@ configure :: (GenericPackageDescription, HookedBuildInfo) -> ConfigFlags -> IO LocalBuildInfo -configure = configure_setupHooks noConfigureHooks +configure p = configure_setupHooks noConfigureHooks p defaultVerbosityHandles configure_setupHooks :: ConfigureHooks -> (GenericPackageDescription, HookedBuildInfo) + -> VerbosityHandles -> ConfigFlags -> IO LocalBuildInfo configure_setupHooks (ConfigureHooks{preConfPackageHook, postConfPackageHook, preConfComponentHook}) (g_pkg_descr, hookedBuildInfo) + verbHandles cfg = do -- Cabal pre-configure - let verbosity = fromFlag (configVerbosity cfg) + let verbosity = mkVerbosity verbHandles (fromFlag (configVerbosity cfg)) distPref = fromFlag $ configDistPref cfg mbWorkDir = flagToMaybe $ configWorkingDir cfg - (lbc0, comp, platform, enabledComps) <- preConfigurePackage cfg g_pkg_descr + (lbc0, comp, platform, enabledComps) <- preConfigurePackage verbHandles cfg g_pkg_descr -- Package-wide pre-configure hook lbc1 <- @@ -503,7 +505,14 @@ configure_setupHooks -- Cabal package-wide configure (lbc2, pbd2, pkg_info) <- - finalizeAndConfigurePackage cfg lbc1 g_pkg_descr comp platform enabledComps + finalizeAndConfigurePackage + verbHandles + cfg + lbc1 + g_pkg_descr + comp + platform + enabledComps -- Package-wide post-configure hook for_ postConfPackageHook $ \postConfPkg -> do @@ -536,19 +545,20 @@ configure_setupHooks let pbd3 = pbd2{LBC.localPkgDescr = pkg_descr} -- Cabal per-component configure - externalPkgDeps <- finalCheckPackage g_pkg_descr pbd3 hookedBuildInfo pkg_info - lbi <- configureComponents lbc2 pbd3 pkg_info externalPkgDeps + externalPkgDeps <- finalCheckPackage verbHandles g_pkg_descr pbd3 hookedBuildInfo pkg_info + lbi <- configureComponents verbHandles lbc2 pbd3 pkg_info externalPkgDeps writePersistBuildConfig mbWorkDir distPref lbi return lbi preConfigurePackage - :: ConfigFlags + :: VerbosityHandles + -> ConfigFlags -> GenericPackageDescription -> IO (LBC.LocalBuildConfig, Compiler, Platform, ComponentRequestedSpec) -preConfigurePackage cfg g_pkg_descr = do - let verbosity = fromFlag $ configVerbosity cfg +preConfigurePackage verbHandles cfg g_pkg_descr = do + let verbosity = mkVerbosity verbHandles (fromFlag $ configVerbosity cfg) -- Determine the component we are configuring, if a user specified -- one on the command line. We use a fake, flattened version of @@ -608,7 +618,7 @@ preConfigurePackage cfg g_pkg_descr = do checkDeprecatedFlags verbosity cfg checkExactConfiguration verbosity g_pkg_descr cfg - programDbPre <- mkProgramDb cfg (configPrograms cfg) + programDbPre <- mkProgramDb verbHandles cfg (configPrograms cfg) -- comp: the compiler we're building with -- compPlatform: the platform we're building for -- programDb: location and args of all programs we're @@ -622,7 +632,7 @@ preConfigurePackage cfg g_pkg_descr = do (flagToMaybe (configHcPath cfg)) (flagToMaybe (configHcPkg cfg)) programDbPre - (lessVerbose verbosity) + (modifyVerbosityFlags lessVerbose verbosity) -- Where to build the package let builddir :: SymbolicPath Pkg (Dir Build) -- e.g. dist/build @@ -631,20 +641,21 @@ preConfigurePackage cfg g_pkg_descr = do -- NB: create this directory now so that all configure hooks get -- to see it. (In practice, the Configure build-type needs it before -- the postConfPackageHook runs.) - createDirectoryIfMissingVerbose (lessVerbose verbosity) True $ + createDirectoryIfMissingVerbose (modifyVerbosityFlags lessVerbose verbosity) True $ interpretSymbolicPath mbWorkDir builddir - lbc <- computeLocalBuildConfig cfg comp programDb00 + lbc <- computeLocalBuildConfig verbHandles cfg comp programDb00 return (lbc, comp, compPlatform, enabled) computeLocalBuildConfig - :: ConfigFlags + :: VerbosityHandles + -> ConfigFlags -> Compiler -> ProgramDb -> IO LBC.LocalBuildConfig -computeLocalBuildConfig cfg comp programDb = do +computeLocalBuildConfig verbHandles cfg comp programDb = do let common = configCommonFlags cfg - verbosity = fromFlag $ setupVerbosity common + verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common) -- Decide if we're going to compile with split sections. split_sections :: Bool <- if not (fromFlag $ configSplitSections cfg) @@ -834,7 +845,8 @@ data PackageInfo = PackageInfo } configurePackage - :: ConfigFlags + :: VerbosityHandles + -> ConfigFlags -> LBC.LocalBuildConfig -> PackageDescription -> FlagAssignment @@ -844,9 +856,9 @@ configurePackage -> ProgramDb -> PackageDBStack -> IO (LBC.LocalBuildConfig, LBC.PackageBuildDescr) -configurePackage cfg lbc0 pkg_descr00 flags enabled comp platform programDb0 packageDbs = do +configurePackage verbHandles cfg lbc0 pkg_descr00 flags enabled comp platform programDb0 packageDbs = do let common = configCommonFlags cfg - verbosity = fromFlag $ setupVerbosity common + verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common) -- add extra include/lib dirs as specified in cfg pkg_descr0 = addExtraIncludeLibDirsFromConfigFlags pkg_descr00 cfg @@ -887,7 +899,7 @@ configurePackage cfg lbc0 pkg_descr00 flags enabled comp platform programDb0 pac externBuildToolDeps ++ unknownBuildTools programDb1 <- - configureAllKnownPrograms (lessVerbose verbosity) programDb0 + configureAllKnownPrograms (modifyVerbosityFlags lessVerbose verbosity) programDb0 >>= configureRequiredPrograms verbosity requiredBuildTools (pkg_descr2, programDb2) <- @@ -936,16 +948,17 @@ configurePackage cfg lbc0 pkg_descr00 flags enabled comp platform programDb0 pac return (lbc, pbd) finalizeAndConfigurePackage - :: ConfigFlags + :: VerbosityHandles + -> ConfigFlags -> LBC.LocalBuildConfig -> GenericPackageDescription -> Compiler -> Platform -> ComponentRequestedSpec -> IO (LBC.LocalBuildConfig, LBC.PackageBuildDescr, PackageInfo) -finalizeAndConfigurePackage cfg lbc0 g_pkg_descr comp platform enabled = do +finalizeAndConfigurePackage verbHandles cfg lbc0 g_pkg_descr comp platform enabled = do let common = configCommonFlags cfg - verbosity = fromFlag $ setupVerbosity common + verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common) mbWorkDir = flagToMaybe $ setupWorkingDir common let programDb0 = LBC.withPrograms lbc0 @@ -959,7 +972,7 @@ finalizeAndConfigurePackage cfg lbc0 g_pkg_descr comp platform enabled = do -- The InstalledPackageIndex of all installed packages installedPackageSet :: InstalledPackageIndex <- getInstalledPackages - (lessVerbose verbosity) + (modifyVerbosityFlags lessVerbose verbosity) comp mbWorkDir packageDbs @@ -1048,6 +1061,7 @@ finalizeAndConfigurePackage cfg lbc0 g_pkg_descr comp platform enabled = do (lbc, pbd) <- configurePackage + verbHandles cfg lbc0 pkg_descr0 @@ -1109,12 +1123,14 @@ addExtraIncludeLibDirsFromConfigFlags pkg_descr cfg = } finalCheckPackage - :: GenericPackageDescription + :: VerbosityHandles + -> GenericPackageDescription -> LBC.PackageBuildDescr -> HookedBuildInfo -> PackageInfo -> IO ([PreExistingComponent], [ConfiguredPromisedComponent]) finalCheckPackage + verbHandles g_pkg_descr ( LBC.PackageBuildDescr { configFlags = cfg @@ -1128,7 +1144,7 @@ finalCheckPackage (PackageInfo{internalPackageSet, promisedDepsSet, installedPackageSet, requiredDepsMap}) = do let common = configCommonFlags cfg - verbosity = fromFlag $ setupVerbosity common + verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common) cabalFileDir = packageRoot common use_external_internal_deps = case enabled of @@ -1207,12 +1223,14 @@ finalCheckPackage enabled configureComponents - :: LBC.LocalBuildConfig + :: VerbosityHandles + -> LBC.LocalBuildConfig -> LBC.PackageBuildDescr -> PackageInfo -> ([PreExistingComponent], [ConfiguredPromisedComponent]) -> IO LocalBuildInfo configureComponents + verbHandles lbc@(LBC.LocalBuildConfig{withPrograms = programDb}) pbd0@( LBC.PackageBuildDescr { configFlags = cfg @@ -1225,7 +1243,7 @@ configureComponents externalPkgDeps = do let common = configCommonFlags cfg - verbosity = fromFlag $ setupVerbosity common + verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common) use_external_internal_deps = case enabled of OneComponentRequestedSpec{} -> True @@ -1379,16 +1397,17 @@ mkPromisedDepsSet comps = Map.fromList [((packageName pn, CLibName ln), p) | p@( -- | Adds the extra program paths from the flags provided to @configure@ as -- well as specified locations for certain known programs and their default -- arguments. -mkProgramDb :: ConfigFlags -> ProgramDb -> IO ProgramDb -mkProgramDb cfg initialProgramDb = do +mkProgramDb :: VerbosityHandles -> ConfigFlags -> ProgramDb -> IO ProgramDb +mkProgramDb verbHandles cfg initialProgramDb = do programDb <- modifyProgramSearchPath (getProgramSearchPath initialProgramDb ++) -- We need to have the paths to programs installed by build-tool-depends before all other paths - <$> prependProgramSearchPath (fromFlagOrDefault normal (configVerbosity cfg)) searchpath [] initialProgramDb + <$> prependProgramSearchPath verbosity searchpath [] initialProgramDb pure . userSpecifyArgss (configProgramArgs cfg) . userSpecifyPaths (configProgramPaths cfg) $ programDb where + verbosity = mkVerbosity verbHandles $ fromFlagOrDefault normal (configVerbosity cfg) searchpath = fromNubList (configProgramPathExtra cfg) -- Note. We try as much as possible to _prepend_ rather than postpend the extra-prog-path @@ -2362,7 +2381,7 @@ configurePkgconfigPackages verbosity pkg_descr progdb enabled | otherwise = do (_, _, progdb') <- requireProgramVersion - (lessVerbose verbosity) + (modifyVerbosityFlags lessVerbose verbosity) pkgConfigProgram (orLaterVersion $ mkVersion [0, 9, 0]) progdb @@ -2385,7 +2404,7 @@ configurePkgconfigPackages verbosity pkg_descr progdb enabled allpkgs = concatMap pkgconfigDepends (enabledBuildInfos pkg_descr enabled) pkgconfig = getDbProgramOutput - (lessVerbose verbosity) + (modifyVerbosityFlags lessVerbose verbosity) pkgConfigProgram progdb @@ -2472,12 +2491,13 @@ ccLdOptionsBuildInfo cflags ldflags ldflags_static = -- Determining the compiler details configCompilerAuxEx - :: ConfigFlags + :: VerbosityHandles + -> ConfigFlags -> IO (Compiler, Platform, ProgramDb) -configCompilerAuxEx cfg = do - programDb <- mkProgramDb cfg defaultProgramDb +configCompilerAuxEx verbHandles cfg = do + programDb <- mkProgramDb verbHandles cfg defaultProgramDb let common = configCommonFlags cfg - verbosity = fromFlag $ setupVerbosity common + verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common) configCompilerEx (flagToMaybe $ configHcFlavor cfg) (flagToMaybe $ configHcPath cfg) diff --git a/Cabal/src/Distribution/Simple/ConfigureScript.hs b/Cabal/src/Distribution/Simple/ConfigureScript.hs index b2922487730..972e8fb81ee 100644 --- a/Cabal/src/Distribution/Simple/ConfigureScript.hs +++ b/Cabal/src/Distribution/Simple/ConfigureScript.hs @@ -35,6 +35,7 @@ import Distribution.Simple.Utils import Distribution.System (Platform, buildPlatform) import Distribution.Utils.NubList import Distribution.Utils.Path +import Distribution.Verbosity -- Base import System.Directory (createDirectoryIfMissing, doesFileExist, makeAbsolute) @@ -49,15 +50,16 @@ import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Map as Map runConfigureScript - :: ConfigFlags + :: VerbosityHandles + -> ConfigFlags -> FlagAssignment -> ProgramDb -> Platform -- ^ host platform -> IO () -runConfigureScript cfg flags programDb hp = do +runConfigureScript verbHandles cfg flags programDb hp = do let commonCfg = configCommonFlags cfg - verbosity = fromFlag $ setupVerbosity commonCfg + verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity commonCfg) dist_dir <- findDistPrefOrDefault $ setupDistPref commonCfg let build_dir = dist_dir makeRelativePathEx "build" mbWorkDir = flagToMaybe $ setupWorkingDir commonCfg diff --git a/Cabal/src/Distribution/Simple/GHC.hs b/Cabal/src/Distribution/Simple/GHC.hs index 271e5eae89f..4896cb4c5a4 100644 --- a/Cabal/src/Distribution/Simple/GHC.hs +++ b/Cabal/src/Distribution/Simple/GHC.hs @@ -655,15 +655,16 @@ getInstalledPackagesMonitorFiles verbosity mbWorkDir platform progdb = -- Building a library buildLib - :: BuildFlags + :: VerbosityHandles + -> BuildFlags -> Flag ParStrat -> PackageDescription -> LocalBuildInfo -> Library -> ComponentLocalBuildInfo -> IO () -buildLib flags numJobs pkg lbi lib clbi = - GHC.build numJobs pkg $ +buildLib verbHandles flags numJobs pkg lbi lib clbi = + GHC.build numJobs verbHandles pkg $ PreBuildComponentInputs { buildingWhat = BuildNormal flags , localBuildInfo = lbi @@ -671,15 +672,16 @@ buildLib flags numJobs pkg lbi lib clbi = } replLib - :: ReplFlags + :: VerbosityHandles + -> ReplFlags -> Flag ParStrat -> PackageDescription -> LocalBuildInfo -> Library -> ComponentLocalBuildInfo -> IO () -replLib flags numJobs pkg lbi lib clbi = - GHC.build numJobs pkg $ +replLib verbHandles flags numJobs pkg lbi lib clbi = + GHC.build numJobs verbHandles pkg $ PreBuildComponentInputs { buildingWhat = BuildRepl flags , localBuildInfo = lbi @@ -719,28 +721,29 @@ buildFLib -> ComponentLocalBuildInfo -> IO () buildFLib v numJobs pkg lbi flib clbi = - GHC.build numJobs pkg $ + GHC.build numJobs (verbosityHandles v) pkg $ PreBuildComponentInputs { buildingWhat = BuildNormal $ mempty { buildCommonFlags = - mempty{setupVerbosity = toFlag v} + mempty{setupVerbosity = toFlag $ verbosityFlags v} } , localBuildInfo = lbi , targetInfo = TargetInfo clbi (CFLib flib) } replFLib - :: ReplFlags + :: VerbosityHandles + -> ReplFlags -> Flag ParStrat -> PackageDescription -> LocalBuildInfo -> ForeignLib -> ComponentLocalBuildInfo -> IO () -replFLib replFlags njobs pkg lbi flib clbi = - GHC.build njobs pkg $ +replFLib verbHandles replFlags njobs pkg lbi flib clbi = + GHC.build njobs verbHandles pkg $ PreBuildComponentInputs { buildingWhat = BuildRepl replFlags , localBuildInfo = lbi @@ -757,28 +760,29 @@ buildExe -> ComponentLocalBuildInfo -> IO () buildExe v njobs pkg lbi exe clbi = - GHC.build njobs pkg $ + GHC.build njobs (verbosityHandles v) pkg $ PreBuildComponentInputs { buildingWhat = BuildNormal $ mempty { buildCommonFlags = - mempty{setupVerbosity = toFlag v} + mempty{setupVerbosity = toFlag $ verbosityFlags v} } , localBuildInfo = lbi , targetInfo = TargetInfo clbi (CExe exe) } replExe - :: ReplFlags + :: VerbosityHandles + -> ReplFlags -> Flag ParStrat -> PackageDescription -> LocalBuildInfo -> Executable -> ComponentLocalBuildInfo -> IO () -replExe replFlags njobs pkg lbi exe clbi = - GHC.build njobs pkg $ +replExe verbHandles replFlags njobs pkg lbi exe clbi = + GHC.build njobs verbHandles pkg $ PreBuildComponentInputs { buildingWhat = BuildRepl replFlags , localBuildInfo = lbi @@ -801,7 +805,7 @@ libAbiHash verbosity _pkg_descr lbi lib clbi = do platform = hostPlatform lbi mbWorkDir = mbWorkDirLBI lbi vanillaArgs = - (Internal.componentGhcOptions verbosity lbi libBi clbi (componentBuildDir lbi clbi)) + (Internal.componentGhcOptions (verbosityLevel verbosity) lbi libBi clbi (componentBuildDir lbi clbi)) `mappend` mempty { ghcOptMode = toFlag GhcModeAbiHash , ghcOptInputModules = toNubListR $ exposedModules lib @@ -940,7 +944,7 @@ installFLib verbosity lbi targetDir builtDir _pkg flib = -- directory it's created in. -- Finally, we first create the symlinks in a temporary -- directory and then rename to simulate 'ln --force'. - withTempDirectory verbosity dstDir nm $ \tmpDir -> do + withTempDirectory dstDir nm $ \tmpDir -> do let link1 = flibBuildName lbi flib link2 = "lib" ++ nm <.> "so" createSymbolicLink name (tmpDir link1) diff --git a/Cabal/src/Distribution/Simple/GHC/Build.hs b/Cabal/src/Distribution/Simple/GHC/Build.hs index 0993e916886..a49b0773b5c 100644 --- a/Cabal/src/Distribution/Simple/GHC/Build.hs +++ b/Cabal/src/Distribution/Simple/GHC/Build.hs @@ -24,6 +24,7 @@ import Distribution.Types.ParStrat import Distribution.Utils.NubList (fromNubListR) import Distribution.Utils.Path +import Distribution.Verbosity (VerbosityHandles, mkVerbosity, verbosityHandles) import System.FilePath (splitDirectories) {- Note [Build Target Dir vs Target Dir] @@ -64,13 +65,14 @@ for linking libraries too (2024-01) (TODO) -- Includes building Haskell modules, extra build sources, and linking. build :: Flag ParStrat + -> VerbosityHandles -> PackageDescription -> PreBuildComponentInputs -- ^ The context and component being built in it. -> IO () -build numJobs pkg_descr pbci = do +build numJobs verbHandles pkg_descr pbci = do let - verbosity = buildVerbosity pbci + verbosity = mkVerbosity verbHandles $ buildVerbosity pbci isLib = buildIsLib pbci lbi = localBuildInfo pbci bi = buildBI pbci @@ -134,7 +136,7 @@ build numJobs pkg_descr pbci = do -- We need a separate build and link phase, and C sources must be compiled -- after Haskell modules, because C sources may depend on stub headers -- generated from compiling Haskell modules (#842, #3294). - (mbMainFile, inputModules) <- componentInputs buildTargetDir pkg_descr pbci + (mbMainFile, inputModules) <- componentInputs buildTargetDir verbHandles pkg_descr pbci let (hsMainFile, nonHsMainFile) = case mbMainFile of Just mainFile @@ -144,10 +146,11 @@ build numJobs pkg_descr pbci = do | otherwise -> (Nothing, Just mainFile) Nothing -> (Nothing, Nothing) - buildOpts <- buildHaskellModules numJobs ghcProg hsMainFile inputModules buildTargetDir finalModBuildWays pbci - extraSources <- buildAllExtraSources nonHsMainFile ghcProg buildTargetDir wantedWays pbci + buildOpts <- buildHaskellModules numJobs ghcProg hsMainFile inputModules buildTargetDir finalModBuildWays verbHandles pbci + extraSources <- buildAllExtraSources nonHsMainFile ghcProg buildTargetDir wantedWays verbHandles pbci linkOrLoadComponent ghcProg + (verbosityHandles verbosity) pkg_descr (fromNubListR extraSources) (buildTargetDir, targetDir) diff --git a/Cabal/src/Distribution/Simple/GHC/Build/ExtraSources.hs b/Cabal/src/Distribution/Simple/GHC/Build/ExtraSources.hs index f2ca9aba02f..ad273d89212 100644 --- a/Cabal/src/Distribution/Simple/GHC/Build/ExtraSources.hs +++ b/Cabal/src/Distribution/Simple/GHC/Build/ExtraSources.hs @@ -27,7 +27,7 @@ import Distribution.Simple.Setup.Common (commonSetupTempFileOptions) import Distribution.System (Arch (JavaScript), Platform (..)) import Distribution.Types.ComponentLocalBuildInfo import Distribution.Utils.Path -import Distribution.Verbosity (Verbosity) +import Distribution.Verbosity (VerbosityHandles, VerbosityLevel, mkVerbosity, verbosityLevel) -- | An action that builds all the extra build sources of a component, i.e. C, -- C++, Js, Asm, C-- sources. @@ -40,6 +40,8 @@ buildAllExtraSources -- ^ The build directory for this target -> (Bool -> [BuildWay], Bool -> BuildWay, BuildWay) -- ^ Needed build ways + -> VerbosityHandles + -- ^ Logging handles -> PreBuildComponentInputs -- ^ The context and component being built in it. -> IO (NubListR (SymbolicPath Pkg File)) @@ -66,6 +68,8 @@ buildCSources -- ^ The build directory for this target -> (Bool -> [BuildWay], Bool -> BuildWay, BuildWay) -- ^ Needed build ways + -> VerbosityHandles + -- ^ Logging handles -> PreBuildComponentInputs -- ^ The context and component being built in it. -> IO (NubListR (SymbolicPath Pkg File)) @@ -96,7 +100,7 @@ buildCxxSources mbMainFile = cxxFiles ++ [main] _otherwise -> cxxFiles ) -buildJsSources _mbMainFile ghcProg buildTargetDir neededWays = do +buildJsSources _mbMainFile ghcProg buildTargetDir neededWays verbHandles = do Platform hostArch _ <- hostPlatform <$> localBuildInfo let hasJsSupport = hostArch == JavaScript buildExtraSources @@ -114,6 +118,7 @@ buildJsSources _mbMainFile ghcProg buildTargetDir neededWays = do ghcProg buildTargetDir neededWays + verbHandles buildAsmSources _mbMainFile = buildExtraSources "Assembler Sources" @@ -131,7 +136,7 @@ buildCmmSources _mbMainFile = buildExtraSources :: String -- ^ String describing the extra sources being built, for printing. - -> ( Verbosity + -> ( VerbosityLevel -> LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo @@ -155,6 +160,8 @@ buildExtraSources -- ^ The build directory for this target -> (Bool -> [BuildWay], Bool -> BuildWay, BuildWay) -- ^ Needed build ways + -> VerbosityHandles + -- ^ Handles for logging -> PreBuildComponentInputs -- ^ The context and component being built in it. -> IO (NubListR (SymbolicPath Pkg File)) @@ -165,11 +172,12 @@ buildExtraSources viewSources ghcProg buildTargetDir - (neededLibWays, neededFLibWay, neededExeWay) = + (neededLibWays, neededFLibWay, neededExeWay) + verbHandles = \PreBuildComponentInputs{buildingWhat, localBuildInfo = lbi, targetInfo} -> do let bi = componentBuildInfo (targetComponent targetInfo) - verbosity = buildingWhatVerbosity buildingWhat + verbosity = mkVerbosity verbHandles $ buildingWhatVerbosity buildingWhat clbi = targetCLBI targetInfo isIndef = componentIsIndefinite clbi mbWorkDir = mbWorkDirLBI lbi @@ -193,7 +201,7 @@ buildExtraSources buildAction sourceFile = do let baseSrcOpts = componentSourceGhcOptions - verbosity + (verbosityLevel verbosity) lbi bi clbi diff --git a/Cabal/src/Distribution/Simple/GHC/Build/Link.hs b/Cabal/src/Distribution/Simple/GHC/Build/Link.hs index a0a5070e6b1..8b6fb81960c 100644 --- a/Cabal/src/Distribution/Simple/GHC/Build/Link.hs +++ b/Cabal/src/Distribution/Simple/GHC/Build/Link.hs @@ -67,6 +67,8 @@ import System.FilePath linkOrLoadComponent :: ConfiguredProgram -- ^ The configured GHC program that will be used for linking + -> VerbosityHandles + -- ^ Handles used for logging -> PackageDescription -- ^ The package description containing the component being built -> [SymbolicPath Pkg File] @@ -85,13 +87,14 @@ linkOrLoadComponent -> IO () linkOrLoadComponent ghcProg + verbHandles pkg_descr extraSources (buildTargetDir, targetDir) ((wantedLibWays, wantedFLibWay, wantedExeWay), buildOpts) pbci = do let - verbosity = buildVerbosity pbci + verbosity = mkVerbosity verbHandles $ buildVerbosity pbci target = targetInfo pbci component = buildComponent pbci what = buildingWhat pbci @@ -193,6 +196,7 @@ linkOrLoadComponent warn verbosity "No exposed modules" runReplOrWriteFlags ghcProg + verbHandles lbi replFlags replOpts_final @@ -476,7 +480,15 @@ linkLibrary buildTargetDir cleanedExtraLibDirs pkg_descr verbosity runGhcProg li -- This would be simpler by not adding every object to the invocation, and -- rather using module names. unless (null staticObjectFiles) $ do - info verbosity (show (ghcOptPackages (Internal.componentGhcOptions verbosity lbi libBi clbi buildTargetDir))) + info verbosity $ + show $ + ghcOptPackages $ + Internal.componentGhcOptions + (verbosityLevel verbosity) + lbi + libBi + clbi + buildTargetDir traverse_ linkWay wantedWays -- | Link the executable resulting from building this component, be it an @@ -734,13 +746,14 @@ hasThreaded bi = "-threaded" `elem` ghc -- GHCi with the GHC options Cabal elaborated to load the component interactively. runReplOrWriteFlags :: ConfiguredProgram + -> VerbosityHandles -> LocalBuildInfo -> ReplFlags -> GhcOptions -> PackageName -> TargetInfo -> IO () -runReplOrWriteFlags ghcProg lbi rflags ghcOpts pkg_name target = +runReplOrWriteFlags ghcProg verbHandles lbi rflags ghcOpts pkg_name target = let bi = componentBuildInfo $ targetComponent target clbi = targetCLBI target cname = componentName (targetComponent target) @@ -748,7 +761,7 @@ runReplOrWriteFlags ghcProg lbi rflags ghcOpts pkg_name target = platform = hostPlatform lbi common = configCommonFlags $ configFlags lbi mbWorkDir = mbWorkDirLBI lbi - verbosity = fromFlag $ setupVerbosity common + verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common) tempFileOptions = commonSetupTempFileOptions common in case replOptionsFlagOutput (replReplOptions rflags) of NoFlag -> do diff --git a/Cabal/src/Distribution/Simple/GHC/Build/Modules.hs b/Cabal/src/Distribution/Simple/GHC/Build/Modules.hs index ad1e55451a1..70184b4e2bb 100644 --- a/Cabal/src/Distribution/Simple/GHC/Build/Modules.hs +++ b/Cabal/src/Distribution/Simple/GHC/Build/Modules.hs @@ -41,6 +41,7 @@ import Distribution.Types.TestSuite import Distribution.Types.TestSuiteInterface import Distribution.Utils.NubList import Distribution.Utils.Path +import Distribution.Verbosity (VerbosityHandles, mkVerbosity, verbosityLevel) import System.FilePath () {- @@ -110,6 +111,8 @@ buildHaskellModules -- has already been created. -> [BuildWay] -- ^ The set of needed build ways according to user options + -> VerbosityHandles + -- ^ Logging handles -> PreBuildComponentInputs -- ^ The context and component being built in it. -> IO (BuildWay -> GhcOptions) @@ -117,11 +120,11 @@ buildHaskellModules -- invocation used to compile the component in that 'BuildWay'. -- This can be useful in, eg, a linker invocation, in which we want to use the -- same options and list the same inputs as those used for building. -buildHaskellModules numJobs ghcProg mbMainFile inputModules buildTargetDir neededLibWays pbci = do +buildHaskellModules numJobs ghcProg mbMainFile inputModules buildTargetDir neededLibWays verbHandles pbci = do -- See Note [Building Haskell Modules accounting for TH] let - verbosity = buildVerbosity pbci + verbosity = mkVerbosity verbHandles $ buildVerbosity pbci isLib = buildIsLib pbci clbi = buildCLBI pbci lbi = localBuildInfo pbci @@ -166,7 +169,7 @@ buildHaskellModules numJobs ghcProg mbMainFile inputModules buildTargetDir neede -- We define the base opts which are shared across different build ways in -- 'buildHaskellModules' baseOpts way = - (Internal.componentGhcOptions verbosity lbi bi clbi buildTargetDir) + (Internal.componentGhcOptions (verbosityLevel verbosity) lbi bi clbi buildTargetDir) `mappend` mempty { ghcOptMode = toFlag GhcModeMake , -- Previously we didn't pass -no-link when building libs, @@ -364,12 +367,14 @@ buildWayExtraHcOptions = \case componentInputs :: SymbolicPath Pkg (Dir Artifacts) -- ^ Target build dir + -> VerbosityHandles + -- ^ Logging handles -> PD.PackageDescription -> PreBuildComponentInputs -- ^ The context and component being built in it. -> IO (Maybe (SymbolicPath Pkg File), [ModuleName]) -- ^ The main input file, and the Haskell modules -componentInputs buildTargetDir pkg_descr pbci = +componentInputs buildTargetDir verbHandles pkg_descr pbci = case component of CLib lib -> pure (Nothing, allLibModules lib clbi) @@ -384,7 +389,7 @@ componentInputs buildTargetDir pkg_descr pbci = CTest TestSuite{} -> error "testSuiteExeV10AsExe: wrong kind" CBench Benchmark{} -> error "benchmarkExeV10asExe: wrong kind" where - verbosity = buildVerbosity pbci + verbosity = mkVerbosity verbHandles $ buildVerbosity pbci component = buildComponent pbci clbi = buildCLBI pbci mbWorkDir = mbWorkDirLBI $ localBuildInfo pbci diff --git a/Cabal/src/Distribution/Simple/GHC/Internal.hs b/Cabal/src/Distribution/Simple/GHC/Internal.hs index 9e252d7c889..2522de9d90e 100644 --- a/Cabal/src/Distribution/Simple/GHC/Internal.hs +++ b/Cabal/src/Distribution/Simple/GHC/Internal.hs @@ -378,7 +378,7 @@ includePaths lbi bi clbi odir = ] componentCcGhcOptions - :: Verbosity + :: VerbosityLevel -> LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo @@ -389,7 +389,7 @@ componentCcGhcOptions verbosity lbi bi clbi odir filename = mempty { -- Respect -v0, but don't crank up verbosity on GHC if -- Cabal verbosity is requested. For that, use --ghc-option=-v instead! - ghcOptVerbosity = toFlag (min verbosity normal) + ghcOptVerbosity = toFlag (min verbosity Normal) , ghcOptMode = toFlag GhcModeCompile , ghcOptInputFiles = toNubListR [filename] , ghcOptCppIncludePath = includePaths lbi bi clbi odir @@ -417,7 +417,7 @@ componentCcGhcOptions verbosity lbi bi clbi odir filename = } componentCxxGhcOptions - :: Verbosity + :: VerbosityLevel -> LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo @@ -428,7 +428,7 @@ componentCxxGhcOptions verbosity lbi bi clbi odir filename = mempty { -- Respect -v0, but don't crank up verbosity on GHC if -- Cabal verbosity is requested. For that, use --ghc-option=-v instead! - ghcOptVerbosity = toFlag (min verbosity normal) + ghcOptVerbosity = toFlag (min verbosity Normal) , ghcOptMode = toFlag GhcModeCompile , ghcOptInputFiles = toNubListR [filename] , ghcOptCppIncludePath = includePaths lbi bi clbi odir @@ -456,7 +456,7 @@ componentCxxGhcOptions verbosity lbi bi clbi odir filename = } componentAsmGhcOptions - :: Verbosity + :: VerbosityLevel -> LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo @@ -467,7 +467,7 @@ componentAsmGhcOptions verbosity lbi bi clbi odir filename = mempty { -- Respect -v0, but don't crank up verbosity on GHC if -- Cabal verbosity is requested. For that, use --ghc-option=-v instead! - ghcOptVerbosity = toFlag (min verbosity normal) + ghcOptVerbosity = toFlag (min verbosity Normal) , ghcOptMode = toFlag GhcModeCompile , ghcOptInputFiles = toNubListR [filename] , ghcOptCppIncludePath = includePaths lbi bi clbi odir @@ -491,7 +491,7 @@ componentAsmGhcOptions verbosity lbi bi clbi odir filename = } componentJsGhcOptions - :: Verbosity + :: VerbosityLevel -> LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo @@ -502,7 +502,7 @@ componentJsGhcOptions verbosity lbi bi clbi odir filename = mempty { -- Respect -v0, but don't crank up verbosity on GHC if -- Cabal verbosity is requested. For that, use --ghc-option=-v instead! - ghcOptVerbosity = toFlag (min verbosity normal) + ghcOptVerbosity = toFlag (min verbosity Normal) , ghcOptMode = toFlag GhcModeCompile , ghcOptInputFiles = toNubListR [filename] , ghcOptJSppOptions = jsppOptions bi @@ -515,7 +515,7 @@ componentJsGhcOptions verbosity lbi bi clbi odir filename = } componentGhcOptions - :: Verbosity + :: VerbosityLevel -> LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo @@ -526,7 +526,7 @@ componentGhcOptions verbosity lbi bi clbi odir = in mempty { -- Respect -v0, but don't crank up verbosity on GHC if -- Cabal verbosity is requested. For that, use --ghc-option=-v instead! - ghcOptVerbosity = toFlag (min verbosity normal) + ghcOptVerbosity = toFlag (min verbosity Normal) , ghcOptCabal = toFlag True , ghcOptThisUnitId = case clbi of LibComponentLocalBuildInfo{componentCompatPackageKey = pk} -> @@ -602,7 +602,7 @@ toGhcOptimisation NormalOptimisation = toFlag GhcNormalOptimisation toGhcOptimisation MaximumOptimisation = toFlag GhcMaximumOptimisation componentCmmGhcOptions - :: Verbosity + :: VerbosityLevel -> LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo @@ -613,7 +613,7 @@ componentCmmGhcOptions verbosity lbi bi clbi odir filename = mempty { -- Respect -v0, but don't crank up verbosity on GHC if -- Cabal verbosity is requested. For that, use --ghc-option=-v instead! - ghcOptVerbosity = toFlag (min verbosity normal) + ghcOptVerbosity = toFlag (min verbosity Normal) , ghcOptMode = toFlag GhcModeCompile , ghcOptInputFiles = toNubListR [filename] , ghcOptCppIncludePath = includePaths lbi bi clbi odir diff --git a/Cabal/src/Distribution/Simple/GHCJS.hs b/Cabal/src/Distribution/Simple/GHCJS.hs index c7f91a5b0e2..b2029c34e50 100644 --- a/Cabal/src/Distribution/Simple/GHCJS.hs +++ b/Cabal/src/Distribution/Simple/GHCJS.hs @@ -84,7 +84,7 @@ import Distribution.Types.PackageName.Magic import Distribution.Types.ParStrat import Distribution.Utils.NubList import Distribution.Utils.Path -import Distribution.Verbosity (Verbosity) +import Distribution.Verbosity (Verbosity (..), VerbosityLevel, verbosityLevel) import Distribution.Version import Control.Arrow ((***)) @@ -580,7 +580,7 @@ buildOrReplLib mReplFlags verbosity numJobs _pkg_descr lbi lib clbi = do let cLikeFiles = fromNubListR $ toNubListR (cSources libBi) <> toNubListR (cxxSources libBi) jsSrcs = jsSources libBi cObjs = map ((`replaceExtensionSymbolicPath` objExtension)) cLikeFiles - baseOpts = componentGhcOptions verbosity lbi libBi clbi libTargetDir + baseOpts = componentGhcOptions (verbosityLevel verbosity) lbi libBi clbi libTargetDir linkJsLibOpts = mempty { ghcOptExtra = @@ -1314,7 +1314,7 @@ gbuild verbosity numJobs pkg_descr lbi bm clbi = do TestComponentLocalBuildInfo{} -> True BenchComponentLocalBuildInfo{} -> True baseOpts = - (componentGhcOptions verbosity lbi bnfo clbi tmpDir) + (componentGhcOptions (verbosityLevel verbosity) lbi bnfo clbi tmpDir) `mappend` mempty { ghcOptMode = toFlag GhcModeMake , ghcOptInputFiles = @@ -1471,7 +1471,7 @@ gbuild verbosity numJobs pkg_descr lbi bm clbi = do [ do let baseCxxOpts = Internal.componentCxxGhcOptions - verbosity + (verbosityLevel verbosity) lbi bnfo clbi @@ -1517,7 +1517,7 @@ gbuild verbosity numJobs pkg_descr lbi bm clbi = do [ do let baseCcOpts = Internal.componentCcGhcOptions - verbosity + (verbosityLevel verbosity) lbi bnfo clbi @@ -1798,7 +1798,7 @@ libAbiHash verbosity _pkg_descr lbi lib clbi = do platform = hostPlatform lbi mbWorkDir = mbWorkDirLBI lbi vanillaArgs = - (componentGhcOptions verbosity lbi libBi clbi (componentBuildDir lbi clbi)) + (componentGhcOptions (verbosityLevel verbosity) lbi libBi clbi (componentBuildDir lbi clbi)) `mappend` mempty { ghcOptMode = toFlag GhcModeAbiHash , ghcOptInputModules = toNubListR $ exposedModules lib @@ -1838,7 +1838,7 @@ libAbiHash verbosity _pkg_descr lbi lib clbi = do return (takeWhile (not . isSpace) hash) componentGhcOptions - :: Verbosity + :: VerbosityLevel -> LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo diff --git a/Cabal/src/Distribution/Simple/Glob.hs b/Cabal/src/Distribution/Simple/Glob.hs index 65973e9e2ac..7154a3c6f00 100644 --- a/Cabal/src/Distribution/Simple/Glob.hs +++ b/Cabal/src/Distribution/Simple/Glob.hs @@ -59,6 +59,8 @@ import Distribution.Simple.Utils import Distribution.Utils.Path import Distribution.Verbosity ( Verbosity + , defaultVerbosityHandles + , mkVerbosity , silent ) @@ -88,7 +90,7 @@ matchGlob root glob = GlobMatchesDirectory a -> Just a GlobMissingDirectory{} -> Nothing ) - <$> runDirFileGlob silent Nothing root glob + <$> runDirFileGlob (mkVerbosity defaultVerbosityHandles silent) Nothing root glob -- | Match a globbing pattern against a file path component matchGlobPieces :: GlobPieces -> String -> Bool diff --git a/Cabal/src/Distribution/Simple/Haddock.hs b/Cabal/src/Distribution/Simple/Haddock.hs index 464f29d8721..1afe426ac70 100644 --- a/Cabal/src/Distribution/Simple/Haddock.hs +++ b/Cabal/src/Distribution/Simple/Haddock.hs @@ -227,10 +227,11 @@ haddock -> [PPSuffixHandler] -> HaddockFlags -> IO () -haddock = haddock_setupHooks noBuildHooks +haddock = haddock_setupHooks noBuildHooks defaultVerbosityHandles haddock_setupHooks :: BuildHooks + -> VerbosityHandles -> PackageDescription -> LocalBuildInfo -> [PPSuffixHandler] @@ -238,6 +239,7 @@ haddock_setupHooks -> IO () haddock_setupHooks _ + verbHandles pkg_descr _ _ @@ -247,17 +249,18 @@ haddock_setupHooks && not (fromFlag $ haddockTestSuites haddockFlags) && not (fromFlag $ haddockBenchmarks haddockFlags) && not (fromFlag $ haddockForeignLibs haddockFlags) = - warn (fromFlag $ setupVerbosity $ haddockCommonFlags haddockFlags) $ + warn (mkVerbosity verbHandles $ fromFlag $ setupVerbosity $ haddockCommonFlags haddockFlags) $ "No documentation was generated as this package does not contain " ++ "a library. Perhaps you want to use the --executables, --tests," ++ " --benchmarks or --foreign-libraries flags." haddock_setupHooks (BuildHooks{preBuildComponentRules = mbPbcRules}) + verbHandles pkg_descr lbi suffixes flags' = do - let verbosity = fromFlag $ haddockVerbosity flags + let verbosity = mkVerbosity verbHandles (fromFlag $ haddockVerbosity flags) mbWorkDir = flagToMaybe $ haddockWorkingDir flags comp = compiler lbi platform = hostPlatform lbi @@ -312,6 +315,7 @@ haddock_setupHooks -- NB: we are not passing the user BuildHooks here, -- because we are already running the pre/post build hooks -- for Haddock. + verbHandles (warn verbosity) haddockTarget pkg_descr @@ -591,7 +595,7 @@ fromFlags env flags = , argBaseUrl = haddockBaseUrl flags , argResourcesDir = haddockResourcesDir flags , argVerbose = - maybe mempty (Any . (>= deafening)) + maybe mempty (Any . (>= Deafening) . vLevel) . flagToMaybe $ setupVerbosity commonFlags , argOutput = @@ -643,7 +647,7 @@ fromPackageDescription _haddockTarget pkg_descr = | otherwise = ": " ++ ShortText.fromShortText (synopsis pkg_descr) componentGhcOptions - :: Verbosity + :: VerbosityLevel -> LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo @@ -706,7 +710,7 @@ mkHaddockArgs mkHaddockArgs verbosity (tmpObjDir, tmpHiDir, tmpStubDir) lbi clbi htmlTemplate inFiles bi = do let vanillaOpts' = - componentGhcOptions normal lbi bi clbi (buildDir lbi) + componentGhcOptions Normal lbi bi clbi (buildDir lbi) vanillaOpts = vanillaOpts' { -- See Note [Hi Haddock Recompilation Avoidance] @@ -1018,7 +1022,7 @@ getInterfaces -> IO HaddockArgs getInterfaces verbosity lbi clbi htmlTemplate = do (packageFlags, warnings) <- haddockPackageFlags verbosity lbi clbi htmlTemplate - traverse_ (warn (verboseUnmarkOutput verbosity)) warnings + traverse_ (warn (modifyVerbosityFlags verboseUnmarkOutput verbosity)) warnings return $ mempty { argInterfaces = packageFlags @@ -1064,12 +1068,12 @@ reusingGHCCompilationArtifacts -> IO r reusingGHCCompilationArtifacts verbosity tmpFileOpts mbWorkDir lbi bi clbi version act | version >= mkVersion [2, 28, 0] = do - withTempDirectoryCwdEx verbosity tmpFileOpts mbWorkDir (distPrefLBI lbi) "haddock-objs" $ \tmpObjDir -> - withTempDirectoryCwdEx verbosity tmpFileOpts mbWorkDir (distPrefLBI lbi) "haddock-his" $ \tmpHiDir -> do + withTempDirectoryCwdEx tmpFileOpts mbWorkDir (distPrefLBI lbi) "haddock-objs" $ \tmpObjDir -> + withTempDirectoryCwdEx tmpFileOpts mbWorkDir (distPrefLBI lbi) "haddock-his" $ \tmpHiDir -> do -- Re-use ghc's interface and obj files, but first copy them to -- somewhere where it is safe if haddock overwrites them let - vanillaOpts = componentGhcOptions normal lbi bi clbi (buildDir lbi) + vanillaOpts = componentGhcOptions Normal lbi bi clbi (buildDir lbi) i = interpretSymbolicPath mbWorkDir copyDir getGhcDir tmpDir = do let ghcDir = i $ fromFlag $ getGhcDir vanillaOpts @@ -1084,7 +1088,7 @@ reusingGHCCompilationArtifacts verbosity tmpFileOpts mbWorkDir lbi bi clbi versi act (tmpObjDir, tmpHiDir, fromFlag $ ghcOptHiDir vanillaOpts) | otherwise = do - withTempDirectoryCwdEx verbosity tmpFileOpts mbWorkDir (distPrefLBI lbi) "tmp" $ + withTempDirectoryCwdEx tmpFileOpts mbWorkDir (distPrefLBI lbi) "tmp" $ \tmpFallback -> act (tmpFallback, tmpFallback, tmpFallback) -- ------------------------------------------------------------------------------ @@ -1475,20 +1479,22 @@ hscolour -> [PPSuffixHandler] -> HscolourFlags -> IO () -hscolour = hscolour_setupHooks noBuildHooks +hscolour = hscolour_setupHooks noBuildHooks defaultVerbosityHandles hscolour_setupHooks :: BuildHooks + -> VerbosityHandles -> PackageDescription -> LocalBuildInfo -> [PPSuffixHandler] -> HscolourFlags -> IO () -hscolour_setupHooks setupHooks = - hscolour' setupHooks dieNoVerbosity ForDevelopment +hscolour_setupHooks setupHooks verbHandles = + hscolour' setupHooks verbHandles dieNoVerbosity ForDevelopment hscolour' :: BuildHooks + -> VerbosityHandles -> (String -> IO ()) -- ^ Called when the 'hscolour' exe is not found. -> HaddockTarget @@ -1499,6 +1505,7 @@ hscolour' -> IO () hscolour' (BuildHooks{preBuildComponentRules = mbPbcRules}) + verbHandles onNoHsColour haddockTarget pkg_descr @@ -1513,7 +1520,7 @@ hscolour' (withPrograms lbi) where common = hscolourCommonFlags flags - verbosity = fromFlag $ setupVerbosity common + verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common) distPref = fromFlag $ setupDistPref common mbWorkDir = mbWorkDirLBI lbi i = interpretSymbolicPathLBI lbi -- See Note [Symbolic paths] in Distribution.Utils.Path diff --git a/Cabal/src/Distribution/Simple/Install.hs b/Cabal/src/Distribution/Simple/Install.hs index 50cef3e099c..85e704cc472 100644 --- a/Cabal/src/Distribution/Simple/Install.hs +++ b/Cabal/src/Distribution/Simple/Install.hs @@ -104,10 +104,11 @@ install -> CopyFlags -- ^ flags sent to copy or install -> IO () -install = install_setupHooks SetupHooks.noInstallHooks +install = install_setupHooks SetupHooks.noInstallHooks defaultVerbosityHandles install_setupHooks :: InstallHooks + -> VerbosityHandles -> PackageDescription -- ^ information from the .cabal file -> LocalBuildInfo @@ -117,6 +118,7 @@ install_setupHooks -> IO () install_setupHooks (InstallHooks{installComponentHook}) + verbHandles pkg_descr lbi flags = do @@ -141,7 +143,7 @@ install_setupHooks where common = copyCommonFlags flags distPref = fromFlag $ setupDistPref common - verbosity = fromFlag $ setupVerbosity common + verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common) copydest = fromFlag (copyDest flags) checkHasLibsOrExes = diff --git a/Cabal/src/Distribution/Simple/PackageDescription.hs b/Cabal/src/Distribution/Simple/PackageDescription.hs index e0f1806d6a1..3ca2756d0cd 100644 --- a/Cabal/src/Distribution/Simple/PackageDescription.hs +++ b/Cabal/src/Distribution/Simple/PackageDescription.hs @@ -44,14 +44,12 @@ import Distribution.Parsec.Warning import Distribution.Simple.Errors import Distribution.Simple.Utils (dieWithException, equating, warn) import Distribution.Utils.Path -import Distribution.Verbosity (Verbosity, normal) -import GHC.Stack +import Distribution.Verbosity (Verbosity, VerbosityLevel (..), verbosityLevel) import System.Directory (doesFileExist) import Text.Printf (printf) readGenericPackageDescription - :: HasCallStack - => Verbosity + :: Verbosity -> Maybe (SymbolicPath CWD (Dir Pkg)) -> SymbolicPath Pkg File -> IO GenericPackageDescription @@ -115,7 +113,7 @@ parseString parser verbosity name bs = do -- a count of further sites flattenDups :: Verbosity -> [PWarningWithSource src] -> [PWarningWithSource src] flattenDups verbosity ws - | verbosity <= normal = rest ++ experimentals + | verbosityLevel verbosity <= Normal = rest ++ experimentals | otherwise = ws -- show all instances where (exps, rest) = partition (\(PWarningWithSource _ (PWarning w _ _)) -> w == PWTExperimental) ws diff --git a/Cabal/src/Distribution/Simple/Program/Ar.hs b/Cabal/src/Distribution/Simple/Program/Ar.hs index 2e9b432385f..76d22af8a4c 100644 --- a/Cabal/src/Distribution/Simple/Program/Ar.hs +++ b/Cabal/src/Distribution/Simple/Program/Ar.hs @@ -57,8 +57,8 @@ import Distribution.System import Distribution.Utils.Path import Distribution.Verbosity ( Verbosity - , deafening - , verbose + , VerbosityLevel (..) + , verbosityLevel ) import System.Directory (doesFileExist, renameFile) @@ -90,7 +90,7 @@ createArLibArchive verbosity lbi targetPath files = do i = interpretSymbolicPath mbWorkDir u :: SymbolicPath Pkg to -> FilePath u = interpretSymbolicPathCWD - withTempDirectoryCwd verbosity mbWorkDir targetDir "objs" $ \tmpDir -> do + withTempDirectoryCwd mbWorkDir targetDir "objs" $ \tmpDir -> do let tmpPath = tmpDir targetName -- The args to use with "ar" are actually rather subtle and system-dependent. @@ -168,8 +168,8 @@ createArLibArchive verbosity lbi targetPath files = do progDb = withPrograms lbi Platform hostArch hostOS = hostPlatform lbi verbosityOpts v - | v >= deafening = ["-v"] - | v >= verbose = [] + | verbosityLevel v >= Deafening = ["-v"] + | verbosityLevel v >= Verbose = [] | otherwise = ["-c"] -- Do not warn if library had to be created. -- | @ar@ by default includes various metadata for each object file in their diff --git a/Cabal/src/Distribution/Simple/Program/Builtin.hs b/Cabal/src/Distribution/Simple/Program/Builtin.hs index 96fd96bd93f..4f9ccc924ed 100644 --- a/Cabal/src/Distribution/Simple/Program/Builtin.hs +++ b/Cabal/src/Distribution/Simple/Program/Builtin.hs @@ -247,7 +247,10 @@ stripProgram :: Program stripProgram = (simpleProgram "strip") { programFindVersion = \verbosity -> - findProgramVersion "--version" stripExtractVersion (lessVerbose verbosity) + findProgramVersion + "--version" + stripExtractVersion + (modifyVerbosityFlags lessVerbose verbosity) } hsc2hsProgram :: Program diff --git a/Cabal/src/Distribution/Simple/Program/GHC.hs b/Cabal/src/Distribution/Simple/Program/GHC.hs index 4c0d1e1929d..4dd99e457bf 100644 --- a/Cabal/src/Distribution/Simple/Program/GHC.hs +++ b/Cabal/src/Distribution/Simple/Program/GHC.hs @@ -578,7 +578,7 @@ data GhcOptions = GhcOptions , --------------- -- Misc flags - ghcOptVerbosity :: Flag Verbosity + ghcOptVerbosity :: Flag VerbosityLevel -- ^ Get GHC to be quiet or verbose with what it's doing; the @ghc -v@ flag. , ghcOptExtraPath :: NubListR (SymbolicPath Pkg (Dir Build)) -- ^ Put the extra folders in the PATH environment variable we invoke @@ -978,10 +978,10 @@ renderGhcOptions comp _platform@(Platform _arch os) opts flags flg = fromNubListR . flg $ opts flagBool flg = fromFlagOrDefault False (flg opts) -verbosityOpts :: Verbosity -> [String] +verbosityOpts :: VerbosityLevel -> [String] verbosityOpts verbosity - | verbosity >= deafening = ["-v"] - | verbosity >= normal = [] + | verbosity >= Deafening = ["-v"] + | verbosity >= Normal = [] | otherwise = ["-w", "-v0"] -- | GHC <7.6 uses '-package-conf' instead of '-package-db'. diff --git a/Cabal/src/Distribution/Simple/Program/HcPkg.hs b/Cabal/src/Distribution/Simple/Program/HcPkg.hs index 414be7bb287..61d353d8d49 100644 --- a/Cabal/src/Distribution/Simple/Program/HcPkg.hs +++ b/Cabal/src/Distribution/Simple/Program/HcPkg.hs @@ -181,7 +181,7 @@ register hpi verbosity mbWorkDir packagedbs pkgInfo registerOptions | otherwise = runProgramInvocation verbosity - (registerInvocation hpi verbosity mbWorkDir packagedbs pkgInfo registerOptions) + (registerInvocation hpi (verbosityLevel verbosity) mbWorkDir packagedbs pkgInfo registerOptions) writeRegistrationFileDirectly :: Verbosity @@ -209,7 +209,7 @@ unregister :: HcPkgInfo -> Verbosity -> Maybe (SymbolicPath CWD (Dir Pkg)) -> Pa unregister hpi verbosity mbWorkDir packagedb pkgid = runProgramInvocation verbosity - (unregisterInvocation hpi verbosity mbWorkDir packagedb pkgid) + (unregisterInvocation hpi (verbosityLevel verbosity) mbWorkDir packagedb pkgid) -- | Call @hc-pkg@ to recache the registered packages. -- @@ -218,7 +218,7 @@ recache :: HcPkgInfo -> Verbosity -> Maybe (SymbolicPath CWD (Dir from)) -> Pack recache hpi verbosity mbWorkDir packagedb = runProgramInvocation verbosity - (recacheInvocation hpi verbosity mbWorkDir packagedb) + (recacheInvocation hpi (verbosityLevel verbosity) mbWorkDir packagedb) -- | Call @hc-pkg@ to expose a package. -- @@ -233,7 +233,7 @@ expose expose hpi verbosity mbWorkDir packagedb pkgid = runProgramInvocation verbosity - (exposeInvocation hpi verbosity mbWorkDir packagedb pkgid) + (exposeInvocation hpi (verbosityLevel verbosity) mbWorkDir packagedb pkgid) -- | Call @hc-pkg@ to retrieve a specific package -- @@ -249,7 +249,7 @@ describe hpi verbosity mbWorkDir packagedb pid = do output <- getProgramInvocationLBS verbosity - (describeInvocation hpi verbosity mbWorkDir packagedb pid) + (describeInvocation hpi (verbosityLevel verbosity) mbWorkDir packagedb pid) `catchIO` \_ -> return mempty case parsePackages output of @@ -269,7 +269,7 @@ hide hide hpi verbosity mbWorkDir packagedb pkgid = runProgramInvocation verbosity - (hideInvocation hpi verbosity mbWorkDir packagedb pkgid) + (hideInvocation hpi (verbosityLevel verbosity) mbWorkDir packagedb pkgid) -- | Call @hc-pkg@ to get all the details of all the packages in the given -- package database. @@ -283,7 +283,7 @@ dump hpi verbosity mbWorkDir packagedb = do output <- getProgramInvocationLBS verbosity - (dumpInvocation hpi verbosity mbWorkDir packagedb) + (dumpInvocation hpi (verbosityLevel verbosity) mbWorkDir packagedb) `catchIO` \e -> dieWithException verbosity $ DumpFailed (programId (hcPkgProgram hpi)) (displayException e) @@ -397,7 +397,7 @@ list hpi verbosity mbWorkDir packagedb = do output <- getProgramInvocationOutput verbosity - (listInvocation hpi verbosity mbWorkDir packagedb) + (listInvocation hpi (verbosityLevel verbosity) mbWorkDir packagedb) `catchIO` \_ -> dieWithException verbosity $ ListFailed (programId (hcPkgProgram hpi)) case parsePackageIds output of @@ -416,11 +416,11 @@ initInvocation hpi verbosity path = where args = ["init", path] - ++ verbosityOpts hpi verbosity + ++ verbosityOpts hpi (verbosityLevel verbosity) registerInvocation :: HcPkgInfo - -> Verbosity + -> VerbosityLevel -> Maybe (SymbolicPath CWD (Dir from)) -> PackageDBStackS from -> InstalledPackageInfo @@ -450,7 +450,7 @@ registerInvocation hpi verbosity mbWorkDir packagedbs pkgInfo registerOptions = unregisterInvocation :: HcPkgInfo - -> Verbosity + -> VerbosityLevel -> Maybe (SymbolicPath CWD (Dir Pkg)) -> PackageDB -> PackageId @@ -462,7 +462,7 @@ unregisterInvocation hpi verbosity mbWorkDir packagedb pkgid = recacheInvocation :: HcPkgInfo - -> Verbosity + -> VerbosityLevel -> Maybe (SymbolicPath CWD (Dir from)) -> PackageDBS from -> ProgramInvocation @@ -473,7 +473,7 @@ recacheInvocation hpi verbosity mbWorkDir packagedb = exposeInvocation :: HcPkgInfo - -> Verbosity + -> VerbosityLevel -> Maybe (SymbolicPath CWD (Dir Pkg)) -> PackageDB -> PackageId @@ -485,7 +485,7 @@ exposeInvocation hpi verbosity mbWorkDir packagedb pkgid = describeInvocation :: HcPkgInfo - -> Verbosity + -> VerbosityLevel -> Maybe (SymbolicPath CWD (Dir Pkg)) -> PackageDBStack -> PackageId @@ -498,7 +498,7 @@ describeInvocation hpi verbosity mbWorkDir packagedbs pkgid = hideInvocation :: HcPkgInfo - -> Verbosity + -> VerbosityLevel -> Maybe (SymbolicPath CWD (Dir Pkg)) -> PackageDB -> PackageId @@ -510,7 +510,7 @@ hideInvocation hpi verbosity mbWorkDir packagedb pkgid = dumpInvocation :: HcPkgInfo - -> Verbosity + -> VerbosityLevel -> Maybe (SymbolicPath CWD (Dir from)) -> PackageDBX (SymbolicPath from (Dir PkgDB)) -> ProgramInvocation @@ -521,14 +521,14 @@ dumpInvocation hpi _verbosity mbWorkDir packagedb = where args = ["dump", packageDbOpts hpi packagedb] - ++ verbosityOpts hpi silent + ++ verbosityOpts hpi Silent --- We use verbosity level 'silent' because it is important that we +-- We use verbosity level 'Silent' because it is important that we -- do not contaminate the output with info/debug messages. listInvocation :: HcPkgInfo - -> Verbosity + -> VerbosityLevel -> Maybe (SymbolicPath CWD (Dir Pkg)) -> PackageDB -> ProgramInvocation @@ -539,9 +539,9 @@ listInvocation hpi _verbosity mbWorkDir packagedb = where args = ["list", "--simple-output", packageDbOpts hpi packagedb] - ++ verbosityOpts hpi silent + ++ verbosityOpts hpi Silent --- We use verbosity level 'silent' because it is important that we +-- We use verbosity level 'Silent' because it is important that we -- do not contaminate the output with info/debug messages. packageDbStackOpts :: HcPkgInfo -> PackageDBStackS from -> [String] @@ -575,10 +575,10 @@ packageDbOpts _ GlobalPackageDB = "--global" packageDbOpts _ UserPackageDB = "--user" packageDbOpts hpi (SpecificPackageDB db) = "--" ++ packageDbFlag hpi ++ "=" ++ interpretSymbolicPathCWD db -verbosityOpts :: HcPkgInfo -> Verbosity -> [String] +verbosityOpts :: HcPkgInfo -> VerbosityLevel -> [String] verbosityOpts hpi v | noVerboseFlag hpi = [] - | v >= deafening = ["-v2"] - | v == silent = ["-v0"] + | v >= Deafening = ["-v2"] + | v == Silent = ["-v0"] | otherwise = [] diff --git a/Cabal/src/Distribution/Simple/Program/Run.hs b/Cabal/src/Distribution/Simple/Program/Run.hs index a0e0346cb2c..2e3c512324b 100644 --- a/Cabal/src/Distribution/Simple/Program/Run.hs +++ b/Cabal/src/Distribution/Simple/Program/Run.hs @@ -130,8 +130,7 @@ runProgramInvocation , progInvokeEnv = [] , progInvokeCwd = Nothing , progInvokeInput = Nothing - } = - rawSystemExit verbosity Nothing path args + } = rawSystemExit verbosity Nothing path args runProgramInvocation verbosity ProgramInvocation diff --git a/Cabal/src/Distribution/Simple/Register.hs b/Cabal/src/Distribution/Simple/Register.hs index 48962782728..2154f334946 100644 --- a/Cabal/src/Distribution/Simple/Register.hs +++ b/Cabal/src/Distribution/Simple/Register.hs @@ -29,7 +29,9 @@ -- generation and the unregister feature are not well used or tested. module Distribution.Simple.Register ( register + , registerWithHandles , unregister + , unregisterWithHandles , internalPackageDBPath , initPackageDB , doesPackageDBExist @@ -98,12 +100,21 @@ register -> RegisterFlags -- ^ Install in the user's database?; verbose -> IO () -register pkg_descr lbi0 flags = do +register = registerWithHandles defaultVerbosityHandles + +registerWithHandles + :: VerbosityHandles + -> PackageDescription + -> LocalBuildInfo + -> RegisterFlags + -- ^ Install in the user's database?; verbose + -> IO () +registerWithHandles verbHandles pkg_descr lbi0 flags = do -- Duncan originally asked for us to not register/install files -- when there was no public library. But with per-component -- configure, we legitimately need to install internal libraries -- so that we can get them. So just unconditionally install. - let verbosity = fromFlag $ registerVerbosity flags + let verbosity = mkVerbosity verbHandles (fromFlag $ registerVerbosity flags) targets <- readTargetInfos verbosity pkg_descr lbi0 $ registerTargets flags -- It's important to register in build order, because ghc-pkg @@ -117,20 +128,21 @@ register pkg_descr lbi0 flags = do CLib lib -> do let clbi = targetCLBI tgt lbi = lbi0{installedPkgs = index} - ipi <- generateOne pkg_descr lib lbi clbi flags + ipi <- generateOne verbHandles pkg_descr lib lbi clbi flags return (Index.insert ipi index, Just ipi) _ -> return (index, Nothing) - registerAll pkg_descr lbi0 flags (catMaybes ipi_mbs) + registerAll verbHandles pkg_descr lbi0 flags (catMaybes ipi_mbs) generateOne - :: PackageDescription + :: VerbosityHandles + -> PackageDescription -> Library -> LocalBuildInfo -> ComponentLocalBuildInfo -> RegisterFlags -> IO InstalledPackageInfo -generateOne pkg lib lbi clbi regFlags = +generateOne verbHandles pkg lib lbi clbi regFlags = do absPackageDBs <- absolutePackageDBPaths mbWorkDir packageDbs installedPkgInfo <- @@ -158,16 +170,17 @@ generateOne pkg lib lbi clbi regFlags = withPackageDB lbi ++ maybeToList (flagToMaybe (regPackageDB regFlags)) distPref = fromFlag $ setupDistPref common - verbosity = fromFlag $ setupVerbosity common + verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common) mbWorkDir = flagToMaybe $ setupWorkingDir common registerAll - :: PackageDescription + :: VerbosityHandles + -> PackageDescription -> LocalBuildInfo -> RegisterFlags -> [InstalledPackageInfo] -> IO () -registerAll pkg lbi regFlags ipis = +registerAll verbHandles pkg lbi regFlags ipis = do when (fromFlag (regPrintId regFlags)) $ do for_ ipis $ \installedPkgInfo -> @@ -176,7 +189,8 @@ registerAll pkg lbi regFlags ipis = ( packageId installedPkgInfo == packageId pkg && IPI.sourceLibName installedPkgInfo == LMainLibName ) - $ putStrLn (prettyShow (IPI.installedUnitId installedPkgInfo)) + $ notice verbosity + $ prettyShow (IPI.installedUnitId installedPkgInfo) -- Three different modes: case () of @@ -217,7 +231,7 @@ registerAll pkg lbi regFlags ipis = withPackageDB lbi ++ maybeToList (flagToMaybe (regPackageDB regFlags)) common = registerCommonFlags regFlags - verbosity = fromFlag (setupVerbosity common) + verbosity = mkVerbosity verbHandles (fromFlag (setupVerbosity common)) mbWorkDir = mbWorkDirLBI lbi writeRegistrationFileOrDirectory = do @@ -452,7 +466,7 @@ writeHcPkgRegisterScript verbosity mbWorkDir ipis packageDbs hpi = do let invocation = HcPkg.registerInvocation hpi - Verbosity.normal + Verbosity.Normal mbWorkDir packageDbs installedPkgInfo @@ -711,11 +725,14 @@ relocatableInstalledPackageInfo pkg abi_hash lib lbi clbi pkgroot = -- Unregistration unregister :: PackageDescription -> LocalBuildInfo -> RegisterFlags -> IO () -unregister pkg lbi regFlags = do +unregister = unregisterWithHandles defaultVerbosityHandles + +unregisterWithHandles :: VerbosityHandles -> PackageDescription -> LocalBuildInfo -> RegisterFlags -> IO () +unregisterWithHandles verbHandles pkg lbi regFlags = do let pkgid = packageId pkg common = registerCommonFlags regFlags genScript = fromFlag (regGenScript regFlags) - verbosity = fromFlag (setupVerbosity common) + verbosity = mkVerbosity verbHandles (fromFlag (setupVerbosity common)) packageDb = fromFlagOrDefault (registrationPackageDB (withPackageDB lbi)) @@ -725,7 +742,7 @@ unregister pkg lbi regFlags = do let invocation = HcPkg.unregisterInvocation hpi - Verbosity.normal + Verbosity.Normal mbWorkDir packageDb pkgid diff --git a/Cabal/src/Distribution/Simple/Setup.hs b/Cabal/src/Distribution/Simple/Setup.hs index 313aa35e1d0..d9d179f9d96 100644 --- a/Cabal/src/Distribution/Simple/Setup.hs +++ b/Cabal/src/Distribution/Simple/Setup.hs @@ -170,7 +170,7 @@ import Distribution.Simple.Setup.SDist import Distribution.Simple.Setup.Test import Distribution.Utils.Path -import Distribution.Verbosity (Verbosity) +import Distribution.Verbosity (VerbosityFlags) -- | What kind of build phase are we doing/hooking into? -- @@ -194,7 +194,7 @@ buildingWhatCommonFlags = \case BuildHaddock flags -> haddockCommonFlags flags BuildHscolour flags -> hscolourCommonFlags flags -buildingWhatVerbosity :: BuildingWhat -> Verbosity +buildingWhatVerbosity :: BuildingWhat -> VerbosityFlags buildingWhatVerbosity = fromFlag . setupVerbosity . buildingWhatCommonFlags buildingWhatWorkingDir :: BuildingWhat -> Maybe (SymbolicPath CWD (Dir Pkg)) diff --git a/Cabal/src/Distribution/Simple/Setup/Benchmark.hs b/Cabal/src/Distribution/Simple/Setup/Benchmark.hs index 79dfe88e79f..da222cb30a7 100644 --- a/Cabal/src/Distribution/Simple/Setup/Benchmark.hs +++ b/Cabal/src/Distribution/Simple/Setup/Benchmark.hs @@ -55,7 +55,7 @@ data BenchmarkFlags = BenchmarkFlags deriving (Show, Generic) pattern BenchmarkCommonFlags - :: Flag Verbosity + :: Flag VerbosityFlags -> Flag (SymbolicPath Pkg (Dir Dist)) -> Flag (SymbolicPath CWD (Dir Pkg)) -> Flag (SymbolicPath Pkg File) diff --git a/Cabal/src/Distribution/Simple/Setup/Build.hs b/Cabal/src/Distribution/Simple/Setup/Build.hs index 8c124027a1e..9359f6d0d27 100644 --- a/Cabal/src/Distribution/Simple/Setup/Build.hs +++ b/Cabal/src/Distribution/Simple/Setup/Build.hs @@ -61,7 +61,7 @@ data BuildFlags = BuildFlags deriving (Read, Show, Generic) pattern BuildCommonFlags - :: Flag Verbosity + :: Flag VerbosityFlags -> Flag (SymbolicPath Pkg (Dir Dist)) -> Flag (SymbolicPath CWD (Dir Pkg)) -> Flag (SymbolicPath Pkg File) diff --git a/Cabal/src/Distribution/Simple/Setup/Clean.hs b/Cabal/src/Distribution/Simple/Setup/Clean.hs index 1e5e8038031..f1501f6caf9 100644 --- a/Cabal/src/Distribution/Simple/Setup/Clean.hs +++ b/Cabal/src/Distribution/Simple/Setup/Clean.hs @@ -53,7 +53,7 @@ data CleanFlags = CleanFlags deriving (Show, Generic) pattern CleanCommonFlags - :: Flag Verbosity + :: Flag VerbosityFlags -> Flag (SymbolicPath Pkg (Dir Dist)) -> Flag (SymbolicPath CWD (Dir Pkg)) -> Flag (SymbolicPath Pkg File) diff --git a/Cabal/src/Distribution/Simple/Setup/Common.hs b/Cabal/src/Distribution/Simple/Setup/Common.hs index 63c239131e8..595ecfc6dae 100644 --- a/Cabal/src/Distribution/Simple/Setup/Common.hs +++ b/Cabal/src/Distribution/Simple/Setup/Common.hs @@ -71,7 +71,7 @@ import Distribution.Verbosity -- | A datatype that stores common flags for different invocations -- of a @Setup@ executable, e.g. configure, build, install. data CommonSetupFlags = CommonSetupFlags - { setupVerbosity :: !(Flag Verbosity) + { setupVerbosity :: !(Flag VerbosityFlags) -- ^ Verbosity , setupWorkingDir :: !(Flag (SymbolicPath CWD (Dir Pkg))) -- ^ Working directory (optional) @@ -396,8 +396,8 @@ reqSymbolicPathArgFlag title sf lf d get set = (set . fmap makeSymbolicPath) optionVerbosity - :: (flags -> Flag Verbosity) - -> (Flag Verbosity -> flags -> flags) + :: (flags -> Flag VerbosityFlags) + -> (Flag VerbosityFlags -> flags -> flags) -> OptionField flags optionVerbosity get set = option diff --git a/Cabal/src/Distribution/Simple/Setup/Config.hs b/Cabal/src/Distribution/Simple/Setup/Config.hs index a1bb8b299f0..3ccc94457ca 100644 --- a/Cabal/src/Distribution/Simple/Setup/Config.hs +++ b/Cabal/src/Distribution/Simple/Setup/Config.hs @@ -237,7 +237,7 @@ data ConfigFlags = ConfigFlags deriving (Generic, Read, Show) pattern ConfigCommonFlags - :: Flag Verbosity + :: Flag VerbosityFlags -> Flag (SymbolicPath Pkg (Dir Dist)) -> Flag (SymbolicPath CWD (Dir Pkg)) -> Flag (SymbolicPath Pkg File) diff --git a/Cabal/src/Distribution/Simple/Setup/Copy.hs b/Cabal/src/Distribution/Simple/Setup/Copy.hs index 9d3255abf5b..93b156f35ab 100644 --- a/Cabal/src/Distribution/Simple/Setup/Copy.hs +++ b/Cabal/src/Distribution/Simple/Setup/Copy.hs @@ -57,7 +57,7 @@ data CopyFlags = CopyFlags deriving (Show, Generic) pattern CopyCommonFlags - :: Flag Verbosity + :: Flag VerbosityFlags -> Flag (SymbolicPath Pkg (Dir Dist)) -> Flag (SymbolicPath CWD (Dir Pkg)) -> Flag (SymbolicPath Pkg File) diff --git a/Cabal/src/Distribution/Simple/Setup/Haddock.hs b/Cabal/src/Distribution/Simple/Setup/Haddock.hs index c7d2403ed69..9dafda9a270 100644 --- a/Cabal/src/Distribution/Simple/Setup/Haddock.hs +++ b/Cabal/src/Distribution/Simple/Setup/Haddock.hs @@ -116,7 +116,7 @@ data HaddockFlags = HaddockFlags deriving (Show, Generic) pattern HaddockCommonFlags - :: Flag Verbosity + :: Flag VerbosityFlags -> Flag (SymbolicPath Pkg (Dir Dist)) -> Flag (SymbolicPath CWD (Dir Pkg)) -> Flag (SymbolicPath Pkg File) diff --git a/Cabal/src/Distribution/Simple/Setup/Hscolour.hs b/Cabal/src/Distribution/Simple/Setup/Hscolour.hs index 4ee69d99b9b..8e03dec10f1 100644 --- a/Cabal/src/Distribution/Simple/Setup/Hscolour.hs +++ b/Cabal/src/Distribution/Simple/Setup/Hscolour.hs @@ -57,7 +57,7 @@ data HscolourFlags = HscolourFlags deriving (Show, Generic) pattern HscolourCommonFlags - :: Flag Verbosity + :: Flag VerbosityFlags -> Flag (SymbolicPath Pkg (Dir Dist)) -> Flag (SymbolicPath CWD (Dir Pkg)) -> Flag (SymbolicPath Pkg File) diff --git a/Cabal/src/Distribution/Simple/Setup/Install.hs b/Cabal/src/Distribution/Simple/Setup/Install.hs index 89e35f48234..9b03a955ace 100644 --- a/Cabal/src/Distribution/Simple/Setup/Install.hs +++ b/Cabal/src/Distribution/Simple/Setup/Install.hs @@ -61,7 +61,7 @@ data InstallFlags = InstallFlags deriving (Show, Generic) pattern InstallCommonFlags - :: Flag Verbosity + :: Flag VerbosityFlags -> Flag (SymbolicPath Pkg (Dir Dist)) -> Flag (SymbolicPath CWD (Dir Pkg)) -> Flag (SymbolicPath Pkg File) diff --git a/Cabal/src/Distribution/Simple/Setup/Register.hs b/Cabal/src/Distribution/Simple/Setup/Register.hs index e768ca94887..6988ec0bd20 100644 --- a/Cabal/src/Distribution/Simple/Setup/Register.hs +++ b/Cabal/src/Distribution/Simple/Setup/Register.hs @@ -61,7 +61,7 @@ data RegisterFlags = RegisterFlags deriving (Show, Generic) pattern RegisterCommonFlags - :: Flag Verbosity + :: Flag VerbosityFlags -> Flag (SymbolicPath Pkg (Dir Dist)) -> Flag (SymbolicPath CWD (Dir Pkg)) -> Flag (SymbolicPath Pkg File) diff --git a/Cabal/src/Distribution/Simple/Setup/Repl.hs b/Cabal/src/Distribution/Simple/Setup/Repl.hs index ceec4649ad8..5931376399d 100644 --- a/Cabal/src/Distribution/Simple/Setup/Repl.hs +++ b/Cabal/src/Distribution/Simple/Setup/Repl.hs @@ -59,7 +59,7 @@ data ReplOptions = ReplOptions deriving (Show, Generic) pattern ReplCommonFlags - :: Flag Verbosity + :: Flag VerbosityFlags -> Flag (SymbolicPath Pkg (Dir Dist)) -> Flag (SymbolicPath CWD (Dir Pkg)) -> Flag (SymbolicPath Pkg File) diff --git a/Cabal/src/Distribution/Simple/Setup/SDist.hs b/Cabal/src/Distribution/Simple/Setup/SDist.hs index 2e560dcc6b9..dddad00fb01 100644 --- a/Cabal/src/Distribution/Simple/Setup/SDist.hs +++ b/Cabal/src/Distribution/Simple/Setup/SDist.hs @@ -56,7 +56,7 @@ data SDistFlags = SDistFlags deriving (Show, Generic) pattern SDistCommonFlags - :: Flag Verbosity + :: Flag VerbosityFlags -> Flag (SymbolicPath Pkg (Dir Dist)) -> Flag (SymbolicPath CWD (Dir Pkg)) -> Flag (SymbolicPath Pkg File) diff --git a/Cabal/src/Distribution/Simple/Setup/Test.hs b/Cabal/src/Distribution/Simple/Setup/Test.hs index baaecaf254f..02e4c092ef5 100644 --- a/Cabal/src/Distribution/Simple/Setup/Test.hs +++ b/Cabal/src/Distribution/Simple/Setup/Test.hs @@ -102,7 +102,7 @@ data TestFlags = TestFlags deriving (Show, Generic) pattern TestCommonFlags - :: Flag Verbosity + :: Flag VerbosityFlags -> Flag (SymbolicPath Pkg (Dir Dist)) -> Flag (SymbolicPath CWD (Dir Pkg)) -> Flag (SymbolicPath Pkg File) diff --git a/Cabal/src/Distribution/Simple/ShowBuildInfo.hs b/Cabal/src/Distribution/Simple/ShowBuildInfo.hs index ac83518aa38..489c237c27c 100644 --- a/Cabal/src/Distribution/Simple/ShowBuildInfo.hs +++ b/Cabal/src/Distribution/Simple/ShowBuildInfo.hs @@ -215,5 +215,5 @@ getCompilerArgs bi lbi clbi = ghcArgs = GHC.renderGhcOptions (compiler lbi) (hostPlatform lbi) baseOpts baseOpts = - GHC.componentGhcOptions normal lbi bi clbi $ + GHC.componentGhcOptions Normal lbi bi clbi $ buildDir lbi diff --git a/Cabal/src/Distribution/Simple/SrcDist.hs b/Cabal/src/Distribution/Simple/SrcDist.hs index d48da792fa4..c5157dfd308 100644 --- a/Cabal/src/Distribution/Simple/SrcDist.hs +++ b/Cabal/src/Distribution/Simple/SrcDist.hs @@ -73,7 +73,8 @@ import System.IO (IOMode (WriteMode), hPutStrLn, withFile) -- | Create a source distribution. sdist - :: PackageDescription + :: VerbosityHandles + -> PackageDescription -- ^ information from the tarball -> SDistFlags -- ^ verbosity & snapshot @@ -82,7 +83,7 @@ sdist -> [PPSuffixHandler] -- ^ extra preprocessors (includes suffixes) -> IO () -sdist pkg flags mkTmpDir pps = do +sdist verbHandles pkg flags mkTmpDir pps = do distPref <- findDistPrefOrDefault $ setupDistPref common let targetPref = i distPref tmpTargetDir = mkTmpDir (i distPref) @@ -108,7 +109,7 @@ sdist pkg flags mkTmpDir pps = do info verbosity $ "Source directory created: " ++ targetDir Nothing -> do createDirectoryIfMissingVerbose verbosity True tmpTargetDir - withTempDirectory verbosity tmpTargetDir "sdist." $ \tmpDir -> do + withTempDirectory tmpTargetDir "sdist." $ \tmpDir -> do let targetDir = tmpDir tarBallName pkg' generateSourceDir targetDir pkg' targzFile <- createArchive verbosity pkg' tmpDir targetPref @@ -122,7 +123,7 @@ sdist pkg flags mkTmpDir pps = do overwriteSnapshotPackageDesc verbosity pkg' targetDir common = sDistCommonFlags flags - verbosity = fromFlag $ setupVerbosity common + verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common) mbWorkDir = flagToMaybe $ setupWorkingDir common i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path snapshot = fromFlag (sDistSnapshot flags) diff --git a/Cabal/src/Distribution/Simple/Test.hs b/Cabal/src/Distribution/Simple/Test.hs index 57107eef648..637f040f07e 100644 --- a/Cabal/src/Distribution/Simple/Test.hs +++ b/Cabal/src/Distribution/Simple/Test.hs @@ -42,6 +42,7 @@ import Distribution.TestSuite import qualified Distribution.Types.LocalBuildInfo as LBI import Distribution.Types.UnqualComponentName import Distribution.Utils.Path +import Distribution.Verbosity import Distribution.Simple.Configure (getInstalledPackagesById) import Distribution.Simple.Errors @@ -62,6 +63,7 @@ import System.Directory test :: Args -- ^ positional command-line arguments + -> VerbosityHandles -> PD.PackageDescription -- ^ information from the .cabal file -> LBI.LocalBuildInfo @@ -69,10 +71,10 @@ test -> TestFlags -- ^ flags sent to test -> IO () -test args pkg_descr lbi0 flags = do +test args verbHandles pkg_descr lbi0 flags = do curDir <- LBI.absoluteWorkingDirLBI lbi0 let common = testCommonFlags flags - verbosity = fromFlag $ setupVerbosity common + verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common) distPref = fromFlag $ setupDistPref common i = LBI.interpretSymbolicPathLBI lbi -- See Note [Symbolic paths] in Distribution.Utils.Path machineTemplate = fromFlag $ testMachineLog flags @@ -105,9 +107,9 @@ test args pkg_descr lbi0 flags = do } case PD.testInterface suite of PD.TestSuiteExeV10 _ _ -> - ExeV10.runTest pkg_descr lbiForTest clbi hpcMarkupInfo flags suite + ExeV10.runTest verbHandles pkg_descr lbiForTest clbi hpcMarkupInfo flags suite PD.TestSuiteLibV09 _ _ -> - LibV09.runTest pkg_descr lbiForTest clbi hpcMarkupInfo flags suite + LibV09.runTest verbHandles pkg_descr lbiForTest clbi hpcMarkupInfo flags suite _ -> return TestSuiteLog diff --git a/Cabal/src/Distribution/Simple/Test/ExeV10.hs b/Cabal/src/Distribution/Simple/Test/ExeV10.hs index 3ad112af2bb..2618e2b5d35 100644 --- a/Cabal/src/Distribution/Simple/Test/ExeV10.hs +++ b/Cabal/src/Distribution/Simple/Test/ExeV10.hs @@ -47,18 +47,18 @@ import System.Directory , doesFileExist , removeDirectoryRecursive ) -import System.IO (stderr, stdout) import System.Process (createPipe) runTest - :: PD.PackageDescription + :: VerbosityHandles + -> PD.PackageDescription -> LBI.LocalBuildInfo -> LBI.ComponentLocalBuildInfo -> HPCMarkupInfo -> TestFlags -> PD.TestSuite -> IO TestSuiteLog -runTest pkg_descr lbi clbi hpcMarkupInfo flags suite = do +runTest verbHandles pkg_descr lbi clbi hpcMarkupInfo flags suite = do let isCoverageEnabled = LBI.testCoverage lbi way = guessWay lbi tixDir_ = i $ tixDir distPref way @@ -113,16 +113,17 @@ runTest pkg_descr lbi clbi hpcMarkupInfo flags suite = do -- Output logger (wOut, wErr, getLogText) <- case details of - Direct -> return (stdout, stderr, return LBS.empty) + Direct -> return (Nothing, Nothing, return LBS.empty) _ -> do (rOut, wOut) <- createPipe - return $ (,,) wOut wOut $ do + return $ (,,) (Just wOut) (Just wOut) $ do -- Read test executables' output logText <- LBS.hGetContents rOut -- '--show-details=streaming': print the log output in another thread - when (details == Streaming) $ LBS.putStr logText + when (details == Streaming) $ + LBS.hPutStr (verbosityChosenOutputHandle verbosity) logText -- drain the output. evaluate (force logText) @@ -139,11 +140,10 @@ runTest pkg_descr lbi clbi hpcMarkupInfo flags suite = do (cmd : opts) mbWorkDir (Just shellEnv') - getLogText - -- these handles are automatically closed + (\_ _ _ -> getLogText) Nothing - (Just wOut) - (Just wErr) + wOut + wErr NoFlag -> rawSystemIOWithEnvAndAction verbosity @@ -151,11 +151,10 @@ runTest pkg_descr lbi clbi hpcMarkupInfo flags suite = do opts mbWorkDir (Just shellEnv') - getLogText - -- these handles are automatically closed + (\_ _ _ -> getLogText) Nothing - (Just wOut) - (Just wErr) + wOut + wErr -- Generate TestSuiteLog from executable exit code and a machine- -- readable test log. @@ -179,9 +178,9 @@ runTest pkg_descr lbi clbi hpcMarkupInfo flags suite = do || details == Failures && not (suitePassed $ testLogs suiteLog) ) -- verbosity overrides show-details - && verbosity >= normal + && verbosityLevel verbosity >= Normal whenPrinting $ do - LBS.putStr logText + LBS.hPutStr (verbosityChosenOutputHandle verbosity) logText putChar '\n' -- Write summary notice to terminal indicating end of test suite @@ -206,7 +205,7 @@ runTest pkg_descr lbi clbi hpcMarkupInfo flags suite = do testName' = unUnqualComponentName $ PD.testName suite distPref = fromFlag $ setupDistPref commonFlags - verbosity = fromFlag $ setupVerbosity commonFlags + verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity commonFlags) details = fromFlag $ testShowDetails flags testLogDir = distPref makeRelativePathEx "test" diff --git a/Cabal/src/Distribution/Simple/Test/LibV09.hs b/Cabal/src/Distribution/Simple/Test/LibV09.hs index 1d2de6f8a41..522a69afdc2 100644 --- a/Cabal/src/Distribution/Simple/Test/LibV09.hs +++ b/Cabal/src/Distribution/Simple/Test/LibV09.hs @@ -57,14 +57,15 @@ import System.IO (hClose, hPutStr) import qualified System.Process as Process runTest - :: PD.PackageDescription + :: VerbosityHandles + -> PD.PackageDescription -> LBI.LocalBuildInfo -> LBI.ComponentLocalBuildInfo -> HPCMarkupInfo -> TestFlags -> PD.TestSuite -> IO TestSuiteLog -runTest pkg_descr lbi clbi hpcMarkupInfo flags suite = do +runTest verbHandles pkg_descr lbi clbi hpcMarkupInfo flags suite = do let isCoverageEnabled = LBI.testCoverage lbi way = guessWay lbi @@ -183,9 +184,9 @@ runTest pkg_descr lbi clbi hpcMarkupInfo flags suite = do when $ (details > Never) && (not (suitePassed $ testLogs suiteLog) || details == Always) - && verbosity >= normal + && verbosityLevel verbosity >= Normal whenPrinting $ do - LBS.putStr logText + LBS.hPutStr (verbosityChosenOutputHandle verbosity) logText putChar '\n' return suiteLog @@ -220,7 +221,7 @@ runTest pkg_descr lbi clbi hpcMarkupInfo flags suite = do hClose h >> return f distPref = fromFlag $ setupDistPref common - verbosity = fromFlag $ setupVerbosity common + verbosity = mkVerbosity verbHandles (fromFlag $ setupVerbosity common) -- TODO: This is abusing the notion of a 'PathTemplate'. The result isn't -- necessarily a path. @@ -312,7 +313,7 @@ stubRunTests tests = do where stubRunTests' (Test t) = do l <- run t >>= finish - summarizeTest normal Always l + summarizeTest (mkVerbosity defaultVerbosityHandles normal) Always l return l where finish (Finished result) = diff --git a/Cabal/src/Distribution/Simple/UHC.hs b/Cabal/src/Distribution/Simple/UHC.hs index 3d57cd6b2bc..73fc834aaba 100644 --- a/Cabal/src/Distribution/Simple/UHC.hs +++ b/Cabal/src/Distribution/Simple/UHC.hs @@ -280,10 +280,10 @@ constructUHCCmdLine -> [String] constructUHCCmdLine user system lbi bi clbi odir verbosity = -- verbosity - ( if verbosity >= deafening + ( if verbosityLevel verbosity >= Deafening then ["-v4"] else - if verbosity >= normal + if verbosityLevel verbosity >= Normal then [] else ["-v0"] ) diff --git a/Cabal/src/Distribution/Simple/Utils.hs b/Cabal/src/Distribution/Simple/Utils.hs index 0992009459e..57d6aee2e02 100644 --- a/Cabal/src/Distribution/Simple/Utils.hs +++ b/Cabal/src/Distribution/Simple/Utils.hs @@ -287,6 +287,7 @@ import System.IO , hSetBinaryMode , hSetBuffering , stderr + , stdin , stdout ) import System.IO.Error @@ -431,19 +432,19 @@ die' :: Verbosity -> String -> IO a die' verbosity msg = withFrozenCallStack $ do ioError . verbatimUserError =<< annotateErrorString verbosity - =<< pure . wrapTextVerbosity verbosity + =<< pure . wrapTextVerbosity (verbosityFlags verbosity) =<< pure . addErrorPrefix =<< prefixWithProgName msg -- Type which will be a wrapper for cabal -exceptions and cabal-install exceptions -data VerboseException a = VerboseException CallStack POSIXTime Verbosity a +data VerboseException a = VerboseException CallStack POSIXTime VerbosityFlags a deriving (Show) -- Function which will replace the existing die' call sites dieWithException :: (HasCallStack, Show a1, Typeable a1, Exception (VerboseException a1)) => Verbosity -> a1 -> IO a dieWithException verbosity exception = do ts <- getPOSIXTime - throwIO $ VerboseException callStack ts verbosity exception + throwIO $ VerboseException callStack ts (verbosityFlags verbosity) exception -- Instance for Cabal Exception which will display error code and error message with callStack info instance Exception (VerboseException CabalException) where @@ -492,7 +493,7 @@ prefixWithProgName msg = do annotateErrorString :: Verbosity -> String -> IO String annotateErrorString verbosity msg = do ts <- getPOSIXTime - return $ withMetadata ts AlwaysMark VerboseTrace verbosity msg + return $ withMetadata ts AlwaysMark VerboseTrace (verbosityFlags verbosity) msg -- | Given a block of IO code that may raise an exception, annotate -- it with the metadata from the current scope. Use this as close @@ -504,7 +505,7 @@ annotateIO verbosity act = do ts <- getPOSIXTime flip modifyIOError act $ ioeModifyErrorString $ - withMetadata ts NeverMark VerboseTrace verbosity + withMetadata ts NeverMark VerboseTrace (verbosityFlags verbosity) -- | A semantic editor for the error message inside an 'IOError'. ioeModifyErrorString :: (String -> String) -> IOError -> IOError @@ -594,12 +595,6 @@ displaySomeExceptionWithContext e = displayException e topHandler :: (Exception.SomeException -> Bool) -> IO a -> IO a topHandler is_user_exception prog = topHandlerWith is_user_exception (const $ exitWith (ExitFailure 1)) prog --- | Depending on 'isVerboseStderr', set the output handle to 'stderr' or 'stdout'. -verbosityHandle :: Verbosity -> Handle -verbosityHandle verbosity - | isVerboseStderr verbosity = stderr - | otherwise = stdout - -- | Non fatal conditions that may be indicative of an error or problem. -- -- We display these at the 'normal' verbosity level. @@ -615,13 +610,17 @@ warnError verbosity message = warnMessage "Error" verbosity message -- | Warning message, with a custom label. warnMessage :: String -> Verbosity -> String -> IO () warnMessage l verbosity msg = withFrozenCallStack $ do - when ((verbosity >= normal) && not (isVerboseNoWarn verbosity)) $ do + when (verbosityLevel verbosity >= Normal && not (isVerboseNoWarn flags)) $ do ts <- getPOSIXTime - hFlush stdout - hPutStr stderr - . withMetadata ts NormalMark FlagTrace verbosity - . wrapTextVerbosity verbosity + let outHandle = verbosityChosenOutputHandle verbosity + errHandle = verbosityErrorHandle verbosity + hFlush outHandle + hPutStr errHandle + . withMetadata ts NormalMark FlagTrace flags + . wrapTextVerbosity flags $ l ++ ": " ++ msg + where + flags = verbosityFlags verbosity -- | Useful status messages. -- @@ -631,32 +630,35 @@ warnMessage l verbosity msg = withFrozenCallStack $ do -- enough information to know that things are working but not floods of detail. notice :: Verbosity -> String -> IO () notice verbosity msg = withFrozenCallStack $ do - when (verbosity >= normal) $ do - let h = verbosityHandle verbosity + when (verbosityLevel verbosity >= Normal) $ do + let h = verbosityChosenOutputHandle verbosity + flags = verbosityFlags verbosity ts <- getPOSIXTime hPutStr h $ - withMetadata ts NormalMark FlagTrace verbosity $ - wrapTextVerbosity verbosity $ + withMetadata ts NormalMark FlagTrace flags $ + wrapTextVerbosity flags $ msg -- | Display a message at 'normal' verbosity level, but without -- wrapping. noticeNoWrap :: Verbosity -> String -> IO () noticeNoWrap verbosity msg = withFrozenCallStack $ do - when (verbosity >= normal) $ do - let h = verbosityHandle verbosity + when (verbosityLevel verbosity >= Normal) $ do + let h = verbosityChosenOutputHandle verbosity + flags = verbosityFlags verbosity ts <- getPOSIXTime - hPutStr h . withMetadata ts NormalMark FlagTrace verbosity $ msg + hPutStr h . withMetadata ts NormalMark FlagTrace flags $ msg -- | Pretty-print a 'Disp.Doc' status message at 'normal' verbosity -- level. Use this if you need fancy formatting. noticeDoc :: Verbosity -> Disp.Doc -> IO () noticeDoc verbosity msg = withFrozenCallStack $ do - when (verbosity >= normal) $ do - let h = verbosityHandle verbosity + when (verbosityLevel verbosity >= Normal) $ do + let h = verbosityChosenOutputHandle verbosity + flags = verbosityFlags verbosity ts <- getPOSIXTime hPutStr h $ - withMetadata ts NormalMark FlagTrace verbosity $ + withMetadata ts NormalMark FlagTrace flags $ Disp.renderStyle defaultStyle $ msg @@ -671,21 +673,23 @@ setupMessage verbosity msg pkgid = withFrozenCallStack $ do -- We display these messages when the verbosity level is 'verbose' info :: Verbosity -> String -> IO () info verbosity msg = withFrozenCallStack $ - when (verbosity >= verbose) $ do - let h = verbosityHandle verbosity + when (verbosityLevel verbosity >= Verbose) $ do + let h = verbosityChosenOutputHandle verbosity + flags = verbosityFlags verbosity ts <- getPOSIXTime hPutStr h $ - withMetadata ts NeverMark FlagTrace verbosity $ - wrapTextVerbosity verbosity $ + withMetadata ts NeverMark FlagTrace flags $ + wrapTextVerbosity flags $ msg infoNoWrap :: Verbosity -> String -> IO () infoNoWrap verbosity msg = withFrozenCallStack $ - when (verbosity >= verbose) $ do - let h = verbosityHandle verbosity + when (verbosityLevel verbosity >= Verbose) $ do + let h = verbosityChosenOutputHandle verbosity + flags = verbosityFlags verbosity ts <- getPOSIXTime hPutStr h $ - withMetadata ts NeverMark FlagTrace verbosity $ + withMetadata ts NeverMark FlagTrace flags $ msg -- | Detailed internal debugging information @@ -693,12 +697,13 @@ infoNoWrap verbosity msg = withFrozenCallStack $ -- We display these messages when the verbosity level is 'deafening' debug :: Verbosity -> String -> IO () debug verbosity msg = withFrozenCallStack $ - when (verbosity >= deafening) $ do - let h = verbosityHandle verbosity + when (verbosityLevel verbosity >= Deafening) $ do + let h = verbosityChosenOutputHandle verbosity + flags = verbosityFlags verbosity ts <- getPOSIXTime hPutStr h $ - withMetadata ts NeverMark FlagTrace verbosity $ - wrapTextVerbosity verbosity $ + withMetadata ts NeverMark FlagTrace flags $ + wrapTextVerbosity flags $ msg -- ensure that we don't lose output if we segfault/infinite loop hFlush stdout @@ -707,11 +712,11 @@ debug verbosity msg = withFrozenCallStack $ -- wrapping. Produces better output in some cases. debugNoWrap :: Verbosity -> String -> IO () debugNoWrap verbosity msg = withFrozenCallStack $ - when (verbosity >= deafening) $ do - let h = verbosityHandle verbosity + when (verbosityLevel verbosity >= Deafening) $ do + let h = verbosityChosenOutputHandle verbosity ts <- getPOSIXTime hPutStr h $ - withMetadata ts NeverMark FlagTrace verbosity $ + withMetadata ts NeverMark FlagTrace (verbosityFlags verbosity) $ msg -- ensure that we don't lose output if we segfault/infinite loop hFlush stdout @@ -719,14 +724,16 @@ debugNoWrap verbosity msg = withFrozenCallStack $ -- | Perform an IO action, catching any IO exceptions and printing an error -- if one occurs. chattyTry - :: String + :: Verbosity + -> String -- ^ a description of the action we were attempting -> IO () -- ^ the action itself -> IO () -chattyTry desc action = +chattyTry verbosity desc action = catchIO action $ \exception -> - hPutStrLn stderr $ "Error while " ++ desc ++ ": " ++ show exception + hPutStrLn (verbosityErrorHandle verbosity) $ + "Error while " ++ desc ++ ": " ++ show exception -- | Run an IO computation, returning @e@ if it raises a "file -- does not exist" error. @@ -740,7 +747,7 @@ handleDoesNotExist e = -- Helper functions -- | Wraps text unless the @+nowrap@ verbosity flag is active -wrapTextVerbosity :: Verbosity -> String -> String +wrapTextVerbosity :: VerbosityFlags -> String -> String wrapTextVerbosity verb | isVerboseNoWrap verb = withTrailingNewline | otherwise = withTrailingNewline . wrapText @@ -748,7 +755,7 @@ wrapTextVerbosity verb -- | Prepends a timestamp if @+timestamp@ verbosity flag is set -- -- This is used by 'withMetadata' -withTimestamp :: Verbosity -> POSIXTime -> String -> String +withTimestamp :: VerbosityFlags -> POSIXTime -> String -> String withTimestamp v ts msg | isVerboseTimestamp v = msg' | otherwise = msg -- no-op @@ -774,7 +781,7 @@ withTimestamp v ts msg -- we don't have the ability to interpose on the output. -- -- This is used by 'withMetadata' -withOutputMarker :: Verbosity -> String -> String +withOutputMarker :: VerbosityFlags -> String -> String withOutputMarker v xs | not (isVerboseMarkOutput v) = xs withOutputMarker _ "" = "" -- Minor optimization, don't mark uselessly withOutputMarker _ xs = @@ -793,7 +800,7 @@ withTrailingNewline (x : xs) = x : go x xs go _ "" = "\n" -- | Prepend a call-site and/or call-stack based on Verbosity -withCallStackPrefix :: WithCallStack (TraceWhen -> Verbosity -> String -> String) +withCallStackPrefix :: WithCallStack (TraceWhen -> VerbosityFlags -> String -> String) withCallStackPrefix tracer verbosity s = withFrozenCallStack $ ( if isVerboseCallSite verbosity @@ -825,9 +832,9 @@ data TraceWhen -- | Determine if we should emit a call stack. -- If we trace, it also emits any prefix we should append. -traceWhen :: Verbosity -> TraceWhen -> Maybe String +traceWhen :: VerbosityFlags -> TraceWhen -> Maybe String traceWhen _ AlwaysTrace = Just "" -traceWhen v VerboseTrace | v >= verbose = Just "" +traceWhen v VerboseTrace | vLevel v >= Verbose = Just "" traceWhen v FlagTrace | isVerboseCallStack v = Just "----\n" traceWhen _ _ = Nothing @@ -837,7 +844,7 @@ traceWhen _ _ = Nothing data MarkWhen = AlwaysMark | NormalMark | NeverMark -- | Add all necessary metadata to a logging message -withMetadata :: WithCallStack (POSIXTime -> MarkWhen -> TraceWhen -> Verbosity -> String -> String) +withMetadata :: WithCallStack (POSIXTime -> MarkWhen -> TraceWhen -> VerbosityFlags -> String -> String) withMetadata ts marker tracer verbosity x = withFrozenCallStack $ @@ -860,7 +867,7 @@ withMetadata ts marker tracer verbosity x = $ x -- | Add all necessary metadata to a logging message -exceptionWithMetadata :: CallStack -> POSIXTime -> Verbosity -> String -> String +exceptionWithMetadata :: CallStack -> POSIXTime -> VerbosityFlags -> String -> String exceptionWithMetadata stack ts verbosity x = withTrailingNewline . exceptionWithCallStackPrefix stack verbosity @@ -877,7 +884,7 @@ clearMarkers s = unlines . filter isMarker $ lines s isMarker _ = True -- | Append a call-site and/or call-stack based on Verbosity -exceptionWithCallStackPrefix :: CallStack -> Verbosity -> String -> String +exceptionWithCallStackPrefix :: CallStack -> VerbosityFlags -> String -> String exceptionWithCallStackPrefix stack verbosity s = s ++ withFrozenCallStack @@ -891,7 +898,7 @@ exceptionWithCallStackPrefix stack verbosity s = else "" else "" ) - ++ ( if verbosity >= verbose + ++ ( if vLevel verbosity >= Verbose then prettyCallStack stack ++ "\n" else "" ) @@ -943,18 +950,24 @@ rawSystemExit verbosity mbWorkDir path args = -- the command's exit code. rawSystemExitCode :: Verbosity - -> Maybe (SymbolicPath CWD (Dir Pkg)) + -> Maybe (SymbolicPath CWD (Dir to)) -> FilePath -> [String] -> Maybe [(String, String)] -> IO ExitCode rawSystemExitCode verbosity mbWorkDir path args menv = withFrozenCallStack $ - rawSystemProc verbosity $ - (proc path args) - { Process.cwd = fmap getSymbolicPath mbWorkDir - , Process.env = menv - } + fmap fst $ + rawSystemIOWithEnvAndAction + verbosity + path + args + (fmap getSymbolicPath mbWorkDir) + menv + (\_ _ _ -> return ()) + Nothing + Nothing + Nothing -- | Execute the given command with the given arguments, returning -- the command's exit code. @@ -982,7 +995,7 @@ rawSystemProcAction -> IO (ExitCode, a) rawSystemProcAction verbosity cp action = withFrozenCallStack $ do logCommand verbosity cp - (exitcode, a) <- Process.withCreateProcess cp $ \mStdin mStdout mStderr p -> do + (exitcode, a) <- compatWithCreateProcess verbosity cp $ \mStdin mStdout mStderr p -> do a <- action mStdin mStdout mStderr exitcode <- Process.waitForProcess p return (exitcode, a) @@ -993,6 +1006,54 @@ rawSystemProcAction verbosity cp action = withFrozenCallStack $ do debug verbosity $ cmd ++ " returned " ++ show exitcode return (exitcode, a) +-- | A version of 'Process.withCreateProcess' that is careful to not close +-- the handles stored in 'Verbosity'. +compatWithCreateProcess + :: Verbosity + -> Process.CreateProcess + -> (Maybe Handle -> Maybe Handle -> Maybe Handle -> Process.ProcessHandle -> IO a) + -> IO a +compatWithCreateProcess verbosity cp action = + Exception.bracket + create + Process.cleanupProcess + (\(m_in, m_out, m_err, ph) -> action m_in m_out m_err ph) + where + -- The 'process' documentation for 'createProcess'/'withCreateProcess' + -- states: + -- + -- Note that `Handle`s provided for `std_in`, `std_out`, or `std_err` via the + -- `UseHandle` constructor will be closed by calling this function. + -- + -- We don't want that, because we don't want the Verbosity handles being + -- closed if they are passed to the subprocess, which would prevent + -- us from continuing logging. + -- + -- To avoid this, we copy the implementation of 'withCreateProcess' in terms + -- of 'withCreateProcess_', but with special logic to avoid closing the + -- verbosity handles. + create = + (Process.createProcess_ "createProcess" cp) + `Exception.finally` do + maybeClose (Process.std_in cp) + maybeClose (Process.std_out cp) + maybeClose (Process.std_err cp) + + maybeClose :: Process.StdStream -> IO () + maybeClose (Process.UseHandle hdl) + | hdl + `elem` [ stdin + , stdout + , stderr + , vStdoutHandle (verbosityHandles verbosity) + , vStderrHandle (verbosityHandles verbosity) + ] -- Don't close the verbosity handles! + = + return () + | otherwise = + hClose hdl + maybeClose _ = return () + -- | fromJust for dealing with 'Maybe Handle' values as obtained via -- 'System.Process.CreatePipe'. Creating a pipe using 'CreatePipe' guarantees -- a 'Just' value for the corresponding handle. @@ -1013,7 +1074,7 @@ rawSystemExitWithEnv verbosity = -- | Like 'rawSystemExitWithEnv', but setting a working directory. rawSystemExitWithEnvCwd :: Verbosity - -> Maybe (SymbolicPath CWD to) + -> Maybe (SymbolicPath CWD (Dir to)) -> FilePath -> [String] -> [(String, String)] @@ -1021,11 +1082,7 @@ rawSystemExitWithEnvCwd rawSystemExitWithEnvCwd verbosity mbWorkDir path args env = withFrozenCallStack $ maybeExit $ - rawSystemProc verbosity $ - (proc path args) - { Process.env = Just env - , Process.cwd = getSymbolicPath <$> mbWorkDir - } + rawSystemExitCode verbosity mbWorkDir path args (Just env) -- | Execute the given command with the given arguments, returning -- the command's exit code. @@ -1055,7 +1112,7 @@ rawSystemIOWithEnv verbosity path args mcwd menv inp out err = withFrozenCallSta args mcwd menv - action + (\_ _ _ -> action) inp out err @@ -1074,11 +1131,12 @@ rawSystemIOWithEnvAndAction :: Verbosity -> FilePath -> [String] + -- ^ arguments -> Maybe FilePath -- ^ New working dir or inherit -> Maybe [(String, String)] -- ^ New environment or inherit - -> IO a + -> (Maybe Handle -> Maybe Handle -> Maybe Handle -> IO a) -- ^ action to perform after process is created, but before 'waitForProcess'. -> Maybe Handle -- ^ stdin @@ -1087,19 +1145,30 @@ rawSystemIOWithEnvAndAction -> Maybe Handle -- ^ stderr -> IO (ExitCode, a) -rawSystemIOWithEnvAndAction verbosity path args mcwd menv action inp out err = withFrozenCallStack $ do - let cp = - (proc path args) - { Process.cwd = mcwd - , Process.env = menv - , Process.std_in = mbToStd inp - , Process.std_out = mbToStd out - , Process.std_err = mbToStd err - } - rawSystemProcAction verbosity cp (\_ _ _ -> action) - where - mbToStd :: Maybe Handle -> Process.StdStream - mbToStd = maybe Process.Inherit Process.UseHandle +rawSystemIOWithEnvAndAction verbosity path args mcwd menv action inp out err = + withFrozenCallStack $ do + -- If the output/error handle is Nothing, we need to use the corresponding + -- logging handle stored in 'Verbosity'. + let + outHandle = + case out of + Just h -> h + Nothing -> verbosityChosenOutputHandle verbosity + errHandle = + case err of + Just h -> h + Nothing -> verbosityErrorHandle verbosity + + let cp = + (proc path args) + { Process.cwd = mcwd + , Process.env = menv + , Process.std_in = maybe Process.Inherit Process.UseHandle inp + , Process.std_out = Process.UseHandle outHandle + , Process.std_err = Process.UseHandle errHandle + } + + rawSystemProcAction verbosity cp action -- | Execute the given command with the given arguments, returning -- the command's output. Exits if the command exits with error. @@ -1860,20 +1929,18 @@ withTempFileEx opts template action = do -- Creates a new temporary directory inside the given directory, making use -- of the template. The temp directory is deleted after use. For example: -- --- > withTempDirectory verbosity "src" "sdist." $ \tmpDir -> do ... +-- > withTempDirectory "src" "sdist." $ \tmpDir -> do ... -- -- The @tmpDir@ will be a new subdirectory of the given directory, e.g. -- @src/sdist.342@. withTempDirectory - :: Verbosity - -> FilePath + :: FilePath -> String -> (FilePath -> IO a) -> IO a -withTempDirectory verb targetDir template f = +withTempDirectory targetDir template f = withFrozenCallStack $ withTempDirectoryCwd - verb Nothing (makeSymbolicPath targetDir) template @@ -1884,22 +1951,20 @@ withTempDirectory verb targetDir template f = -- Creates a new temporary directory inside the given directory, making use -- of the template. The temp directory is deleted after use. For example: -- --- > withTempDirectory verbosity "src" "sdist." $ \tmpDir -> do ... +-- > withTempDirectory "src" "sdist." $ \tmpDir -> do ... -- -- The @tmpDir@ will be a new subdirectory of the given directory, e.g. -- @src/sdist.342@. withTempDirectoryCwd - :: Verbosity - -> Maybe (SymbolicPath CWD (Dir Pkg)) + :: Maybe (SymbolicPath CWD (Dir Pkg)) -- ^ Working directory -> SymbolicPath Pkg (Dir tmpDir1) -> String -> (SymbolicPath Pkg (Dir tmpDir2) -> IO a) -> IO a -withTempDirectoryCwd verbosity mbWorkDir targetDir template f = +withTempDirectoryCwd mbWorkDir targetDir template f = withFrozenCallStack $ withTempDirectoryCwdEx - verbosity defaultTempFileOptions mbWorkDir targetDir @@ -1909,30 +1974,28 @@ withTempDirectoryCwd verbosity mbWorkDir targetDir template f = -- | A version of 'withTempDirectory' that additionally takes a -- 'TempFileOptions' argument. withTempDirectoryEx - :: Verbosity - -> TempFileOptions + :: TempFileOptions -> FilePath -> String -> (FilePath -> IO a) -> IO a -withTempDirectoryEx verbosity opts targetDir template f = +withTempDirectoryEx opts targetDir template f = withFrozenCallStack $ - withTempDirectoryCwdEx verbosity opts Nothing (makeSymbolicPath targetDir) template $ + withTempDirectoryCwdEx opts Nothing (makeSymbolicPath targetDir) template $ \fp -> f (getSymbolicPath fp) -- | A version of 'withTempDirectoryCwd' that additionally takes a -- 'TempFileOptions' argument. withTempDirectoryCwdEx :: forall a tmpDir1 tmpDir2 - . Verbosity - -> TempFileOptions + . TempFileOptions -> Maybe (SymbolicPath CWD (Dir Pkg)) -- ^ Working directory -> SymbolicPath Pkg (Dir tmpDir1) -> String -> (SymbolicPath Pkg (Dir tmpDir2) -> IO a) -> IO a -withTempDirectoryCwdEx _verbosity opts mbWorkDir targetDir template f = +withTempDirectoryCwdEx opts mbWorkDir targetDir template f = withFrozenCallStack $ Exception.bracket (createTempDirectory (i targetDir) template) diff --git a/Cabal/src/Distribution/Utils/LogProgress.hs b/Cabal/src/Distribution/Utils/LogProgress.hs index 33c50f20b5e..b8484eecc14 100644 --- a/Cabal/src/Distribution/Utils/LogProgress.hs +++ b/Cabal/src/Distribution/Utils/LogProgress.hs @@ -16,6 +16,7 @@ import Prelude () import Distribution.Simple.Utils import Distribution.Utils.Progress import Distribution.Verbosity +import System.IO (hPutStrLn) import Text.PrettyPrint type CtxMsg = Doc @@ -55,7 +56,7 @@ runLogProgress verbosity (LogProgress m) = } step_fn :: LogMsg -> IO a -> IO a step_fn doc go = do - putStrLn (render doc) + hPutStrLn (verbosityChosenOutputHandle verbosity) (render doc) go fail_fn :: Doc -> IO a fail_fn doc = do @@ -64,14 +65,14 @@ runLogProgress verbosity (LogProgress m) = -- | Output a warning trace message in 'LogProgress'. warnProgress :: Doc -> LogProgress () warnProgress s = LogProgress $ \env -> - when (le_verbosity env >= normal) $ + when (verbosityLevel (le_verbosity env) >= Normal) $ stepProgress $ hang (text "Warning:") 4 (formatMsg (le_context env) s) -- | Output an informational trace message in 'LogProgress'. infoProgress :: Doc -> LogProgress () infoProgress s = LogProgress $ \env -> - when (le_verbosity env >= verbose) $ + when (verbosityLevel (le_verbosity env) >= Verbose) $ stepProgress s -- | Fail the computation with an error message. diff --git a/Cabal/src/Distribution/Verbosity.hs b/Cabal/src/Distribution/Verbosity.hs index d35100cc550..43df3dee180 100644 --- a/Cabal/src/Distribution/Verbosity.hs +++ b/Cabal/src/Distribution/Verbosity.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeApplications #-} ----------------------------------------------------------------------------- @@ -24,8 +25,22 @@ -- are interested in.) It's important to note that the instances -- for 'Verbosity' assume that this does not exist. module Distribution.Verbosity - ( -- * Verbosity - Verbosity + ( -- * Rich verbosity + Verbosity (..) + , VerbosityHandles (..) + , defaultVerbosityHandles + , VerbosityLevel (..) + , verbosityLevel + , verbosityChosenOutputHandle + , verbosityErrorHandle + , modifyVerbosityFlags + , mkVerbosity + , setVerbosityHandles + + -- * Verbosity flags + , VerbosityFlags (vLevel) + , mkVerbosityFlags + , makeVerbose , silent , normal , verbose @@ -39,7 +54,6 @@ module Distribution.Verbosity , showForGHC , verboseNoFlags , verboseHasFlags - , modifyVerbosity -- * Call stacks , verboseCallSite @@ -47,7 +61,7 @@ module Distribution.Verbosity , isVerboseCallSite , isVerboseCallStack - -- * Output markets + -- * Output markers , verboseMarkOutput , isVerboseMarkOutput , verboseUnmarkOutput @@ -84,55 +98,121 @@ import Distribution.Verbosity.Internal import qualified Data.Set as Set import qualified Distribution.Compat.CharParsing as P +import Distribution.Utils.Structured +import System.IO (Handle, stderr, stdout) import qualified Text.PrettyPrint as PP +import qualified Type.Reflection as Typeable +-- | Rich verbosity, used for the Cabal library interface. data Verbosity = Verbosity - { vLevel :: VerbosityLevel - , vFlags :: Set VerbosityFlag - , vQuiet :: Bool + { verbosityFlags :: VerbosityFlags + , verbosityHandles :: VerbosityHandles } - deriving (Generic, Show, Read) + deriving (Generic) -mkVerbosity :: VerbosityLevel -> Verbosity -mkVerbosity l = Verbosity{vLevel = l, vFlags = Set.empty, vQuiet = False} +-- | Handles to use for logging (e.g. log to stdout, or log to a file). +data VerbosityHandles = VerbosityHandles + { vStdoutHandle :: Handle + , vStderrHandle :: Handle + } -instance Eq Verbosity where - x == y = vLevel x == vLevel y +defaultVerbosityHandles :: VerbosityHandles +defaultVerbosityHandles = + VerbosityHandles + { vStdoutHandle = stdout + , vStderrHandle = stderr + } -instance Ord Verbosity where - compare x y = compare (vLevel x) (vLevel y) +-- | Verbosity information which can be passed by the CLI. +data VerbosityFlags = VerbosityFlags + { vLevel :: VerbosityLevel + , vFlags :: Set VerbosityFlag + , vQuiet :: Bool + } + deriving (Generic, Show, Read, Eq) -instance Enum Verbosity where - toEnum = mkVerbosity . toEnum - fromEnum = fromEnum . vLevel +verbosityLevel :: Verbosity -> VerbosityLevel +verbosityLevel = vLevel . verbosityFlags -instance Bounded Verbosity where - minBound = mkVerbosity minBound - maxBound = mkVerbosity maxBound +-- | The handle used for normal output. +-- +-- With the @+stderr@ verbosity flag, this is the error handle. +verbosityChosenOutputHandle :: Verbosity -> Handle +verbosityChosenOutputHandle verb = + if isVerboseStderr (verbosityFlags verb) + then vStderrHandle $ verbosityHandles verb + else vStdoutHandle $ verbosityHandles verb + +-- | The verbosity handle used for error output. +verbosityErrorHandle :: Verbosity -> Handle +verbosityErrorHandle = vStderrHandle . verbosityHandles + +setVerbosityHandles :: Maybe Handle -> Verbosity -> Verbosity +setVerbosityHandles Nothing v = v +setVerbosityHandles (Just h) v = + v{verbosityHandles = VerbosityHandles{vStdoutHandle = h, vStderrHandle = h}} + +mkVerbosity :: VerbosityHandles -> VerbosityFlags -> Verbosity +mkVerbosity handles flags = + Verbosity + { verbosityFlags = flags + , verbosityHandles = handles + } + +modifyVerbosityFlags :: (VerbosityFlags -> VerbosityFlags) -> Verbosity -> Verbosity +modifyVerbosityFlags f v@(Verbosity{verbosityFlags = flags}) = + v{verbosityFlags = f flags} + +mkVerbosityFlags :: VerbosityLevel -> VerbosityFlags +mkVerbosityFlags l = VerbosityFlags{vLevel = l, vFlags = Set.empty, vQuiet = False} + +instance Binary VerbosityFlags +instance NFData VerbosityFlags +instance Structured VerbosityFlags + +-- Hand-written instances, because there are no NFData/Structured instances +-- for Handle. +instance NFData VerbosityHandles where + rnf (VerbosityHandles o e) = o `seq` e `seq` () +instance Structured VerbosityHandles where + structure _ = + Structure + tr + 0 + (show tr) + [ + ( "VerbosityHandles" + , + [ nominalStructure $ Proxy @Handle + , nominalStructure $ Proxy @Handle + ] + ) + ] + where + tr = Typeable.SomeTypeRep $ Typeable.typeRep @VerbosityHandles -instance Binary Verbosity instance NFData Verbosity instance Structured Verbosity -- | In 'silent' mode, we should not print /anything/ unless an error occurs. -silent :: Verbosity -silent = mkVerbosity Silent +silent :: VerbosityFlags +silent = mkVerbosityFlags Silent -- | Print stuff we want to see by default. -normal :: Verbosity -normal = mkVerbosity Normal +normal :: VerbosityFlags +normal = mkVerbosityFlags Normal -- | Be more verbose about what's going on. -verbose :: Verbosity -verbose = mkVerbosity Verbose +verbose :: VerbosityFlags +verbose = mkVerbosityFlags Verbose -- | Not only are we verbose ourselves (perhaps even noisier than when -- being 'verbose'), but we tell everything we run to be verbose too. -deafening :: Verbosity -deafening = mkVerbosity Deafening +deafening :: VerbosityFlags +deafening = mkVerbosityFlags Deafening -- | Increase verbosity level, but stay 'silent' if we are. -moreVerbose :: Verbosity -> Verbosity +moreVerbose :: VerbosityFlags -> VerbosityFlags moreVerbose v = case vLevel v of Silent -> v -- silent should stay silent @@ -140,8 +220,18 @@ moreVerbose v = Verbose -> v{vLevel = Deafening} Deafening -> v +-- | Make sure the verbosity level is at least 'verbose', +-- but stay 'silent' if we are. +makeVerbose :: VerbosityFlags -> VerbosityFlags +makeVerbose v = + case vLevel v of + Silent -> v -- silent should stay silent + Normal -> v{vLevel = Verbose} + Verbose -> v + Deafening -> v + -- | Decrease verbosity level, but stay 'deafening' if we are. -lessVerbose :: Verbosity -> Verbosity +lessVerbose :: VerbosityFlags -> VerbosityFlags lessVerbose v = verboseQuiet $ case vLevel v of @@ -150,56 +240,42 @@ lessVerbose v = Normal -> v{vLevel = Silent} Silent -> v --- | Combinator for transforming verbosity level while retaining the --- original hidden state. --- --- For instance, the following property holds --- --- prop> isVerboseNoWrap (modifyVerbosity (max verbose) v) == isVerboseNoWrap v --- --- __Note__: you can use @modifyVerbosity (const v1) v0@ to overwrite --- @v1@'s flags with @v0@'s flags. --- --- @since 2.0.1.0 -modifyVerbosity :: (Verbosity -> Verbosity) -> Verbosity -> Verbosity -modifyVerbosity f v = v{vLevel = vLevel (f v)} - -- | Numeric verbosity level @0..3@: @0@ is 'silent', @3@ is 'deafening'. -intToVerbosity :: Int -> Maybe Verbosity -intToVerbosity 0 = Just (mkVerbosity Silent) -intToVerbosity 1 = Just (mkVerbosity Normal) -intToVerbosity 2 = Just (mkVerbosity Verbose) -intToVerbosity 3 = Just (mkVerbosity Deafening) +intToVerbosity :: Int -> Maybe VerbosityFlags +intToVerbosity 0 = Just (mkVerbosityFlags Silent) +intToVerbosity 1 = Just (mkVerbosityFlags Normal) +intToVerbosity 2 = Just (mkVerbosityFlags Verbose) +intToVerbosity 3 = Just (mkVerbosityFlags Deafening) intToVerbosity _ = Nothing -- | Parser verbosity -- -- >>> explicitEitherParsec parsecVerbosity "normal" --- Right (Verbosity {vLevel = Normal, vFlags = fromList [], vQuiet = False}) +-- Right (VerbosityFlags {vLevel = Normal, vFlags = fromList [], vQuiet = False}) -- -- >>> explicitEitherParsec parsecVerbosity "normal+nowrap " --- Right (Verbosity {vLevel = Normal, vFlags = fromList [VNoWrap], vQuiet = False}) +-- Right (VerbosityFlags {vLevel = Normal, vFlags = fromList [VNoWrap], vQuiet = False}) -- -- >>> explicitEitherParsec parsecVerbosity "normal+nowrap +markoutput" --- Right (Verbosity {vLevel = Normal, vFlags = fromList [VNoWrap,VMarkOutput], vQuiet = False}) +-- Right (VerbosityFlags {vLevel = Normal, vFlags = fromList [VNoWrap,VMarkOutput], vQuiet = False}) -- -- >>> explicitEitherParsec parsecVerbosity "normal +nowrap +markoutput" --- Right (Verbosity {vLevel = Normal, vFlags = fromList [VNoWrap,VMarkOutput], vQuiet = False}) +-- Right (VerbosityFlags {vLevel = Normal, vFlags = fromList [VNoWrap,VMarkOutput], vQuiet = False}) -- -- >>> explicitEitherParsec parsecVerbosity "normal+nowrap+markoutput" --- Right (Verbosity {vLevel = Normal, vFlags = fromList [VNoWrap,VMarkOutput], vQuiet = False}) +-- Right (VerbosityFlags {vLevel = Normal, vFlags = fromList [VNoWrap,VMarkOutput], vQuiet = False}) -- -- >>> explicitEitherParsec parsecVerbosity "deafening+nowrap+stdout+stderr+callsite+callstack" --- Right (Verbosity {vLevel = Deafening, vFlags = fromList [VCallStack,VCallSite,VNoWrap,VStderr], vQuiet = False}) +-- Right (VerbosityFlags {vLevel = Deafening, vFlags = fromList [VCallStack,VCallSite,VNoWrap,VStderr], vQuiet = False}) -- -- /Note:/ this parser will eat trailing spaces. -instance Parsec Verbosity where +instance Parsec VerbosityFlags where parsec = parsecVerbosity -instance Pretty Verbosity where +instance Pretty VerbosityFlags where pretty = PP.text . showForCabal -parsecVerbosity :: CabalParsing m => m Verbosity +parsecVerbosity :: CabalParsing m => m VerbosityFlags parsecVerbosity = parseIntVerbosity <|> parseStringVerbosity where parseIntVerbosity = do @@ -212,7 +288,7 @@ parsecVerbosity = parseIntVerbosity <|> parseStringVerbosity level <- parseVerbosityLevel _ <- P.spaces flags <- many (parseFlag <* P.spaces) - return $ foldl' (flip ($)) (mkVerbosity level) flags + return $ foldl' (flip ($)) (mkVerbosityFlags level) flags parseVerbosityLevel = do token <- P.munch1 isAsciiAlpha @@ -237,18 +313,18 @@ parsecVerbosity = parseIntVerbosity <|> parseStringVerbosity "nowarn" -> return verboseNoWarn _ -> P.unexpected $ "Bad verbosity flag: " ++ token -flagToVerbosity :: ReadE Verbosity +flagToVerbosity :: ReadE VerbosityFlags flagToVerbosity = parsecToReadE id parsecVerbosity -showForCabal :: Verbosity -> String -showForCabal v - | Set.null (vFlags v) = +showForCabal :: VerbosityFlags -> String +showForCabal (VerbosityFlags{vLevel = lvl, vFlags = flags}) + | Set.null flags = maybe (error "unknown verbosity") show $ - elemIndex v [silent, normal, verbose, deafening] + elemIndex lvl [Silent, Normal, Verbose, Deafening] | otherwise = unwords $ - showLevel (vLevel v) - : concatMap showFlag (Set.toList (vFlags v)) + showLevel lvl + : concatMap showFlag (Set.toList flags) where showLevel Silent = "silent" showLevel Normal = "normal" @@ -263,116 +339,116 @@ showForCabal v showFlag VStderr = ["+stderr"] showFlag VNoWarn = ["+nowarn"] -showForGHC :: Verbosity -> String +showForGHC :: VerbosityFlags -> String showForGHC v = maybe (error "unknown verbosity") show $ - elemIndex v [silent, normal, __, verbose, deafening] + elemIndex (vLevel v) [Silent, Normal, __, Verbose, Deafening] where - __ = silent -- this will be always ignored by elemIndex + __ = Silent -- this will be always ignored by elemIndex -- | Turn on verbose call-site printing when we log. -verboseCallSite :: Verbosity -> Verbosity +verboseCallSite :: VerbosityFlags -> VerbosityFlags verboseCallSite = verboseFlag VCallSite -- | Turn on verbose call-stack printing when we log. -verboseCallStack :: Verbosity -> Verbosity +verboseCallStack :: VerbosityFlags -> VerbosityFlags verboseCallStack = verboseFlag VCallStack -- | Turn on @-----BEGIN CABAL OUTPUT-----@ markers for output -- from Cabal (as opposed to GHC, or system dependent). -verboseMarkOutput :: Verbosity -> Verbosity +verboseMarkOutput :: VerbosityFlags -> VerbosityFlags verboseMarkOutput = verboseFlag VMarkOutput -- | Turn off marking; useful for suppressing nondeterministic output. -verboseUnmarkOutput :: Verbosity -> Verbosity +verboseUnmarkOutput :: VerbosityFlags -> VerbosityFlags verboseUnmarkOutput = verboseNoFlag VMarkOutput -- | Disable line-wrapping for log messages. -verboseNoWrap :: Verbosity -> Verbosity +verboseNoWrap :: VerbosityFlags -> VerbosityFlags verboseNoWrap = verboseFlag VNoWrap -- | Mark the verbosity as quiet. -verboseQuiet :: Verbosity -> Verbosity +verboseQuiet :: VerbosityFlags -> VerbosityFlags verboseQuiet v = v{vQuiet = True} -- | Turn on timestamps for log messages. -verboseTimestamp :: Verbosity -> Verbosity +verboseTimestamp :: VerbosityFlags -> VerbosityFlags verboseTimestamp = verboseFlag VTimestamp -- | Turn off timestamps for log messages. -verboseNoTimestamp :: Verbosity -> Verbosity +verboseNoTimestamp :: VerbosityFlags -> VerbosityFlags verboseNoTimestamp = verboseNoFlag VTimestamp -- | Switch logging to 'stderr'. -- -- @since 3.4.0.0 -verboseStderr :: Verbosity -> Verbosity +verboseStderr :: VerbosityFlags -> VerbosityFlags verboseStderr = verboseFlag VStderr -- | Switch logging to 'stdout'. -- -- @since 3.4.0.0 -verboseNoStderr :: Verbosity -> Verbosity +verboseNoStderr :: VerbosityFlags -> VerbosityFlags verboseNoStderr = verboseNoFlag VStderr -- | Turn off warnings for log messages. -verboseNoWarn :: Verbosity -> Verbosity +verboseNoWarn :: VerbosityFlags -> VerbosityFlags verboseNoWarn = verboseFlag VNoWarn -- | Helper function for flag enabling functions. -verboseFlag :: VerbosityFlag -> (Verbosity -> Verbosity) -verboseFlag flag v = v{vFlags = Set.insert flag (vFlags v)} +verboseFlag :: VerbosityFlag -> (VerbosityFlags -> VerbosityFlags) +verboseFlag flag v@(VerbosityFlags{vFlags = flags}) = v{vFlags = Set.insert flag flags} -- | Helper function for flag disabling functions. -verboseNoFlag :: VerbosityFlag -> (Verbosity -> Verbosity) -verboseNoFlag flag v = v{vFlags = Set.delete flag (vFlags v)} +verboseNoFlag :: VerbosityFlag -> (VerbosityFlags -> VerbosityFlags) +verboseNoFlag flag v@(VerbosityFlags{vFlags = flags}) = v{vFlags = Set.delete flag flags} -- | Turn off all flags. -verboseNoFlags :: Verbosity -> Verbosity +verboseNoFlags :: VerbosityFlags -> VerbosityFlags verboseNoFlags v = v{vFlags = Set.empty} -verboseHasFlags :: Verbosity -> Bool -verboseHasFlags = not . Set.null . vFlags +verboseHasFlags :: VerbosityFlags -> Bool +verboseHasFlags (VerbosityFlags{vFlags = flags}) = not $ Set.null flags -- | Test if we should output call sites when we log. -isVerboseCallSite :: Verbosity -> Bool +isVerboseCallSite :: VerbosityFlags -> Bool isVerboseCallSite = isVerboseFlag VCallSite -- | Test if we should output call stacks when we log. -isVerboseCallStack :: Verbosity -> Bool +isVerboseCallStack :: VerbosityFlags -> Bool isVerboseCallStack = isVerboseFlag VCallStack --- | Test if we should output markets. -isVerboseMarkOutput :: Verbosity -> Bool +-- | Test if we should output markers. +isVerboseMarkOutput :: VerbosityFlags -> Bool isVerboseMarkOutput = isVerboseFlag VMarkOutput -- | Test if line-wrapping is disabled for log messages. -isVerboseNoWrap :: Verbosity -> Bool +isVerboseNoWrap :: VerbosityFlags -> Bool isVerboseNoWrap = isVerboseFlag VNoWrap -- | Test if we had called 'lessVerbose' on the verbosity. -isVerboseQuiet :: Verbosity -> Bool +isVerboseQuiet :: VerbosityFlags -> Bool isVerboseQuiet = vQuiet -- | Test if we should output timestamps when we log. -isVerboseTimestamp :: Verbosity -> Bool +isVerboseTimestamp :: VerbosityFlags -> Bool isVerboseTimestamp = isVerboseFlag VTimestamp -- | Test if we should output to 'stderr' when we log. -- -- @since 3.4.0.0 -isVerboseStderr :: Verbosity -> Bool +isVerboseStderr :: VerbosityFlags -> Bool isVerboseStderr = isVerboseFlag VStderr -- | Test if we should output warnings when we log. -isVerboseNoWarn :: Verbosity -> Bool +isVerboseNoWarn :: VerbosityFlags -> Bool isVerboseNoWarn = isVerboseFlag VNoWarn -- | Helper function for flag testing functions. -isVerboseFlag :: VerbosityFlag -> Verbosity -> Bool -isVerboseFlag flag = (Set.member flag) . vFlags +isVerboseFlag :: VerbosityFlag -> VerbosityFlags -> Bool +isVerboseFlag flag v = flag `Set.member` vFlags v -- $setup -- >>> import Test.QuickCheck (Arbitrary (..), arbitraryBoundedEnum) -- >>> instance Arbitrary VerbosityLevel where arbitrary = arbitraryBoundedEnum --- >>> instance Arbitrary Verbosity where arbitrary = fmap mkVerbosity arbitrary +-- >>> instance Arbitrary VerbosityFlags where arbitrary = fmap mkVerbosityFlags arbitrary diff --git a/cabal-install-solver/src/Distribution/Solver/Modular.hs b/cabal-install-solver/src/Distribution/Solver/Modular.hs index a4baebf496c..edcca8e764d 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular.hs @@ -72,7 +72,7 @@ import Distribution.Simple.Setup ( BooleanFlag(..) ) import Distribution.Simple.Utils ( ordNubBy ) -import Distribution.Verbosity ( normal, verbose ) +import Distribution.Verbosity import Distribution.Solver.Modular.Message ( renderSummarizedMessage ) -- | Ties the two worlds together: classic cabal-install vs. the modular @@ -202,7 +202,7 @@ solve' sc cinfo idx pkgConfigDB pprefs gcs pns = in unlines ("Could not resolve dependencies:" : map renderSummarizedMessage (messages (toProgress (runSolver True sc')))) - printFullLog = solverVerbosity sc >= verbose + printFullLog = solverVerbosity sc >= Verbose messages :: Progress step fail done -> [step] messages = foldProgress (:) (const []) (const []) @@ -343,7 +343,7 @@ finalErrorMsg sc failure = ++ showCS cm cs ++ flagSuggestion where - showCS = if solverVerbosity sc > normal + showCS = if solverVerbosity sc > Normal then CS.showCSWithFrequency else CS.showCSSortedByFrequency flagSuggestion = diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Solver.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Solver.hs index b2c89fc1537..d16fb37af37 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Solver.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Solver.hs @@ -71,7 +71,7 @@ data SolverConfig = SolverConfig { enableBackjumping :: EnableBackjumping, solveExecutables :: SolveExecutables, goalOrder :: Maybe (Variable QPN -> Variable QPN -> Ordering), - solverVerbosity :: Verbosity, + solverVerbosity :: VerbosityLevel, pruneAfterFirstSuccess :: PruneAfterFirstSuccess } diff --git a/cabal-install/parser-tests/Tests/ParserTests.hs b/cabal-install/parser-tests/Tests/ParserTests.hs index d9ab2f5247f..df144f3d1f9 100644 --- a/cabal-install/parser-tests/Tests/ParserTests.hs +++ b/cabal-install/parser-tests/Tests/ParserTests.hs @@ -147,7 +147,7 @@ testProjectConfigBuildOnly = do assertConfigEquals expected config legacy (projectConfigBuildOnly . condTreeData) where expected = ProjectConfigBuildOnly{..} - projectConfigVerbosity = toFlag (toEnum 2) + projectConfigVerbosity = toFlag (mkVerbosityFlags Verbose) projectConfigDryRun = mempty -- cli only projectConfigOnlyDeps = mempty -- cli only projectConfigOnlyDownload = mempty -- cli only @@ -554,7 +554,7 @@ baseDir :: FilePath baseDir = "parser-tests" "Tests" "files" verbosity :: Verbosity -verbosity = normal +verbosity = mkVerbosity defaultVerbosityHandles normal readConfigDefault :: FilePath -> IO (ProjectConfigSkeleton, ProjectConfigSkeleton) readConfigDefault testSubDir = readConfig testSubDir "cabal.project" diff --git a/cabal-install/src/Distribution/Client/CmdClean.hs b/cabal-install/src/Distribution/Client/CmdClean.hs index 322eeb61f7e..a228ecbcb17 100644 --- a/cabal-install/src/Distribution/Client/CmdClean.hs +++ b/cabal-install/src/Distribution/Client/CmdClean.hs @@ -63,7 +63,10 @@ import Distribution.Utils.Path hiding , () ) import Distribution.Verbosity - ( normal + ( VerbosityFlags + , defaultVerbosityHandles + , mkVerbosity + , normal ) import Control.Exception @@ -95,7 +98,7 @@ import qualified System.Process as Process data CleanFlags = CleanFlags { cleanSaveConfig :: Flag Bool - , cleanVerbosity :: Flag Verbosity + , cleanVerbosity :: Flag VerbosityFlags , cleanDistDir :: Flag (SymbolicPath Pkg (Dir Dist)) } deriving (Eq) @@ -149,7 +152,7 @@ cleanOptions showOrParseArgs = cleanAction :: (ProjectFlags, CleanFlags) -> [String] -> GlobalFlags -> IO () cleanAction (ProjectFlags{..}, CleanFlags{..}) extraArgs _ = do - let verbosity = fromFlagOrDefault normal cleanVerbosity + let verbosity = mkVerbosity defaultVerbosityHandles $ fromFlagOrDefault normal cleanVerbosity saveConfig = fromFlagOrDefault False cleanSaveConfig mdistDirectory = fmap getSymbolicPath $ flagToMaybe cleanDistDir mprojectDir = flagToMaybe flagProjectDir diff --git a/cabal-install/src/Distribution/Client/CmdExec.hs b/cabal-install/src/Distribution/Client/CmdExec.hs index b649bbabde5..f750e439341 100644 --- a/cabal-install/src/Distribution/Client/CmdExec.hs +++ b/cabal-install/src/Distribution/Client/CmdExec.hs @@ -250,7 +250,6 @@ withTempEnvFile verbosity baseCtx buildCtx buildStatus action = do let tmpDirTemplate = distTempDirectory (distDirLayout baseCtx) createDirectoryIfMissingVerbose verbosity True tmpDirTemplate withTempDirectory - verbosity tmpDirTemplate "environment." ( \tmpDir -> do diff --git a/cabal-install/src/Distribution/Client/CmdHaddockProject.hs b/cabal-install/src/Distribution/Client/CmdHaddockProject.hs index 9d1e589aa32..320de351887 100644 --- a/cabal-install/src/Distribution/Client/CmdHaddockProject.hs +++ b/cabal-install/src/Distribution/Client/CmdHaddockProject.hs @@ -106,7 +106,9 @@ import Distribution.Types.UnitId (unUnitId) import Distribution.Types.Version (mkVersion) import Distribution.Types.VersionRange (orLaterVersion) import Distribution.Verbosity as Verbosity - ( normal + ( defaultVerbosityHandles + , mkVerbosity + , normal ) import Distribution.Client.Errors @@ -359,7 +361,9 @@ haddockProjectAction flags _extraArgs globalFlags = do -- build all packages with appropriate haddock flags commonFlags = haddockProjectCommonFlags flags - verbosity = fromFlagOrDefault normal (setupVerbosity commonFlags) + verbosity = + mkVerbosity defaultVerbosityHandles $ + fromFlagOrDefault normal (setupVerbosity commonFlags) haddockFlags = defaultHaddockFlags diff --git a/cabal-install/src/Distribution/Client/CmdInstall.hs b/cabal-install/src/Distribution/Client/CmdInstall.hs index 414ab9c49b8..d33801f2ab9 100644 --- a/cabal-install/src/Distribution/Client/CmdInstall.hs +++ b/cabal-install/src/Distribution/Client/CmdInstall.hs @@ -215,6 +215,7 @@ import Distribution.Utils.Generic ) import Distribution.Verbosity ( lessVerbose + , modifyVerbosityFlags , normal ) @@ -460,7 +461,7 @@ installAction flags@NixStyleFlags{extraFlags, configFlags, installFlags, project -- temporary dist directory. globalTmp <- getTemporaryDirectory - withTempDirectory verbosity globalTmp "cabal-install." $ \tmpDir -> do + withTempDirectory globalTmp "cabal-install." $ \tmpDir -> do distDirLayout <- establishDummyDistDirLayout verbosity config tmpDir uriSpecs <- @@ -593,7 +594,7 @@ withProject verbosity cliConfig targetStrings installLibs = do concatMap (targetPkgNames $ localPackages baseCtx) targetSelectors return (pkgSpecs, targetSelectors, config) where - reducedVerbosity = lessVerbose verbosity + reducedVerbosity = modifyVerbosityFlags lessVerbose verbosity -- We take the targets and try to parse them as package ids (with name and version). -- The ones who don't parse will have to be resolved in the project context. @@ -623,7 +624,7 @@ resolveTargetSelectorsInProjectBaseContext -> Maybe ComponentKindFilter -> IO ([PackageSpecifier UnresolvedSourcePackage], [TargetSelector]) resolveTargetSelectorsInProjectBaseContext verbosity baseCtx targetStrings targetFilter = do - let reducedVerbosity = lessVerbose verbosity + let reducedVerbosity = modifyVerbosityFlags lessVerbose verbosity sourcePkgDb <- projectConfigWithBuilderRepoContext diff --git a/cabal-install/src/Distribution/Client/CmdLegacy.hs b/cabal-install/src/Distribution/Client/CmdLegacy.hs index 86c94d3d9e5..d849fbfb535 100644 --- a/cabal-install/src/Distribution/Client/CmdLegacy.hs +++ b/cabal-install/src/Distribution/Client/CmdLegacy.hs @@ -24,7 +24,10 @@ import Distribution.Simple.Utils ( wrapText ) import Distribution.Verbosity - ( normal + ( VerbosityFlags + , defaultVerbosityHandles + , mkVerbosity + , normal ) import Control.Exception @@ -57,7 +60,9 @@ wrapperAction command getCommonFlags = } $ \flags extraArgs globalFlags -> do let common = getCommonFlags flags - verbosity' = Setup.fromFlagOrDefault normal (Setup.setupVerbosity common) + verbosity' = + mkVerbosity defaultVerbosityHandles $ + Setup.fromFlagOrDefault normal (Setup.setupVerbosity common) mbWorkDir = Setup.flagToMaybe $ Setup.setupWorkingDir common load <- try (loadConfigOrSandboxConfig verbosity' globalFlags) @@ -83,9 +88,9 @@ wrapperAction command getCommonFlags = -- class HasVerbosity a where - verbosity :: a -> Verbosity + verbosity :: a -> VerbosityFlags -instance HasVerbosity (Setup.Flag Verbosity) where +instance HasVerbosity (Setup.Flag VerbosityFlags) where verbosity = Setup.fromFlagOrDefault normal instance HasVerbosity a => HasVerbosity (a, b) where diff --git a/cabal-install/src/Distribution/Client/CmdListBin.hs b/cabal-install/src/Distribution/Client/CmdListBin.hs index 0dc78bcb4f3..b6bdf4b9339 100644 --- a/cabal-install/src/Distribution/Client/CmdListBin.hs +++ b/cabal-install/src/Distribution/Client/CmdListBin.hs @@ -52,7 +52,7 @@ import Distribution.System (Platform) import Distribution.Types.ComponentName (showComponentName) import Distribution.Types.UnitId (UnitId) import Distribution.Types.UnqualComponentName (UnqualComponentName) -import Distribution.Verbosity (silent, verboseStderr) +import Distribution.Verbosity (silent, verboseStderr, verbosityFlags) import System.FilePath ((<.>), ()) import qualified Data.Map as Map @@ -155,7 +155,7 @@ listbinAction flags args globalFlags = do case binfiles of [] -> dieWithException verbosity NoTargetFound - [exe] -> putStr $ withOutputMarker verbosity $ exe ++ "\n" + [exe] -> putStr $ withOutputMarker (verbosityFlags verbosity) $ exe ++ "\n" -- Andreas, 2023-01-13, issue #8400: -- Regular output of `list-bin` should go to stdout unconditionally, -- but for the sake of the testsuite, we want to mark it so it goes diff --git a/cabal-install/src/Distribution/Client/CmdOutdated.hs b/cabal-install/src/Distribution/Client/CmdOutdated.hs index cd3bf674007..1d7cf38093b 100644 --- a/cabal-install/src/Distribution/Client/CmdOutdated.hs +++ b/cabal-install/src/Distribution/Client/CmdOutdated.hs @@ -270,9 +270,10 @@ outdatedAction flags targetStrings globalFlags = where OutdatedFlags{..} = extraFlags flags verbosity = - if quiet - then silent - else fromFlagOrDefault normal (setupVerbosity (configCommonFlags (configFlags flags))) + mkVerbosity defaultVerbosityHandles $ + if quiet + then silent + else fromFlagOrDefault normal (setupVerbosity (configCommonFlags (configFlags flags))) freezeFile = fromFlagOrDefault False outdatedFreezeFile newFreezeFile = fromFlagOrDefault False outdatedNewFreezeFile simpleOutput = fromFlagOrDefault False outdatedSimpleOutput diff --git a/cabal-install/src/Distribution/Client/CmdPath.hs b/cabal-install/src/Distribution/Client/CmdPath.hs index 9beacf73287..4f570cf95e8 100644 --- a/cabal-install/src/Distribution/Client/CmdPath.hs +++ b/cabal-install/src/Distribution/Client/CmdPath.hs @@ -81,6 +81,7 @@ import Distribution.Simple.Utils ) import Distribution.Verbosity ( normal + , verbosityFlags ) ------------------------------------------------------------------------------- @@ -272,7 +273,7 @@ pathAction flags@NixStyleFlags{extraFlags = pathFlags'} cliTargetStrings globalF KeyValue -> do showAsKeyValuePair pathOutputs - putStr $ withOutputMarker verbosity output + putStr $ withOutputMarker (verbosityFlags verbosity) output where verbosity = cfgVerbosity normal flags diff --git a/cabal-install/src/Distribution/Client/CmdRepl.hs b/cabal-install/src/Distribution/Client/CmdRepl.hs index c78f6f4416d..41be0dc0518 100644 --- a/cabal-install/src/Distribution/Client/CmdRepl.hs +++ b/cabal-install/src/Distribution/Client/CmdRepl.hs @@ -157,6 +157,7 @@ import Distribution.Utils.Generic ) import Distribution.Verbosity ( lessVerbose + , modifyVerbosityFlags , normal ) import Language.Haskell.Extension @@ -382,7 +383,7 @@ replAction flags@NixStyleFlags{extraFlags = replFlags@ReplFlags{..}, configFlags else -- Unfortunately, the best way to do this is to let the normal solver -- help us resolve the targets, but that isn't ideal for performance, -- especially in the no-project case. - withInstallPlan (lessVerbose verbosity) baseCtx' $ \elaboratedPlan sharedConfig -> do + withInstallPlan (modifyVerbosityFlags lessVerbose verbosity) baseCtx' $ \elaboratedPlan sharedConfig -> do -- targets should be non-empty map, but there's no NonEmptyMap yet. targets <- validatedTargets' (projectConfigShared (projectConfig ctx)) (pkgConfigCompiler sharedConfig) elaboratedPlan targetSelectors @@ -451,7 +452,7 @@ replAction flags@NixStyleFlags{extraFlags = replFlags@ReplFlags{..}, configFlags -- Multi Repl implementation see: https://well-typed.com/blog/2023/03/cabal-multi-unit/ for -- a high-level overview about how everything fits together. if Set.size (distinctTargetComponents targets) > 1 - then withTempDirectoryEx verbosity tempFileOptions distDir "multi-out" $ \dir' -> do + then withTempDirectoryEx tempFileOptions distDir "multi-out" $ \dir' -> do -- multi target repl dir <- makeAbsolute dir' -- Modify the replOptions so that the ./Setup repl command will write options diff --git a/cabal-install/src/Distribution/Client/CmdSdist.hs b/cabal-install/src/Distribution/Client/CmdSdist.hs index 5dcc90a8bfb..0fadca710bf 100644 --- a/cabal-install/src/Distribution/Client/CmdSdist.hs +++ b/cabal-install/src/Distribution/Client/CmdSdist.hs @@ -127,7 +127,11 @@ import Distribution.Types.PackageName , unPackageName ) import Distribution.Verbosity - ( normal + ( VerbosityFlags + , defaultVerbosityHandles + , mkVerbosity + , normal + , verbosityFlags ) import qualified Data.ByteString.Lazy.Char8 as BSL @@ -169,7 +173,7 @@ sdistCommand = ------------------------------------------------------------------------------- data SdistFlags = SdistFlags - { sdistVerbosity :: Flag Verbosity + { sdistVerbosity :: Flag VerbosityFlags , sdistDistDir :: Flag (SymbolicPath Pkg (Dir Dist)) , sdistListSources :: Flag Bool , sdistNulSeparated :: Flag Bool @@ -282,7 +286,9 @@ sdistAction (pf@ProjectFlags{..}, SdistFlags{..}) targetStrings globalFlags = do (outputPath pkg) pkg where - verbosity = fromFlagOrDefault normal sdistVerbosity + verbosity = + mkVerbosity defaultVerbosityHandles $ + fromFlagOrDefault normal sdistVerbosity listSources = fromFlagOrDefault False sdistListSources nulSeparated = fromFlagOrDefault False sdistNulSeparated mOutputPath = flagToMaybe sdistOutputPath @@ -334,7 +340,7 @@ packageToSdist verbosity projectRootDir format outputFile pkg = do let -- Write String to stdout or file, using the default TextEncoding. write str - | outputFile == "-" = putStr (withOutputMarker verbosity str) + | outputFile == "-" = putStr (withOutputMarker (verbosityFlags verbosity) str) | otherwise = do writeFile outputFile str notice verbosity $ "Wrote source list to " ++ outputFile ++ "\n" diff --git a/cabal-install/src/Distribution/Client/CmdTarget.hs b/cabal-install/src/Distribution/Client/CmdTarget.hs index 6fc0f9f973c..9f22958cb63 100644 --- a/cabal-install/src/Distribution/Client/CmdTarget.hs +++ b/cabal-install/src/Distribution/Client/CmdTarget.hs @@ -42,7 +42,9 @@ import Distribution.Simple.Utils , wrapText ) import Distribution.Verbosity - ( normal + ( defaultVerbosityHandles + , mkVerbosity + , normal ) import Text.PrettyPrint import qualified Text.PrettyPrint as Pretty @@ -181,7 +183,9 @@ targetAction flags@NixStyleFlags{..} ts globalFlags = do printTargetForms verbosity targetStrings targets elaboratedPlan where - verbosity = fromFlagOrDefault normal (configVerbosity configFlags) + verbosity = + mkVerbosity defaultVerbosityHandles $ + fromFlagOrDefault normal (configVerbosity configFlags) targetStrings = if null ts then ["all"] else ts cliConfig = commandLineFlagsToProjectConfig diff --git a/cabal-install/src/Distribution/Client/CmdUpdate.hs b/cabal-install/src/Distribution/Client/CmdUpdate.hs index f66e03340d6..03d76eca205 100644 --- a/cabal-install/src/Distribution/Client/CmdUpdate.hs +++ b/cabal-install/src/Distribution/Client/CmdUpdate.hs @@ -72,6 +72,7 @@ import Distribution.Simple.Utils ) import Distribution.Verbosity ( lessVerbose + , modifyVerbosityFlags , normal ) import System.Directory @@ -250,7 +251,7 @@ updateRepo verbosity _updateFlags repoCtxt (repo, indexState) = do RepoSecure{} -> repoContextWithSecureRepo repoCtxt repo $ \repoSecure -> do let index = RepoIndex repoCtxt repo -- NB: This may be a NoTimestamp if we've never updated before - current_ts <- currentIndexTimestamp (lessVerbose verbosity) index + current_ts <- currentIndexTimestamp (modifyVerbosityFlags lessVerbose verbosity) index -- NB: always update the timestamp, even if we didn't actually -- download anything writeIndexTimestamp index indexState @@ -282,7 +283,7 @@ updateRepo verbosity _updateFlags repoCtxt (repo, indexState) = do -- This resolves indexState (which could be HEAD) into a timestamp -- This could be null but should not be, since the above guarantees -- we have an updated index. - new_ts <- currentIndexTimestamp (lessVerbose verbosity) index + new_ts <- currentIndexTimestamp (modifyVerbosityFlags lessVerbose verbosity) index noticeNoWrap verbosity $ "The index-state is set to " ++ prettyShow (IndexStateTime new_ts) ++ "." diff --git a/cabal-install/src/Distribution/Client/Config.hs b/cabal-install/src/Distribution/Client/Config.hs index 9036932b6b2..5e50d2b5788 100644 --- a/cabal-install/src/Distribution/Client/Config.hs +++ b/cabal-install/src/Distribution/Client/Config.hs @@ -213,6 +213,7 @@ import Distribution.Solver.Types.ConstraintSource import Distribution.Utils.Path (getSymbolicPath, unsafeMakeSymbolicPath) import Distribution.Verbosity ( normal + , verbosityFlags ) import Network.URI ( URI (..) @@ -1941,7 +1942,7 @@ parseExtraLines verbosity extraLines = -- config file and the one that cabal would generate if it didn't exist. userConfigDiff :: Verbosity -> GlobalFlags -> [String] -> IO [String] userConfigDiff verbosity globalFlags extraLines = do - userConfig <- loadRawConfig normal (globalConfigFile globalFlags) + userConfig <- loadRawConfig (verbosity{verbosityFlags = normal}) (globalConfigFile globalFlags) extraConfig <- parseExtraLines verbosity extraLines testConfig <- initialSavedConfig return $ @@ -1995,7 +1996,7 @@ userConfigDiff verbosity globalFlags extraLines = do -- | Update the user's config file keeping the user's customizations. userConfigUpdate :: Verbosity -> GlobalFlags -> [String] -> IO () userConfigUpdate verbosity globalFlags extraLines = do - userConfig <- loadRawConfig normal (globalConfigFile globalFlags) + userConfig <- loadRawConfig (verbosity{verbosityFlags = normal}) (globalConfigFile globalFlags) extraConfig <- parseExtraLines verbosity extraLines newConfig <- initialSavedConfig commentConf <- commentSavedConfig diff --git a/cabal-install/src/Distribution/Client/Configure.hs b/cabal-install/src/Distribution/Client/Configure.hs index bf0b7fdec27..5d1a1f9bc9f 100644 --- a/cabal-install/src/Distribution/Client/Configure.hs +++ b/cabal-install/src/Distribution/Client/Configure.hs @@ -130,6 +130,7 @@ import Distribution.Version ) import Distribution.Client.Errors +import Distribution.Verbosity (verbosityFlags, verbosityLevel) -- | Choose the Cabal version such that the setup scripts compiled against this -- version will support the given command-line flags. Currently, it implements no @@ -462,7 +463,7 @@ planLocalPackage -- package database and executables never show up in the -- installed package index . setSolveExecutables (SolveExecutables False) - . setSolverVerbosity verbosity + . setSolverVerbosity (verbosityLevel verbosity) $ standardInstallPolicy installedPkgIndex -- NB: We pass in an *empty* source package database, @@ -515,7 +516,7 @@ configurePackage configFlags { configCommonFlags = (configCommonFlags configFlags) - { setupVerbosity = toFlag verbosity + { setupVerbosity = toFlag $ verbosityFlags verbosity , setupWorkingDir = maybeToFlag $ useWorkingDir scriptOptions } , configIPID = diff --git a/cabal-install/src/Distribution/Client/Dependency.hs b/cabal-install/src/Distribution/Client/Dependency.hs index a65c41cb046..ad2205bf077 100644 --- a/cabal-install/src/Distribution/Client/Dependency.hs +++ b/cabal-install/src/Distribution/Client/Dependency.hs @@ -137,7 +137,7 @@ import Distribution.Types.DependencySatisfaction ( DependencySatisfaction (..) ) import Distribution.Verbosity - ( normal + ( VerbosityLevel (..) ) import Distribution.Version @@ -210,7 +210,7 @@ data DepResolverParams = DepResolverParams -- so we shouldn't solve for them. See #3875. , depResolverGoalOrder :: Maybe (Variable QPN -> Variable QPN -> Ordering) -- ^ Function to override the solver's goal-ordering heuristics. - , depResolverVerbosity :: Verbosity + , depResolverVerbosity :: VerbosityLevel } showDepResolverParams :: DepResolverParams -> String @@ -307,7 +307,7 @@ basicDepResolverParams installedPkgIndex sourcePkgIndex = , depResolverEnableBackjumping = EnableBackjumping True , depResolverSolveExecutables = SolveExecutables True , depResolverGoalOrder = Nothing - , depResolverVerbosity = normal + , depResolverVerbosity = Normal } addTargets @@ -437,7 +437,7 @@ setGoalOrder order params = { depResolverGoalOrder = order } -setSolverVerbosity :: Verbosity -> DepResolverParams -> DepResolverParams +setSolverVerbosity :: VerbosityLevel -> DepResolverParams -> DepResolverParams setSolverVerbosity verbosity params = params { depResolverVerbosity = verbosity diff --git a/cabal-install/src/Distribution/Client/Fetch.hs b/cabal-install/src/Distribution/Client/Fetch.hs index 033d3a01e14..13c6f23415e 100644 --- a/cabal-install/src/Distribution/Client/Fetch.hs +++ b/cabal-install/src/Distribution/Client/Fetch.hs @@ -60,6 +60,7 @@ import Distribution.Simple.Utils import Distribution.System ( Platform ) +import Distribution.Verbosity (verbosityLevel) -- ------------------------------------------------------------ @@ -206,7 +207,7 @@ planPackages . setStrongFlags strongFlags . setAllowBootLibInstalls allowBootLibInstalls . setOnlyConstrained onlyConstrained - . setSolverVerbosity verbosity + . setSolverVerbosity (verbosityLevel verbosity) . addConstraints [ let pc = PackageConstraint diff --git a/cabal-install/src/Distribution/Client/FetchUtils.hs b/cabal-install/src/Distribution/Client/FetchUtils.hs index 62da386573d..fc1b0bb16d5 100644 --- a/cabal-install/src/Distribution/Client/FetchUtils.hs +++ b/cabal-install/src/Distribution/Client/FetchUtils.hs @@ -69,7 +69,8 @@ import Distribution.Simple.Utils , warn ) import Distribution.Verbosity - ( verboseUnmarkOutput + ( modifyVerbosityFlags + , verboseUnmarkOutput ) import Control.Concurrent.Async @@ -266,7 +267,7 @@ fetchRepoTarball verbosity' repoCtxt repo pkgid = do return res where -- whether we download or not is non-deterministic - verbosity = verboseUnmarkOutput verbosity' + verbosity = modifyVerbosityFlags verboseUnmarkOutput verbosity' downloadRepoPackage :: IO FilePath downloadRepoPackage = case repo of @@ -353,7 +354,7 @@ asyncFetchPackages verbosity repoCtxt pkglocs body = do -- specifically 'AsyncCancelled' thrown at us from 'concurrently'. result <- Safe.try $ - fetchPackage (verboseUnmarkOutput verbosity) repoCtxt pkgloc + fetchPackage (modifyVerbosityFlags verboseUnmarkOutput verbosity) repoCtxt pkgloc putMVar var result (_, res) <- diff --git a/cabal-install/src/Distribution/Client/Freeze.hs b/cabal-install/src/Distribution/Client/Freeze.hs index a03b45b6a2d..a586b72d66d 100644 --- a/cabal-install/src/Distribution/Client/Freeze.hs +++ b/cabal-install/src/Distribution/Client/Freeze.hs @@ -80,6 +80,7 @@ import Distribution.Simple.Utils import Distribution.System ( Platform ) +import Distribution.Verbosity (verbosityLevel) import Distribution.Version ( thisVersion ) @@ -235,7 +236,7 @@ planPackages . setStrongFlags strongFlags . setAllowBootLibInstalls allowBootLibInstalls . setOnlyConstrained onlyConstrained - . setSolverVerbosity verbosity + . setSolverVerbosity (verbosityLevel verbosity) . addConstraints [ let pkg = pkgSpecifierTarget pkgSpecifier pc = diff --git a/cabal-install/src/Distribution/Client/Haddock.hs b/cabal-install/src/Distribution/Client/Haddock.hs index 058b24f6537..0bf3ee11857 100644 --- a/cabal-install/src/Distribution/Client/Haddock.hs +++ b/cabal-install/src/Distribution/Client/Haddock.hs @@ -66,7 +66,7 @@ regenerateHaddockIndex verbosity pkgs progdb index = do createDirectoryIfMissing True destDir - withTempDirectory verbosity destDir "tmphaddock" $ \tempDir -> do + withTempDirectory destDir "tmphaddock" $ \tempDir -> do let flags = [ "--gen-contents" , "--gen-index" diff --git a/cabal-install/src/Distribution/Client/IndexUtils.hs b/cabal-install/src/Distribution/Client/IndexUtils.hs index e143d661c3b..8872ad6467f 100644 --- a/cabal-install/src/Distribution/Client/IndexUtils.hs +++ b/cabal-install/src/Distribution/Client/IndexUtils.hs @@ -166,7 +166,7 @@ getInstalledPackages getInstalledPackages verbosity comp packageDbs progdb = Configure.getInstalledPackages verbosity' comp Nothing (coercePackageDBStack packageDbs) progdb where - verbosity' = lessVerbose verbosity + verbosity' = modifyVerbosityFlags lessVerbose verbosity -- | Get filename base (i.e. without file extension) for index-related files -- @@ -257,7 +257,7 @@ getSourcePackagesAtIndexState verbosity repoCtxt _ _ | null (repoContextRepos repoCtxt) = do -- In the test suite, we routinely don't have any remote package -- servers, so don't bleat about it - warn (verboseUnmarkOutput verbosity) $ + warn (modifyVerbosityFlags verboseUnmarkOutput verbosity) $ "No remote package servers have been specified. Usually " ++ "you would have one specified in the config file." return diff --git a/cabal-install/src/Distribution/Client/Init/FileCreators.hs b/cabal-install/src/Distribution/Client/Init/FileCreators.hs index 3eaf60a5035..be9f1ff9f60 100644 --- a/cabal-install/src/Distribution/Client/Init/FileCreators.hs +++ b/cabal-install/src/Distribution/Client/Init/FileCreators.hs @@ -54,6 +54,7 @@ import Distribution.Types.PackageName import Distribution.FieldGrammar.Newtypes import Distribution.License (licenseToSPDX) +import Distribution.Verbosity (defaultVerbosityHandles, mkVerbosity) import System.FilePath ((<.>), ()) -- -------------------------------------------------------------------- -- @@ -279,7 +280,7 @@ instance Show WriteAction where -- | Possibly generate a message to stdout, taking into account the -- --quiet flag. message :: Interactive m => WriteOpts -> T.Severity -> String -> m () -message opts = T.message (_optVerbosity opts) +message opts = T.message (mkVerbosity defaultVerbosityHandles $ _optVerbosity opts) -- | Write a file \"safely\" if it doesn't exist, backing up any existing version when -- the overwrite flag is set. diff --git a/cabal-install/src/Distribution/Client/Init/Interactive/Command.hs b/cabal-install/src/Distribution/Client/Init/Interactive/Command.hs index e01590df1fc..0ea245ef9b6 100644 --- a/cabal-install/src/Distribution/Client/Init/Interactive/Command.hs +++ b/cabal-install/src/Distribution/Client/Init/Interactive/Command.hs @@ -66,6 +66,7 @@ import Distribution.Version (Version) import Distribution.License (knownLicenses) import Distribution.Parsec (simpleParsec') +import Distribution.Verbosity (verbosityFlags) import Language.Haskell.Extension (Language (..)) -- | Main driver for interactive prompt code. @@ -107,7 +108,7 @@ createProject v pkgIx srcDb initFlags = do doOverwrite isMinimal cs - v + (verbosityFlags v) pkgDir pkgType pkgName diff --git a/cabal-install/src/Distribution/Client/Init/NonInteractive/Command.hs b/cabal-install/src/Distribution/Client/Init/NonInteractive/Command.hs index 6a93ab6069e..f3d40806462 100644 --- a/cabal-install/src/Distribution/Client/Init/NonInteractive/Command.hs +++ b/cabal-install/src/Distribution/Client/Init/NonInteractive/Command.hs @@ -113,7 +113,7 @@ createProject comp v pkgIx srcDb initFlags = do doOverwrite isMinimal cs - v + (verbosityFlags v) pkgDir pkgType pkgName @@ -497,8 +497,9 @@ dependenciesHeuristics flags fp pkgIx = getDependencies flags $ do groupedDeps = concatMap (\s -> map (moduleName s,) (imports s)) sources filteredDeps = filter ((`notElem` mods) . snd) groupedDeps preludeNub = nubBy (\a b -> snd a == snd b) $ (fromString "Prelude", fromString "Prelude") : filteredDeps + verbosity = mkVerbosity defaultVerbosityHandles (fromFlagOrDefault normal $ initVerbosity flags) - retrieveDependencies (fromFlagOrDefault normal $ initVerbosity flags) flags preludeNub pkgIx + retrieveDependencies verbosity flags preludeNub pkgIx -- | Retrieve the list of extensions otherExtsHeuristics :: Interactive m => InitFlags -> FilePath -> m [Extension] diff --git a/cabal-install/src/Distribution/Client/Init/Simple.hs b/cabal-install/src/Distribution/Client/Init/Simple.hs index 09e9d370875..08320b84525 100644 --- a/cabal-install/src/Distribution/Client/Init/Simple.hs +++ b/cabal-install/src/Distribution/Client/Init/Simple.hs @@ -45,7 +45,7 @@ createProject v pkgIx _srcDb initFlags = do doOverwrite isMinimal cs - v + (verbosityFlags v) pkgDir pkgType pkgName diff --git a/cabal-install/src/Distribution/Client/Init/Types.hs b/cabal-install/src/Distribution/Client/Init/Types.hs index f72634248a0..fedae63f657 100644 --- a/cabal-install/src/Distribution/Client/Init/Types.hs +++ b/cabal-install/src/Distribution/Client/Init/Types.hs @@ -81,7 +81,7 @@ import Distribution.Fields.Pretty import Distribution.ModuleName import qualified Distribution.Package as P import Distribution.Simple.Setup (Flag) -import Distribution.Verbosity (silent) +import Distribution.Verbosity (VerbosityFlags, VerbosityLevel (..), verbosityLevel) import Distribution.Version import Language.Haskell.Extension (Extension, Language (..)) import qualified System.IO @@ -129,7 +129,7 @@ data InitFlags = InitFlags , initializeTestSuite :: Flag Bool , testDirs :: Flag [String] , initHcPath :: Flag FilePath - , initVerbosity :: Flag Verbosity + , initVerbosity :: Flag VerbosityFlags , overwrite :: Flag Bool } deriving (Eq, Show, Generic) @@ -209,7 +209,7 @@ data WriteOpts = WriteOpts { _optOverwrite :: Bool , _optMinimal :: Bool , _optNoComments :: Bool - , _optVerbosity :: Verbosity + , _optVerbosity :: VerbosityFlags , _optPkgDir :: FilePath , _optPkgType :: PackageType , _optPkgName :: P.PackageName @@ -410,7 +410,7 @@ instance Interactive PromptIO where renameDirectory a b = liftIO $ P.renameDirectory a b hFlush = liftIO <$> System.IO.hFlush message q severity msg - | q == silent = pure () + | verbosityLevel q == Silent = pure () | otherwise = putStrLn $ "[" ++ displaySeverity severity ++ "] " ++ msg break = return False throwPrompt = liftIO <$> throwM diff --git a/cabal-install/src/Distribution/Client/Init/Utils.hs b/cabal-install/src/Distribution/Client/Init/Utils.hs index d55ac85a947..bdb9b325666 100644 --- a/cabal-install/src/Distribution/Client/Init/Utils.hs +++ b/cabal-install/src/Distribution/Client/Init/Utils.hs @@ -48,7 +48,7 @@ import Distribution.Types.Dependency (Dependency, mkDependency) import Distribution.Types.LibraryName import Distribution.Types.PackageName import Distribution.Utils.String (trim) -import Distribution.Verbosity (silent) +import Distribution.Verbosity (defaultVerbosityHandles, mkVerbosity, silent) import Distribution.Version -- | Data type of source files found in the working directory @@ -323,7 +323,7 @@ mkStringyDep = mkPackageNameDep . mkPackageName getBaseDep :: Interactive m => InstalledPackageIndex -> InitFlags -> m [Dependency] getBaseDep pkgIx flags = retrieveDependencies - silent + (mkVerbosity defaultVerbosityHandles silent) flags [(fromString "Prelude", fromString "Prelude")] pkgIx diff --git a/cabal-install/src/Distribution/Client/Install.hs b/cabal-install/src/Distribution/Client/Install.hs index bd28046db6e..b942253b6c2 100644 --- a/cabal-install/src/Distribution/Client/Install.hs +++ b/cabal-install/src/Distribution/Client/Install.hs @@ -266,11 +266,7 @@ import Distribution.Types.PackageVersionConstraint , thisPackageVersionConstraint ) import Distribution.Utils.NubList -import Distribution.Verbosity as Verbosity - ( modifyVerbosity - , normal - , verbose - ) +import Distribution.Verbosity import Distribution.Version ( Version , VersionRange @@ -608,7 +604,7 @@ planPackages . setStrongFlags strongFlags . setAllowBootLibInstalls allowBootLibInstalls . setOnlyConstrained onlyConstrained - . setSolverVerbosity verbosity + . setSolverVerbosity (verbosityLevel verbosity) . setPreferenceDefault ( if upgradeDeps then PreferAllLatest @@ -791,7 +787,7 @@ checkPrintPlan let adaptedVerbosity | containsReinstalls , not overrideReinstall = - modifyVerbosity (max verbose) verbosity + modifyVerbosityFlags makeVerbose verbosity | otherwise = verbosity -- We print the install plan if we are in a dry-run or if we are confronted @@ -917,7 +913,7 @@ printPlan printPlan dryRun verbosity plan sourcePkgDb = case plan of [] -> return () pkgs - | verbosity >= Verbosity.verbose -> + | verbosityLevel verbosity >= Verbose -> notice verbosity $ unlines $ ("In order, the following " ++ wouldWill ++ " be installed:") @@ -1536,7 +1532,7 @@ performInstallations -- --build-log, use more verbose logging. loggingVerbosity :: Verbosity loggingVerbosity - | overrideVerbosity = modifyVerbosity (max verbose) verbosity + | overrideVerbosity = modifyVerbosityFlags makeVerbose verbosity | otherwise = verbosity useDefaultTemplate :: Bool @@ -1599,7 +1595,7 @@ executeInstallPlan verbosity jobCtl keepGoing useLogFile plan0 installPkg = (Right _) -> progressMessage verbosity ProgressCompleted (prettyShow pkgid) (Left _) -> do notice verbosity $ "Failed to install " ++ prettyShow pkgid - when (verbosity >= normal) $ + when (verbosityLevel verbosity >= Normal) $ case useLogFile of Nothing -> return () Just (mkLogFileName, _) -> do @@ -1754,7 +1750,7 @@ installLocalTarballPackage distPref installPkg = do tmp <- getTemporaryDirectory - withTempDirectory verbosity tmp "cabal-tmp" $ \tmpDirPath -> + withTempDirectory tmp "cabal-tmp" $ \tmpDirPath -> onFailure UnpackFailed $ do let relUnpackedPath = prettyShow pkgid absUnpackedPath = tmpDirPath relUnpackedPath @@ -1870,7 +1866,7 @@ installUnpackedPackage (`filterCommonFlags` ver) $ defaultCommonSetupFlags { setupDistPref = setupDistPref $ configCommonFlags configFlags - , setupVerbosity = toFlag verbosity' + , setupVerbosity = toFlag $ verbosityFlags verbosity' , setupWorkingDir = maybeToFlag mbWorkDir } @@ -1884,7 +1880,7 @@ installUnpackedPackage configFlags' { configCommonFlags = (configCommonFlags (configFlags')) - { setupVerbosity = toFlag verbosity' + { setupVerbosity = toFlag $ verbosityFlags verbosity' } } @@ -2023,7 +2019,7 @@ installUnpackedPackage -> IO [Installed.InstalledPackageInfo] genPkgConfs flags mLogPath = do tmp <- getTemporaryDirectory - withTempDirectory verbosity tmp (tempTemplate "pkgConf") $ \dir -> do + withTempDirectory tmp (tempTemplate "pkgConf") $ \dir -> do let pkgConfDest = makeSymbolicPath dir makeRelativePathEx "pkgConf" registerFlags' version = (flags version) @@ -2081,7 +2077,7 @@ installUnpackedPackage (traverse_ hClose) ( \logFileHandle -> setupWrapper - verbosity + (setVerbosityHandles logFileHandle verbosity) scriptOptions { useLoggingHandle = logFileHandle , useWorkingDir = makeSymbolicPath <$> workingDir diff --git a/cabal-install/src/Distribution/Client/InstallSymlink.hs b/cabal-install/src/Distribution/Client/InstallSymlink.hs index 1b7f5cdbf3b..9e73aabe310 100644 --- a/cabal-install/src/Distribution/Client/InstallSymlink.hs +++ b/cabal-install/src/Distribution/Client/InstallSymlink.hs @@ -396,7 +396,7 @@ makeRelative a b = trySymlink :: Verbosity -> IO Bool trySymlink verbosity = do tmp <- getTemporaryDirectory - withTempDirectory verbosity tmp "cabal-symlink-test" $ \tmpDirPath -> do + withTempDirectory tmp "cabal-symlink-test" $ \tmpDirPath -> do let from = tmpDirPath "file.txt" let to = tmpDirPath "file2.txt" diff --git a/cabal-install/src/Distribution/Client/Main.hs b/cabal-install/src/Distribution/Client/Main.hs index 7583369cda2..6c7f05cfb99 100644 --- a/cabal-install/src/Distribution/Client/Main.hs +++ b/cabal-install/src/Distribution/Client/Main.hs @@ -248,7 +248,12 @@ import Distribution.Utils.Path hiding , () ) import Distribution.Verbosity as Verbosity - ( normal + ( VerbosityFlags + , defaultVerbosityHandles + , mkVerbosity + , normal + , verbosityFlags + , verbosityHandles ) import Distribution.Version ( Version @@ -375,7 +380,8 @@ mainWorker args = do -- we rely on cabal's implementation of findProgramOnSearchPath not following -- symlinks here. If that ever happens, then the argv[0] of the called executable -- will be different from the intended one and will break tools that work by reading it. - mCommand <- findProgramOnSearchPath normal defaultProgramSearchPath ("cabal-" <> name) + let verb = mkVerbosity defaultVerbosityHandles normal + mCommand <- findProgramOnSearchPath verb defaultProgramSearchPath ("cabal-" <> name) case mCommand of Just (exec, _) -> return (CommandReadyToGo $ \_ -> callExternal exec cmdArgs) Nothing -> defaultCommandFallback commands' name cmdArgs @@ -528,7 +534,10 @@ wrapperAction command getCommonFlags = } $ \flags extraArgs globalFlags -> do let common = getCommonFlags flags - verbosity = fromFlagOrDefault normal $ setupVerbosity common + verbosity = + mkVerbosity defaultVerbosityHandles $ + fromFlagOrDefault normal $ + setupVerbosity common mbWorkDir = flagToMaybe $ setupWorkingDir common load <- try (loadConfigOrSandboxConfig verbosity globalFlags) let config = either (\(SomeException _) -> mempty) id load @@ -553,7 +562,10 @@ configureAction -> Action configureAction (configFlags, configExFlags) extraArgs globalFlags = do let common = configCommonFlags configFlags - verbosity = fromFlagOrDefault normal $ setupVerbosity common + verbosity = + mkVerbosity defaultVerbosityHandles $ + fromFlagOrDefault normal $ + setupVerbosity common config <- updateInstallDirs (configUserInstall configFlags) @@ -563,7 +575,7 @@ configureAction (configFlags, configExFlags) extraArgs globalFlags = do let configFlags' = savedConfigureFlags config `mappend` configFlags configExFlags' = savedConfigureExFlags config `mappend` configExFlags globalFlags' = savedGlobalFlags config `mappend` globalFlags - (comp, platform, progdb) <- configCompilerAuxEx configFlags' + (comp, platform, progdb) <- configCompilerAuxEx (verbosityHandles verbosity) configFlags' writeConfigFlags verbosity distPref (configFlags', configExFlags') @@ -592,7 +604,9 @@ reconfigureAction -> Action reconfigureAction flags@(configFlags, _) _ globalFlags = do let common = configCommonFlags configFlags - verbosity = fromFlagOrDefault normal (setupVerbosity common) + verbosity = + mkVerbosity defaultVerbosityHandles $ + fromFlagOrDefault normal (setupVerbosity common) config <- updateInstallDirs (configUserInstall configFlags) <$> loadConfigOrSandboxConfig verbosity globalFlags @@ -623,7 +637,10 @@ reconfigureAction flags@(configFlags, _) _ globalFlags = do buildAction :: BuildFlags -> [String] -> Action buildAction buildFlags extraArgs globalFlags = do let common = buildCommonFlags buildFlags - verbosity = fromFlagOrDefault normal $ setupVerbosity common + verbosity = + mkVerbosity defaultVerbosityHandles $ + fromFlagOrDefault normal $ + setupVerbosity common config <- loadConfigOrSandboxConfig verbosity globalFlags distPref <- findSavedDistPref config (setupDistPref common) -- Calls 'configureAction' to do the real work, so nothing special has to be @@ -663,7 +680,7 @@ build verbosity config distPref buildFlags extraArgs = buildFlags { buildCommonFlags = commonFlags - { setupVerbosity = toFlag verbosity + { setupVerbosity = toFlag $ verbosityFlags verbosity , setupDistPref = toFlag distPref } } @@ -701,7 +718,10 @@ filterBuildFlags' version config buildFlags replAction :: ReplFlags -> [String] -> Action replAction replFlags extraArgs globalFlags = do let common = replCommonFlags replFlags - verbosity = fromFlagOrDefault normal $ setupVerbosity common + verbosity = + mkVerbosity defaultVerbosityHandles $ + fromFlagOrDefault normal $ + setupVerbosity common config <- loadConfigOrSandboxConfig verbosity globalFlags distPref <- findSavedDistPref config (setupDistPref common) pkgDesc <- findPackageDesc Nothing @@ -732,7 +752,7 @@ replAction replFlags extraArgs globalFlags = do replFlags { replCommonFlags = commonFlags - { setupVerbosity = toFlag verbosity + { setupVerbosity = toFlag $ verbosityFlags verbosity , setupDistPref = toFlag distPref } } @@ -780,7 +800,9 @@ installAction installAction (configFlags, _, installFlags, _, _, _) _ globalFlags | fromFlagOrDefault False (installOnly installFlags) = do let common = configCommonFlags configFlags - verb = fromFlagOrDefault normal (setupVerbosity common) + verb = + mkVerbosity defaultVerbosityHandles $ + fromFlagOrDefault normal (setupVerbosity common) config <- loadConfigOrSandboxConfig verb globalFlags dist <- findSavedDistPref config (setupDistPref common) let setupOpts = defaultSetupScriptOptions{useDistPref = dist} @@ -803,7 +825,10 @@ installAction extraArgs globalFlags = do let common = configCommonFlags configFlags - verb = fromFlagOrDefault normal $ setupVerbosity common + verb = + mkVerbosity defaultVerbosityHandles $ + fromFlagOrDefault normal $ + setupVerbosity common config <- updateInstallDirs (configUserInstall configFlags) <$> loadConfigOrSandboxConfig verb globalFlags @@ -893,7 +918,9 @@ testAction -> GlobalFlags -> IO () testAction (buildFlags, testFlags) extraArgs globalFlags = do - let verbosity = fromFlagOrDefault normal (setupVerbosity $ buildCommonFlags buildFlags) + let verbosity = + mkVerbosity defaultVerbosityHandles $ + fromFlagOrDefault normal (setupVerbosity $ buildCommonFlags buildFlags) config <- loadConfigOrSandboxConfig verbosity globalFlags distPref <- findSavedDistPref config (setupDistPref $ testCommonFlags testFlags) let buildFlags' = @@ -1009,9 +1036,10 @@ benchmarkAction extraArgs globalFlags = do let verbosity = - fromFlagOrDefault - normal - (setupVerbosity $ buildCommonFlags buildFlags) + mkVerbosity defaultVerbosityHandles $ + fromFlagOrDefault + normal + (setupVerbosity $ buildCommonFlags buildFlags) config <- loadConfigOrSandboxConfig verbosity globalFlags distPref <- findSavedDistPref config (setupDistPref $ benchmarkCommonFlags benchmarkFlags) @@ -1086,8 +1114,10 @@ benchmarkAction haddockAction :: HaddockFlags -> [String] -> Action haddockAction haddockFlags extraArgs globalFlags = do let common = haddockCommonFlags haddockFlags - verbosity = fromFlag $ setupVerbosity common - + verbosity = + mkVerbosity defaultVerbosityHandles $ + fromFlag $ + setupVerbosity common config <- loadConfigOrSandboxConfig verbosity globalFlags distPref <- findSavedDistPref config (setupDistPref common) config' <- @@ -1136,7 +1166,10 @@ haddockAction haddockFlags extraArgs globalFlags = do cleanAction :: CleanFlags -> [String] -> Action cleanAction cleanFlags extraArgs globalFlags = do let common = cleanCommonFlags cleanFlags - verbosity = fromFlagOrDefault normal $ setupVerbosity common + verbosity = + mkVerbosity defaultVerbosityHandles $ + fromFlagOrDefault normal $ + setupVerbosity common load <- try (loadConfigOrSandboxConfig verbosity globalFlags) let config = either (\(SomeException _) -> mempty) id load distPref <- findSavedDistPref config $ setupDistPref common @@ -1163,7 +1196,9 @@ cleanAction cleanFlags extraArgs globalFlags = do listAction :: ListFlags -> [String] -> Action listAction listFlags extraArgs globalFlags = do - let verbosity = fromFlag (listVerbosity listFlags) + let verbosity = + mkVerbosity defaultVerbosityHandles $ + fromFlag (listVerbosity listFlags) config <- loadConfigOrSandboxConfig verbosity globalFlags let configFlags' = savedConfigureFlags config configFlags = @@ -1191,7 +1226,9 @@ listAction listFlags extraArgs globalFlags = do infoAction :: InfoFlags -> [String] -> Action infoAction infoFlags extraArgs globalFlags = do - let verbosity = fromFlag (infoVerbosity infoFlags) + let verbosity = + mkVerbosity defaultVerbosityHandles $ + fromFlag (infoVerbosity infoFlags) targets <- readUserTargets verbosity extraArgs config <- loadConfigOrSandboxConfig verbosity globalFlags let configFlags' = savedConfigureFlags config @@ -1202,7 +1239,7 @@ infoAction infoFlags extraArgs globalFlags = do `mappend` infoPackageDBs infoFlags } globalFlags' = savedGlobalFlags config `mappend` globalFlags - (comp, _, progdb) <- configCompilerAuxEx configFlags + (comp, _, progdb) <- configCompilerAuxEx defaultVerbosityHandles configFlags withRepoContext verbosity globalFlags' $ \repoContext -> List.info verbosity @@ -1216,7 +1253,9 @@ infoAction infoFlags extraArgs globalFlags = do fetchAction :: FetchFlags -> [String] -> Action fetchAction fetchFlags extraArgs globalFlags = do - let verbosity = fromFlag (fetchVerbosity fetchFlags) + let verbosity = + mkVerbosity defaultVerbosityHandles $ + fromFlag (fetchVerbosity fetchFlags) targets <- readUserTargets verbosity extraArgs config <- loadConfig verbosity (globalConfigFile globalFlags) let configFlags = savedConfigureFlags config @@ -1236,7 +1275,9 @@ fetchAction fetchFlags extraArgs globalFlags = do freezeAction :: FreezeFlags -> [String] -> Action freezeAction freezeFlags _extraArgs globalFlags = do - let verbosity = fromFlag (freezeVerbosity freezeFlags) + let verbosity = + mkVerbosity defaultVerbosityHandles $ + fromFlag (freezeVerbosity freezeFlags) config <- loadConfigOrSandboxConfig verbosity globalFlags let configFlags = savedConfigureFlags config globalFlags' = savedGlobalFlags config `mappend` globalFlags @@ -1255,7 +1296,9 @@ freezeAction freezeFlags _extraArgs globalFlags = do genBoundsAction :: FreezeFlags -> [String] -> GlobalFlags -> IO () genBoundsAction freezeFlags _extraArgs globalFlags = do - let verbosity = fromFlag (freezeVerbosity freezeFlags) + let verbosity = + mkVerbosity defaultVerbosityHandles $ + fromFlag (freezeVerbosity freezeFlags) config <- loadConfigOrSandboxConfig verbosity globalFlags let configFlags = savedConfigureFlags config globalFlags' = savedGlobalFlags config `mappend` globalFlags @@ -1313,7 +1356,9 @@ uploadAction uploadFlags extraArgs globalFlags = do (fromFlag (uploadCandidate uploadFlags')) tarfiles where - verbosity = fromFlag (uploadVerbosity uploadFlags) + verbosity = + mkVerbosity defaultVerbosityHandles $ + fromFlag (uploadVerbosity uploadFlags) checkTarFiles tarfiles | not (null otherFiles) = dieWithException verbosity $ UploadActionOnlyArchives otherFiles @@ -1348,16 +1393,16 @@ uploadAction uploadFlags extraArgs globalFlags = do checkAction :: CheckFlags -> [String] -> Action checkAction checkFlags extraArgs _globalFlags = do let verbosityFlag = checkVerbosity checkFlags - verbosity = fromFlag verbosityFlag + verbosity = mkVerbosity defaultVerbosityHandles $ fromFlag verbosityFlag unless (null extraArgs) $ dieWithException verbosity $ CheckAction extraArgs - allOk <- Check.check (fromFlag verbosityFlag) (checkIgnore checkFlags) + allOk <- Check.check (mkVerbosity defaultVerbosityHandles $ fromFlag verbosityFlag) (checkIgnore checkFlags) unless allOk exitFailure -formatAction :: Flag Verbosity -> [String] -> Action +formatAction :: Flag VerbosityFlags -> [String] -> Action formatAction verbosityFlag extraArgs _globalFlags = do - let verbosity = fromFlag verbosityFlag + let verbosity = mkVerbosity defaultVerbosityHandles $ fromFlag verbosityFlag warn verbosity "This command is not a full formatter yet" path <- case extraArgs of [] -> relativeSymbolicPath <$> tryFindPackageDesc verbosity Nothing @@ -1368,7 +1413,9 @@ formatAction verbosityFlag extraArgs _globalFlags = do reportAction :: ReportFlags -> [String] -> Action reportAction reportFlags extraArgs globalFlags = do - let verbosity = fromFlag (reportVerbosity reportFlags) + let verbosity = + mkVerbosity defaultVerbosityHandles $ + fromFlag (reportVerbosity reportFlags) unless (null extraArgs) $ dieWithException verbosity $ ReportAction extraArgs @@ -1387,7 +1434,10 @@ reportAction reportFlags extraArgs globalFlags = do runAction :: BuildFlags -> [String] -> Action runAction buildFlags extraArgs globalFlags = do let common = buildCommonFlags buildFlags - verbosity = fromFlagOrDefault normal $ setupVerbosity common + verbosity = + mkVerbosity defaultVerbosityHandles $ + fromFlagOrDefault normal $ + setupVerbosity common config <- loadConfigOrSandboxConfig verbosity globalFlags distPref <- findSavedDistPref config $ setupDistPref common config' <- @@ -1409,7 +1459,9 @@ runAction buildFlags extraArgs globalFlags = do getAction :: GetFlags -> [String] -> Action getAction getFlags extraArgs globalFlags = do - let verbosity = fromFlag (getVerbosity getFlags) + let verbosity = + mkVerbosity defaultVerbosityHandles $ + fromFlag (getVerbosity getFlags) targets <- readUserTargets verbosity extraArgs config <- loadConfigOrSandboxConfig verbosity globalFlags let globalFlags' = savedGlobalFlags config `mappend` globalFlags @@ -1454,12 +1506,16 @@ initAction initFlags extraArgs globalFlags = do progdb initFlags' - verbosity = fromFlag (initVerbosity initFlags) + verbosity = + mkVerbosity defaultVerbosityHandles $ + fromFlag (initVerbosity initFlags) compFlags = mempty{configHcPath = initHcPath initFlags} userConfigAction :: UserConfigFlags -> [String] -> Action userConfigAction ucflags extraArgs globalFlags = do - let verbosity = fromFlag (userConfigVerbosity ucflags) + let verbosity = + mkVerbosity defaultVerbosityHandles $ + fromFlag (userConfigVerbosity ucflags) frc = fromFlag (userConfigForce ucflags) extraLines = fromFlag (userConfigAppendLines ucflags) case extraArgs of @@ -1485,6 +1541,7 @@ actAsSetupAction actAsSetupFlags args _globalFlags = Configure -> Simple.defaultMainWithSetupHooksArgs Simple.autoconfSetupHooks + defaultVerbosityHandles args Make -> Make.defaultMainArgs args Hooks -> error "actAsSetupAction Hooks" @@ -1492,7 +1549,9 @@ actAsSetupAction actAsSetupFlags args _globalFlags = manpageAction :: [CommandSpec action] -> ManpageFlags -> [String] -> Action manpageAction commands flags extraArgs _ = do - let verbosity = fromFlag (manpageVerbosity flags) + let verbosity = + mkVerbosity defaultVerbosityHandles $ + fromFlag (manpageVerbosity flags) unless (null extraArgs) $ dieWithException verbosity $ ManpageAction extraArgs diff --git a/cabal-install/src/Distribution/Client/Manpage.hs b/cabal-install/src/Distribution/Client/Manpage.hs index 42480f33d9e..8002a2092ec 100644 --- a/cabal-install/src/Distribution/Client/Manpage.hs +++ b/cabal-install/src/Distribution/Client/Manpage.hs @@ -37,6 +37,7 @@ import Distribution.Simple.Utils , rawSystemProcAction , rawSystemStdInOut ) +import Distribution.Verbosity import System.Environment (lookupEnv) import System.IO (hClose, hPutStr) import qualified System.Process as Process @@ -102,7 +103,10 @@ manpageCmd pname commands flags where contents :: String contents = manpage pname commands - verbosity = fromFlag $ manpageVerbosity flags + verbosity = + mkVerbosity defaultVerbosityHandles $ + fromFlag $ + manpageVerbosity flags -- | Produces a manual page with @troff@ markup. manpage :: String -> [CommandSpec a] -> String diff --git a/cabal-install/src/Distribution/Client/ManpageFlags.hs b/cabal-install/src/Distribution/Client/ManpageFlags.hs index c45a6d59f07..d7a1e2324a5 100644 --- a/cabal-install/src/Distribution/Client/ManpageFlags.hs +++ b/cabal-install/src/Distribution/Client/ManpageFlags.hs @@ -10,10 +10,10 @@ import Distribution.Client.Compat.Prelude import Distribution.Simple.Command (OptionField (..), ShowOrParseArgs (..), option) import Distribution.Simple.Setup (Flag, optionVerbosity, toFlag, trueArg) -import Distribution.Verbosity (normal) +import Distribution.Verbosity (VerbosityFlags, normal) data ManpageFlags = ManpageFlags - { manpageVerbosity :: Flag Verbosity + { manpageVerbosity :: Flag VerbosityFlags , manpageRaw :: Flag Bool } deriving (Eq, Show, Generic) diff --git a/cabal-install/src/Distribution/Client/NixStyleOptions.hs b/cabal-install/src/Distribution/Client/NixStyleOptions.hs index 5a0b66323f5..6201df0d316 100644 --- a/cabal-install/src/Distribution/Client/NixStyleOptions.hs +++ b/cabal-install/src/Distribution/Client/NixStyleOptions.hs @@ -40,6 +40,7 @@ import Distribution.Client.Setup , liftOptions , testOptions ) +import Distribution.Verbosity (VerbosityFlags, defaultVerbosityHandles, mkVerbosity) data NixStyleFlags a = NixStyleFlags { configFlags :: ConfigFlags @@ -157,5 +158,7 @@ updNixStyleCommonSetupFlags setFlag nixFlags = in flags{benchmarkCommonFlags = setFlag common} } -cfgVerbosity :: Verbosity -> NixStyleFlags a -> Verbosity -cfgVerbosity v flags = fromFlagOrDefault v (setupVerbosity . configCommonFlags $ configFlags flags) +cfgVerbosity :: VerbosityFlags -> NixStyleFlags a -> Verbosity +cfgVerbosity v flags = + mkVerbosity defaultVerbosityHandles $ + fromFlagOrDefault v (setupVerbosity . configCommonFlags $ configFlags flags) diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding.hs b/cabal-install/src/Distribution/Client/ProjectBuilding.hs index 7bf6de869a5..b2f24efc5d6 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding.hs @@ -713,7 +713,7 @@ withTarballLocalDirectory BuildAndInstall -> let tmpdir = distTempDirectory builddir = relativeSymbolicPath $ makeRelativePathEx "dist" - in withTempDirectory verbosity tmpdir "src" $ \unpackdir -> do + in withTempDirectory tmpdir "src" $ \unpackdir -> do let srcdir = makeSymbolicPath $ unpackdir prettyShow pkgid unpackPackageTarball verbosity diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs index 8bf322870b9..e66428ef1c3 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs @@ -115,6 +115,7 @@ import Web.Browser (openBrowser) import Distribution.Client.Errors import Distribution.Client.ProjectBuilding.PackageFileMonitor +import Distribution.Verbosity (setVerbosityHandles) -- | Each unpacked package is processed in the following phases: -- @@ -367,7 +368,7 @@ buildAndRegisterUnpackedPackage setup cmd getCommonFlags flags args = withLogging $ \mLogFileHandle -> do setupWrapper - verbosity + (setVerbosityHandles mLogFileHandle verbosity) scriptOptions { useLoggingHandle = mLogFileHandle , useExtraEnvOverrides = @@ -932,7 +933,7 @@ withTempInstalledPackageInfoFile -> (FilePath -> IO ()) -> IO InstalledPackageInfo withTempInstalledPackageInfoFile verbosity tempdir action = - withTempDirectory verbosity tempdir "package-registration-" $ \dir -> do + withTempDirectory tempdir "package-registration-" $ \dir -> do -- make absolute since @action@ will often change directory abs_dir <- canonicalizePath dir diff --git a/cabal-install/src/Distribution/Client/ProjectConfig.hs b/cabal-install/src/Distribution/Client/ProjectConfig.hs index 56554f7ec15..55266c5bf30 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig.hs @@ -215,8 +215,8 @@ import Distribution.Utils.NubList ( fromNubList ) import Distribution.Verbosity - ( modifyVerbosity - , verbose + ( makeVerbose + , modifyVerbosityFlags ) import Distribution.Version @@ -541,7 +541,7 @@ resolveBuildTimeSettings -- buildSettingLogVerbosity :: Verbosity buildSettingLogVerbosity - | overrideVerbosity = modifyVerbosity (max verbose) verbosity + | overrideVerbosity = modifyVerbosityFlags makeVerbose verbosity | otherwise = verbosity overrideVerbosity :: Bool diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Lens.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Lens.hs index 03e05835cd6..f570b593409 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Lens.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Lens.hs @@ -100,7 +100,7 @@ projectConfigSpecificPackage :: Lens' ProjectConfig (MapMappend PackageName Pack projectConfigSpecificPackage f s = fmap (\x -> s{T.projectConfigSpecificPackage = x}) (f (T.projectConfigSpecificPackage s)) {-# INLINEABLE projectConfigSpecificPackage #-} -projectConfigVerbosity :: Lens' ProjectConfigBuildOnly (Flag Verbosity) +projectConfigVerbosity :: Lens' ProjectConfigBuildOnly (Flag VerbosityFlags) projectConfigVerbosity f s = fmap (\x -> s{T.projectConfigVerbosity = x}) (f (T.projectConfigVerbosity s)) {-# INLINEABLE projectConfigVerbosity #-} diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs index 14069f57a0b..8e9e62c780a 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs @@ -100,6 +100,7 @@ import Distribution.Version import qualified Data.Map as Map import Distribution.Solver.Types.ProjectConfigPath (ProjectConfigPath) import Distribution.Types.ParStrat +import Distribution.Verbosity (VerbosityFlags) ------------------------------- -- Project config types @@ -161,7 +162,7 @@ data ProjectConfig = ProjectConfig -- does not need to be tracked for changes since it does not affect the -- outcome. data ProjectConfigBuildOnly = ProjectConfigBuildOnly - { projectConfigVerbosity :: Flag Verbosity + { projectConfigVerbosity :: Flag VerbosityFlags , projectConfigDryRun :: Flag Bool , projectConfigOnlyDeps :: Flag Bool , projectConfigOnlyDownload :: Flag Bool diff --git a/cabal-install/src/Distribution/Client/ProjectOrchestration.hs b/cabal-install/src/Distribution/Client/ProjectOrchestration.hs index 942e18232cf..bcf472e5117 100644 --- a/cabal-install/src/Distribution/Client/ProjectOrchestration.hs +++ b/cabal-install/src/Distribution/Client/ProjectOrchestration.hs @@ -1117,11 +1117,11 @@ printPlan pkgs = InstallPlan.executionOrder elaboratedPlan ifVerbose s - | verbosity >= verbose = s + | verbosityLevel verbosity >= Verbose = s | otherwise = "" ifNormal s - | verbosity >= verbose = "" + | verbosityLevel verbosity >= Verbose = "" | otherwise = s wouldWill @@ -1133,7 +1133,7 @@ printPlan unwords $ filter (not . null) $ [ " -" - , if verbosity >= deafening + , if verbosityLevel verbosity >= Deafening then prettyShow (installedUnitId elab) else prettyShow (packageId elab) , case elabBuildStyle elab of @@ -1345,14 +1345,14 @@ dieOnBuildFailures verbosity currentCommand plan buildOutcomes unlines [ case failureClassification of ShowBuildSummaryAndLog reason _ - | verbosity > normal -> + | verbosityLevel verbosity > Normal -> renderFailureDetail mentionDepOf pkg reason | otherwise -> renderFailureSummary mentionDepOf pkg reason ++ ". See the build log above for details." ShowBuildSummaryOnly reason -> renderFailureDetail mentionDepOf pkg reason - | let mentionDepOf = verbosity <= normal + | let mentionDepOf = verbosityLevel verbosity <= Normal , (pkg, failureClassification) <- failuresClassification ] where @@ -1367,7 +1367,7 @@ dieOnBuildFailures verbosity currentCommand plan buildOutcomes [ (pkg, classifyBuildFailure failure) | (pkgid, failure) <- failures , case buildFailureReason failure of - DependentFailed{} -> verbosity > normal + DependentFailed{} -> verbosityLevel verbosity > Normal _ -> True , InstallPlan.Configured pkg <- maybeToList (InstallPlan.lookup plan pkgid) diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index 685e46dfa77..462661271f9 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -465,7 +465,7 @@ rebuildProjectConfig | cwd == distProjectRootDirectory = info | otherwise = notice unless (null configFiles) - . out (verboseStderr verbosity) + . out (modifyVerbosityFlags verboseStderr verbosity) . render $ message where @@ -487,7 +487,7 @@ rebuildProjectConfig where configFilesDoc = map (quoteUntrimmed . projectConfigPathRoot) configFiles configFilesVertList -- if verbose, include provenance ("imported by" stuff) - | verbosity < verbose = docProjectConfigFiles configFiles + | verbosityLevel verbosity < Verbose = docProjectConfigFiles configFiles | otherwise = vcat $ map (\p -> text "- " <> docProjectConfigPath p) configFiles affectedByMsg = text "Configuration is affected by " atProjectRootMsg = text "at '" <> text distProjectRootDirectory <> text "'." @@ -496,7 +496,7 @@ rebuildProjectConfig [ path | Explicit path <- Set.toList - . (if verbosity >= verbose then id else onlyTopLevelProvenance) + . (if verbosityLevel verbosity >= Verbose then id else onlyTopLevelProvenance) $ projectConfigProvenance projectConfig ] @@ -1352,7 +1352,7 @@ planPackages . setStrongFlags solverSettingStrongFlags . setAllowBootLibInstalls solverSettingAllowBootLibInstalls . setOnlyConstrained solverSettingOnlyConstrained - . setSolverVerbosity verbosity + . setSolverVerbosity (verbosityLevel verbosity) -- TODO: [required eventually] decide if we need to prefer -- installed for global packages, or prefer latest even for -- global packages. Perhaps should be configurable but with a @@ -4214,7 +4214,7 @@ setupHsCommonFlags setupHsCommonFlags verbosity mbWorkDir builddir keepTempFiles = Cabal.CommonSetupFlags { setupDistPref = toFlag builddir - , setupVerbosity = toFlag verbosity + , setupVerbosity = toFlag $ verbosityFlags verbosity , setupCabalFilePath = mempty , setupWorkingDir = maybeToFlag mbWorkDir , setupTargets = [] diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs index 6aa1065d20e..654f316eac6 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs @@ -116,13 +116,13 @@ import qualified Distribution.Types.LocalBuildConfig as LBC import Distribution.Types.PackageDescription (PackageDescription (..)) import Distribution.Types.PkgconfigVersion import Distribution.Utils.Path (getSymbolicPath) -import Distribution.Verbosity (normal) import Distribution.Version import qualified Data.ByteString.Lazy as LBS import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map import qualified Data.Monoid as Mon +import Distribution.Verbosity import System.FilePath (()) import Text.PrettyPrint (hsep, parens, text) @@ -145,7 +145,7 @@ type ElaboratedPlanPackage = -- | User-friendly display string for an 'ElaboratedPlanPackage'. elabPlanPackageName :: Verbosity -> ElaboratedPlanPackage -> String elabPlanPackageName verbosity (PreExisting ipkg) - | verbosity <= normal = prettyShow (packageName ipkg) + | verbosityLevel verbosity <= Normal = prettyShow (packageName ipkg) | otherwise = prettyShow (installedUnitId ipkg) elabPlanPackageName verbosity (Configured elab) = elabConfiguredName verbosity elab @@ -518,7 +518,7 @@ elabComponentName elab = -- | A user-friendly descriptor for an 'ElaboratedConfiguredPackage'. elabConfiguredName :: Verbosity -> ElaboratedConfiguredPackage -> String elabConfiguredName verbosity elab - | verbosity <= normal = + | verbosityLevel verbosity <= Normal = ( case elabPkgOrComp elab of ElabPackage _ -> "" ElabComponent comp -> diff --git a/cabal-install/src/Distribution/Client/Reconfigure.hs b/cabal-install/src/Distribution/Client/Reconfigure.hs index 7dd5fa8524a..899020ff25f 100644 --- a/cabal-install/src/Distribution/Client/Reconfigure.hs +++ b/cabal-install/src/Distribution/Client/Reconfigure.hs @@ -15,6 +15,7 @@ import Distribution.Simple.Utils , info ) import Distribution.Utils.Path +import Distribution.Verbosity import Distribution.Client.Config (SavedConfig (..)) import Distribution.Client.Configure (readConfigFlags) @@ -133,7 +134,7 @@ reconfigure configFlags' = configFlags { configCommonFlags = - common{setupVerbosity = toFlag verbosity} + common{setupVerbosity = toFlag $ verbosityFlags verbosity} } return (mempty, (configFlags', configExFlags)) diff --git a/cabal-install/src/Distribution/Client/SavedFlags.hs b/cabal-install/src/Distribution/Client/SavedFlags.hs index 1f752e11bd4..16e8e99460c 100644 --- a/cabal-install/src/Distribution/Client/SavedFlags.hs +++ b/cabal-install/src/Distribution/Client/SavedFlags.hs @@ -22,7 +22,7 @@ import System.FilePath (takeDirectory) writeSavedArgs :: Verbosity -> FilePath -> [String] -> IO () writeSavedArgs verbosity path args = do createDirectoryIfMissingVerbose - (lessVerbose verbosity) + (modifyVerbosityFlags lessVerbose verbosity) True (takeDirectory path) writeFile path (intercalate "\0" args) diff --git a/cabal-install/src/Distribution/Client/Setup.hs b/cabal-install/src/Distribution/Client/Setup.hs index 148633d20a4..67dc3e7fa2f 100644 --- a/cabal-install/src/Distribution/Client/Setup.hs +++ b/cabal-install/src/Distribution/Client/Setup.hs @@ -227,7 +227,9 @@ import Distribution.Types.UnqualComponentName ( unqualComponentNameToPackageName ) import Distribution.Verbosity - ( lessVerbose + ( VerbosityFlags + , defaultVerbosityHandles + , lessVerbose , normal , verboseNoFlags , verboseNoTimestamp @@ -871,6 +873,7 @@ configCompilerAux' :: ConfigFlags -> IO (Compiler, Platform, ProgramDb) configCompilerAux' configFlags = do let commonFlags = configCommonFlags configFlags configCompilerAuxEx + defaultVerbosityHandles configFlags { -- FIXME: make configCompilerAux use a sensible verbosity configCommonFlags = @@ -1391,7 +1394,7 @@ data FetchFlags = FetchFlags , fetchOnlyConstrained :: Flag OnlyConstrained , fetchTests :: Flag Bool , fetchBenchmarks :: Flag Bool - , fetchVerbosity :: Flag Verbosity + , fetchVerbosity :: Flag VerbosityFlags } defaultFetchFlags :: FetchFlags @@ -1524,7 +1527,7 @@ data FreezeFlags = FreezeFlags , freezeStrongFlags :: Flag StrongFlags , freezeAllowBootLibInstalls :: Flag AllowBootLibInstalls , freezeOnlyConstrained :: Flag OnlyConstrained - , freezeVerbosity :: Flag Verbosity + , freezeVerbosity :: Flag VerbosityFlags } defaultFreezeFlags :: FreezeFlags @@ -1654,7 +1657,7 @@ genBoundsCommand = -- ------------------------------------------------------------ data CheckFlags = CheckFlags - { checkVerbosity :: Flag Verbosity + { checkVerbosity :: Flag VerbosityFlags , checkIgnore :: [CheckExplanationIDString] } deriving (Show) @@ -1706,7 +1709,7 @@ checkOptions' _showOrParseArgs = -- ------------------------------------------------------------ data UpdateFlags = UpdateFlags - { updateVerbosity :: Flag Verbosity + { updateVerbosity :: Flag VerbosityFlags , updateIndexState :: Flag TotalIndexState } deriving (Generic) @@ -1731,7 +1734,7 @@ cleanCommand = "Usage: " ++ pname ++ " v1-clean [FLAGS]\n" } -formatCommand :: CommandUI (Flag Verbosity) +formatCommand :: CommandUI (Flag VerbosityFlags) formatCommand = CommandUI { commandName = "format" @@ -1801,7 +1804,7 @@ data ReportFlags = ReportFlags { reportToken :: Flag Token , reportUsername :: Flag Username , reportPassword :: Flag Password - , reportVerbosity :: Flag Verbosity + , reportVerbosity :: Flag VerbosityFlags } deriving (Generic) @@ -1883,7 +1886,7 @@ data GetFlags = GetFlags , getIndexState :: Flag TotalIndexState , getActiveRepos :: Flag ActiveRepos , getSourceRepository :: Flag (Maybe RepoKind) - , getVerbosity :: Flag Verbosity + , getVerbosity :: Flag VerbosityFlags } deriving (Generic) @@ -2037,7 +2040,7 @@ data ListFlags = ListFlags { listInstalled :: Flag Bool , listSimpleOutput :: Flag Bool , listCaseInsensitive :: Flag Bool - , listVerbosity :: Flag Verbosity + , listVerbosity :: Flag VerbosityFlags , listPackageDBs :: [Maybe PackageDB] , listHcPath :: Flag FilePath } @@ -2147,7 +2150,7 @@ instance Semigroup ListFlags where -- ------------------------------------------------------------ data InfoFlags = InfoFlags - { infoVerbosity :: Flag Verbosity + { infoVerbosity :: Flag VerbosityFlags , infoPackageDBs :: [Maybe PackageDB] } deriving (Generic) @@ -2854,7 +2857,7 @@ data UploadFlags = UploadFlags , uploadUsername :: Flag Username , uploadPassword :: Flag Password , uploadPasswordCmd :: Flag [String] - , uploadVerbosity :: Flag Verbosity + , uploadVerbosity :: Flag VerbosityFlags } deriving (Generic) @@ -3451,7 +3454,7 @@ instance Semigroup ActAsSetupFlags where -- ------------------------------------------------------------ data UserConfigFlags = UserConfigFlags - { userConfigVerbosity :: Flag Verbosity + { userConfigVerbosity :: Flag VerbosityFlags , userConfigForce :: Flag Bool , userConfigAppendLines :: Flag [String] } diff --git a/cabal-install/src/Distribution/Client/SetupWrapper.hs b/cabal-install/src/Distribution/Client/SetupWrapper.hs index e1f1c8d2008..810ebccda05 100644 --- a/cabal-install/src/Distribution/Client/SetupWrapper.hs +++ b/cabal-install/src/Distribution/Client/SetupWrapper.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {- FOURMOLU_DISABLE -} @@ -422,10 +423,9 @@ getSetupMethod verbosity options pkg buildType' || maybe False (cabalVersion /=) (useCabalSpecVersion options) || not (cabalVersion `withinRange` useCabalVersion options) = getExternalSetupMethod verbosity options pkg buildType' - | isJust (useLoggingHandle options) - -- Forcing is done to use an external process e.g. due to parallel - -- build concerns. - || forceExternalSetupMethod options = + | -- Forcing is done to use an external process e.g. due to parallel + -- build concerns. + forceExternalSetupMethod options = return (cabalVersion, SelfExecMethod, options) | otherwise = return (cabalVersion, InternalMethod, options) @@ -446,8 +446,8 @@ runSetup verbosity setup args0 = do options = setupScriptOptions setup bt = setupBuildType setup args = verbosityHack (setupVersion setup) args0 - when (verbosity >= deafening {- avoid test if not debug -} && args /= args0) $ - infoNoWrap verbose $ + when (verbosityLevel verbosity >= Deafening {- avoid test if not debug -} && args /= args0) $ + infoNoWrap (verbosity { verbosityFlags = verbose }) $ "Applied verbosity hack:\n" ++ " Before: " ++ show args0 @@ -562,16 +562,20 @@ internalSetupMethod verbosity options bt args = do withEnv "HASKELL_DIST_DIR" (getSymbolicPath $ useDistPref options) $ withExtraPathEnv (useExtraPathEnv options) $ withEnvOverrides (useExtraEnvOverrides options) $ - buildTypeAction bt args - -buildTypeAction :: BuildType -> ([String] -> IO ()) -buildTypeAction Simple = Simple.defaultMainArgs -buildTypeAction Configure = - Simple.defaultMainWithSetupHooksArgs - Simple.autoconfSetupHooks -buildTypeAction Make = Make.defaultMainArgs -buildTypeAction Hooks = error "buildTypeAction Hooks" -buildTypeAction Custom = error "buildTypeAction Custom" + buildTypeAction (verbosityHandles verbosity) bt args + +buildTypeAction :: VerbosityHandles -> BuildType -> ([String] -> IO ()) +buildTypeAction verbHandles = \ case + Simple -> + Simple.defaultMainArgsWithHandles verbHandles + Configure -> + Simple.defaultMainWithSetupHooksArgs Simple.autoconfSetupHooks verbHandles + Make -> + Make.defaultMainArgsWithHandles verbHandles + Hooks -> + error "buildTypeAction Hooks" + Custom -> + error "buildTypeAction Custom" invoke :: Verbosity -> FilePath -> [String] -> SetupScriptOptions -> IO () invoke verbosity path args options = do @@ -652,7 +656,7 @@ externalSetupMethod path verbosity options _ args = invokeWithWin32CleanHack origPath = do info verbosity $ "Using the Win32 clean hack." -- Recursively removes the temp dir on exit. - withTempDirectory verbosity (workingDir options) "cabal-tmp" $ \tmpDir -> + withTempDirectory (workingDir options) "cabal-tmp" $ \tmpDir -> bracket (moveOutOfTheWay tmpDir origPath) (\tmpPath -> maybeRestore origPath tmpPath) @@ -1117,7 +1121,7 @@ getExternalSetupMethod verbosity options pkg bt = do { -- Respect -v0, but don't crank up verbosity on GHC if -- Cabal verbosity is requested. For that, use -- --ghc-option=-v instead! - ghcOptVerbosity = Flag (min verbosity normal) + ghcOptVerbosity = Flag (min (verbosityLevel verbosity) Normal) , ghcOptMode = Flag GhcModeMake , ghcOptInputFiles = toNubListR [setupHs] , ghcOptOutputFile = Flag $ setupProgFile diff --git a/cabal-install/src/Distribution/Client/SourceFiles.hs b/cabal-install/src/Distribution/Client/SourceFiles.hs index 1166f333f3c..c00e5fc4419 100644 --- a/cabal-install/src/Distribution/Client/SourceFiles.hs +++ b/cabal-install/src/Distribution/Client/SourceFiles.hs @@ -38,7 +38,7 @@ import Distribution.Utils.Path import Distribution.ModuleName import Distribution.Client.Compat.Prelude -import Distribution.Verbosity (normal) +import Distribution.Verbosity (defaultVerbosityHandles, mkVerbosity, normal) import Prelude () import System.FilePath @@ -173,7 +173,12 @@ needBuildInfo pkg_descr bi modules = do expandedExtraSrcFiles <- liftIO $ fmap concat . for (extraSrcFiles pkg_descr) $ \fpath -> - matchDirFileGlobWithDie normal (\_ _ -> return []) (specVersion pkg_descr) (Just $ makeSymbolicPath root) fpath + matchDirFileGlobWithDie + (mkVerbosity defaultVerbosityHandles normal) + (\_ _ -> return []) + (specVersion pkg_descr) + (Just $ makeSymbolicPath root) + fpath traverse_ needIfExists $ concat [ map getSymbolicPath $ cSources bi diff --git a/cabal-install/src/Distribution/Client/Store.hs b/cabal-install/src/Distribution/Client/Store.hs index dcf4c78d02c..61db0c3bbb3 100644 --- a/cabal-install/src/Distribution/Client/Store.hs +++ b/cabal-install/src/Distribution/Client/Store.hs @@ -34,9 +34,6 @@ import Distribution.Simple.Utils , info , withTempDirectory ) -import Distribution.Verbosity - ( silent - ) import Control.Exception import qualified Data.Set as Set @@ -233,7 +230,7 @@ withTempIncomingDir -> IO a withTempIncomingDir StoreDirLayout{storeIncomingDirectory} compiler action = do createDirectoryIfMissing True incomingDir - withTempDirectory silent incomingDir "new" action + withTempDirectory incomingDir "new" action where incomingDir = storeIncomingDirectory compiler diff --git a/cabal-install/src/Distribution/Client/VCS.hs b/cabal-install/src/Distribution/Client/VCS.hs index 977b366ceb1..0e4c210858d 100644 --- a/cabal-install/src/Distribution/Client/VCS.hs +++ b/cabal-install/src/Distribution/Client/VCS.hs @@ -73,7 +73,8 @@ import Distribution.Types.SourceRepo , RepoType (..) ) import Distribution.Verbosity as Verbosity - ( normal + ( VerbosityLevel (..) + , verbosityLevel ) import Distribution.Version ( mkVersion @@ -331,7 +332,7 @@ vcsBzr = Nothing -> [] Just tag -> ["-r", "tag:" ++ tag] verboseArg :: [String] - verboseArg = ["--quiet" | verbosity < Verbosity.normal] + verboseArg = ["--quiet" | verbosityLevel verbosity < Verbosity.Normal] vcsSyncRepos :: Verbosity @@ -384,7 +385,7 @@ vcsDarcs = Nothing -> [] Just tag -> ["-t", tag] verboseArg :: [String] - verboseArg = ["--quiet" | verbosity < Verbosity.normal] + verboseArg = ["--quiet" | verbosityLevel verbosity < Verbosity.Normal] vcsSyncRepos :: Verbosity @@ -436,7 +437,7 @@ vcsDarcs = Nothing -> [] Just tag -> ["-t" ++ tag] verboseArg :: [String] - verboseArg = ["--quiet" | verbosity < Verbosity.normal] + verboseArg = ["--quiet" | verbosityLevel verbosity < Verbosity.Normal] darcsProgram :: Program darcsProgram = @@ -489,7 +490,7 @@ vcsGit = Just b -> ["--branch", b] Nothing -> [] resetArgs tag = "reset" : verboseArg ++ ["--hard", tag, "--"] - verboseArg = ["--quiet" | verbosity < Verbosity.normal] + verboseArg = ["--quiet" | verbosityLevel verbosity < Verbosity.Normal] -- Note: No --depth=1 for vcsCloneRepo since that is used for `cabal get -s`, -- whereas `vcsSyncRepo` is used for source-repository-package where we do want shallow clones. @@ -617,7 +618,7 @@ vcsGit = where loc = srpLocation - verboseArg = ["--quiet" | verbosity < Verbosity.normal] + verboseArg = ["--quiet" | verbosityLevel verbosity < Verbosity.Normal] gitProgram :: Program gitProgram = @@ -671,7 +672,7 @@ vcsHg = tagArgs = case srpTag repo of Just t -> ["--rev", t] Nothing -> [] - verboseArg = ["--quiet" | verbosity < Verbosity.normal] + verboseArg = ["--quiet" | verbosityLevel verbosity < Verbosity.Normal] vcsSyncRepos :: Verbosity @@ -708,7 +709,7 @@ vcsHg = cloneArgs = ["clone", "--noupdate", (srpLocation repo), localDir] ++ verboseArg - verboseArg = ["--quiet" | verbosity < Verbosity.normal] + verboseArg = ["--quiet" | verbosityLevel verbosity < Verbosity.Normal] checkoutArgs = ["checkout", "--clean"] ++ tagArgs @@ -747,7 +748,7 @@ vcsSvn = [programInvocation prog checkoutArgs] where checkoutArgs = ["checkout", srcuri, destdir] ++ verboseArg - verboseArg = ["--quiet" | verbosity < Verbosity.normal] + verboseArg = ["--quiet" | verbosityLevel verbosity < Verbosity.Normal] -- TODO: branch or tag? vcsSyncRepos diff --git a/cabal-install/src/Distribution/Client/Win32SelfUpgrade.hs b/cabal-install/src/Distribution/Client/Win32SelfUpgrade.hs index c029ce4149b..4a5f839934f 100644 --- a/cabal-install/src/Distribution/Client/Win32SelfUpgrade.hs +++ b/cabal-install/src/Distribution/Client/Win32SelfUpgrade.hs @@ -54,7 +54,7 @@ import System.Process (runProcess) import System.Directory (canonicalizePath) import System.FilePath (takeBaseName, replaceBaseName, equalFilePath) -import Distribution.Verbosity as Verbosity (showForCabal) +import Distribution.Verbosity as Verbosity (showForCabal, verbosityFlags) import Distribution.Simple.Utils (debug, info) @@ -81,7 +81,7 @@ possibleSelfUpgrade verbosity newPaths action = do result <- action scheduleOurDemise verbosity dstPath tmpPath (\pid path -> ["win32selfupgrade", pid, path - ,"--verbose=" ++ Verbosity.showForCabal verbosity]) + ,"--verbose=" ++ Verbosity.showForCabal (verbosityFlags verbosity)]) return result -- | The name of a Win32 Event object that we use to synchronise between the diff --git a/cabal-install/tests/IntegrationTests2.hs b/cabal-install/tests/IntegrationTests2.hs index 391cad4d0f7..7a670f97171 100644 --- a/cabal-install/tests/IntegrationTests2.hs +++ b/cabal-install/tests/IntegrationTests2.hs @@ -96,6 +96,7 @@ import System.IO.Silently import qualified Data.ByteString as BS import Distribution.Simple.Flag (pattern Flag) import Distribution.Types.ParStrat +import Distribution.Verbosity main :: IO () main = do @@ -2171,18 +2172,18 @@ configureProject testdir cliConfig = do -- ended in an exception (as we leave the files to help with debugging). cleanProject testdir - httpTransport <- configureTransport verbosity [] Nothing + httpTransport <- configureTransport testVerbosity [] Nothing (projectConfig, localPackages) <- rebuildProjectConfig - verbosity + testVerbosity httpTransport distDirLayout cliConfig let buildSettings = resolveBuildTimeSettings - verbosity + testVerbosity cabalDirLayout projectConfig @@ -2212,7 +2213,7 @@ planProject testdir cliConfig = do (elaboratedPlan, _, elaboratedShared, _, _) <- rebuildInstallPlan - verbosity + testVerbosity distDirLayout cabalDirLayout projectConfig @@ -2260,7 +2261,7 @@ executePlan buildOutcomes <- rebuildTargets - verbosity + testVerbosity config distDirLayout (cabalStoreDirLayout cabalDirLayout) @@ -2281,8 +2282,8 @@ cleanProject testdir = do distDirLayout = defaultDistDirLayout projectRoot Nothing Nothing distDir = distDirectory distDirLayout -verbosity :: Verbosity -verbosity = minBound -- normal --verbose --maxBound --minBound +testVerbosity :: Verbosity +testVerbosity = mkVerbosity defaultVerbosityHandles silent ------------------------------------------- -- Tasty integration to adjust the config @@ -2495,7 +2496,7 @@ testConfigOptionComments = do cwd <- getCurrentDirectory let configFile = cwd basedir "config" "default-config" - _ <- createDefaultConfigFile verbosity [] configFile + _ <- createDefaultConfigFile testVerbosity [] configFile defaultConfigFile <- readFile configFile let @@ -2772,7 +2773,7 @@ testHaddockProjectDependencies config = do defaultHaddockProjectFlags { haddockProjectCommonFlags = defaultCommonSetupFlags - { setupVerbosity = Flag verbosity + { setupVerbosity = Flag $ verbosityFlags testVerbosity } } ["all"] diff --git a/cabal-install/tests/LongTests.hs b/cabal-install/tests/LongTests.hs index 0c315046780..a539df85dec 100644 --- a/cabal-install/tests/LongTests.hs +++ b/cabal-install/tests/LongTests.hs @@ -17,7 +17,7 @@ main = do (mtimeChange, mtimeChange') <- calibrateMtimeChangeDelay let toMillis :: Int -> Double toMillis x = fromIntegral x / 1000.0 - notice normal $ + notice (mkVerbosity defaultVerbosityHandles normal) $ "File modification time resolution calibration completed, " ++ "maximum delay observed: " ++ (show . toMillis $ mtimeChange) diff --git a/cabal-install/tests/UnitTests/Distribution/Client/FetchUtils.hs b/cabal-install/tests/UnitTests/Distribution/Client/FetchUtils.hs index c14682c2bcb..a83a608a1d1 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/FetchUtils.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/FetchUtils.hs @@ -38,7 +38,7 @@ tests = ] verbosity :: Verbosity.Verbosity -verbosity = Verbosity.silent +verbosity = Verbosity.mkVerbosity Verbosity.defaultVerbosityHandles Verbosity.silent -- | An interval that we use to assert that something happens "immediately". -- Must be shorter than 'longSleep' to ensure those are interrupted. diff --git a/cabal-install/tests/UnitTests/Distribution/Client/FileMonitor.hs b/cabal-install/tests/UnitTests/Distribution/Client/FileMonitor.hs index d14f87d06da..7c8be795725 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/FileMonitor.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/FileMonitor.hs @@ -15,7 +15,6 @@ import qualified Prelude as IO (writeFile) import Distribution.Compat.Binary import Distribution.Simple.Utils (withTempDirectory) import Distribution.System (OS (Windows), buildOS) -import Distribution.Verbosity (silent) import Distribution.Client.FileMonitor import Distribution.Compat.Time @@ -96,7 +95,7 @@ tests mtimeChange = -- we rely on file mtimes having a reasonable resolution testFileMTimeSanity :: Int -> Assertion testFileMTimeSanity mtimeChange = - withTempDirectory silent "." "file-status-" $ \dir -> do + withTempDirectory "." "file-status-" $ \dir -> do replicateM_ 10 $ do IO.writeFile (dir "a") "content" t1 <- getModTime (dir "a") @@ -108,7 +107,7 @@ testFileMTimeSanity mtimeChange = -- We rely on directories changing mtime when entries are added or removed testDirChangeSanity :: Int -> Assertion testDirChangeSanity mtimeChange = - withTempDirectory silent "." "dir-mtime-" $ \dir -> do + withTempDirectory "." "dir-mtime-" $ \dir -> do expectMTimeChange dir "file add" $ IO.writeFile (dir "file") "content" @@ -902,7 +901,7 @@ updateMonitorWithTimestamp (RootPath root) monitor timestamp files key result = withFileMonitor :: Eq a => (RootPath -> FileMonitor a b -> IO c) -> IO c withFileMonitor action = do - withTempDirectory silent "." "file-status-" $ \root -> do + withTempDirectory "." "file-status-" $ \root -> do let file = root <.> "monitor" monitor = newFileMonitor file finally (action (RootPath root) monitor) $ do diff --git a/cabal-install/tests/UnitTests/Distribution/Client/Get.hs b/cabal-install/tests/UnitTests/Distribution/Client/Get.hs index 2788a21ac00..2e614ce6d80 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/Get.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/Get.hs @@ -49,7 +49,7 @@ tests = includeTestsIf False _ = [] verbosity :: Verbosity -verbosity = Verbosity.silent -- for debugging try verbose +verbosity = Verbosity.mkVerbosity Verbosity.defaultVerbosityHandles Verbosity.silent -- for debugging try verbose pkgidfoo :: PackageId pkgidfoo = PackageIdentifier (mkPackageName "foo") (mkVersion [1, 0]) diff --git a/cabal-install/tests/UnitTests/Distribution/Client/Init.hs b/cabal-install/tests/UnitTests/Distribution/Client/Init.hs index ce33e9ab302..79bd67ea7d1 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/Init.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/Init.hs @@ -45,7 +45,7 @@ tests = do ] where v :: Verbosity - v = normal + v = mkVerbosity defaultVerbosityHandles normal compFlags :: ConfigFlags compFlags = mempty{configHcPath = initHcPath emptyFlags} diff --git a/cabal-install/tests/UnitTests/Distribution/Client/Init/FileCreators.hs b/cabal-install/tests/UnitTests/Distribution/Client/Init/FileCreators.hs index 9a92735b988..da2c1e8d487 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/Init/FileCreators.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/Init/FileCreators.hs @@ -82,7 +82,7 @@ tests _v _initFlags comp pkgIx srcDb = ] case flip runPrompt inputs $ do - projSettings <- createProject comp silent pkgIx srcDb dummyFlags' + projSettings <- createProject comp (mkVerbosity defaultVerbosityHandles silent) pkgIx srcDb dummyFlags' writeProject projSettings of Left (BreakException ex) -> assertFailure $ show ex Right _ -> return () diff --git a/cabal-install/tests/UnitTests/Distribution/Client/Init/Golden.hs b/cabal-install/tests/UnitTests/Distribution/Client/Init/Golden.hs index 674f2f9be02..a59d5e62b63 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/Init/Golden.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/Init/Golden.hs @@ -84,22 +84,22 @@ goldenPkgDescTests v srcDb pkgDir pkgName = [ goldenVsString "Empty flags, non-simple, no comments" (goldenPkgDesc "pkg.golden") - $ let opts = WriteOpts False False False v pkgDir Library pkgName defaultCabalVersion + $ let opts = WriteOpts False False False (verbosityFlags v) pkgDir Library pkgName defaultCabalVersion in runPkgDesc opts emptyFlags pkgArgs , goldenVsString "Empty flags, non-simple, with comments" (goldenPkgDesc "pkg-with-comments.golden") - $ let opts = WriteOpts False False False v pkgDir Library pkgName defaultCabalVersion + $ let opts = WriteOpts False False False (verbosityFlags v) pkgDir Library pkgName defaultCabalVersion in runPkgDesc opts emptyFlags pkgArgs , goldenVsString "Dummy flags, >= cabal version syntax, with comments" (goldenPkgDesc "pkg-with-flags.golden") - $ let opts = WriteOpts False False False v pkgDir Library pkgName defaultCabalVersion + $ let opts = WriteOpts False False False (verbosityFlags v) pkgDir Library pkgName defaultCabalVersion in runPkgDesc opts (dummyFlags{cabalVersion = Flag CabalSpecV1_0}) pkgArgs , goldenVsString "Dummy flags, old cabal version, with comments" (goldenPkgDesc "pkg-old-cabal-with-flags.golden") - $ let opts = WriteOpts False False False v pkgDir Library pkgName defaultCabalVersion + $ let opts = WriteOpts False False False (verbosityFlags v) pkgDir Library pkgName defaultCabalVersion in runPkgDesc opts (dummyFlags{cabalVersion = Flag CabalSpecV2_0}) pkgArgs ] where @@ -120,27 +120,27 @@ goldenExeTests v pkgIx pkgDir pkgName = [ goldenVsString "Empty flags, not simple, no options, no comments" (goldenExe "exe-no-comments.golden") - $ let opts = WriteOpts False False True v pkgDir Executable pkgName defaultCabalVersion + $ let opts = WriteOpts False False True (verbosityFlags v) pkgDir Executable pkgName defaultCabalVersion in runGoldenExe opts exeArgs emptyFlags , goldenVsString "Empty flags, not simple, with comments + no minimal" (goldenExe "exe-with-comments.golden") - $ let opts = WriteOpts False False False v pkgDir Executable pkgName defaultCabalVersion + $ let opts = WriteOpts False False False (verbosityFlags v) pkgDir Executable pkgName defaultCabalVersion in runGoldenExe opts exeArgs emptyFlags , goldenVsString "Empty flags, not simple, with minimal + no comments" (goldenExe "exe-minimal-no-comments.golden") - $ let opts = WriteOpts False True True v pkgDir Executable pkgName defaultCabalVersion + $ let opts = WriteOpts False True True (verbosityFlags v) pkgDir Executable pkgName defaultCabalVersion in runGoldenExe opts exeArgs emptyFlags , goldenVsString "Empty flags, not simple, with minimal + comments" (goldenExe "exe-simple-minimal-with-comments.golden") - $ let opts = WriteOpts False True False v pkgDir Executable pkgName defaultCabalVersion + $ let opts = WriteOpts False True False (verbosityFlags v) pkgDir Executable pkgName defaultCabalVersion in runGoldenExe opts exeArgs emptyFlags , goldenVsString "Build tools flag, not simple, with comments + no minimal" (goldenExe "exe-build-tools-with-comments.golden") - $ let opts = WriteOpts False False False v pkgDir Executable pkgName defaultCabalVersion + $ let opts = WriteOpts False False False (verbosityFlags v) pkgDir Executable pkgName defaultCabalVersion in runGoldenExe opts exeArgs (emptyFlags{buildTools = Flag ["happy"]}) ] where @@ -161,32 +161,32 @@ goldenLibTests v pkgIx pkgDir pkgName = [ goldenVsString "Empty flags, not simple, no options, no comments" (goldenLib "lib-no-comments.golden") - $ let opts = WriteOpts False False True v pkgDir Library pkgName defaultCabalVersion + $ let opts = WriteOpts False False True (verbosityFlags v) pkgDir Library pkgName defaultCabalVersion in runGoldenLib opts libArgs emptyFlags , goldenVsString "Empty flags, simple, no options, no comments" (goldenLib "lib-simple-no-comments.golden") - $ let opts = WriteOpts False False True v pkgDir Library pkgName defaultCabalVersion + $ let opts = WriteOpts False False True (verbosityFlags v) pkgDir Library pkgName defaultCabalVersion in runGoldenLib opts libArgs emptyFlags , goldenVsString "Empty flags, not simple, with comments + no minimal" (goldenLib "lib-with-comments.golden") - $ let opts = WriteOpts False False False v pkgDir Library pkgName defaultCabalVersion + $ let opts = WriteOpts False False False (verbosityFlags v) pkgDir Library pkgName defaultCabalVersion in runGoldenLib opts libArgs emptyFlags , goldenVsString "Empty flags, not simple, with minimal + no comments" (goldenLib "lib-minimal-no-comments.golden") - $ let opts = WriteOpts False True True v pkgDir Library pkgName defaultCabalVersion + $ let opts = WriteOpts False True True (verbosityFlags v) pkgDir Library pkgName defaultCabalVersion in runGoldenLib opts libArgs emptyFlags , goldenVsString "Empty flags, not simple, with minimal + comments" (goldenLib "lib-simple-minimal-with-comments.golden") - $ let opts = WriteOpts False True False v pkgDir Library pkgName defaultCabalVersion + $ let opts = WriteOpts False True False (verbosityFlags v) pkgDir Library pkgName defaultCabalVersion in runGoldenLib opts libArgs emptyFlags , goldenVsString "Build tools flag, not simple, with comments + no minimal" (goldenLib "lib-build-tools-with-comments.golden") - $ let opts = WriteOpts False False False v pkgDir Library pkgName defaultCabalVersion + $ let opts = WriteOpts False False False (verbosityFlags v) pkgDir Library pkgName defaultCabalVersion in runGoldenLib opts libArgs (emptyFlags{buildTools = Flag ["happy"]}) ] where @@ -207,37 +207,37 @@ goldenTestTests v pkgIx pkgDir pkgName = [ goldenVsString "Empty flags, not simple, no options, no comments" (goldenTest "test-no-comments.golden") - $ let opts = WriteOpts False False True v pkgDir Library pkgName defaultCabalVersion + $ let opts = WriteOpts False False True (verbosityFlags v) pkgDir Library pkgName defaultCabalVersion in runGoldenTest opts testArgs emptyFlags , goldenVsString "Empty flags, not simple, with comments + no minimal" (goldenTest "test-with-comments.golden") - $ let opts = WriteOpts False False False v pkgDir Library pkgName defaultCabalVersion + $ let opts = WriteOpts False False False (verbosityFlags v) pkgDir Library pkgName defaultCabalVersion in runGoldenTest opts testArgs emptyFlags , goldenVsString "Empty flags, not simple, with minimal + no comments" (goldenTest "test-minimal-no-comments.golden") - $ let opts = WriteOpts False True True v pkgDir Library pkgName defaultCabalVersion + $ let opts = WriteOpts False True True (verbosityFlags v) pkgDir Library pkgName defaultCabalVersion in runGoldenTest opts testArgs emptyFlags , goldenVsString "Empty flags, not simple, with minimal + comments" (goldenTest "test-simple-minimal-with-comments.golden") - $ let opts = WriteOpts False True False v pkgDir Library pkgName defaultCabalVersion + $ let opts = WriteOpts False True False (verbosityFlags v) pkgDir Library pkgName defaultCabalVersion in runGoldenTest opts testArgs emptyFlags , goldenVsString "Build tools flag, not simple, with comments + no minimal" (goldenTest "test-build-tools-with-comments.golden") - $ let opts = WriteOpts False False False v pkgDir Library pkgName defaultCabalVersion + $ let opts = WriteOpts False False False (verbosityFlags v) pkgDir Library pkgName defaultCabalVersion in runGoldenTest opts testArgs (emptyFlags{buildTools = Flag ["happy"]}) , goldenVsString "Standalone tests, empty flags, not simple, no options, no comments" (goldenTest "standalone-test-no-comments.golden") - $ let opts = WriteOpts False False True v pkgDir TestSuite pkgName defaultCabalVersion + $ let opts = WriteOpts False False True (verbosityFlags v) pkgDir TestSuite pkgName defaultCabalVersion in runGoldenTest opts testArgs emptyFlags , goldenVsString "Standalone tests, empty flags, not simple, with comments + no minimal" (goldenTest "standalone-test-with-comments.golden") - $ let opts = WriteOpts False False False v pkgDir TestSuite pkgName defaultCabalVersion + $ let opts = WriteOpts False False False (verbosityFlags v) pkgDir TestSuite pkgName defaultCabalVersion in runGoldenTest opts testArgs emptyFlags ] where diff --git a/cabal-install/tests/UnitTests/Distribution/Client/Init/Interactive.hs b/cabal-install/tests/UnitTests/Distribution/Client/Init/Interactive.hs index b536dd76b3b..960166d5553 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/Init/Interactive.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/Init/Interactive.hs @@ -76,7 +76,7 @@ createProjectTest pkgIx srcDb = , dependencies = Flag [] } - case (runPrompt $ createProject silent pkgIx srcDb dummyFlags') (fromList ["[]", "3", "quxTest/Main.hs"]) of + case (runPrompt $ createProject (mkVerbosity defaultVerbosityHandles silent) pkgIx srcDb dummyFlags') (fromList ["[]", "3", "quxTest/Main.hs"]) of Right (ProjectSettings opts desc (Just lib) (Just exe) (Just test), _) -> do _optOverwrite opts @?= False _optMinimal opts @?= False @@ -186,7 +186,7 @@ createProjectTest pkgIx srcDb = "y" ] - case (runPrompt $ createProject silent pkgIx srcDb emptyFlags) inputs of + case (runPrompt $ createProject (mkVerbosity defaultVerbosityHandles silent) pkgIx srcDb emptyFlags) inputs of Right (ProjectSettings opts desc (Just lib) (Just exe) (Just test), _) -> do _optOverwrite opts @?= False _optMinimal opts @?= False @@ -286,7 +286,7 @@ createProjectTest pkgIx srcDb = "y" ] - case (runPrompt $ createProject silent pkgIx srcDb emptyFlags) inputs of + case (runPrompt $ createProject (mkVerbosity defaultVerbosityHandles silent) pkgIx srcDb emptyFlags) inputs of Right (ProjectSettings opts desc (Just lib) Nothing (Just test), _) -> do _optOverwrite opts @?= False _optMinimal opts @?= False @@ -372,7 +372,7 @@ createProjectTest pkgIx srcDb = "y" ] - case (runPrompt $ createProject silent pkgIx srcDb emptyFlags) inputs of + case (runPrompt $ createProject (mkVerbosity defaultVerbosityHandles silent) pkgIx srcDb emptyFlags) inputs of Right (ProjectSettings opts desc Nothing Nothing (Just test), _) -> do _optOverwrite opts @?= False _optMinimal opts @?= False @@ -460,7 +460,7 @@ createProjectTest pkgIx srcDb = "y" ] - case (runPrompt $ createProject silent pkgIx srcDb emptyFlags) inputs of + case (runPrompt $ createProject (mkVerbosity defaultVerbosityHandles silent) pkgIx srcDb emptyFlags) inputs of Right (ProjectSettings opts desc (Just lib) (Just exe) Nothing, _) -> do _optOverwrite opts @?= False _optMinimal opts @?= False @@ -546,7 +546,7 @@ createProjectTest pkgIx srcDb = "y" ] - case (runPrompt $ createProject silent pkgIx srcDb emptyFlags) inputs of + case (runPrompt $ createProject (mkVerbosity defaultVerbosityHandles silent) pkgIx srcDb emptyFlags) inputs of Right (ProjectSettings opts desc (Just lib) Nothing Nothing, _) -> do _optOverwrite opts @?= False _optMinimal opts @?= False @@ -631,7 +631,7 @@ createProjectTest pkgIx srcDb = , extraSrc = Flag ["README.md"] } - case (runPrompt $ createProject silent pkgIx srcDb flags) inputs of + case (runPrompt $ createProject (mkVerbosity defaultVerbosityHandles silent) pkgIx srcDb flags) inputs of Right (ProjectSettings opts desc (Just lib) Nothing Nothing, _) -> do _optOverwrite opts @?= False _optMinimal opts @?= False @@ -709,7 +709,7 @@ createProjectTest pkgIx srcDb = "y" ] - case (runPrompt $ createProject silent pkgIx srcDb emptyFlags) inputs of + case (runPrompt $ createProject (mkVerbosity defaultVerbosityHandles silent) pkgIx srcDb emptyFlags) inputs of Right (ProjectSettings opts desc Nothing (Just exe) Nothing, _) -> do _optOverwrite opts @?= False _optMinimal opts @?= False diff --git a/cabal-install/tests/UnitTests/Distribution/Client/Init/NonInteractive.hs b/cabal-install/tests/UnitTests/Distribution/Client/Init/NonInteractive.hs index 60a4a95990b..599357a9cd3 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/Init/NonInteractive.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/Init/NonInteractive.hs @@ -93,7 +93,7 @@ driverFunctionTest pkgIx srcDb comp = , "[\"quxTest/Main.hs\"]" ] - case (runPrompt $ createProject comp silent pkgIx srcDb dummyFlags') inputs of + case (runPrompt $ createProject comp (mkVerbosity defaultVerbosityHandles silent) pkgIx srcDb dummyFlags') inputs of Right (ProjectSettings opts desc (Just lib) (Just exe) (Just test), _) -> do _optOverwrite opts @?= False _optMinimal opts @?= False @@ -180,7 +180,7 @@ driverFunctionTest pkgIx srcDb comp = "False" ] - case (runPrompt $ createProject comp silent pkgIx srcDb dummyFlags') inputs of + case (runPrompt $ createProject comp (mkVerbosity defaultVerbosityHandles silent) pkgIx srcDb dummyFlags') inputs of Right (ProjectSettings opts desc (Just lib) (Just exe) (Just test), _) -> do _optOverwrite opts @?= False _optMinimal opts @?= False @@ -359,7 +359,7 @@ driverFunctionTest pkgIx srcDb comp = case ( runPrompt $ createProject comp - silent + (mkVerbosity defaultVerbosityHandles silent) pkgIx srcDb ( emptyFlags @@ -511,7 +511,7 @@ driverFunctionTest pkgIx srcDb comp = case ( runPrompt $ createProject comp - silent + (mkVerbosity defaultVerbosityHandles silent) pkgIx srcDb ( emptyFlags @@ -664,7 +664,7 @@ driverFunctionTest pkgIx srcDb comp = , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]" ] - case (runPrompt $ createProject comp silent pkgIx srcDb emptyFlags) inputs of + case (runPrompt $ createProject comp (mkVerbosity defaultVerbosityHandles silent) pkgIx srcDb emptyFlags) inputs of Right (ProjectSettings opts desc (Just lib) (Just exe) Nothing, _) -> do _optOverwrite opts @?= False _optMinimal opts @?= False @@ -774,7 +774,7 @@ driverFunctionTest pkgIx srcDb comp = , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]" ] - case (runPrompt $ createProject comp silent pkgIx srcDb emptyFlags) inputs of + case (runPrompt $ createProject comp (mkVerbosity defaultVerbosityHandles silent) pkgIx srcDb emptyFlags) inputs of Right (ProjectSettings opts desc (Just lib) Nothing Nothing, _) -> do _optOverwrite opts @?= False _optMinimal opts @?= False @@ -865,7 +865,7 @@ driverFunctionTest pkgIx srcDb comp = , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]" ] - case (runPrompt $ createProject comp silent pkgIx srcDb emptyFlags) inputs of + case (runPrompt $ createProject comp (mkVerbosity defaultVerbosityHandles silent) pkgIx srcDb emptyFlags) inputs of Right (ProjectSettings opts desc Nothing (Just exe) Nothing, _) -> do _optOverwrite opts @?= False _optMinimal opts @?= False diff --git a/cabal-install/tests/UnitTests/Distribution/Client/Init/Simple.hs b/cabal-install/tests/UnitTests/Distribution/Client/Init/Simple.hs index aab65a25317..4ddbb04e6d1 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/Init/Simple.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/Init/Simple.hs @@ -63,7 +63,7 @@ simpleCreateProjectTests v pkgIx srcDb pkgName = flags = emptyFlags{packageType = Flag Library} settings = ProjectSettings - (WriteOpts False False False v "/home/test/1" Library pkgName defaultCabalVersion) + (WriteOpts False False False (verbosityFlags v) "/home/test/1" Library pkgName defaultCabalVersion) (simplePkgDesc pkgName) (Just $ simpleLibTarget baseDep) Nothing @@ -77,7 +77,7 @@ simpleCreateProjectTests v pkgIx srcDb pkgName = flags = emptyFlags{packageType = Flag Library} settings = ProjectSettings - (WriteOpts False False False v "/home/test/1" Library pkgName defaultCabalVersion) + (WriteOpts False False False (verbosityFlags v) "/home/test/1" Library pkgName defaultCabalVersion) (simplePkgDesc pkgName) (Just $ simpleLibTarget baseDep) Nothing @@ -91,7 +91,7 @@ simpleCreateProjectTests v pkgIx srcDb pkgName = flags = emptyFlags{packageType = Flag Executable} settings = ProjectSettings - (WriteOpts False False False v "/home/test/2" Executable pkgName defaultCabalVersion) + (WriteOpts False False False (verbosityFlags v) "/home/test/2" Executable pkgName defaultCabalVersion) (simplePkgDesc pkgName) Nothing (Just $ simpleExeTarget Nothing baseDep) @@ -105,7 +105,7 @@ simpleCreateProjectTests v pkgIx srcDb pkgName = flags = emptyFlags{packageType = Flag LibraryAndExecutable} settings = ProjectSettings - (WriteOpts False False False v "/home/test/2" LibraryAndExecutable pkgName defaultCabalVersion) + (WriteOpts False False False (verbosityFlags v) "/home/test/2" LibraryAndExecutable pkgName defaultCabalVersion) (simplePkgDesc pkgName) (Just $ simpleLibTarget baseDep) (Just $ simpleExeTarget (Just pkgName) baseDep) @@ -119,7 +119,7 @@ simpleCreateProjectTests v pkgIx srcDb pkgName = flags = emptyFlags{packageType = Flag LibraryAndExecutable} settings = ProjectSettings - (WriteOpts False False False v "/home/test/2" LibraryAndExecutable pkgName defaultCabalVersion) + (WriteOpts False False False (verbosityFlags v) "/home/test/2" LibraryAndExecutable pkgName defaultCabalVersion) (simplePkgDesc pkgName) (Just $ simpleLibTarget baseDep) (Just $ simpleExeTarget (Just pkgName) baseDep) @@ -133,7 +133,7 @@ simpleCreateProjectTests v pkgIx srcDb pkgName = flags = emptyFlags{packageType = Flag TestSuite} settings = ProjectSettings - (WriteOpts False False False v "/home/test/2" TestSuite pkgName defaultCabalVersion) + (WriteOpts False False False (verbosityFlags v) "/home/test/2" TestSuite pkgName defaultCabalVersion) (simplePkgDesc pkgName) Nothing Nothing diff --git a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs index be9837b2412..ac560596112 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs @@ -48,7 +48,7 @@ import Distribution.Client.Targets import Distribution.Client.Types import Distribution.Client.Types.SourceRepo import Distribution.Utils.NubList -import Distribution.Verbosity (silent) +import Distribution.Verbosity import Distribution.Solver.Types.ConstraintSource import Distribution.Solver.Types.PackageConstraint @@ -176,17 +176,17 @@ testFindProjectRoot = test name wrap projectDir projectFile validate = testCaseSteps name $ \step -> fromMaybe id wrap $ do - result <- findProjectRoot silent projectDir projectFile + result <- findProjectRoot (mkVerbosity defaultVerbosityHandles silent) projectDir projectFile _ <- validate result when (isRight result) $ do for_ projectDir $ \path -> do step "missing project dir" - fails =<< findProjectRoot silent (missing path) projectFile + fails =<< findProjectRoot (mkVerbosity defaultVerbosityHandles silent) (missing path) projectFile for_ projectFile $ \path -> do step "missing project file" - fails =<< findProjectRoot silent projectDir (missing path) + fails =<< findProjectRoot (mkVerbosity defaultVerbosityHandles silent) projectDir (missing path) cd d = Just (withCurrentDirectory d) diff --git a/cabal-install/tests/UnitTests/Distribution/Client/Store.hs b/cabal-install/tests/UnitTests/Distribution/Client/Store.hs index 5f30ff496f5..d9b0181139e 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/Store.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/Store.hs @@ -12,7 +12,7 @@ import System.FilePath import Distribution.Package (UnitId, mkUnitId) import Distribution.Simple.Compiler (AbiTag (..), Compiler (..), CompilerFlavor (..), CompilerId (..)) import Distribution.Simple.Utils (withTempDirectory) -import Distribution.Verbosity (Verbosity, silent) +import Distribution.Verbosity import Distribution.Version (mkVersion) import Distribution.Client.RebuildMonad @@ -31,7 +31,7 @@ tests = testListEmpty :: Assertion testListEmpty = - withTempDirectory verbosity "." "store-" $ \tmp -> do + withTempDirectory "." "store-" $ \tmp -> do let storeDirLayout = defaultStoreDirLayout (tmp "store") assertStoreEntryExists storeDirLayout compiler unitid False @@ -53,7 +53,7 @@ testListEmpty = testInstallSerial :: Assertion testInstallSerial = - withTempDirectory verbosity "." "store-" $ \tmp -> do + withTempDirectory "." "store-" $ \tmp -> do let storeDirLayout = defaultStoreDirLayout (tmp "store") copyFiles file content dir = do -- we copy into a prefix inside the tmp dir and return the prefix @@ -117,7 +117,7 @@ testInstallSerial = testInstallParallel :: Assertion testInstallParallel = - withTempDirectory verbosity "." "store-" $ \tmp -> do + withTempDirectory "." "store-" $ \tmp -> do let storeDirLayout = defaultStoreDirLayout (tmp "store") sync1 <- newEmptyMVar @@ -228,4 +228,4 @@ assertFileEqual path expected = do assertEqual ("file content for:\n" ++ path) expected actual verbosity :: Verbosity -verbosity = silent +verbosity = mkVerbosity defaultVerbosityHandles silent diff --git a/cabal-install/tests/UnitTests/Distribution/Client/UserConfig.hs b/cabal-install/tests/UnitTests/Distribution/Client/UserConfig.hs index 1eda271f98e..30edd4fc758 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/UserConfig.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/UserConfig.hs @@ -23,7 +23,7 @@ import Distribution.Client.Utils (removeExistingFile) import Distribution.Simple.Setup (ConfigFlags (..), fromFlag, pattern Flag) import Distribution.Simple.Utils (withTempDirectory) import Distribution.Utils.NubList (fromNubList) -import Distribution.Verbosity (silent) +import Distribution.Verbosity tests :: [TestTree] tests = @@ -37,17 +37,17 @@ tests = nullDiffOnCreateTest :: Assertion nullDiffOnCreateTest = bracketTest $ \configFile -> do -- Create a new default config file in our test directory. - _ <- createDefaultConfigFile silent [] configFile + _ <- createDefaultConfigFile (mkVerbosity defaultVerbosityHandles silent) [] configFile -- Now we read it in and compare it against the default. - diff <- userConfigDiff silent (globalFlags configFile) [] + diff <- userConfigDiff (mkVerbosity defaultVerbosityHandles silent) (globalFlags configFile) [] assertBool (unlines $ "Following diff should be empty:" : diff) $ null diff canDetectDifference :: Assertion canDetectDifference = bracketTest $ \configFile -> do -- Create a new default config file in our test directory. - _ <- createDefaultConfigFile silent [] configFile + _ <- createDefaultConfigFile (mkVerbosity defaultVerbosityHandles silent) [] configFile appendFile configFile "verbose: 0\n" - diff <- userConfigDiff silent (globalFlags configFile) [] + diff <- userConfigDiff (mkVerbosity defaultVerbosityHandles silent) (globalFlags configFile) [] assertBool (unlines $ "Should detect a difference:" : diff) $ diff == ["+ verbose: 0"] @@ -56,20 +56,20 @@ canUpdateConfig = bracketTest $ \configFile -> do -- Write a trivial cabal file. writeFile configFile "tests: True\n" -- Update the config file. - userConfigUpdate silent (globalFlags configFile) [] + userConfigUpdate (mkVerbosity defaultVerbosityHandles silent) (globalFlags configFile) [] -- Load it again. - updated <- loadConfig silent (Flag configFile) + updated <- loadConfig (mkVerbosity defaultVerbosityHandles silent) (Flag configFile) assertBool ("Field 'tests' should be True") $ fromFlag (configTests $ savedConfigureFlags updated) doubleUpdateConfig :: Assertion doubleUpdateConfig = bracketTest $ \configFile -> do -- Create a new default config file in our test directory. - _ <- createDefaultConfigFile silent [] configFile + _ <- createDefaultConfigFile (mkVerbosity defaultVerbosityHandles silent) [] configFile -- Update it twice. - replicateM_ 2 $ userConfigUpdate silent (globalFlags configFile) [] + replicateM_ 2 $ userConfigUpdate (mkVerbosity defaultVerbosityHandles silent) (globalFlags configFile) [] -- Load it again. - updated <- loadConfig silent (Flag configFile) + updated <- loadConfig (mkVerbosity defaultVerbosityHandles silent) (Flag configFile) assertBool ("Field 'remote-repo' doesn't contain duplicates") $ listUnique (map show . fromNubList . globalRemoteRepos $ savedGlobalFlags updated) @@ -81,9 +81,9 @@ doubleUpdateConfig = bracketTest $ \configFile -> do newDefaultConfig :: Assertion newDefaultConfig = do sysTmpDir <- getTemporaryDirectory - withTempDirectory silent sysTmpDir "cabal-test" $ \tmpDir -> do + withTempDirectory sysTmpDir "cabal-test" $ \tmpDir -> do let configFile = tmpDir "tmp.config" - _ <- createDefaultConfigFile silent [] configFile + _ <- createDefaultConfigFile (mkVerbosity defaultVerbosityHandles silent) [] configFile exists <- doesFileExist configFile assertBool ("Config file should be written to " ++ configFile) exists diff --git a/cabal-install/tests/UnitTests/Distribution/Client/VCS.hs b/cabal-install/tests/UnitTests/Distribution/Client/VCS.hs index e5a880fbb5f..17ee3743270 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/VCS.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/VCS.hs @@ -250,7 +250,7 @@ testSetup vcs mkVCSTestDriver repoRecipe theTest = do return result where - verbosity = silent + verbosity = mkVerbosity defaultVerbosityHandles silent -- ------------------------------------------------------------ @@ -282,7 +282,7 @@ prop_framework vcs mkVCSTestDriver repoRecipe = Right checkoutCloneTo -> do checkoutCloneTo tagname destRepoPath checkExpectedWorkingState vcsIgnoreFiles destRepoPath expectedState - removeDirectoryRecursiveHack silent destRepoPath + removeDirectoryRecursiveHack (mkVerbosity defaultVerbosityHandles silent) destRepoPath where destRepoPath = tmpdir "dest" @@ -316,7 +316,7 @@ prop_cloneRepo vcs mkVCSTestDriver repoRecipe = , srpSubdir = [] , srpCommand = [] } - verbosity = silent + verbosity = mkVerbosity defaultVerbosityHandles silent -- ------------------------------------------------------------ @@ -355,7 +355,7 @@ prop_syncRepos syncTargetSetIterations seed where - verbosity = silent + verbosity = mkVerbosity defaultVerbosityHandles silent getRepoDirs :: RepoDirSet -> [FilePath] getRepoDirs (RepoDirSet n) = @@ -989,7 +989,7 @@ vcsTestDriverGit gitQuiet [] = git [] gitQuiet (cmd : args) = git (cmd : verboseArg ++ args) - verboseArg = ["--quiet" | verbosity < Verbosity.normal] + verboseArg = ["--quiet" | Verbosity.verbosityLevel verbosity < Verbosity.Normal] submoduleGitDir path = repoRoot ".git" "modules" path @@ -1149,4 +1149,4 @@ vcsTestDriverHg } hg = runProgramInvocation verbosity . hgInvocation hg' = getProgramInvocationOutput verbosity . hgInvocation - verboseArg = ["--quiet" | verbosity < Verbosity.normal] + verboseArg = ["--quiet" | Verbosity.verbosityLevel verbosity < Verbosity.Normal] diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs index 0d17ddc32b7..89993604390 100644 --- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs +++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs @@ -872,7 +872,7 @@ exResolve setEnableBackjumping enableBj $ setSolveExecutables solveExes $ setGoalOrder goalOrder $ - setSolverVerbosity verbosity $ + setSolverVerbosity (C.verbosityLevel verbosity) $ standardInstallPolicy instIdx avaiIdx targets' toLpc pc = LabeledPackageConstraint pc ConstraintSourceUnknown diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL/TestCaseUtils.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL/TestCaseUtils.hs index bfe563947cd..3fe0eb6a339 100644 --- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL/TestCaseUtils.hs +++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL/TestCaseUtils.hs @@ -138,7 +138,7 @@ data SolverTest = SolverTest , testGoalOrder :: Maybe [ExampleVar] , testConstraints :: [ExConstraint] , testSoftConstraints :: [ExPreference] - , testVerbosity :: Verbosity + , testVerbosity :: VerbosityFlags , testDb :: ExampleDb , testSupportedExts :: Maybe [Extension] , testSupportedLangs :: Maybe [Language] @@ -276,7 +276,7 @@ runTest SolverTest{..} = askOption $ \(OptionShowSolverLog showSolverLog) -> (sortGoals <$> testGoalOrder) testConstraints testSoftConstraints - testVerbosity + (mkVerbosity defaultVerbosityHandles testVerbosity) testEnableAllTests printMsg msg = when showSolverLog $ putStrLn msg msgs = foldProgress (:) (const []) (const []) progress diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs index 2e1f5ba39db..eecab420f8c 100644 --- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs +++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs @@ -261,7 +261,7 @@ solve enableBj fineGrainedConflicts reorder countConflicts indep prefOldest goal (unVarOrdering <$> goalOrder) (testConstraints test) (testPreferences test) - normal + (mkVerbosity defaultVerbosityHandles normal) (EnableAllTests False) failure :: String -> Failure diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck/Utils.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck/Utils.hs index 24d61e1e72d..8e10995be63 100644 --- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck/Utils.hs +++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck/Utils.hs @@ -40,7 +40,7 @@ instance IsTest QCWithSeed where replay <- case lookupOption options of QuickCheckReplayLegacy override -> return override _ -> getStdRandom random - notice normal $ "Using --quickcheck-replay=" ++ show replay + notice (mkVerbosity defaultVerbosityHandles normal) $ "Using --quickcheck-replay=" ++ show replay run (setOption (QuickCheckReplayLegacy replay) options) test progress -- | Typeclass for doing arbitrary (but law-abiding) comparisons. See also diff --git a/cabal-testsuite/PackageTests/AutoconfBadPaths/cabal.test.hs b/cabal-testsuite/PackageTests/AutoconfBadPaths/cabal.test.hs index 544764affcd..8365e6b763c 100644 --- a/cabal-testsuite/PackageTests/AutoconfBadPaths/cabal.test.hs +++ b/cabal-testsuite/PackageTests/AutoconfBadPaths/cabal.test.hs @@ -1,6 +1,7 @@ import Test.Cabal.Prelude import Data.Foldable (traverse_) import Distribution.Simple.Utils +import Distribution.Verbosity import System.Directory main = do -- Most of these are magic on Windows, so don't bother testing there. @@ -39,11 +40,14 @@ main = do env <- getTestEnv let cwd = testCurrentDir env liftIO $ createDirectory (testCurrentDir env dir) - liftIO $ copyFiles minBound (testCurrentDir env dir) - [ (cwd, "configure") - , (cwd, "Setup.hs") - , (cwd, "test.cabal") - ] + liftIO $ + copyFiles + (mkVerbosity defaultVerbosityHandles silent) + (testCurrentDir env dir) + [ (cwd, "configure") + , (cwd, "Setup.hs") + , (cwd, "test.cabal") + ] -- 'cabal' from the prelude requires the command to succeed; we -- don't mind if it fails, so long as we get the warning. This is -- an inlined+specialised version of 'cabal' for v1-configure. @@ -59,7 +63,7 @@ main = do , testDistDir env ] configured_prog <- requireProgramM cabalProgram - r <- liftIO $ run (testVerbosity env) + r <- liftIO $ run (Just $ testCurrentDir env dir) (testEnvironment env) (programPath configured_prog) diff --git a/cabal-testsuite/PackageTests/BuildToolPaths/pbts/SetupHooks.hs b/cabal-testsuite/PackageTests/BuildToolPaths/pbts/SetupHooks.hs index 478d7af2f5d..3a18fa24671 100644 --- a/cabal-testsuite/PackageTests/BuildToolPaths/pbts/SetupHooks.hs +++ b/cabal-testsuite/PackageTests/BuildToolPaths/pbts/SetupHooks.hs @@ -40,6 +40,7 @@ import Distribution.Types.LocalBuildInfo import Distribution.Utils.Path import Distribution.Utils.ShortText ( toShortText ) +import Distribution.Verbosity -- filepath import System.FilePath @@ -66,7 +67,7 @@ preBuildRules , targetInfo = tgt } = do - let verbosity = buildingWhatVerbosity what + let verbosityFlags = buildingWhatVerbosity what comp = targetComponent tgt compNm = componentName comp clbi = targetCLBI tgt @@ -97,10 +98,10 @@ preBuildRules -- 2. Create a command to run a preprocessor, passing input and output file locations. let ppCmd :: ConfiguredProgram -> Location -> Location - -> Command ( Verbosity, Maybe (SymbolicPath CWD (Dir Pkg)), ConfiguredProgram, Location, Location ) ( IO () ) + -> Command ( VerbosityFlags, Maybe (SymbolicPath CWD (Dir Pkg)), ConfiguredProgram, Location, Location ) ( IO () ) ppCmd pp i o = mkCommand ( static Dict ) ( static ppModule ) - ( verbosity, mbWorkDir, pp, i, o ) + ( verbosityFlags, mbWorkDir, pp, i, o ) -- 3. Get all modules listed in the package description for this component. let mods = componentModules comp @@ -142,10 +143,11 @@ preBuildRules registerRule_ ( toShortText $ show md ) $ staticRule ( ppCmd customPp inputLoc outputLoc ) [] ( outputLoc NE.:| [] ) -ppModule :: ( Verbosity, Maybe (SymbolicPath CWD (Dir Pkg)), ConfiguredProgram, Location, Location ) -> IO () -ppModule ( verbosity, mbWorkDir, customPp, inputLoc, outputLoc ) = do +ppModule :: ( VerbosityFlags, Maybe (SymbolicPath CWD (Dir Pkg)), ConfiguredProgram, Location, Location ) -> IO () +ppModule ( verbosityFlags, mbWorkDir, customPp, inputLoc, outputLoc ) = do let inputPath = location inputLoc outputPath = location outputLoc + verbosity = mkVerbosity defaultVerbosityHandles verbosityFlags createDirectoryIfMissingVerbose verbosity True $ interpretSymbolicPath mbWorkDir (takeDirectorySymbolicPath outputPath) runProgramCwd verbosity mbWorkDir customPp [ getSymbolicPath inputPath, getSymbolicPath outputPath ] diff --git a/cabal-testsuite/PackageTests/ExternalCommand/cabal.test.hs b/cabal-testsuite/PackageTests/ExternalCommand/cabal.test.hs index 69319db30ca..14d8772b1ed 100644 --- a/cabal-testsuite/PackageTests/ExternalCommand/cabal.test.hs +++ b/cabal-testsuite/PackageTests/ExternalCommand/cabal.test.hs @@ -35,7 +35,7 @@ cabal_raw_action :: [String] -> (Process.ProcessHandle -> IO ()) -> TestM Result cabal_raw_action args action = do configured_prog <- requireProgramM cabalProgram env <- getTestEnv - r <- liftIO $ runAction (testVerbosity env) + r <- liftIO $ runAction (Just $ testCurrentDir env) (testEnvironment env) (programPath configured_prog) diff --git a/cabal-testsuite/PackageTests/ExternalCommandEnv/cabal.test.hs b/cabal-testsuite/PackageTests/ExternalCommandEnv/cabal.test.hs index 7f1728c831b..0f3f67cce0e 100644 --- a/cabal-testsuite/PackageTests/ExternalCommandEnv/cabal.test.hs +++ b/cabal-testsuite/PackageTests/ExternalCommandEnv/cabal.test.hs @@ -25,7 +25,7 @@ cabal_raw_action :: [String] -> (Process.ProcessHandle -> IO ()) -> TestM Result cabal_raw_action args action = do configured_prog <- requireProgramM cabalProgram env <- getTestEnv - r <- liftIO $ runAction (testVerbosity env) + r <- liftIO $ runAction (Just $ testCurrentDir env) (testEnvironment env) (programPath configured_prog) diff --git a/cabal-testsuite/PackageTests/ExternalCommandExitCode/cabal.test.hs b/cabal-testsuite/PackageTests/ExternalCommandExitCode/cabal.test.hs index a9ba8972e3f..087fb06b309 100644 --- a/cabal-testsuite/PackageTests/ExternalCommandExitCode/cabal.test.hs +++ b/cabal-testsuite/PackageTests/ExternalCommandExitCode/cabal.test.hs @@ -26,7 +26,7 @@ cabal_raw_action :: [String] -> (Process.ProcessHandle -> IO ()) -> TestM Result cabal_raw_action args action = do configured_prog <- requireProgramM cabalProgram env <- getTestEnv - r <- liftIO $ runAction (testVerbosity env) + r <- liftIO $ runAction (Just $ testCurrentDir env) (testEnvironment env) (programPath configured_prog) diff --git a/cabal-testsuite/PackageTests/ExternalCommandHelp/cabal.test.hs b/cabal-testsuite/PackageTests/ExternalCommandHelp/cabal.test.hs index 1932d49ed48..3d08a0add99 100644 --- a/cabal-testsuite/PackageTests/ExternalCommandHelp/cabal.test.hs +++ b/cabal-testsuite/PackageTests/ExternalCommandHelp/cabal.test.hs @@ -22,7 +22,7 @@ cabal_raw_action :: [String] -> (Process.ProcessHandle -> IO ()) -> TestM Result cabal_raw_action args action = do configured_prog <- requireProgramM cabalProgram env <- getTestEnv - r <- liftIO $ runAction (testVerbosity env) + r <- liftIO $ runAction (Just $ testCurrentDir env) (testEnvironment env) (programPath configured_prog) diff --git a/cabal-testsuite/PackageTests/ForeignLibs/setup.test.hs b/cabal-testsuite/PackageTests/ForeignLibs/setup.test.hs index 69df1e8d313..dd990267b9f 100644 --- a/cabal-testsuite/PackageTests/ForeignLibs/setup.test.hs +++ b/cabal-testsuite/PackageTests/ForeignLibs/setup.test.hs @@ -63,7 +63,8 @@ main = setupAndCabalTest . recordMode DoNotRecord $ do let libraryName = "libversionedlib.so.5.4.3" libdir = flibdir installDirs objdumpProgram = simpleProgram "objdump" - (objdump, _) <- liftIO $ requireProgram normal objdumpProgram (withPrograms lbi) + verbosity = mkVerbosity defaultVerbosityHandles normal + (objdump, _) <- liftIO $ requireProgram verbosity objdumpProgram (withPrograms lbi) path1 <- liftIO $ readSymbolicLink $ libdir "libversionedlib.so" path2 <- liftIO $ readSymbolicLink $ libdir "libversionedlib.so.5" assertEqual "Symbolic link 'libversionedlib.so' incorrect" diff --git a/cabal-testsuite/PackageTests/Init/init-without-git.test.hs b/cabal-testsuite/PackageTests/Init/init-without-git.test.hs index 4c98f751c57..02a0d87b378 100644 --- a/cabal-testsuite/PackageTests/Init/init-without-git.test.hs +++ b/cabal-testsuite/PackageTests/Init/init-without-git.test.hs @@ -8,7 +8,7 @@ import Distribution.Verbosity main = do skipIfWindows "Might fail on windows." tmp <- getTemporaryDirectory - withTempDirectory normal tmp "bin" $ + withTempDirectory tmp "bin" $ \bin -> cabalTest $ do ghc_path <- programPathM ghcProgram diff --git a/cabal-testsuite/PackageTests/LinkerOptions/NonignoredConfigs/cabal.test.hs b/cabal-testsuite/PackageTests/LinkerOptions/NonignoredConfigs/cabal.test.hs index 55ec5ee6144..5608ad04a57 100644 --- a/cabal-testsuite/PackageTests/LinkerOptions/NonignoredConfigs/cabal.test.hs +++ b/cabal-testsuite/PackageTests/LinkerOptions/NonignoredConfigs/cabal.test.hs @@ -1,5 +1,6 @@ import Test.Cabal.Prelude import Distribution.Simple.Utils +import Distribution.Verbosity -- This test ensures the following fix holds: -- > Fix project-local build flags being ignored. @@ -57,7 +58,11 @@ main = cabalTest $ do withPackageDb $ do -- Phase 1: get 4 hashes according to config flags. results <- forM (zip [0..] lrun) $ \(idx, linking) -> do - liftIO $ copyDirectoryRecursive minBound (testCurrentDir env "basic") (testCurrentDir env "basic" ++ show idx) + liftIO $ + copyDirectoryRecursive + (mkVerbosity defaultVerbosityHandles silent) + (testCurrentDir env "basic") + (testCurrentDir env "basic" ++ show idx) withDirectory ("basic" ++ show idx) $ do packageEnv <- ( ("basic" ++ show idx ++ ".env")) . testWorkDir <$> getTestEnv let installOptions = ["--disable-deterministic", "--lib", "--package-env=" ++ packageEnv] ++ linkConfigFlags linking ++ ["basic"] diff --git a/cabal-testsuite/PackageTests/LoggingHandle/Setup.hs b/cabal-testsuite/PackageTests/LoggingHandle/Setup.hs new file mode 100644 index 00000000000..f1267c90868 --- /dev/null +++ b/cabal-testsuite/PackageTests/LoggingHandle/Setup.hs @@ -0,0 +1,26 @@ + +module Main (main) where + +import Distribution.Simple +import Distribution.Verbosity + +import System.IO + +-- Custom setup script which simply changes the logging handles of the default +-- user hooks. +-- +-- This has the effect of redirecting MOST of the Cabal output to file. +-- MOST, not ALL, because 'simpleUserHooksWithHandles' doesn't modify the +-- logging handles for a few operations (e.g. 'confPkgDescr' in 'configureAction'). + +main :: IO () +main = do + let outPath = "stdout_log.txt" + errPath = "stderr_log.txt" + withFile outPath AppendMode $ \ outHandle -> + withFile errPath AppendMode $ \ errHandle -> do + hSetBuffering outHandle LineBuffering + hSetBuffering errHandle LineBuffering + let + verbHandles = VerbosityHandles outHandle errHandle + defaultMainWithHooks $ simpleUserHooksWithHandles verbHandles diff --git a/cabal-testsuite/PackageTests/LoggingHandle/bench/Main.hs b/cabal-testsuite/PackageTests/LoggingHandle/bench/Main.hs new file mode 100644 index 00000000000..c88bc312593 --- /dev/null +++ b/cabal-testsuite/PackageTests/LoggingHandle/bench/Main.hs @@ -0,0 +1,11 @@ +module Main where + +import Lib ( libFun ) + +main :: IO () +main = putStrLn $ libFun "benchmark" + + +-- Just something that causes GHC to emit a warning +unusedBench :: Int -> Int +unusedBench 3 = 4 diff --git a/cabal-testsuite/PackageTests/LoggingHandle/exe/Main.hs b/cabal-testsuite/PackageTests/LoggingHandle/exe/Main.hs new file mode 100644 index 00000000000..3f091e99cf7 --- /dev/null +++ b/cabal-testsuite/PackageTests/LoggingHandle/exe/Main.hs @@ -0,0 +1,11 @@ +module Main where + +import Lib ( libFun ) + +main :: IO () +main = putStrLn $ libFun "executable" + + +-- Just something that causes GHC to emit a warning +unusedExe :: Int -> Int +unusedExe 3 = 4 diff --git a/cabal-testsuite/PackageTests/LoggingHandle/lib/Lib.hs b/cabal-testsuite/PackageTests/LoggingHandle/lib/Lib.hs new file mode 100644 index 00000000000..d153224aba9 --- /dev/null +++ b/cabal-testsuite/PackageTests/LoggingHandle/lib/Lib.hs @@ -0,0 +1,9 @@ +module Lib ( libFun ) where + +libFun :: String -> String +libFun str = "I am the " ++ str ++ "!" + + +-- Just something that causes GHC to emit a warning +unusedLib :: Int -> Int +unusedLib 3 = 4 diff --git a/cabal-testsuite/PackageTests/LoggingHandle/setup.out b/cabal-testsuite/PackageTests/LoggingHandle/setup.out new file mode 100644 index 00000000000..2e04906bf09 --- /dev/null +++ b/cabal-testsuite/PackageTests/LoggingHandle/setup.out @@ -0,0 +1,4 @@ +# Setup configure +# Setup build +# Setup test +# Setup bench diff --git a/cabal-testsuite/PackageTests/LoggingHandle/setup.test.hs b/cabal-testsuite/PackageTests/LoggingHandle/setup.test.hs new file mode 100644 index 00000000000..5029cb1ef62 --- /dev/null +++ b/cabal-testsuite/PackageTests/LoggingHandle/setup.test.hs @@ -0,0 +1,51 @@ +import Distribution.Simple +import Distribution.Simple.InstallDirs +import Distribution.Simple.Setup + hiding ( testVerbosity ) +import Distribution.Utils.Path + ( interpretSymbolicPath ) +import Distribution.Verbosity + +import Test.Cabal.Prelude + +import System.IO + ( IOMode(ReadWriteMode), withFile ) + +import System.Directory + ( createDirectoryIfMissing ) + +main = setupTest $ do + skipUnlessAnyCabalVersion ">= 3.17" + cwd <- fmap testCurrentDir getTestEnv + let + outFile = cwd "stdout_log.txt" + errFile = cwd "stderr_log.txt" + + confRes <- setup' "configure" ["-v1", "--enable-tests", "--enable-benchmarks"] + assertOutputDoesNotContain "Configuring" confRes + assertFileDoesContain outFile "Configuring" + + buildRes <- setup' "build" ["-v1"] + assertOutputDoesNotContain "unusedLib" buildRes + assertOutputDoesNotContain "unusedExe" buildRes + assertOutputDoesNotContain "unusedTest" buildRes + assertOutputDoesNotContain "unusedBench" buildRes + assertFileDoesContain errFile "unusedLib" + assertFileDoesContain errFile "unusedExe" + assertFileDoesContain errFile "unusedTest" + assertFileDoesContain errFile "unusedBench" + + assertOutputDoesNotContain "Compiling Lib" buildRes + assertFileDoesContain outFile "Compiling Lib" + + testRes <- setup' "test" ["-v1"] + assertOutputDoesNotContain "Test suite pkg-test: RUNNING..." testRes + assertFileDoesContain outFile "Test suite pkg-test: RUNNING..." + assertOutputDoesNotContain "I am the test-suite!" testRes + assertFileDoesContain outFile "I am the test-suite!" + + benchRes <- setup' "bench" ["-v1"] + assertOutputDoesNotContain "Benchmark pkg-bench: RUNNING..." benchRes + assertFileDoesContain outFile "Benchmark pkg-bench: RUNNING..." + assertOutputDoesNotContain "I am the benchmark!" benchRes + assertFileDoesContain outFile "I am the benchmark!" diff --git a/cabal-testsuite/PackageTests/LoggingHandle/test-pkg.cabal b/cabal-testsuite/PackageTests/LoggingHandle/test-pkg.cabal new file mode 100644 index 00000000000..8e092a79a75 --- /dev/null +++ b/cabal-testsuite/PackageTests/LoggingHandle/test-pkg.cabal @@ -0,0 +1,45 @@ +cabal-version: 3.0 +name: pkg +version: 0.1.0.0 +license: BSD-3-Clause +author: sheaf +maintainer: sheaf +category: Testing +build-type: Custom +description: Test package for testing logging handles + +common warnings + ghc-options: -Wall + +custom-setup + setup-depends: Cabal, base + +library + import: warnings + exposed-modules: Lib + build-depends: base + hs-source-dirs: lib + default-language: Haskell2010 + +executable pkg-exe + import: warnings + default-language: Haskell2010 + hs-source-dirs: exe + main-is: Main.hs + build-depends: base, pkg + +test-suite pkg-test + import: warnings + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: base, pkg + +benchmark pkg-bench + import: warnings + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: bench + main-is: Main.hs + build-depends: base, pkg diff --git a/cabal-testsuite/PackageTests/LoggingHandle/test/Main.hs b/cabal-testsuite/PackageTests/LoggingHandle/test/Main.hs new file mode 100644 index 00000000000..da6bcfdc350 --- /dev/null +++ b/cabal-testsuite/PackageTests/LoggingHandle/test/Main.hs @@ -0,0 +1,11 @@ +module Main where + +import Lib ( libFun ) + +main :: IO () +main = putStrLn $ libFun "test-suite" + + +-- Just something that causes GHC to emit a warning +unusedTest :: Int -> Int +unusedTest 3 = 4 diff --git a/cabal-testsuite/PackageTests/NewBuild/CmdRun/Terminate/cabal.test.hs b/cabal-testsuite/PackageTests/NewBuild/CmdRun/Terminate/cabal.test.hs index cf8f179d70f..eeb8ad3d480 100644 --- a/cabal-testsuite/PackageTests/NewBuild/CmdRun/Terminate/cabal.test.hs +++ b/cabal-testsuite/PackageTests/NewBuild/CmdRun/Terminate/cabal.test.hs @@ -64,7 +64,7 @@ cabal_raw_action :: [String] -> (Process.ProcessHandle -> IO ()) -> TestM Result cabal_raw_action args action = do configured_prog <- requireProgramM cabalProgram env <- getTestEnv - r <- liftIO $ runAction (testVerbosity env) + r <- liftIO $ runAction (Just $ testCurrentDir env) (testEnvironment env) (programPath configured_prog) diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/SetupHooks.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/SetupHooks.hs index 2e3bcf4a818..45559af69c9 100644 --- a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/SetupHooks.hs +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/SetupHooks.hs @@ -17,6 +17,7 @@ import Distribution.Simple.LocalBuildInfo (interpretSymbolicPathLBI) import Distribution.Simple.SetupHooks import Distribution.Simple.Utils import Distribution.Utils.Path +import Distribution.Verbosity import Data.Foldable ( for_ ) import Data.List ( isPrefixOf ) @@ -38,19 +39,21 @@ setupHooks = preBuildRules :: PreBuildComponentInputs -> RulesM () preBuildRules (PreBuildComponentInputs { buildingWhat = what, localBuildInfo = lbi, targetInfo = tgt }) = mdo - let verbosity = buildingWhatVerbosity what + let verbosityFlags = buildingWhatVerbosity what clbi = targetCLBI tgt autogenDir = autogenComponentModulesDir lbi clbi buildDir = componentBuildDir lbi clbi computeC2HsDepsAction (C2HsDepsInput {..}) = do importLine : _srcLines <- lines <$> readFile (getSymbolicPath $ inDir moduleNameSymbolicPath modNm <.> "myChs") - let imports :: [ModuleName] - imports - | "imports:" `isPrefixOf` importLine - = map fromString $ words $ drop 8 importLine - | otherwise - = error "Malformed MyChs file: first line should start with 'imports:'" + let + verbosity = mkVerbosity defaultVerbosityHandles verbosityFlags + imports :: [ModuleName] + imports + | "imports:" `isPrefixOf` importLine + = map fromString $ words $ drop 8 importLine + | otherwise + = error "Malformed MyChs file: first line should start with 'imports:'" warn verbosity $ "Computed C2Hs dependencies of " ++ modName modNm ++ ".myChs: " ++ modNames imports return $ @@ -61,6 +64,7 @@ preBuildRules (PreBuildComponentInputs { buildingWhat = what, localBuildInfo = l runC2HsAction (C2HsInput {..}) importModNms = do let modPath = moduleNameSymbolicPath modNm + verbosity = mkVerbosity defaultVerbosityHandles verbosityFlags warn verbosity $ "Running C2Hs on " ++ modName modNm ++ ".myChs.\n C2Hs dependencies: " ++ modNames importModNms _importLine : srcLines <- lines <$> readFile (getSymbolicPath $ inDir modPath <.> "myChs") @@ -93,7 +97,7 @@ preBuildRules (PreBuildComponentInputs { buildingWhat = what, localBuildInfo = l -- | Input to C2Hs dependency computation data C2HsDepsInput = C2HsDepsInput - { verbosity :: Verbosity + { verbosityFlags :: VerbosityFlags , inDir :: SymbolicPath Pkg (Dir Source) , modNm :: ModuleName , ruleIds :: Map.Map ModuleName RuleId @@ -104,7 +108,7 @@ data C2HsDepsInput -- | Input to C2Hs command data C2HsInput = C2HsInput - { verbosity :: Verbosity + { verbosityFlags :: VerbosityFlags , modNm :: ModuleName , inDir :: SymbolicPath Pkg (Dir Source) , hsDir :: SymbolicPath Pkg (Dir Source) diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksInvalidRuleOutputIndex/SetupHooks.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksInvalidRuleOutputIndex/SetupHooks.hs index 56db5f98f13..8f848bfbe8c 100644 --- a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksInvalidRuleOutputIndex/SetupHooks.hs +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksInvalidRuleOutputIndex/SetupHooks.hs @@ -9,6 +9,7 @@ import Distribution.Simple.LocalBuildInfo (interpretSymbolicPathLBI) import Distribution.Simple.SetupHooks import Distribution.Simple.Utils (rewriteFileEx) import Distribution.Utils.Path +import Distribution.Verbosity import qualified Data.List.NonEmpty as NE ( NonEmpty(..) ) @@ -25,18 +26,20 @@ invalidRuleOutputIndexRules :: PreBuildComponentInputs -> RulesM () invalidRuleOutputIndexRules (PreBuildComponentInputs { buildingWhat = what, localBuildInfo = lbi, targetInfo = tgt }) = do let clbi = targetCLBI tgt autogenDir = autogenComponentModulesDir lbi clbi - verbosity = buildingWhatVerbosity what + verbosityFlags = buildingWhatVerbosity what action = mkCommand (static Dict) $ static (\ ((dir, modNm), verb) -> do - let loc = getSymbolicPath dir modNm <.> "hs" - rewriteFileEx verb loc $ + let + verbosity = mkVerbosity defaultVerbosityHandles verb + loc = getSymbolicPath dir modNm <.> "hs" + rewriteFileEx verbosity loc $ "module " ++ modNm ++ " where {}" ) r1 <- registerRule "r1" $ staticRule - (action ((autogenDir, "A"), verbosity)) + (action ((autogenDir, "A"), verbosityFlags)) [] ( Location autogenDir (makeRelativePathEx "A.hs") NE.:| [] ) registerRule_ "r2" $ - staticRule (action ((autogenDir, "B"), verbosity)) + staticRule (action ((autogenDir, "B"), verbosityFlags)) [ RuleDependency $ RuleOutput r1 7 ] ( Location autogenDir (makeRelativePathEx "B.hs") NE.:| [] ) diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksInvalidRuleOutputIndex/setup.out b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksInvalidRuleOutputIndex/setup.out index 82f5148e9b9..20a2cfaf33d 100644 --- a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksInvalidRuleOutputIndex/setup.out +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksInvalidRuleOutputIndex/setup.out @@ -2,5 +2,5 @@ Configuring setup-hooks-invalid-rule-output-index-test-0.1.0.0... # Setup build Error: [Cabal-1173] -Invalid index '7' in dependency of RuleId {ruleNameSpace = RulesNameSpace {rulesUnitId = UnitId "main", rulesModuleName = ModuleName "SetupHooks", rulesSrcLoc = (20,59)}, ruleName = "r2"}. -The dependency RuleId {ruleNameSpace = RulesNameSpace {rulesUnitId = UnitId "main", rulesModuleName = ModuleName "SetupHooks", rulesSrcLoc = (20,59)}, ruleName = "r1"} only has 1 output. +Invalid index '7' in dependency of RuleId {ruleNameSpace = RulesNameSpace {rulesUnitId = UnitId "main", rulesModuleName = ModuleName "SetupHooks", rulesSrcLoc = (21,59)}, ruleName = "r2"}. +The dependency RuleId {ruleNameSpace = RulesNameSpace {rulesUnitId = UnitId "main", rulesModuleName = ModuleName "SetupHooks", rulesSrcLoc = (21,59)}, ruleName = "r1"} only has 1 output. diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRuleOrdering/SetupHooks.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRuleOrdering/SetupHooks.hs index e15c3ae2ead..5a78716941e 100644 --- a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRuleOrdering/SetupHooks.hs +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRuleOrdering/SetupHooks.hs @@ -10,6 +10,7 @@ import Distribution.Simple.LocalBuildInfo (interpretSymbolicPathLBI) import Distribution.Simple.SetupHooks import Distribution.Simple.Utils ( rewriteFileEx, warn ) import Distribution.Utils.Path +import Distribution.Verbosity import Data.Foldable ( for_ ) import qualified Data.List.NonEmpty as NE ( NonEmpty(..) ) @@ -33,20 +34,21 @@ setupHooks = -- and check that we run them in dependency order, i.e. r2, r1, r3. preBuildRules :: PreBuildComponentInputs -> RulesM () preBuildRules (PreBuildComponentInputs { buildingWhat = what, localBuildInfo = lbi, targetInfo = tgt }) = mdo - let verbosity = buildingWhatVerbosity what + let verbosityFlags = buildingWhatVerbosity what clbi = targetCLBI tgt autogenDir = autogenComponentModulesDir lbi clbi mkAction = - mkCommand (static Dict) $ static (\ (dir, verb, (inMod, outMod)) -> do - warn verb $ "Running rule: " ++ inMod ++ " --> " ++ outMod + mkCommand (static Dict) $ static (\ (dir, verbFlags, (inMod, outMod)) -> do + let verbosity = mkVerbosity defaultVerbosityHandles verbFlags + warn verbosity $ "Running rule: " ++ inMod ++ " --> " ++ outMod let loc = getSymbolicPath dir outMod <.> "hs" - rewriteFileEx verb loc $ + rewriteFileEx verbosity loc $ "module " ++ outMod ++ " where { import " ++ inMod ++ " }" ) actionArg inMod outMod = - (autogenDir, verbosity, (inMod, outMod)) + (autogenDir, verbosityFlags, (inMod, outMod)) mkRule action input outMod = staticRule action diff --git a/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/cabal-with-hpc.multitest.hs b/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/cabal-with-hpc.multitest.hs index 172b48d8c80..8fbd5b87260 100644 --- a/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/cabal-with-hpc.multitest.hs +++ b/cabal-testsuite/PackageTests/TestSuiteTests/ExeV10/cabal-with-hpc.multitest.hs @@ -43,7 +43,7 @@ main = do -- | Checks for a suitable HPC version for testing. correctHpcVersion :: TestM Bool correctHpcVersion = do - let verbosity = Verbosity.normal + let verbosity = Verbosity.mkVerbosity Verbosity.defaultVerbosityHandles Verbosity.normal verRange = orLaterVersion (mkVersion [0,7]) progDB <- testProgramDb `fmap` ask liftIO $ (requireProgramVersion verbosity hpcProgram verRange progDB diff --git a/cabal-testsuite/main/cabal-tests.hs b/cabal-testsuite/main/cabal-tests.hs index 05871ab7190..ce63312a01a 100644 --- a/cabal-testsuite/main/cabal-tests.hs +++ b/cabal-testsuite/main/cabal-tests.hs @@ -8,7 +8,7 @@ import Test.Cabal.Server import Test.Cabal.Monad import Test.Cabal.TestCode -import Distribution.Verbosity (normal, verbose, Verbosity) +import Distribution.Verbosity import Distribution.Simple.Utils (getDirectoryContentsRecursive) import Distribution.Simple.Program import Distribution.Utils.Path (getSymbolicPath) @@ -203,7 +203,9 @@ main = do -- Parse arguments. N.B. 'helper' adds the option `--help`. args <- execParser $ info (mainArgParser <**> helper) mempty - let verbosity = if mainArgVerbose args then verbose else normal + let verbosity = + mkVerbosity defaultVerbosityHandles $ + if mainArgVerbose args then verbose else normal testPattern = Tasty.lookupOption @Tasty.TestPattern (mainTastyArgs args) pkg_dbs <- @@ -242,7 +244,7 @@ main = do dist_dir <- case mainArgDistDir args of Just dist_dir -> return dist_dir Nothing -> getSymbolicPath <$> guessDistDir - when (verbosity >= verbose) $ + when (verbosityLevel verbosity >= Verbose) $ hPutStrLn stderr $ "Using dist dir: " ++ dist_dir -- Get ready to go! senv <- mkScriptEnv verbosity @@ -324,7 +326,7 @@ main = do case mb_work of Nothing -> return () Just path -> do - when (verbosity >= verbose) $ + when (verbosityLevel verbosity >= Verbose) $ logMeta $ "Running " ++ path start <- getTime r <- runTest (runOnServer server) path @@ -432,7 +434,7 @@ outputThread verbosity chan log_handle = go "" ServerLogMsg t msg -> do let ls = lines msg pre s c - | verbosity >= verbose + | verbosityLevel verbosity >= Verbose -- Didn't use printf as GHC 7.4 -- doesn't understand % 7s. = replicate (7 - length s) ' ' ++ s ++ " " ++ c : " " diff --git a/cabal-testsuite/src/Test/Cabal/Monad.hs b/cabal-testsuite/src/Test/Cabal/Monad.hs index eac5cc96b19..f3a8b65a03f 100644 --- a/cabal-testsuite/src/Test/Cabal/Monad.hs +++ b/cabal-testsuite/src/Test/Cabal/Monad.hs @@ -48,6 +48,7 @@ module Test.Cabal.Monad , testStoreDir , testUserCabalConfigFile , testActualFile + , testVerbosity -- * Skipping tests , skip @@ -437,7 +438,7 @@ runTestM mode m = , testCompiler = comp , testCompilerPath = programPath configuredGhcProg , testPackageDBStack = db_stack - , testVerbosity = verbosity + , testVerbosityFlags = verbosityFlags verbosity , testMtimeChangeDelay = Nothing , testScriptEnv = senv , testSetupPath = dist_dir "build" "setup" "setup" @@ -491,7 +492,9 @@ runTestM mode m = _ -> E.throwIO e ) where - verbosity = normal -- TODO: configurable + verbosity = mkVerbosity defaultVerbosityHandles normal + -- TODO: make this configurable by the test-suite driver + cleanup = do env <- getTestEnv onlyIfExists . removeDirectoryRecursiveHack verbosity $ testWorkDir env @@ -584,7 +587,7 @@ withSourceCopy m = do createDirectoryIfMissing True (takeDirectory (dest f)) d <- liftIO $ doesDirectoryExist (curdir f) if d - then copyDirectoryRecursive normal (curdir f) (dest f) + then copyDirectoryRecursive (mkVerbosity defaultVerbosityHandles normal) (curdir f) (dest f) else copyFile (curdir f) (dest f) m @@ -609,7 +612,6 @@ getSourceFiles = do r <- liftIO $ run - (testVerbosity env) (Just $ testSourceDir env) (testEnvironment env) (programPath configured_prog) @@ -719,7 +721,12 @@ mkNormalizerEnv = do case cabalProgM of Nothing -> pure Nothing Just cabalProg -> do - liftIO (findProgramVersion "--numeric-version" id (testVerbosity env) (programPath cabalProg)) + liftIO $ + findProgramVersion + "--numeric-version" + id + (testVerbosity env) + (programPath cabalProg) return NormalizerEnv @@ -769,7 +776,10 @@ requireProgramM program = do env <- getTestEnv (configured_program, _) <- liftIO $ - requireProgram (testVerbosity env) program (testProgramDb env) + requireProgram + (testVerbosity env) + program + (testProgramDb env) return configured_program needProgramM :: String -> TestM (Maybe ConfiguredProgram) @@ -788,7 +798,12 @@ isAvailableProgram program = do Just _ -> return True Nothing -> do -- It might not have been configured. Try to configure. - progdb <- liftIO $ configureProgram (testVerbosity env) program (testProgramDb env) + progdb <- + liftIO $ + configureProgram + (testVerbosity env) + program + (testProgramDb env) case lookupProgram program progdb of Just _ -> return True Nothing -> return False @@ -830,7 +845,7 @@ data TestEnv = TestEnv -- ^ Platform we are running tests on , testPackageDBStack :: PackageDBStackCWD -- ^ Package database stack (actually this changes lol) - , testVerbosity :: Verbosity + , testVerbosityFlags :: VerbosityFlags -- ^ How verbose to be , testMtimeChangeDelay :: Maybe Int -- ^ How long we should 'threadDelay' to make sure the file timestamp is @@ -877,6 +892,9 @@ data TestEnv = TestEnv } deriving (Show) +testVerbosity :: TestEnv -> Verbosity +testVerbosity = mkVerbosity defaultVerbosityHandles . testVerbosityFlags + testRecordMode :: TestEnv -> RecordMode testRecordMode env = fromMaybe (testRecordDefaultMode env) (testRecordUserMode env) diff --git a/cabal-testsuite/src/Test/Cabal/Prelude.hs b/cabal-testsuite/src/Test/Cabal/Prelude.hs index f889135484b..b7b0d6bf077 100644 --- a/cabal-testsuite/src/Test/Cabal/Prelude.hs +++ b/cabal-testsuite/src/Test/Cabal/Prelude.hs @@ -49,7 +49,7 @@ import Distribution.Utils.Path , makeSymbolicPath , relativeSymbolicPath ) -import Distribution.Verbosity (normal) +import Distribution.Verbosity import Distribution.Version import Test.Utils.TempTestDir (withTestDir) @@ -103,7 +103,6 @@ runM' run_dir path args input = do r <- liftIO $ run - (testVerbosity env) run_dir (testEnvironment env) path @@ -183,7 +182,9 @@ setup'' -> TestM Result setup'' prefix cmd args = do env <- getTestEnv - let work_dir = if testRelativeCurrentDir env == "." then Nothing else Just (testRelativeCurrentDir env) + let + verbosity = testVerbosity env + work_dir = if testRelativeCurrentDir env == "." then Nothing else Just (testRelativeCurrentDir env) when ((cmd == "register" || cmd == "copy") && not (testHavePackageDb env)) $ error "Cannot register/copy without using 'withPackageDb'" ghc_path <- programPathM ghcProgram @@ -227,8 +228,8 @@ setup'' prefix cmd args = do -- `cabal` and `Setup.hs` do have different interface. -- let pkgDir = makeSymbolicPath $ testTmpDir env testRelativeCurrentDir env prefix - pdfile <- liftIO $ tryFindPackageDesc (testVerbosity env) (Just pkgDir) - pdesc <- liftIO $ readGenericPackageDescription (testVerbosity env) (Just pkgDir) $ relativeSymbolicPath pdfile + pdfile <- liftIO $ tryFindPackageDesc verbosity (Just pkgDir) + pdesc <- liftIO $ readGenericPackageDescription verbosity (Just pkgDir) $ relativeSymbolicPath pdfile if testCabalInstallAsSetup env then if buildType (packageDescription pdesc) == Simple @@ -1092,7 +1093,6 @@ testCompilerWithArgs args = do r <- liftIO $ run - (testVerbosity env) (Just $ testCurrentDir env) (testEnvironment env) ghc_path @@ -1407,7 +1407,10 @@ copySourceFileTo src dest = do -- The directory must be passed to new- commands with --store-dir. withShorterPathForNewBuildStore :: TestM a -> TestM a withShorterPathForNewBuildStore test = - withTestDir normal "cabal-test-store" (\f -> withStoreDir f test) + withTestDir + (mkVerbosity defaultVerbosityHandles normal) + "cabal-test-store" + (\f -> withStoreDir f test) -- | Find where a package locates in the store dir. This works only if there is exactly one 1 ghc version -- and exactly 1 directory for the given package in the store dir. diff --git a/cabal-testsuite/src/Test/Cabal/Run.hs b/cabal-testsuite/src/Test/Cabal/Run.hs index f5dfb6d7f4a..10e9d02cbbc 100644 --- a/cabal-testsuite/src/Test/Cabal/Run.hs +++ b/cabal-testsuite/src/Test/Cabal/Run.hs @@ -9,7 +9,6 @@ module Test.Cabal.Run ) where import Distribution.Simple.Program.Run -import Distribution.Verbosity import Control.Concurrent.Async import System.Directory @@ -29,26 +28,24 @@ data Result = Result -- | Run a command, streaming its output to stdout, and return a 'Result' -- with this information. run - :: Verbosity - -> Maybe FilePath + :: Maybe FilePath -> [(String, Maybe String)] -> FilePath -> [String] -> Maybe String -> IO Result -run verbosity mb_cwd env_overrides path0 args input = - runAction verbosity mb_cwd env_overrides path0 args input (\_ -> return ()) +run mb_cwd env_overrides path0 args input = + runAction mb_cwd env_overrides path0 args input (\_ -> return ()) runAction - :: Verbosity - -> Maybe FilePath + :: Maybe FilePath -> [(String, Maybe String)] -> FilePath -> [String] -> Maybe String -> (ProcessHandle -> IO ()) -> IO Result -runAction _verbosity mb_cwd env_overrides path0 args input action = do +runAction mb_cwd env_overrides path0 args input action = do -- In our test runner, we allow a path to be relative to the -- current directory using the same heuristic as shells: -- 'foo' refers to an executable in the PATH, but './foo' diff --git a/cabal-testsuite/src/Test/Cabal/Script.hs b/cabal-testsuite/src/Test/Cabal/Script.hs index 3f86bfc082d..d0ef37cf5c2 100644 --- a/cabal-testsuite/src/Test/Cabal/Script.hs +++ b/cabal-testsuite/src/Test/Cabal/Script.hs @@ -34,7 +34,7 @@ import qualified Data.Monoid as M data ScriptEnv = ScriptEnv { runnerProgramDb :: ProgramDb , runnerPackageDbStack :: PackageDBStackCWD - , runnerVerbosity :: Verbosity + , runnerVerbosity :: VerbosityFlags , runnerPlatform :: Platform , runnerCompiler :: Compiler , runnerPackages :: [(OpenUnitId, ModuleRenaming)] @@ -59,7 +59,7 @@ mkScriptEnv :: Verbosity -> IO ScriptEnv mkScriptEnv verbosity = return $ ScriptEnv - { runnerVerbosity = verbosity + { runnerVerbosity = verbosityFlags verbosity , runnerProgramDb = lbiProgramDb , runnerPackageDbStack = lbiPackageDbStack , runnerPlatform = lbiPlatform @@ -80,7 +80,7 @@ runghc -> IO Result runghc senv mb_cwd env_overrides script_path args = do (real_path, real_args) <- runnerCommand senv mb_cwd env_overrides script_path args - run (runnerVerbosity senv) mb_cwd env_overrides real_path real_args Nothing + run mb_cwd env_overrides real_path real_args Nothing -- | Compute the command line which should be used to run a Haskell -- script with 'runghc'. @@ -98,7 +98,7 @@ runnerCommand senv mb_cwd _env_overrides script_path args = do , runghc_args ++ ["--"] ++ map ("--ghc-arg=" ++) ghc_args ++ [script_path] ++ args ) where - verbosity = runnerVerbosity senv + verbosity = mkVerbosity defaultVerbosityHandles $ runnerVerbosity senv runghc_args = [] ghc_args = runnerGhcArgs senv mb_cwd diff --git a/cabal-testsuite/src/Test/Cabal/Server.hs b/cabal-testsuite/src/Test/Cabal/Server.hs index bf396703190..9ec675c07ca 100644 --- a/cabal-testsuite/src/Test/Cabal/Server.hs +++ b/cabal-testsuite/src/Test/Cabal/Server.hs @@ -240,7 +240,7 @@ startServer chan senv = do , std_out = CreatePipe , std_err = CreatePipe } - when (verbosity >= verbose) $ + when (verbosityLevel verbosity >= Verbose) $ writeChan chan (ServerLogMsg AllServers (showCommandForUser (programPath prog) ghc_args)) (Just hin, Just hout, Just herr, proch) <- createProcess proc_spec out_acc <- newMVar [] @@ -259,7 +259,7 @@ startServer chan senv = do , serverScriptEnv = senv } where - verbosity = runnerVerbosity senv + verbosity = mkVerbosity defaultVerbosityHandles $ runnerVerbosity senv -- | Unmasked initialization for the server initServer :: Server -> IO Server @@ -360,7 +360,7 @@ stopServer s = do Left () -> "GHCi was forcibly terminated" Right exit -> "GHCi exited with " ++ show exit ) - ++ if verbosity < verbose + ++ if vLevel verbosity < Verbose then " (use -v for more information)" else "" else log ServerOut s rest_out @@ -387,7 +387,7 @@ ignore m = withAsync m $ \a -> void (waitCatch a) log :: (ProcessId -> ServerLogMsgType) -> Server -> String -> IO () log ctor s msg = - when (verbosity >= verbose) $ info ctor s msg + when (vLevel verbosity >= Verbose) $ info ctor s msg where verbosity = runnerVerbosity (serverScriptEnv s) diff --git a/changelog.d/pr-11077 b/changelog.d/pr-11077 new file mode 100644 index 00000000000..888b600c80d --- /dev/null +++ b/changelog.d/pr-11077 @@ -0,0 +1,97 @@ +--- +synopsis: Cabal library support for logging handles +packages: [Cabal] +prs: 11077 +issues: 9987 +significance: significant +--- + +The Cabal library now supports setting the handles used for logging, as +opposed to always using stdout & stderr. + +To achieve this, the `Verbosity` data type has been modified: + + 1. The old `Verbosity` data type is now `VerbosityFlags`. This consists of + verbosity & logging information that can be passed via the command-line + interface. + 2. The new `Verbosity` data type consists of `VerbosityFlags` together with + `VerbosityHandles`, which store the handles used for logging. + As `Handle`s cannot be serialised, neither can we serialise this new + `Verbosity`. + +The end result is that functions such as `createDirectoryIfMissingVerbose` or +`runProgramInvocation`, which take a `Verbosity` argument, now support logging +to arbitrary handles. Their type signature remains textually unchanged, as it is +the `Verbosity` type itself that has changed. + +Several additional changes have been made in relation to the `VerbosityFlags` +data type (which, recall, is what `Verbosity` used to be): + + 1. The `Ord` instance of `VerbosityFlags` has been removed. To compare + verbosity levels, use the `Ord` instance on `VerbosityLevel` via + `verbosityLevel :: Verbosity -> VerbosityLevel`. + 2. The `Eq` instance of `VerbosityFlags` now takes into account all the fields, + and not only the verbosity level. + 3. The `Enum` and `Bounded` instances of `VerbosityFlags` have been removed. + If you were using these, you might want to consider using the `Enum` and + `Bounded` instances of `VerbosityLevel` instead, in conjunction with + the new function `mkVerbosityFlags :: VerbosityLevel -> VerbosityFlags`. + +In addition, the `modifyVerbosity` function has been removed. It allowed +arbitrarily changing the verbosity level, which is undesirable in general (e.g. +in practice one wants the "silent" verbosity level to remain "silent"). To +migrate, one should instead use the existing `moreVerbose`, `lessVerbose` +combinators, or the new `makeVerbose` function which turns "normal" verbosity +into "verbose" verbosity. + + +Users of the command-line interface do not substantially benefit from this +change, as the logging handles continue to be set for the spawned process, e.g. + +```hs + Process.createProcess $ + (Process.proc ...) + { Process.std_out = customHandle1, Process.std_err = customHandle2 } +``` + +To migrate custom `Setup` scripts and `SetupHooks` hooks, in the typical +situation in which one retrieves the verbosity from flags (such as `ConfigFlags` +or `BuildFlags`), one can define the following compatibility helper: + +```hs +mkVerbosityCompat + :: +#if MIN_VERSION_Cabal(3,17,0) + Flag VerbosityFlags +#else + Flag Verbosity +#endif + -> Verbosity +mkVerbosityCompat v = +#if MIN_VERSION_Cabal(3,17,0) + mkVerbosity defaultVerbosityHandles $ +#endif + fromFlag v +``` + +This means that code such as: + +```hs +doSomething :: BuildFlags -> IO () +doSomething flags = do + let verbosity = fromFlag $ buildVerbosity flags + createDirectoryIfMissingVerbose verbosity True dir + runProgramInvocation verbosity prog + ... +``` + +will become: + +```hs +doSomething :: BuildFlags -> IO () +doSomething flags = do + let verbosity = mkVerbosityCompat $ buildVerbosity flags + createDirectoryIfMissingVerbose verbosity True dir + runProgramInvocation verbosity prog + ... +```