[RFC] Support for entering/leaving annotations and concurrent log linearization

cabal-install/cabal-install.cabal

@@ -159,6 +159,7 @@ executable cabal
         Distribution.Client.ProjectConfig.Legacy
         Distribution.Client.ProjectConfig.Types
         Distribution.Client.ProjectFlags
+        Distribution.Client.ProjectLogging
         Distribution.Client.ProjectOrchestration
         Distribution.Client.ProjectPlanOutput
         Distribution.Client.ProjectPlanning

cabal-install/cabal-install.cabal.dev

@@ -151,6 +151,7 @@ library cabal-lib-client
         Distribution.Client.ProjectConfig.Legacy
         Distribution.Client.ProjectConfig.Types
         Distribution.Client.ProjectFlags
+        Distribution.Client.ProjectLogging
         Distribution.Client.ProjectOrchestration
         Distribution.Client.ProjectPlanOutput
         Distribution.Client.ProjectPlanning

cabal-install/cabal-install.cabal.prod

@@ -159,6 +159,7 @@ executable cabal
         Distribution.Client.ProjectConfig.Legacy
         Distribution.Client.ProjectConfig.Types
         Distribution.Client.ProjectFlags
+        Distribution.Client.ProjectLogging
         Distribution.Client.ProjectOrchestration
         Distribution.Client.ProjectPlanOutput
         Distribution.Client.ProjectPlanning

cabal-install/cabal-install.cabal.zinza

@@ -170,6 +170,7 @@ Version:            3.5.0.0
         Distribution.Client.ProjectConfig.Legacy
         Distribution.Client.ProjectConfig.Types
         Distribution.Client.ProjectFlags
+        Distribution.Client.ProjectLogging
         Distribution.Client.ProjectOrchestration
         Distribution.Client.ProjectPlanOutput
         Distribution.Client.ProjectPlanning

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

@@ -218,6 +218,8 @@ configureSetupScript packageDBs
     , useDependenciesExclusive = not defaultSetupDeps && isJust explicitSetupDeps
     , useVersionMacros         = not defaultSetupDeps && isJust explicitSetupDeps
     , isInteractive            = False
+    , processCloseHandle       = True
+    , processCloseFds          = False
     }
   where
     -- When we are compiling a legacy setup script without an explicit

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

