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.

Author: sheaf

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

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"]

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')

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

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)
     ]

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
 

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,15 +67,15 @@ 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
       print (resOutput, resErrors, resExitCode)
 
       -- 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

Cabal-tests/tests/UnitTests/Distribution/Utils/Structured.hs

@@ -33,4 +33,4 @@ md5CheckGenericPackageDescription proxy = md5Check proxy
 
 md5CheckLocalBuildInfo :: Proxy LocalBuildInfo -> Assertion
 md5CheckLocalBuildInfo proxy = md5Check proxy
-    0xea86b170fa32ac289cbd1fb6174b5cbf
+    0xaa3a1e323dbdc3a8a881f84f5a0468fa

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 #-}
 
 {-
@@ -335,7 +336,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

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.fromFlag $ 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.fromFlag $ 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.fromFlag $ 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