Rework show-build-info command to avoid wrapper

This means that cabal-install now extracts the LocalBuildInfo etc. itself for each component, and now assembles the JSON without the need for writing to temporary files. It also means that one build info JSON object can be returned instead of an array. It works by configuring each component separately as before, and instead of making its own build info object, it just collects the component information. This one build info object now reports the compiler used with the ElaboratedSharedConfig, which is shared across all components.
haskell · Jun 3, 2020 · de2a4d6 · de2a4d6
1 parent 9ea9b57
commit de2a4d6
Show file tree

Hide file tree

Showing 17 changed files with 169 additions and 211 deletions.
diff --git a/Cabal/Cabal.cabal b/Cabal/Cabal.cabal
@@ -506,6 +506,7 @@ library
     Distribution.Utils.NubList
     Distribution.Utils.ShortText
     Distribution.Utils.Progress
+    Distribution.Utils.Json
     Distribution.Verbosity
     Distribution.Verbosity.Internal
     Distribution.Version
@@ -585,7 +586,6 @@ library
     Distribution.Simple.GHC.EnvironmentParser
     Distribution.Simple.GHC.Internal
     Distribution.Simple.GHC.ImplInfo
-    Distribution.Simple.Utils.Json
     Distribution.ZinzaPrelude
     Paths_Cabal
 
@@ -665,7 +665,7 @@ test-suite unit-tests
     Distribution.Described
     Distribution.Utils.CharSet
     Distribution.Utils.GrammarRegex
-    
+
   main-is: UnitTests.hs
   build-depends:
     array,

