Cache show-build-info results in cache directory

haskell · Jul 12, 2021 · d0471c2 · d0471c2
1 parent 8cfd8b8
commit d0471c2
Show file tree

Hide file tree

Showing 3 changed files with 34 additions and 34 deletions.
diff --git a/cabal-install/src/Distribution/Client/CmdBench.hs b/cabal-install/src/Distribution/Client/CmdBench.hs
@@ -118,7 +118,7 @@ benchAction flags@NixStyleFlags {..} targetStrings globalFlags = do
     runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes
   where
     verbosity = fromFlagOrDefault normal (configVerbosity configFlags)
-    cliConfig = commandLineFlagsToProjectConfig globalFlags flags 
+    cliConfig = commandLineFlagsToProjectConfig globalFlags flags
                   mempty -- ClientInstallFlags, not needed here
 
 -- | This defines what a 'TargetSelector' means for the @bench@ command.

diff --git 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 )
+         ( for )
 import Distribution.Client.ProjectOrchestration
 import Distribution.Client.CmdErrorMessages
 
@@ -17,7 +17,7 @@ import Distribution.Client.Setup
 import Distribution.Client.TargetProblem
          ( TargetProblem', TargetProblem (TargetProblemNoneEnabled, TargetProblemNoTargets) )
 import Distribution.Simple.Setup
-         (Flag(..), haddockVerbosity, configVerbosity, fromFlagOrDefault )
+         ( configVerbosity, fromFlagOrDefault )
 import Distribution.Simple.Command
          ( CommandUI(..), option, reqArg', usageAlternatives )
 import Distribution.Verbosity
@@ -26,20 +26,19 @@ import Distribution.Simple.Utils
          ( wrapText )
 
 import qualified Data.Map as Map
-import qualified Distribution.Simple.Setup as Cabal
-import Distribution.Client.ProjectBuilding.Types
 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
 
-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 +107,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 +134,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
@@ -97,7 +97,6 @@ import qualified Data.Map as Map
 import qualified Data.Set as Set
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Lazy as LBS
-import qualified Data.Text.IO as T
 
 import Control.Exception (Handler (..), SomeAsyncException, assert, catches, handle)
 import System.Directory  (canonicalizePath, createDirectoryIfMissing, doesDirectoryExist, doesFileExist, removeFile, renameDirectory)
@@ -1193,6 +1192,7 @@ buildInplaceUnpackedPackage :: Verbosity
 buildInplaceUnpackedPackage verbosity
                             distDirLayout@DistDirLayout {
                               distTempDirectory,
+                              distProjectCacheDirectory,
                               distPackageCacheDirectory,
                               distDirectory
                             }
@@ -1206,7 +1206,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
@@ -1301,7 +1300,7 @@ buildInplaceUnpackedPackage verbosity
         --
         whenRepl $
           annotateFailureNoLog ReplFailed $
-          setupInteractive replCommand replFlags replArgs
+            setupInteractive replCommand replFlags replArgs
 
         -- Haddock phase
         whenHaddock $
@@ -1317,22 +1316,23 @@ buildInplaceUnpackedPackage verbosity
               notice verbosity $ "Documentation tarball created: " ++ dest
 
         -- Build info phase
-        buildInfo <- whenBuildInfo $
+        {- buildInfo <- -}
+        whenBuildInfo $ do
           -- 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
+          let dir = distProjectCacheDirectory </> "buildinfo"
+          let fp = dir </> (unUnitId $ elabUnitId pkg) <.> "json"
+          createDirectoryIfMissing True dir
+          setupInteractive
+            buildInfoCommand
+            (\v -> (buildInfoFlags v) { Cabal.buildInfoOutputFile = Just fp })
+            buildInfoArgs
 
         return BuildResult {
           buildResultDocs    = docsResult,
           buildResultTests   = testsResult,
           buildResultLogFile = Nothing,
-          buildResultBuildInfo = buildInfo
+          buildResultBuildInfo = Nothing
         }
 
   where
@@ -1351,7 +1351,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
@@ -1371,7 +1372,7 @@ buildInplaceUnpackedPackage verbosity
       | otherwise                  = return ()
 
     whenBuildInfo action
-      | null (elabBuildInfoTargets pkg) = return Nothing
+      | null (elabBuildInfoTargets pkg) = return ()
       | otherwise                       = action
 
     whenReRegister  action