Skip to content

Commit

Permalink
Rework show-build-info command to avoid wrapper
Browse files Browse the repository at this point in the history
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.
  • Loading branch information
lukel97 committed Jun 3, 2020
1 parent 9ea9b57 commit de2a4d6
Show file tree
Hide file tree
Showing 17 changed files with 169 additions and 211 deletions.
4 changes: 2 additions & 2 deletions Cabal/Cabal.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -506,6 +506,7 @@ library
Distribution.Utils.NubList
Distribution.Utils.ShortText
Distribution.Utils.Progress
Distribution.Utils.Json
Distribution.Verbosity
Distribution.Verbosity.Internal
Distribution.Version
Expand Down Expand Up @@ -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

Expand Down Expand Up @@ -665,7 +665,7 @@ test-suite unit-tests
Distribution.Described
Distribution.Utils.CharSet
Distribution.Utils.GrammarRegex

main-is: UnitTests.hs
build-depends:
array,
Expand Down
2 changes: 1 addition & 1 deletion Cabal/Distribution/Simple/Build.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down
117 changes: 62 additions & 55 deletions Cabal/Distribution/Simple/ShowBuildInfo.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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 ()
Expand All @@ -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
Expand All @@ -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.
Expand Down
Original file line number Diff line number Diff line change
@@ -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

Expand Down Expand Up @@ -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)
117 changes: 40 additions & 77 deletions cabal-install/Distribution/Client/CmdShowBuildInfo.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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
Expand All @@ -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 {
Expand Down Expand Up @@ -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
Expand All @@ -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
_ -> ""
Expand All @@ -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
Expand All @@ -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
Expand All @@ -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.
Expand Down
Loading

0 comments on commit de2a4d6

Please sign in to comment.