Implement show-build-info for cabal-install

Cabal/Cabal.cabal

@@ -257,6 +257,7 @@ library
     Distribution.Utils.NubList
     Distribution.Utils.ShortText
     Distribution.Utils.Progress
+    Distribution.Utils.Json
     Distribution.Verbosity
     Distribution.Verbosity.Internal
     Distribution.Version
@@ -337,7 +338,6 @@ library
     Distribution.Simple.GHC.EnvironmentParser
     Distribution.Simple.GHC.Internal
     Distribution.Simple.GHC.ImplInfo
-    Distribution.Simple.Utils.Json
     Distribution.ZinzaPrelude
     Paths_Cabal
 

Cabal/src/Distribution/Simple.hs

@@ -107,6 +107,8 @@ import Data.List       (unionBy, (\\))
 
 import Distribution.PackageDescription.Parsec
 
+import qualified Data.Text.IO as T
+
 -- | A simple implementation of @main@ for a Cabal setup script.
 -- It reads the package description file using IO, and performs the
 -- action specified on the command line.
@@ -263,31 +265,34 @@ buildAction hooks flags args = do
                hooks flags' { buildArgs = args } args
 
 showBuildInfoAction :: UserHooks -> ShowBuildInfoFlags -> Args -> IO ()
-showBuildInfoAction hooks (ShowBuildInfoFlags flags fileOutput) args = do
-  distPref <- findDistPrefOrDefault (buildDistPref flags)
-  let verbosity = fromFlag $ buildVerbosity flags
+showBuildInfoAction hooks flags args = do
+  let buildFlags = buildInfoBuildFlags flags
+  distPref <- findDistPrefOrDefault (buildDistPref buildFlags)
+  let verbosity = fromFlag $ buildVerbosity buildFlags
   lbi <- getBuildConfig hooks verbosity distPref
-  let flags' = flags { buildDistPref = toFlag distPref
-                     , buildCabalFilePath = maybeToFlag (cabalFilePath lbi)
-                     }
+  let buildFlags' =
+        buildFlags { buildDistPref = toFlag distPref
+                   , buildCabalFilePath = maybeToFlag (cabalFilePath lbi)
+                   }
 
   progs <- reconfigurePrograms verbosity
