From c44cb87f0f291261447d4c943f2469b4d954d1e0 Mon Sep 17 00:00:00 2001 From: Fendor Date: Thu, 8 Jul 2021 16:37:42 +0200 Subject: [PATCH] WIP: use cache file for generating jsons while building --- .../Distribution/Client/CmdShowBuildInfo.hs | 32 ++++++++-------- .../Distribution/Client/ProjectBuilding.hs | 37 ++++++++++--------- 2 files changed, 37 insertions(+), 32 deletions(-) diff --git a/cabal-install/src/Distribution/Client/CmdShowBuildInfo.hs b/cabal-install/src/Distribution/Client/CmdShowBuildInfo.hs index bc160293153..9c3ac1ab0ce 100644 --- a/cabal-install/src/Distribution/Client/CmdShowBuildInfo.hs +++ b/cabal-install/src/Distribution/Client/CmdShowBuildInfo.hs @@ -8,7 +8,7 @@ module Distribution.Client.CmdShowBuildInfo ( ) where import Distribution.Client.Compat.Prelude - ( catMaybes ) + ( catMaybes, for ) import Distribution.Client.ProjectOrchestration import Distribution.Client.CmdErrorMessages import Distribution.Client.TargetProblem @@ -32,7 +32,7 @@ import Distribution.Client.ProjectPlanning.Types import Distribution.Client.NixStyleOptions ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags ) import Distribution.Client.DistDirLayout - ( distProjectRootDirectory ) + ( distProjectRootDirectory, DistDirLayout (distProjectCacheDirectory) ) import Distribution.Simple.ShowBuildInfo import Distribution.Utils.Json @@ -40,6 +40,8 @@ import Distribution.Utils.Json import Data.Either import qualified Data.Text as T import qualified Data.Text.IO as T +import System.FilePath +import Distribution.Types.UnitId (unUnitId) showBuildInfoCommand :: CommandUI (NixStyleFlags ShowBuildInfoFlags) showBuildInfoCommand = CommandUI { @@ -108,13 +110,13 @@ showBuildInfoAction flags@NixStyleFlags { extraFlags = (ShowBuildInfoFlags fileO buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes - -- We can ignore the errors here, since runProjectPostBuildPhase should - -- have already died and reported them if they exist - let (_errs, buildResults) = partitionEithers $ Map.elems buildOutcomes - - let componentBuildInfos = - concatMap T.lines $ -- Component infos are returned each on a newline - catMaybes (buildResultBuildInfo <$> buildResults) + let tm = targetsMap buildCtx + let units = Map.keys tm + let layout = distDirLayout baseCtx + let dir = distProjectCacheDirectory layout "buildinfo" + componentBuildInfos <- for units $ \unit -> do + let fp = dir (unUnitId unit) <.> "json" + T.strip <$> T.readFile fp let compilerInfo = mkCompilerInfo (pkgConfigCompilerProgs (elaboratedShared buildCtx)) @@ -135,12 +137,12 @@ showBuildInfoAction flags@NixStyleFlags { extraFlags = (ShowBuildInfoFlags fileO -- Default to silent verbosity otherwise it will pollute our json output verbosity = fromFlagOrDefault silent (configVerbosity configFlags) -- Also shut up haddock since it dumps warnings to stdout - flags' = flags { haddockFlags = haddockFlags { haddockVerbosity = Flag silent } - , configFlags = configFlags { Cabal.configTests = Flag True - , Cabal.configBenchmarks = Flag True - } - } - cliConfig = commandLineFlagsToProjectConfig globalFlags flags' + -- flags' = flags { haddockFlags = haddockFlags { haddockVerbosity = Flag silent } + -- , configFlags = configFlags { Cabal.configTests = Flag True + -- , Cabal.configBenchmarks = Flag True + -- } + -- } + cliConfig = commandLineFlagsToProjectConfig globalFlags flags mempty -- ClientInstallFlags, not needed here -- | This defines what a 'TargetSelector' means for the @show-build-info@ command. diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding.hs b/cabal-install/src/Distribution/Client/ProjectBuilding.hs index d48e299f1c9..7d3a494bd5b 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding.hs @@ -1193,6 +1193,7 @@ buildInplaceUnpackedPackage :: Verbosity buildInplaceUnpackedPackage verbosity distDirLayout@DistDirLayout { distTempDirectory, + distProjectCacheDirectory, distPackageCacheDirectory, distDirectory } @@ -1206,7 +1207,6 @@ buildInplaceUnpackedPackage verbosity rpkg@(ReadyPackage pkg) buildStatus srcdir builddir = do - --TODO: [code cleanup] there is duplication between the -- distdirlayout and the builddir here builddir is not -- enough, we also need the per-package cachedir @@ -1261,6 +1261,16 @@ buildInplaceUnpackedPackage verbosity | otherwise -> listSimple + -- Write the json to a temporary file to read it, since stdout can get + -- cluttered + let dir = distProjectCacheDirectory "buildinfo" + let fp = dir (unUnitId $ elabUnitId pkg) <.> "json" + createDirectoryIfMissing True dir + setupInteractive + buildInfoCommand + (\v -> (buildInfoFlags v) { Cabal.buildInfoOutputFile = Just fp }) + buildInfoArgs + let dep_monitors = map monitorFileHashed $ elabInplaceDependencyBuildCacheFiles distDirLayout pkgshared plan pkg @@ -1301,7 +1311,7 @@ buildInplaceUnpackedPackage verbosity -- whenRepl $ annotateFailureNoLog ReplFailed $ - setupInteractive replCommand replFlags replArgs + setupInteractive replCommand replFlags replArgs -- Haddock phase whenHaddock $ @@ -1317,22 +1327,14 @@ buildInplaceUnpackedPackage verbosity notice verbosity $ "Documentation tarball created: " ++ dest -- Build info phase - buildInfo <- whenBuildInfo $ - -- Write the json to a temporary file to read it, since stdout can get - -- cluttered - withTempDirectory verbosity distTempDirectory "build-info" $ \dir -> do - let fp = dir "out" - setupInteractive - buildInfoCommand - (\v -> (buildInfoFlags v) { Cabal.buildInfoOutputFile = Just fp }) - buildInfoArgs - Just <$> T.readFile fp + -- buildInfo <- whenBuildInfo $ + return BuildResult { buildResultDocs = docsResult, buildResultTests = testsResult, buildResultLogFile = Nothing, - buildResultBuildInfo = buildInfo + buildResultBuildInfo = Nothing } where @@ -1351,7 +1353,8 @@ buildInplaceUnpackedPackage verbosity | null (elabBuildTargets pkg) -- NB: we have to build the test/bench suite! , null (elabTestTargets pkg) - , null (elabBenchTargets pkg) = return () + , null (elabBenchTargets pkg) + , null (elabBuildInfoTargets pkg) = return () | otherwise = action whenTest action @@ -1370,9 +1373,9 @@ buildInplaceUnpackedPackage verbosity | hasValidHaddockTargets pkg = action | otherwise = return () - whenBuildInfo action - | null (elabBuildInfoTargets pkg) = return Nothing - | otherwise = action + -- whenBuildInfo action + -- | null (elabBuildInfoTargets pkg) = return Nothing + -- | otherwise = action whenReRegister action = case buildStatus of