WIP: use cache file for generating jsons while building

haskell · Jul 8, 2021 · bebb70e · bebb70e
1 parent 6ce880c
commit bebb70e
Show file tree

Hide file tree

Showing 2 changed files with 37 additions and 32 deletions.
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 )
+         ( catMaybes, for )
 import Distribution.Client.ProjectOrchestration
 import Distribution.Client.CmdErrorMessages
 import Distribution.Client.TargetProblem
@@ -32,14 +32,16 @@ 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 +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
@@ -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