-             (buildProgramPaths flags')
-             (buildProgramArgs flags')
+             (buildProgramPaths buildFlags')
+             (buildProgramArgs buildFlags')
              (withPrograms lbi)
 
-  pbi <- preBuild hooks args flags'
+  pbi <- preBuild hooks args buildFlags'
   let lbi' = lbi { withPrograms = progs }
       pkg_descr0 = localPkgDescr lbi'
       pkg_descr = updatePackageDescription pbi pkg_descr0
       -- TODO: Somehow don't ignore build hook?
-  buildInfoString <- showBuildInfo pkg_descr lbi' flags
 
-  case fileOutput of
-    Nothing -> putStr buildInfoString
-    Just fp -> writeFile fp buildInfoString
+  buildInfoText <- showBuildInfo pkg_descr lbi' flags
+
+  case buildInfoOutputFile flags of
+    Nothing -> T.putStr buildInfoText
+    Just fp -> T.writeFile fp buildInfoText
 
-  postBuild hooks args flags' pkg_descr lbi'
+  postBuild hooks args buildFlags' pkg_descr lbi'
 
 replAction :: UserHooks -> ReplFlags -> Args -> IO ()
 replAction hooks flags args = do

Cabal/src/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
@@ -77,7 +78,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
@@ -90,6 +90,7 @@ import Control.Monad
 import qualified Data.Set as Set
 import System.FilePath ( (</>), (<.>), takeDirectory )
 import System.Directory ( getCurrentDirectory )
+import qualified Data.Text as Text
 
 -- -----------------------------------------------------------------------------
 -- |Build the libraries and executables in this package.
@@ -134,15 +135,24 @@ build pkg_descr lbi flags suffixes = do
 
 
 showBuildInfo :: PackageDescription  -- ^ Mostly information from the .cabal file
-  -> LocalBuildInfo      -- ^ Configuration information
-  -> BuildFlags          -- ^ Flags that the user passed to build
-  -> IO String
+  -> LocalBuildInfo                  -- ^ Configuration information
+  -> ShowBuildInfoFlags              -- ^ Flags that the user passed to build
+  -> IO Text.Text
 showBuildInfo pkg_descr lbi flags = do
-  let verbosity = fromFlag (buildVerbosity flags)
-  targets <- readTargetInfos verbosity pkg_descr lbi (buildArgs flags)
+  let buildFlags = buildInfoBuildFlags flags
+      verbosity = fromFlag (buildVerbosity buildFlags)
+  targets <- readTargetInfos verbosity pkg_descr lbi (buildArgs buildFlags)
+  pwd <- getCurrentDirectory
   let targetsToBuild = neededTargetsInBuildOrder' pkg_descr lbi (map nodeKey targets)
-      doc = mkBuildInfo pkg_descr lbi flags targetsToBuild
-  return $ renderJson doc ""
+      result
+        | fromFlag (buildInfoComponentsOnly flags) =
+            let components = map (mkComponentInfo pwd pkg_descr lbi . targetCLBI)
+                                 targetsToBuild
+              in Text.unlines $ map (flip renderJson mempty) components
+        | otherwise =
+            let json = mkBuildInfo pwd pkg_descr lbi buildFlags targetsToBuild
+              in renderJson json mempty
+  return result
 
 
 repl     :: PackageDescription  -- ^ Mostly information from the .cabal file

Cabal/src/Distribution/Simple/BuildTarget.hs

@@ -67,7 +67,7 @@ import System.Directory ( doesFileExist, doesDirectoryExist )
 import qualified Data.Map as Map
 
 -- | Take a list of 'String' build targets, and parse and validate them
--- into actual 'TargetInfo's to be built/registered/whatever.
+-- into actual 'TargetInfo's to be built\/registered\/whatever.
 readTargetInfos :: Verbosity -> PackageDescription -> LocalBuildInfo -> [String] -> IO [TargetInfo]
 readTargetInfos verbosity pkg_descr lbi args = do
     build_targets <- readBuildTargets verbosity pkg_descr args

Cabal/src/Distribution/Simple/Setup.hs

@@ -2153,15 +2153,18 @@ optionNumJobs get set =
 -- ------------------------------------------------------------
 
 data ShowBuildInfoFlags = ShowBuildInfoFlags
-  { buildInfoBuildFlags :: BuildFlags
-  , buildInfoOutputFile :: Maybe FilePath
+  { buildInfoBuildFlags     :: BuildFlags
+  , buildInfoOutputFile     :: Maybe FilePath
+  , buildInfoComponentsOnly :: Flag Bool
+  -- ^ If 'True' then only print components, each separated by a newline
   } deriving (Show, Typeable)
 
 defaultShowBuildFlags  :: ShowBuildInfoFlags
 defaultShowBuildFlags =
     ShowBuildInfoFlags
-      { buildInfoBuildFlags = defaultBuildFlags
-      , buildInfoOutputFile = Nothing
+      { buildInfoBuildFlags     = defaultBuildFlags
+      , buildInfoOutputFile     = Nothing
+      , buildInfoComponentsOnly = Flag False
       }
 
 showBuildInfoCommand :: ProgramDb -> CommandUI ShowBuildInfoFlags
@@ -2198,8 +2201,12 @@ showBuildInfoCommand progDb = CommandUI
       ++
       [ option [] ["buildinfo-json-output"]
                 "Write the result to the given file instead of stdout"
-                buildInfoOutputFile (\pf flags -> flags { buildInfoOutputFile = pf })
+                buildInfoOutputFile (\v flags -> flags { buildInfoOutputFile = v })
                 (reqArg' "FILE" Just (maybe [] pure))
+      , option [] ["buildinfo-components-only"]
+                  "Print out only the component info, each separated by a newline"
+                  buildInfoComponentsOnly (\v flags -> flags { buildInfoComponentsOnly = v})
+                  trueArg
       ]
 
   }

Cabal/src/Distribution/Simple/ShowBuildInfo.hs

@@ -2,7 +2,7 @@
 -- This module defines a simple JSON-based format for exporting basic
 -- information about a Cabal package and the compiler configuration Cabal
 -- would use to build it. This can be produced with the
--- @cabal new-show-build-info@ command.
+-- @cabal show-build-info@ command.
 --
 --
 -- This format is intended for consumption by external tooling and should
@@ -54,7 +54,12 @@
 -- Note: At the moment this is only supported when using the GHC compiler.
 --
 
-module Distribution.Simple.ShowBuildInfo (mkBuildInfo) where
+{-# LANGUAGE OverloadedStrings #-}
+
+module Distribution.Simple.ShowBuildInfo
+  ( mkBuildInfo, mkBuildInfo', mkCompilerInfo, mkComponentInfo ) where
+
+import qualified Data.Text as T
 
 import Distribution.Compat.Prelude
 import Prelude ()
@@ -70,85 +75,112 @@ 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
-import Distribution.Utils.Path
+
+import System.FilePath (addTrailingPathSeparator)
 
 -- | Construct a JSON document describing the build information for a
 -- package.
 mkBuildInfo
-  :: PackageDescription  -- ^ Mostly information from the .cabal file
+  :: FilePath            -- ^ The source directory of the package
+  -> PackageDescription  -- ^ Mostly information from the .cabal file
   -> LocalBuildInfo      -- ^ Configuration information
   -> 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 wdir pkg_descr lbi _flags targetsToBuild =
+  JsonObject $
+    mkBuildInfo' (mkCompilerInfo (withPrograms lbi) (compiler lbi))
+                 (map (mkComponentInfo wdir 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'
+  -> [(T.Text, Json)]
+mkBuildInfo' cmplrInfo componentInfos =
+    [ "cabal-version" .= JsonString (T.pack (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 (T.pack (prettyShow $ compilerFlavor cmplr))
+  , "compiler-id" .= JsonString (T.pack (showCompilerId cmplr))
+  , "path"        .= path
+  ]
+  where
+    path = maybe JsonNull (JsonString . T.pack . 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 $ map getSymbolicPath $ 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 :: FilePath -> PackageDescription -> LocalBuildInfo -> ComponentLocalBuildInfo -> Json
+mkComponentInfo wdir pkg_descr lbi clbi = JsonObject $
+  [ "type"          .= JsonString compType
+  , "name"          .= JsonString (T.pack $ prettyShow name)
+  , "unit-id"       .= JsonString (T.pack $ prettyShow $ componentUnitId clbi)
+  , "compiler-args" .= JsonArray (map JsonString $ getCompilerArgs bi lbi clbi)
+  , "modules"       .= JsonArray (map (JsonString . T.pack . display) modules)
+  , "src-files"     .= JsonArray (map (JsonString . T.pack) sourceFiles)
+  , "hs-src-dirs"   .= JsonArray (map (JsonString . T.pack . prettyShow) $ hsSourceDirs bi)
+  , "src-dir"       .= JsonString (T.pack $ addTrailingPathSeparator wdir)
+  ] <> cabalFile
+  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
+      CTest test ->
+        case testInterface test of
+          TestSuiteExeV10 _ _ -> []
+          TestSuiteLibV09 _ modName -> [modName]
+          TestSuiteUnsupported _ -> []
+      CBench bench -> benchmarkModules bench
+      CFLib flib -> foreignLibModules flib
+    sourceFiles = case comp of
+      CLib _   -> []
+      CExe exe -> [modulePath exe]
+      CTest test ->
+        case testInterface test of
+          TestSuiteExeV10 _ fp -> [fp]
+          TestSuiteLibV09 _ _ -> []
+          TestSuiteUnsupported _ -> []
+      CBench bench -> case benchmarkInterface bench of
+        BenchmarkExeV10 _ fp -> [fp]
+        BenchmarkUnsupported _ -> []
+
+      CFLib _ -> []
+    cabalFile
+      | Just fp <- pkgDescrFile lbi = [("cabal-file", JsonString (T.pack fp))]
+      | otherwise                   = []
 
 -- | Get the command-line arguments that would be passed
 -- to the compiler to build the given component.
 getCompilerArgs
   :: BuildInfo
   -> LocalBuildInfo
   -> ComponentLocalBuildInfo
-  -> [String]
+  -> [T.Text]
 getCompilerArgs bi lbi clbi =
   case compilerFlavor $ compiler lbi of
       GHC   -> ghc
@@ -157,6 +189,7 @@ getCompilerArgs bi lbi clbi =
                        "build arguments for compiler "++show c
   where
     -- This is absolutely awful
-    ghc = GHC.renderGhcOptions (compiler lbi) (hostPlatform lbi) baseOpts
+    ghc = T.pack <$>
+      GHC.renderGhcOptions (compiler lbi) (hostPlatform lbi) baseOpts
       where
         baseOpts = GHC.componentGhcOptions normal lbi bi clbi (buildDir lbi)