diff --git a/Cabal/Distribution/Simple/Build.hs b/Cabal/Distribution/Simple/Build.hs
@@ -31,6 +31,7 @@ module Distribution.Simple.Build (
 import Prelude ()
 import Distribution.Compat.Prelude
 import Distribution.Utils.Generic
+import Distribution.Utils.Json
 
 import Distribution.Types.ComponentLocalBuildInfo
 import Distribution.Types.ComponentRequestedSpec
@@ -76,7 +77,6 @@ import Distribution.Simple.Configure
 import Distribution.Simple.Register
 import Distribution.Simple.Test.LibV09
 import Distribution.Simple.Utils
-import Distribution.Simple.Utils.Json
 
 import Distribution.System
 import Distribution.Pretty

diff --git a/Cabal/Distribution/Simple/ShowBuildInfo.hs b/Cabal/Distribution/Simple/ShowBuildInfo.hs
@@ -54,7 +54,8 @@
 -- Note: At the moment this is only supported when using the GHC compiler.
 --
 
-module Distribution.Simple.ShowBuildInfo (mkBuildInfo) where
+module Distribution.Simple.ShowBuildInfo
+  ( mkBuildInfo, mkBuildInfo', mkCompilerInfo, mkComponentInfo ) where
 
 import Distribution.Compat.Prelude
 import Prelude ()
@@ -70,7 +71,7 @@ import Distribution.Simple.LocalBuildInfo
 import Distribution.Simple.Program
 import Distribution.Simple.Setup
 import Distribution.Simple.Utils (cabalVersion)
-import Distribution.Simple.Utils.Json
+import Distribution.Utils.Json
 import Distribution.Types.TargetInfo
 import Distribution.Text
 import Distribution.Pretty
@@ -83,63 +84,69 @@ mkBuildInfo
   -> BuildFlags          -- ^ Flags that the user passed to build
   -> [TargetInfo]
   -> Json
-mkBuildInfo pkg_descr lbi _flags targetsToBuild = info
-  where
-    targetToNameAndLBI target =
-      (componentLocalName $ targetCLBI target, targetCLBI target)
-    componentsToBuild = map targetToNameAndLBI targetsToBuild
-    (.=) :: String -> Json -> (String, Json)
-    k .= v = (k, v)
+mkBuildInfo pkg_descr lbi _flags targetsToBuild =
+  mkBuildInfo' (mkCompilerInfo (withPrograms lbi) (compiler lbi))
+               (map (mkComponentInfo pkg_descr lbi . targetCLBI) targetsToBuild)
 
-    info = JsonObject
-      [ "cabal-version" .= JsonString (display cabalVersion)
-      , "compiler"      .= mkCompilerInfo
-      , "components"    .= JsonArray (map mkComponentInfo componentsToBuild)
-      ]
+-- | A variant of 'mkBuildInfo' if you need to call 'mkCompilerInfo' and
+-- 'mkComponentInfo' yourself.
+mkBuildInfo'
+  :: Json   -- ^ The 'Json' from 'mkCompilerInfo'
+  -> [Json] -- ^ The 'Json' from 'mkComponentInfo'
+  -> Json
+mkBuildInfo' cmplrInfo componentInfos =
+  JsonObject
+    [ "cabal-version" .= JsonString (display cabalVersion)
+    , "compiler"      .= cmplrInfo
+    , "components"    .= JsonArray componentInfos
+    ]
 
-    mkCompilerInfo = JsonObject
-      [ "flavour"     .= JsonString (prettyShow $ compilerFlavor $ compiler lbi)
-      , "compiler-id" .= JsonString (showCompilerId $ compiler lbi)
-      , "path"        .= path
-      ]
-      where
-        path = maybe JsonNull (JsonString . programPath)
-               $ (flavorToProgram . compilerFlavor $ compiler lbi)
-               >>= flip lookupProgram (withPrograms lbi)
+mkCompilerInfo :: ProgramDb -> Compiler -> Json
+mkCompilerInfo programDb cmplr = JsonObject
+  [ "flavour"     .= JsonString (prettyShow $ compilerFlavor cmplr)
+  , "compiler-id" .= JsonString (showCompilerId cmplr)
+  , "path"        .= path
+  ]
+  where
+    path = maybe JsonNull (JsonString . programPath)
+            $ (flavorToProgram . compilerFlavor $ cmplr)
+            >>= flip lookupProgram programDb
 
-        flavorToProgram :: CompilerFlavor -> Maybe Program
-        flavorToProgram GHC   = Just ghcProgram
-        flavorToProgram GHCJS = Just ghcjsProgram
-        flavorToProgram UHC   = Just uhcProgram
-        flavorToProgram JHC   = Just jhcProgram
-        flavorToProgram _     = Nothing
+    flavorToProgram :: CompilerFlavor -> Maybe Program
+    flavorToProgram GHC   = Just ghcProgram
+    flavorToProgram GHCJS = Just ghcjsProgram
+    flavorToProgram UHC   = Just uhcProgram
+    flavorToProgram JHC   = Just jhcProgram
+    flavorToProgram _     = Nothing
 
-    mkComponentInfo (name, clbi) = JsonObject
-      [ "type"          .= JsonString compType
-      , "name"          .= JsonString (prettyShow name)
-      , "unit-id"       .= JsonString (prettyShow $ componentUnitId clbi)
-      , "compiler-args" .= JsonArray (map JsonString $ getCompilerArgs bi lbi clbi)
-      , "modules"       .= JsonArray (map (JsonString . display) modules)
-      , "src-files"     .= JsonArray (map JsonString sourceFiles)
-      , "src-dirs"      .= JsonArray (map JsonString $ hsSourceDirs bi)
-      ]
-      where
-        bi = componentBuildInfo comp
-        comp = fromMaybe (error $ "mkBuildInfo: no component " ++ prettyShow name) $ lookupComponent pkg_descr name
-        compType = case comp of
-          CLib _   -> "lib"
-          CExe _   -> "exe"
-          CTest _  -> "test"
-          CBench _ -> "bench"
-          CFLib _  -> "flib"
-        modules = case comp of
-          CLib lib -> explicitLibModules lib
-          CExe exe -> exeModules exe
-          _        -> []
-        sourceFiles = case comp of
-          CLib _   -> []
-          CExe exe -> [modulePath exe]
-          _        -> []
+mkComponentInfo :: PackageDescription -> LocalBuildInfo -> ComponentLocalBuildInfo -> Json
+mkComponentInfo pkg_descr lbi clbi = JsonObject
+  [ "type"          .= JsonString compType
+  , "name"          .= JsonString (prettyShow name)
+  , "unit-id"       .= JsonString (prettyShow $ componentUnitId clbi)
+  , "compiler-args" .= JsonArray (map JsonString $ getCompilerArgs bi lbi clbi)
+  , "modules"       .= JsonArray (map (JsonString . display) modules)
+  , "src-files"     .= JsonArray (map JsonString sourceFiles)
+  , "src-dirs"      .= JsonArray (map JsonString $ hsSourceDirs bi)
+  ]
+  where
+    name = componentLocalName clbi
+    bi = componentBuildInfo comp
+    comp = fromMaybe (error $ "mkBuildInfo: no component " ++ prettyShow name) $ lookupComponent pkg_descr name
+    compType = case comp of
+      CLib _   -> "lib"
+      CExe _   -> "exe"
+      CTest _  -> "test"
+      CBench _ -> "bench"
+      CFLib _  -> "flib"
+    modules = case comp of
+      CLib lib -> explicitLibModules lib
+      CExe exe -> exeModules exe
+      _        -> []
+    sourceFiles = case comp of
+      CLib _   -> []
+      CExe exe -> [modulePath exe]
+      _        -> []
 
 -- | Get the command-line arguments that would be passed
 -- to the compiler to build the given component.

diff --git a/Cabal/Distribution/Simple/Utils/Json.hs → Cabal/Distribution/Utils/Json.hs b/Cabal/Distribution/Simple/Utils/Json.hs → Cabal/Distribution/Utils/Json.hs
@@ -1,7 +1,8 @@
--- | Utility json lib for Cabal
--- TODO: Remove it again.
-module Distribution.Simple.Utils.Json
+-- | Extremely simple JSON helper. Don't do anything too fancy with this!
+
+module Distribution.Utils.Json
     ( Json(..)
+    , (.=)
     , renderJson
     ) where
 
@@ -44,3 +45,6 @@ intercalate sep = go
     go []     = id
     go [x]    = x
     go (x:xs) = x . showString' sep . go xs
+
+(.=) :: String -> Json -> (String, Json)
+k .= v = (k, v)
diff --git a/cabal-install/Distribution/Client/CmdShowBuildInfo.hs b/cabal-install/Distribution/Client/CmdShowBuildInfo.hs
@@ -23,7 +23,7 @@ import Distribution.Simple.Command
 import Distribution.Verbosity
          ( Verbosity, silent )
 import Distribution.Simple.Utils
-         ( wrapText, die', withTempDirectory )
+         ( wrapText, die' )
 import Distribution.Types.UnitId
          ( UnitId, mkUnitId )
 import Distribution.Types.Version
@@ -36,13 +36,11 @@ import Distribution.Pretty
 import qualified Data.Map as Map
 import qualified Distribution.Simple.Setup as Cabal
 import Distribution.Client.SetupWrapper
-import Distribution.Simple.Program
-        ( defaultProgramDb )
 import qualified Distribution.Client.InstallPlan as InstallPlan
 import Distribution.Client.ProjectPlanning.Types
 import Distribution.Client.ProjectPlanning
         ( setupHsConfigureFlags, setupHsConfigureArgs, setupHsBuildFlags
-        , setupHsBuildArgs, setupHsScriptOptions )
+        , setupHsScriptOptions )
 import Distribution.Client.NixStyleOptions
          ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags )
 import Distribution.Client.DistDirLayout
@@ -52,12 +50,16 @@ import Distribution.Client.Types
 import Distribution.Client.JobControl
         ( newLock, Lock )
 import Distribution.Simple.Configure
-        ( tryGetPersistBuildConfig )
+        (getPersistBuildConfig,  tryGetPersistBuildConfig )
 
-import System.Directory
-        ( getTemporaryDirectory )
-import System.FilePath
-        ( (</>) )
+import Distribution.Simple.ShowBuildInfo
+import Distribution.Utils.Json
+
+import Distribution.Simple.BuildTarget (readTargetInfos)
+import Distribution.Types.LocalBuildInfo (neededTargetsInBuildOrder')
+import Distribution.Compat.Graph (IsNode(nodeKey))
+import Distribution.Simple.Setup (BuildFlags(buildArgs))
+import Distribution.Types.TargetInfo (TargetInfo(targetCLBI))
 
 showBuildInfoCommand :: CommandUI (NixStyleFlags ShowBuildInfoFlags)
 showBuildInfoCommand = CommandUI {
@@ -137,51 +139,26 @@ showBuildInfoAction flags@NixStyleFlags { extraFlags = (ShowBuildInfoFlags fileO
     cliConfig = commandLineFlagsToProjectConfig globalFlags flags
                   mempty -- ClientInstallFlags, not needed here
 
--- Pretty nasty piecemeal out of json, but I can't see a way to retrieve output of the setupWrapper'd tasks
 showTargets :: Maybe FilePath -> Maybe [String] -> Verbosity -> ProjectBaseContext -> ProjectBuildContext -> Lock -> IO ()
 showTargets fileOutput unitIds verbosity baseCtx buildCtx lock = do
-  tempDir <- getTemporaryDirectory
-  withTempDirectory verbosity tempDir "show-build-info" $ \dir -> do
-    mapM_ (doShowInfo dir) targets
-    case fileOutput of
-      Nothing -> outputResult dir putStr targets
-      Just fp -> do
-        writeFile fp ""
-        outputResult dir (appendFile fp) targets
+  let configured = [p | InstallPlan.Configured p <- InstallPlan.toList (elaboratedPlanOriginal buildCtx)]
+      targets = maybe (fst <$> (Map.toList . targetsMap $ buildCtx)) (map mkUnitId) unitIds
+
+  components <- concat <$> mapM (getComponentInfo verbosity baseCtx buildCtx
+                                  lock configured) targets
 
-    where configured = [p | InstallPlan.Configured p <- InstallPlan.toList (elaboratedPlanOriginal buildCtx)]
-          targets = maybe (fst <$> (Map.toList . targetsMap $ buildCtx)) (map mkUnitId) unitIds
-          doShowInfo :: FilePath -> UnitId -> IO ()
-          doShowInfo dir unitId =
-              showInfo
-                (dir </> unitIdToFilePath unitId)
-                verbosity
-                baseCtx
-                buildCtx
-                lock
-                configured
-                unitId
+  let compilerInfo = mkCompilerInfo (pkgConfigCompilerProgs (elaboratedShared buildCtx))
+                                    (pkgConfigCompiler (elaboratedShared buildCtx))
 
-          outputResult :: FilePath -> (String -> IO ()) -> [UnitId] -> IO ()
-          outputResult dir printer units = do
-              let unroll [] = return ()
-                  unroll [x] = do
-                    content <- readFile (dir </> unitIdToFilePath x)
-                    printer content
-                  unroll (x:xs) = do
-                    content <- readFile (dir </> unitIdToFilePath x)
-                    printer content
-                    printer ","
-                    unroll xs
-              printer "["
-              unroll units
-              printer "]"
+      json = mkBuildInfo' compilerInfo components
+      res = renderJson json ""
 
-          unitIdToFilePath :: UnitId -> FilePath
-          unitIdToFilePath unitId = "build-info-" ++ prettyShow unitId ++ ".json"
+  case fileOutput of
+    Nothing -> putStrLn res
+    Just fp -> writeFile fp res
 
-showInfo :: FilePath -> Verbosity -> ProjectBaseContext -> ProjectBuildContext -> Lock -> [ElaboratedConfiguredPackage] -> UnitId -> IO ()
-showInfo fileOutput verbosity baseCtx buildCtx lock pkgs targetUnitId =
+getComponentInfo :: Verbosity -> ProjectBaseContext -> ProjectBuildContext -> Lock -> [ElaboratedConfiguredPackage] -> UnitId -> IO [Json]
+getComponentInfo verbosity baseCtx buildCtx lock pkgs targetUnitId =
   case mbPkg of
     Nothing -> die' verbosity $ "No unit " ++ prettyShow targetUnitId
     Just pkg -> do
@@ -191,7 +168,6 @@ showInfo fileOutput verbosity baseCtx buildCtx lock pkgs targetUnitId =
           buildDir = distBuildDirectory dirLayout (elabDistDirParams shared pkg)
           buildType' = buildType (elabPkgDescription pkg)
           flags = setupHsBuildFlags pkg shared verbosity buildDir
-          args = setupHsBuildArgs pkg
           srcDir = case (elabPkgSourceLocation pkg) of
             LocalUnpackedPackage fp -> fp
             _ -> ""
@@ -216,29 +192,25 @@ showInfo fileOutput verbosity baseCtx buildCtx lock pkgs targetUnitId =
               ++ "For component: " ++ prettyShow targetUnitId
         )
       -- Configure the package if there's no existing config
-      lbi <- tryGetPersistBuildConfig buildDir
-      case lbi of
+      lbi' <- tryGetPersistBuildConfig buildDir
+      case lbi' of
         Left _ -> setupWrapper
                     verbosity
                     scriptOptions
                     (Just $ elabPkgDescription pkg)
-                    (Cabal.configureCommand defaultProgramDb)
+                    (Cabal.configureCommand
+                      (pkgConfigCompilerProgs (elaboratedShared buildCtx)))
                     (const configureFlags)
                     (const configureArgs)
         Right _ -> pure ()
 
-      setupWrapper
-        verbosity
-        scriptOptions
-        (Just $ elabPkgDescription pkg)
-        (Cabal.showBuildInfoCommand defaultProgramDb)
-        (const (Cabal.ShowBuildInfoFlags
-          { Cabal.buildInfoBuildFlags = flags
-          , Cabal.buildInfoOutputFile = Just fileOutput
-          }
-          )
-        )
-        (const args)
+      -- Do the bit the Cabal library would normally do here
+      lbi <- getPersistBuildConfig buildDir
+      let pkgDesc = elabPkgDescription pkg
+      targets <- readTargetInfos verbosity pkgDesc lbi (buildArgs flags)
+      let targetsToBuild = neededTargetsInBuildOrder' pkgDesc lbi (map nodeKey targets)
+      return $ map (mkComponentInfo pkgDesc lbi . targetCLBI) targetsToBuild
+
     where
       mbPkg :: Maybe ElaboratedConfiguredPackage
       mbPkg = find ((targetUnitId ==) . elabUnitId) pkgs
@@ -247,9 +219,9 @@ showInfo fileOutput verbosity baseCtx buildCtx lock pkgs targetUnitId =
 -- It selects the 'AvailableTarget's that the 'TargetSelector' refers to,
 -- or otherwise classifies the problem.
 --
--- For the @show-build-info@ command select all components except non-buildable and disabled
--- tests\/benchmarks, fail if there are no such components
---
+-- For the @show-build-info@ command select all components. Unlike the @build@
+-- command, we want to show info for tests and benchmarks even without the
+-- @--enable-tests@\/@--enable-benchmarks@ flag set.
 selectPackageTargets :: TargetSelector
                      -> [AvailableTarget k] -> Either TargetProblem' [k]
 selectPackageTargets targetSelector targets
@@ -267,16 +239,7 @@ selectPackageTargets targetSelector targets
   = Left (TargetProblemNoTargets targetSelector)
   where
     targets'         = forgetTargetsDetail targets
-    targetsBuildable = selectBuildableTargetsWith
-                         (buildable targetSelector)
-                         targets
-
-    -- When there's a target filter like "pkg:tests" then we do select tests,
-    -- but if it's just a target like "pkg" then we don't build tests unless
-    -- they are requested by default (i.e. by using --enable-tests)
-    buildable (TargetPackage _ _  Nothing) TargetNotRequestedByDefault = False
-    buildable (TargetAllPackages  Nothing) TargetNotRequestedByDefault = False
-    buildable _ _ = True
+    targetsBuildable = selectBuildableTargets targets
 
 -- | For a 'TargetComponent' 'TargetSelector', check if the component can be
 -- selected.