@@ -6,6 +6,8 @@
 {-# LANGUAGE RecordWildCards     #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeFamilies        #-}
+{-# LANGUAGE TupleSections       #-}
+{-# LANGUAGE NondecreasingIndentation #-}
 
 -- |
 --
@@ -47,6 +49,7 @@ import           Distribution.Client.ProjectConfig
 import           Distribution.Client.ProjectPlanning
 import           Distribution.Client.ProjectPlanning.Types
 import           Distribution.Client.ProjectBuilding.Types
+import           Distribution.Client.ProjectLogging
 import           Distribution.Client.Store
 
 import           Distribution.Client.Types
@@ -98,10 +101,12 @@ import qualified Data.Set as Set
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Lazy as LBS
 
-import Control.Exception (Handler (..), SomeAsyncException, assert, catches, handle)
+import Control.Exception (Handler (..), SomeAsyncException, assert, catches, handle, bracket_)
+-- import Control.Exception (Exception (..), Handler (..), SomeAsyncException, SomeException, assert, catches, handle, throwIO, bracket_)
+-- import Data.Function     (on)
 import System.Directory  (canonicalizePath, createDirectoryIfMissing, doesDirectoryExist, doesFileExist, removeFile, renameDirectory)
 import System.FilePath   (dropDrive, makeRelative, normalise, takeDirectory, (<.>), (</>))
-import System.IO         (IOMode (AppendMode), withFile)
+import System.IO         (hPutStrLn, stdout)
 
 import Distribution.Compat.Directory (listDirectory)
 
@@ -569,6 +574,8 @@ rebuildTargets verbosity
     cacheLock     <- newLock -- serialise access to setup exe cache
                              --TODO: [code cleanup] eliminate setup exe cache
 
+    logHandleMap  <- newLogHandleMap pkgsBuildStatus installPlan
+
     debug verbosity $
         "Executing install plan "
      ++ if isParallelBuild
@@ -592,10 +599,14 @@ rebuildTargets verbosity
         handle (\(e :: BuildFailure) -> return (Left e)) $ fmap Right $
 
         let uid = installedUnitId pkg
-            pkgBuildStatus = Map.findWithDefault (error "rebuildTargets") uid pkgsBuildStatus in
+            look = Map.findWithDefault (error "rebuildTargets uid not found")
+            pkgBuildStatus = look uid pkgsBuildStatus
+            logHandle = look uid logHandleMap
+        in
 
         rebuildTarget
           verbosity
+          logHandle
           distDirLayout
           storeDirLayout
           buildSettings downloadMap
@@ -635,6 +646,7 @@ createPackageDBIfMissing _ _ _ _ = return ()
 -- | Given all the context and resources, (re)build an individual package.
 --
 rebuildTarget :: Verbosity
+              -> LogHandle
               -> DistDirLayout
               -> StoreDirLayout
               -> BuildTimeSettings
@@ -646,6 +658,7 @@ rebuildTarget :: Verbosity
               -> BuildStatus
               -> IO BuildResult
 rebuildTarget verbosity
+              logHandle
               distDirLayout@DistDirLayout{distBuildDirectory}
               storeDirLayout
               buildSettings downloadMap
@@ -702,7 +715,7 @@ rebuildTarget verbosity
 
     buildAndInstall srcdir builddir =
         buildAndInstallUnpackedPackage
-          verbosity distDirLayout storeDirLayout
+          verbosity logHandle distDirLayout storeDirLayout
           buildSettings registerLock cacheLock
           sharedPackageConfig
           plan rpkg
@@ -714,7 +727,7 @@ rebuildTarget verbosity
     buildInplace buildStatus srcdir builddir =
         --TODO: [nice to have] use a relative build dir rather than absolute
         buildInplaceUnpackedPackage
-          verbosity distDirLayout
+          verbosity logHandle distDirLayout
           buildSettings registerLock cacheLock
           sharedPackageConfig
           plan rpkg
@@ -899,6 +912,7 @@ moveTarballShippedDistDirectory verbosity DistDirLayout{distBuildDirectory}
 
 
 buildAndInstallUnpackedPackage :: Verbosity
+                               -> LogHandle
                                -> DistDirLayout
                                -> StoreDirLayout
                                -> BuildTimeSettings -> Lock -> Lock
@@ -908,6 +922,7 @@ buildAndInstallUnpackedPackage :: Verbosity
                                -> FilePath -> FilePath
                                -> IO BuildResult
 buildAndInstallUnpackedPackage verbosity
+                               logHandle
                                distDirLayout@DistDirLayout{distTempDirectory}
                                storeDirLayout@StoreDirLayout {
                                  storePackageDBStack
@@ -926,7 +941,18 @@ buildAndInstallUnpackedPackage verbosity
                                srcdir builddir = do
 
     createDirectoryIfMissingVerbose verbosity True (srcdir </> builddir)
-    initLogFile
+
+    bracket_ initLogFile closeLogFile $ do
+
+    let
+        entering = withLogging $ \mLogFileHandle -> do
+          let hdl = fromMaybe stdout mLogFileHandle
+          hPutStrLn hdl $ "Entering directory '" ++ srcdir ++ "'"
+        leaving  = withLogging $ \mLogFileHandle -> do
+          let hdl = fromMaybe stdout mLogFileHandle
+          hPutStrLn hdl $ "Leaving directory '" ++ srcdir ++ "'"
+
+    bracket_ entering leaving $ do
 
     --TODO: [code cleanup] deal consistently with talking to older
     --      Setup.hs versions, much like we do for ghc, with a proper
@@ -1118,6 +1144,8 @@ buildAndInstallUnpackedPackage verbosity
           verbosity
           scriptOptions
             { useLoggingHandle     = mLogFileHandle
+            , processCloseHandle   = False
+            , processCloseFds      = True
             , useExtraEnvOverrides = dataDirsEnvironmentForPlan
                                      distDirLayout plan }
           (Just (elabPkgDescription pkg))
@@ -1136,11 +1164,17 @@ buildAndInstallUnpackedPackage verbosity
           createDirectoryIfMissing True (takeDirectory logFile)
           exists <- doesFileExist logFile
           when exists $ removeFile logFile
+          openLogHandle logHandle logFile stdout
+
+    closeLogFile =
+      case mlogFile of
+        Nothing -> return ()
+        Just _ -> closeLogHandle logHandle
 
     withLogging action =
       case mlogFile of
-        Nothing      -> action Nothing
-        Just logFile -> withFile logFile AppendMode (action . Just)
+        Nothing -> action Nothing
+        Just _  -> withLogHandle logHandle (action . Just)
 
 
 hasValidHaddockTargets :: ElaboratedConfiguredPackage -> Bool
@@ -1165,6 +1199,7 @@ hasValidHaddockTargets ElaboratedConfiguredPackage{..}
 
 
 buildInplaceUnpackedPackage :: Verbosity
+                            -> LogHandle
                             -> DistDirLayout
                             -> BuildTimeSettings -> Lock -> Lock
                             -> ElaboratedSharedConfig
@@ -1174,14 +1209,19 @@ buildInplaceUnpackedPackage :: Verbosity
                             -> FilePath -> FilePath
                             -> IO BuildResult
 buildInplaceUnpackedPackage verbosity
+                            logHandle
                             distDirLayout@DistDirLayout {
                               distTempDirectory,
                               distPackageCacheDirectory,
                               distDirectory
                             }
-                            BuildTimeSettings{buildSettingNumJobs}
+                            BuildTimeSettings {
+                              buildSettingNumJobs,
+                              buildSettingLogFile
+                            }
                             registerLock cacheLock
                             pkgshared@ElaboratedSharedConfig {
+                              pkgConfigPlatform      = platform,
                               pkgConfigCompiler      = compiler,
                               pkgConfigCompilerProgs = progdb
                             }
@@ -1197,6 +1237,18 @@ buildInplaceUnpackedPackage verbosity
         createDirectoryIfMissingVerbose verbosity True
           (distPackageCacheDirectory dparams)
 
+        bracket_ initLogFile closeLogFile $ do
+
+        let
+            entering = withLogging $ \mLogFileHandle -> do
+              let hdl = fromMaybe stdout mLogFileHandle
+              hPutStrLn hdl $ "Entering directory '" ++ srcdir ++ "'"
+            leaving  = withLogging $ \mLogFileHandle -> do
+              let hdl = fromMaybe stdout mLogFileHandle
+              hPutStrLn hdl $ "Leaving directory '" ++ srcdir ++ "'"
+
+        bracket_ entering leaving $ do
+
         -- Configure phase
         --
         whenReConfigure $ do
@@ -1399,10 +1451,15 @@ buildInplaceUnpackedPackage verbosity
     setup :: CommandUI flags -> (Version -> flags) -> (Version -> [String])
           -> IO ()
     setup cmd flags args =
-      setupWrapper verbosity
-                   scriptOptions
-                   (Just (elabPkgDescription pkg))
-                   cmd flags args
+      withLogging $ \mLogFileHandle ->
+        setupWrapper
+          verbosity
+          scriptOptions { useLoggingHandle = mLogFileHandle
+                        , processCloseHandle = False
+                        , processCloseFds    = True
+                        }
+          (Just (elabPkgDescription pkg))
+          cmd flags args
 
     generateInstalledPackageInfo :: IO InstalledPackageInfo
     generateInstalledPackageInfo =
@@ -1414,6 +1471,34 @@ buildInplaceUnpackedPackage verbosity
                                 pkgConfDest
         setup Cabal.registerCommand registerFlags (const [])
 
+    pkgid  = packageId rpkg
+    uid    = installedUnitId rpkg
+
+    mlogFile :: Maybe FilePath
+    mlogFile =
+      case buildSettingLogFile of
+        Nothing        -> Nothing
+        Just mkLogFile -> Just (mkLogFile compiler platform pkgid uid)
+
+    initLogFile =
+      case mlogFile of
+        Nothing      -> return ()
+        Just logFile -> do
+          createDirectoryIfMissing True (takeDirectory logFile)
+          exists <- doesFileExist logFile
+          when exists $ removeFile logFile
+          openLogHandle logHandle logFile stdout
+
+    closeLogFile =
+      case mlogFile of
+        Nothing -> return ()
+        Just _ -> closeLogHandle logHandle
+
+    withLogging action =
+      case mlogFile of
+        Nothing -> action Nothing
+        Just _  -> withLogHandle logHandle (action . Just)
+
 withTempInstalledPackageInfoFile :: Verbosity -> FilePath
                                   -> (FilePath -> IO ())
                                   -> IO InstalledPackageInfo