Skip to content

Commit

Permalink
Add flags for new-show-build-info
Browse files Browse the repository at this point in the history
Add functioning flag `--buildinfo-json-output=FILE`
Add custom flags to parse more flags.
Dont write always to stdout but to a file if specified.
  • Loading branch information
fendor committed Apr 12, 2019
1 parent 50b62ed commit d54726c
Show file tree
Hide file tree
Showing 7 changed files with 137 additions and 50 deletions.
19 changes: 12 additions & 7 deletions Cabal/Distribution/Simple.hs
Original file line number Diff line number Diff line change
Expand Up @@ -264,13 +264,16 @@ buildAction hooks flags args = do
(return lbi { withPrograms = progs })
hooks flags' { buildArgs = args } args

showBuildInfoAction :: UserHooks -> BuildFlags -> Args -> IO ()
showBuildInfoAction hooks flags args = do
showBuildInfoAction :: UserHooks -> ShowBuildInfoFlags -> Args -> IO ()
showBuildInfoAction hooks a@(ShowBuildInfoFlags flags fileOutput _) args = do
print a
distPref <- findDistPrefOrDefault (buildDistPref flags)
let verbosity = fromFlag $ buildVerbosity flags
flags' = flags { buildDistPref = toFlag distPref }

lbi <- getBuildConfig hooks verbosity distPref
let flags' = flags { buildDistPref = toFlag distPref
, buildCabalFilePath = maybeToFlag (cabalFilePath lbi)
}

