diff --git a/Cabal/Distribution/Simple.hs b/Cabal/Distribution/Simple.hs index f0d252bf4e9..b86f948e579 100644 --- a/Cabal/Distribution/Simple.hs +++ b/Cabal/Distribution/Simple.hs @@ -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') @@ -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 () diff --git a/Cabal/Distribution/Simple/Build.hs b/Cabal/Distribution/Simple/Build.hs index c2ae84a15e9..c76d32897d6 100644 --- a/Cabal/Distribution/Simple/Build.hs +++ b/Cabal/Distribution/Simple/Build.hs @@ -25,7 +25,7 @@ module Distribution.Simple.Build ( initialBuildSteps, createInternalPackageDB, componentInitialBuildSteps, - writeAutogenFiles + writeAutogenFiles, ) where import Prelude () @@ -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 diff --git a/Cabal/Distribution/Simple/Setup.hs b/Cabal/Distribution/Simple/Setup.hs index 02ae2b0d07e..dabbf489c23 100644 --- a/Cabal/Distribution/Simple/Setup.hs +++ b/Cabal/Distribution/Simple/Setup.hs @@ -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, @@ -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." @@ -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 diff --git a/cabal-install/Distribution/Client/CmdBuild.hs b/cabal-install/Distribution/Client/CmdBuild.hs index cb1858837a4..5cb36f55529 100644 --- a/cabal-install/Distribution/Client/CmdBuild.hs +++ b/cabal-install/Distribution/Client/CmdBuild.hs @@ -8,7 +8,8 @@ module Distribution.Client.CmdBuild ( -- * Internals exposed for testing TargetProblem(..), selectPackageTargets, - selectComponentTarget + selectComponentTarget, + reportTargetProblems ) where import Distribution.Client.ProjectOrchestration diff --git a/cabal-install/Distribution/Client/CmdShowBuildInfo.hs b/cabal-install/Distribution/Client/CmdShowBuildInfo.hs index 1a013d64b3f..5060ffb9ee5 100644 --- a/cabal-install/Distribution/Client/CmdShowBuildInfo.hs +++ b/cabal-install/Distribution/Client/CmdShowBuildInfo.hs @@ -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 @@ -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]" ], @@ -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 @@ -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) { @@ -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 @@ -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 diff --git a/cabal-install/Distribution/Client/Setup.hs b/cabal-install/Distribution/Client/Setup.hs index 5af13f8fcdd..db6267d7172 100644 --- a/cabal-install/Distribution/Client/Setup.hs +++ b/cabal-install/Distribution/Client/Setup.hs @@ -55,7 +55,7 @@ module Distribution.Client.Setup , doctestCommand , copyCommand , registerCommand - , showBuildInfoCommand + --, showBuildInfoCommand , parsePackageArgs , liftOptions , yesNoOpt @@ -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 = diff --git a/cabal-install/main/Main.hs b/cabal-install/main/Main.hs index f05ae26a494..9047828284a 100644 --- a/cabal-install/main/Main.hs +++ b/cabal-install/main/Main.hs @@ -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