progs <- reconfigurePrograms verbosity
(buildProgramPaths flags')
(buildProgramArgs flags')
Expand All @@ -280,9 +283,11 @@ showBuildInfoAction hooks flags args = do
let lbi' = lbi { withPrograms = progs }
pkg_descr0 = localPkgDescr lbi'
pkg_descr = updatePackageDescription pbi pkg_descr0
-- TODO: Somehow don't ignore build hook?
showBuildInfo pkg_descr lbi' flags

-- TODO: Somehow don't ignore build hook?
buildInfoString <- showBuildInfo pkg_descr lbi' flags

maybe (putStrLn buildInfoString) (\fp -> appendFile fp buildInfoString) (fileOutput)

postBuild hooks args flags' pkg_descr lbi'

replAction :: UserHooks -> ReplFlags -> Args -> IO ()
Expand Down
6 changes: 3 additions & 3 deletions Cabal/Distribution/Simple/Build.hs
Original file line number Diff line number Diff line change
Expand Up @@ -25,7 +25,7 @@ module Distribution.Simple.Build (
initialBuildSteps,
createInternalPackageDB,
componentInitialBuildSteps,
writeAutogenFiles
writeAutogenFiles,
) where

import Prelude ()
Expand Down Expand Up @@ -133,13 +133,13 @@ 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 ()
-> IO String
showBuildInfo pkg_descr lbi flags = do
let verbosity = fromFlag (buildVerbosity flags)
targets <- readTargetInfos verbosity pkg_descr lbi (buildArgs flags)
let targetsToBuild = neededTargetsInBuildOrder' pkg_descr lbi (map nodeKey targets)
doc = mkBuildInfo pkg_descr lbi flags targetsToBuild
putStrLn $ renderJson doc ""
return $ renderJson doc ""


repl :: PackageDescription -- ^ Mostly information from the .cabal file
Expand Down
50 changes: 44 additions & 6 deletions Cabal/Distribution/Simple/Setup.hs
Original file line number Diff line number Diff line change
Expand Up @@ -46,7 +46,7 @@ module Distribution.Simple.Setup (
HscolourFlags(..), emptyHscolourFlags, defaultHscolourFlags, hscolourCommand,
BuildFlags(..), emptyBuildFlags, defaultBuildFlags, buildCommand,

showBuildInfoCommand,
showBuildInfoCommand, ShowBuildInfoFlags(..),
buildVerbose,
ReplFlags(..), defaultReplFlags, replCommand,
CleanFlags(..), emptyCleanFlags, defaultCleanFlags, cleanCommand,
Expand Down Expand Up @@ -2219,7 +2219,21 @@ optionNumJobs get set =
-- * show-build-info command flags
-- ------------------------------------------------------------

showBuildInfoCommand :: ProgramDb -> CommandUI BuildFlags
data ShowBuildInfoFlags = ShowBuildInfoFlags
{ buildInfoBuildFlags :: BuildFlags
, buildInfoOutputFile :: Maybe FilePath
, buildInfoUnitIds :: Maybe [String]
} deriving Show

defaultShowBuildFlags :: ShowBuildInfoFlags
defaultShowBuildFlags =
ShowBuildInfoFlags
{ buildInfoBuildFlags = defaultBuildFlags
, buildInfoOutputFile = Nothing
, buildInfoUnitIds = Nothing
}

showBuildInfoCommand :: ProgramDb -> CommandUI ShowBuildInfoFlags
showBuildInfoCommand progDb = CommandUI
{ commandName = "show-build-info"
, commandSynopsis = "Emit details about how a package would be built."
Expand Down Expand Up @@ -2247,16 +2261,40 @@ showBuildInfoCommand progDb = CommandUI
[ "[FLAGS]"
, "COMPONENTS [FLAGS]"
]
, commandDefaultFlags = defaultBuildFlags
, commandOptions = \showOrParseArgs ->
, commandDefaultFlags = defaultShowBuildFlags
, commandOptions = \showOrParseArgs ->
parseBuildFlagsForShowBuildInfoFlags showOrParseArgs progDb
++
[ option [] ["buildinfo-json-output"]
"Write the result to the given file instead of stdout"
buildInfoOutputFile (\pf flags -> flags { buildInfoOutputFile = pf })
(reqArg' "FILE" Just (maybe [] pure)),
option [] ["unit-ids-json"]
"Show build-info only for selected unit-id's."
buildInfoUnitIds (\pf flags -> flags { buildInfoUnitIds = pf })
(reqArg' "UNIT-ID" (Just . words) (fromMaybe [] ))
]

}

parseBuildFlagsForShowBuildInfoFlags :: ShowOrParseArgs -> ProgramDb -> [OptionField ShowBuildInfoFlags]
parseBuildFlagsForShowBuildInfoFlags showOrParseArgs progDb =
map
(liftOption
buildInfoBuildFlags
(\bf flags -> flags { buildInfoBuildFlags = bf } )
)
buildFlags
where
buildFlags = buildOptions progDb showOrParseArgs
++
[ optionVerbosity
buildVerbosity (\v flags -> flags { buildVerbosity = v })

, optionDistPref
buildDistPref (\d flags -> flags { buildDistPref = d }) showOrParseArgs
]
++ buildOptions progDb showOrParseArgs
}
--

-- ------------------------------------------------------------
-- * Other Utils
Expand Down
3 changes: 2 additions & 1 deletion cabal-install/Distribution/Client/CmdBuild.hs
Original file line number Diff line number Diff line change
Expand Up @@ -8,7 +8,8 @@ module Distribution.Client.CmdBuild (
-- * Internals exposed for testing
TargetProblem(..),
selectPackageTargets,
selectComponentTarget
selectComponentTarget,
reportTargetProblems
) where

import Distribution.Client.ProjectOrchestration
Expand Down
90 changes: 66 additions & 24 deletions cabal-install/Distribution/Client/CmdShowBuildInfo.hs
Original file line number Diff line number Diff line change
Expand Up @@ -11,12 +11,16 @@ import Distribution.Client.CmdErrorMessages
import Distribution.Client.CmdInstall.ClientInstallFlags

import Distribution.Client.Setup
( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags )
( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags
)
import qualified Distribution.Client.Setup as Client
import Distribution.Simple.Setup
( HaddockFlags, fromFlagOrDefault, TestFlags )
( HaddockFlags, TestFlags
, fromFlagOrDefault
)
import Distribution.Simple.Command
( CommandUI(..), usageAlternatives )
( CommandUI(..), option, reqArg', usageAlternatives
)
import Distribution.Verbosity
( Verbosity, silent )
import Distribution.Simple.Utils
Expand All @@ -38,10 +42,12 @@ import Distribution.Client.DistDirLayout (distBuildDirectory)
import Distribution.Client.Types ( PackageLocation(..), GenericReadyPackage(..) )
import Distribution.Client.JobControl (newLock, Lock)
import Distribution.Simple.Configure (tryGetPersistBuildConfig)
import qualified Distribution.Client.CmdInstall as CmdInstall
import Data.List (find)
import Data.Maybe (fromMaybe)

showBuildInfoCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags)
showBuildInfoCommand = Client.installCommand {
showBuildInfoCommand :: CommandUI ShowBuildInfoFlags
showBuildInfoCommand = CmdInstall.installCommand {
commandName = "new-show-build-info",
commandSynopsis = "Show project build information",
commandUsage = usageAlternatives "new-show-build-info" [ "[TARGETS] [FLAGS]" ],
Expand All @@ -56,9 +62,35 @@ showBuildInfoCommand = Client.installCommand {
++ " Shows build information about the current package\n"
++ " " ++ pname ++ " new-show-build-info ./pkgname \n"
++ " Shows build information about the package located in './pkgname'\n"
++ cmdCommonHelpTextNewBuildBeta
++ cmdCommonHelpTextNewBuildBeta,
commandOptions = \showOrParseArgs ->
Client.liftOptions buildInfoInstallCommandFlags (\pf flags -> flags { buildInfoInstallCommandFlags = pf }) (commandOptions CmdInstall.installCommand showOrParseArgs)
++
[ option [] ["buildinfo-json-output"]
"Write the result to the given file instead of stdout"
buildInfoOutputFile (\pf flags -> flags { buildInfoOutputFile = pf })
(reqArg' "FILE" Just (maybe [] pure)),
option [] ["unit-ids-json"]
"Show build-info only for selected unit-id's."
buildInfoUnitIds (\pf flags -> flags { buildInfoUnitIds = pf })
(reqArg' "UNIT-ID" (Just . words) (fromMaybe []))
],
commandDefaultFlags = defaultShowBuildInfoFlags

}

data ShowBuildInfoFlags = ShowBuildInfoFlags
{ buildInfoInstallCommandFlags :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags, ClientInstallFlags)
, buildInfoOutputFile :: Maybe FilePath
, buildInfoUnitIds :: Maybe [String]
}

defaultShowBuildInfoFlags :: ShowBuildInfoFlags
defaultShowBuildInfoFlags = ShowBuildInfoFlags
{ buildInfoInstallCommandFlags = (mempty, mempty, mempty, mempty, mempty, mempty)
, buildInfoOutputFile = Nothing
, buildInfoUnitIds = Nothing
}

-- | The @show-build-info@ command does a lot. It brings the install plan up to date,
-- selects that part of the plan needed by the given or implicit targets and
Expand All @@ -67,11 +99,10 @@ showBuildInfoCommand = Client.installCommand {
-- For more details on how this works, see the module
-- "Distribution.Client.ProjectOrchestration"
--
showBuildInfoAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags)
showBuildInfoAction :: ShowBuildInfoFlags
-> [String] -> GlobalFlags -> IO ()
showBuildInfoAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags)
showBuildInfoAction (ShowBuildInfoFlags (configFlags, configExFlags, installFlags, haddockFlags, testFlags, clientInstallFlags) fileOutput unitIds)
targetStrings globalFlags = do

baseCtx <- establishProjectBaseContext verbosity cliConfig
let baseCtx' = baseCtx {
buildSettings = (buildSettings baseCtx) {
Expand Down Expand Up @@ -99,32 +130,36 @@ showBuildInfoAction (configFlags, configExFlags, installFlags, haddockFlags, tes
return (elaboratedPlan, targets)

scriptLock <- newLock
showTargets verbosity baseCtx' buildCtx scriptLock
showTargets fileOutput unitIds verbosity baseCtx' buildCtx scriptLock

where
-- Default to silent verbosity otherwise it will pollute our json output
verbosity = fromFlagOrDefault silent (configVerbosity configFlags)
cliConfig = commandLineFlagsToProjectConfig
globalFlags configFlags configExFlags
installFlags mempty -- Not needed here
installFlags clientInstallFlags
haddockFlags
testFlags

-- Pretty nasty piecemeal out of json, but I can't see a way to retrieve output of the setupWrapper'd tasks
showTargets :: Verbosity -> ProjectBaseContext -> ProjectBuildContext -> Lock -> IO ()
showTargets verbosity baseCtx buildCtx lock = do
putStr "["
mapM_ showSeparated (zip [0..] targets)
putStrLn "]"
showTargets :: Maybe FilePath -> Maybe [String] -> Verbosity -> ProjectBaseContext -> ProjectBuildContext -> Lock -> IO ()
showTargets fileOutput unitIds verbosity baseCtx buildCtx lock = do
case fileOutput of
Nothing -> do
putStr "["
mapM_ doShowInfo targets
putStrLn "]"
Just fp -> do
writeFile fp "["
mapM_ doShowInfo targets
appendFile fp "]"

where configured = [p | InstallPlan.Configured p <- InstallPlan.toList (elaboratedPlanOriginal buildCtx)]
targets = fst <$> (Map.toList . targetsMap $ buildCtx)
doShowInfo unitId = showInfo verbosity baseCtx buildCtx lock configured unitId
showSeparated (idx, unitId)
| idx == length targets - 1 = doShowInfo unitId
| otherwise = doShowInfo unitId >> putStrLn ","
doShowInfo unitId = showInfo fileOutput unitIds verbosity baseCtx buildCtx lock configured unitId

showInfo :: Verbosity -> ProjectBaseContext -> ProjectBuildContext -> Lock -> [ElaboratedConfiguredPackage] -> UnitId -> IO ()
showInfo verbosity baseCtx buildCtx lock pkgs targetUnitId
showInfo :: Maybe FilePath -> Maybe [String] -> Verbosity -> ProjectBaseContext -> ProjectBuildContext -> Lock -> [ElaboratedConfiguredPackage] -> UnitId -> IO ()
showInfo fileOutput unitIds verbosity baseCtx buildCtx lock pkgs targetUnitId
| Nothing <- mbPkg = die' verbosity $ "No unit " ++ show targetUnitId
| Just pkg <- mbPkg = do
let shared = elaboratedShared buildCtx
Expand Down Expand Up @@ -155,15 +190,22 @@ showInfo verbosity baseCtx buildCtx lock pkgs targetUnitId
scriptOptions
(Just $ elabPkgDescription pkg)
(Cabal.configureCommand defaultProgramDb)
(const $ configureFlags)
(const configureFlags)
(const configureArgs)
Right _ -> pure ()

setupWrapper
verbosity
scriptOptions
(Just $ elabPkgDescription pkg)
(Cabal.showBuildInfoCommand defaultProgramDb)
(const flags)
(const (Cabal.ShowBuildInfoFlags
{ Cabal.buildInfoBuildFlags = flags
, Cabal.buildInfoOutputFile = fileOutput
, Cabal.buildInfoUnitIds = unitIds
}
)
)
(const args)
where mbPkg = find ((targetUnitId ==) . elabUnitId) pkgs

Expand Down
4 changes: 2 additions & 2 deletions cabal-install/Distribution/Client/Setup.hs
Original file line number Diff line number Diff line change
Expand Up @@ -55,7 +55,7 @@ module Distribution.Client.Setup
, doctestCommand
, copyCommand
, registerCommand
, showBuildInfoCommand
--, showBuildInfoCommand
, parsePackageArgs
, liftOptions
, yesNoOpt
Expand Down Expand Up @@ -2957,7 +2957,7 @@ relevantConfigValuesText vs =
-- * Commands to support show-build-info
-- ------------------------------------------------------------

showBuildInfoCommand :: CommandUI (BuildFlags, BuildExFlags)
showBuildInfoCommand :: CommandUI (Cabal.ShowBuildInfoFlags, BuildExFlags)
showBuildInfoCommand = parent {
commandDefaultFlags = (commandDefaultFlags parent, mempty),
commandOptions =
Expand Down
15 changes: 8 additions & 7 deletions cabal-install/main/Main.hs
Original file line number Diff line number Diff line change
Expand Up @@ -454,13 +454,14 @@ buildAction flags@(buildFlags, _) = buildActionForCommand
flags
where verbosity = fromFlagOrDefault normal (buildVerbosity buildFlags)

showBuildInfoAction :: (BuildFlags, BuildExFlags) -> [String] -> Action
showBuildInfoAction flags@(buildFlags, _) = buildActionForCommand
(Cabal.showBuildInfoCommand defaultProgramDb)
verbosity
flags
-- Default silent verbosity so as not to pollute json output
where verbosity = fromFlagOrDefault silent (buildVerbosity buildFlags)
-- showBuildInfoAction :: (Cabal.ShowBuildInfoFlags, BuildExFlags) -> [String] -> Action
-- showBuildInfoAction (showBuildInfoFlags, buildEx) = buildActionForCommand
-- (Cabal.showBuildInfoCommand defaultProgramDb)
-- showBuildInfoFlags
-- verbosity
-- (Cabal.buildInfoBuildFlags showBuildInfoFlags, buildEx)
-- -- Default silent verbosity so as not to pollute json output
-- where verbosity = fromFlagOrDefault silent (buildVerbosity (Cabal.buildInfoBuildFlags showBuildInfoFlags ))

buildActionForCommand :: CommandUI BuildFlags
-> Verbosity
Expand Down

0 comments on commit d54726c

Please sign in to comment.