Skip to content

Commit 59281db

Browse files
fendorfendor
committed
Rebase work of cfraz89 and bgamari
Add (currently nonfunctional) new-show-build-info Fix compile error Make new-show-build-info functional Use silent verbosity by default on showBuildInfo commands to keep output json clean Make show-build-info commands hidden Implement write-autogen-files Make new-write-autogen-files work Make new-write-autogen-files configure if necessary Use target selectors for new-show-build-info Don't prune plan for new-show-build-info Only configure in new-show-build-info and new-write-autogen-files if no persist build info file is found Wrap multiple target output of new-show-build-info in json list
1 parent 7b222f4 commit 59281db

File tree

5 files changed

+602
-31
lines changed

5 files changed

+602
-31
lines changed

‎cabal-install/Distribution/Client/CmdShowBuildInfo.hs

Lines changed: 254 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,254 @@
1+
-- | cabal-install CLI command: build
2+
--
3+
module Distribution.Client.CmdShowBuildInfo (
4+
-- * The @build@ CLI and action
5+
showBuildInfoCommand,
6+
showBuildInfoAction
7+
) where
8+
9+
import Distribution.Client.ProjectOrchestration
10+
import Distribution.Client.CmdErrorMessages
11+
import Distribution.Client.CmdInstall.ClientInstallFlags
12+
13+
import Distribution.Client.Setup
14+
( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags )
15+
import qualified Distribution.Client.Setup as Client
16+
import Distribution.Simple.Setup
17+
( HaddockFlags, fromFlagOrDefault, TestFlags )
18+
import Distribution.Simple.Command
19+
( CommandUI(..), usageAlternatives )
20+
import Distribution.Verbosity
21+
( Verbosity, silent )
22+
import Distribution.Simple.Utils
23+
( wrapText, die')
24+
import Distribution.Types.UnitId (UnitId)
25+
26+
import qualified Data.Map as Map
27+
import qualified Distribution.Simple.Setup as Cabal
28+
import Distribution.Client.SetupWrapper
29+
import Distribution.Simple.Program ( defaultProgramDb )
30+
import qualified Distribution.Client.InstallPlan as InstallPlan
31+
import Distribution.Client.ProjectPlanning.Types
32+
import Distribution.Client.ProjectPlanning (
33+
setupHsConfigureFlags, setupHsConfigureArgs,
34+
setupHsBuildFlags, setupHsBuildArgs,
35+
setupHsScriptOptions
36+
)
37+
import Distribution.Client.DistDirLayout (distBuildDirectory)
38+
import Distribution.Client.Types ( PackageLocation(..), GenericReadyPackage(..) )
39+
import Distribution.Client.JobControl (newLock, Lock)
40+
import Distribution.Simple.Configure (tryGetPersistBuildConfig)
41+
import Data.List (find)
42+
43+
showBuildInfoCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags)
44+
showBuildInfoCommand = Client.installCommand {
45+
commandName = "new-show-build-info",
46+
commandSynopsis = "Show project build information",
47+
commandUsage = usageAlternatives "new-show-build-info" [ "[TARGETS] [FLAGS]" ],
48+
commandDescription = Just $ \_ -> wrapText $
49+
"Build one or more targets from within the project. The available "
50+
++ "targets are the packages in the project as well as individual "
51+
++ "components within those packages, including libraries, executables, "
52+
++ "test-suites or benchmarks. Targets can be specified by name or "
53+
++ "location. If no target is specified then the default is to build "
54+
++ "the package in the current directory.\n\n"
55+
56+
++ "Dependencies are built or rebuilt as necessary. Additional "
57+
++ "configuration flags can be specified on the command line and these "
58+
++ "extend the project configuration from the 'cabal.project', "
59+
++ "'cabal.project.local' and other files.",
60+
commandNotes = Just $ \pname ->
61+
"Examples:\n"
62+
++ " " ++ pname ++ " new-build\n"
63+
++ " Build the package in the current directory or all packages in the project\n"
64+
++ " " ++ pname ++ " new-build pkgname\n"
65+
++ " Build the package named pkgname in the project\n"
66+
++ " " ++ pname ++ " new-build ./pkgfoo\n"
67+
++ " Build the package in the ./pkgfoo directory\n"
68+
++ " " ++ pname ++ " new-build cname\n"
69+
++ " Build the component named cname module Distribution.Client.InstallPlanin the project\n"
70+
++ " " ++ pname ++ " new-build cname --module Distribution.Client.InstallPlanenable-profiling\n"
71+
++ " Build the component in profilingmodule Distribution.Client.InstallPlan mode (including dependencies as needed)\n\n"
72+
73+
++ cmdCommonHelpTextNewBuildBeta
74+
}
75+
76+
77+
-- | The @build@ command does a lot. It brings the install plan up to date,
78+
-- selects that part of the plan needed by the given or implicit targets and
79+
-- then executes the plan.
80+
--
81+
-- For more details on how this works, see the module
82+
-- "Distribution.Client.ProjectOrchestration"
83+
--
84+
showBuildInfoAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags)
85+
-> [String] -> GlobalFlags -> IO ()
86+
showBuildInfoAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags)
87+
targetStrings globalFlags = do
88+
89+
baseCtx <- establishProjectBaseContext verbosity cliConfig
90+
let baseCtx' = baseCtx {
91+
buildSettings = (buildSettings baseCtx) {
92+
buildSettingDryRun = True
93+
}
94+
}
95+
96+
targetSelectors <- either (reportTargetSelectorProblems verbosity) return
97+
=<< readTargetSelectors (localPackages baseCtx') Nothing targetStrings
98+
99+
buildCtx <-
100+
runProjectPreBuildPhase verbosity baseCtx' $ \elaboratedPlan -> do
101+
-- Interpret the targets on the command line as build targets
102+
-- (as opposed to say repl or haddock targets).
103+
targets <- either (reportTargetProblems verbosity) return
104+
$ resolveTargets
105+
selectPackageTargets
106+
selectComponentTarget
107+
TargetProblemCommon
108+
elaboratedPlan
109+
Nothing
110+
targetSelectors
111+
112+
-- Don't prune the plan though, as we want a list of all configured packages
113+
return (elaboratedPlan, targets)
114+
115+
scriptLock <- newLock
116+
showTargets verbosity baseCtx' buildCtx scriptLock
117+
118+
where
119+
-- Default to silent verbosity otherwise it will pollute our json output
120+
verbosity = fromFlagOrDefault silent (configVerbosity configFlags)
121+
cliConfig = commandLineFlagsToProjectConfig
122+
globalFlags configFlags configExFlags
123+
installFlags defaultClientInstallFlags
124+
haddockFlags
125+
testFlags
126+
127+
-- Pretty nasty piecemeal out of json, but I can't see a way to retrieve output of the setupWrapper'd tasks
128+
showTargets :: Verbosity -> ProjectBaseContext -> ProjectBuildContext -> Lock -> IO ()
129+
showTargets verbosity baseCtx buildCtx lock = do
130+
putStr "["
131+
mapM_ showSeparated (zip [0..] targets)
132+
putStrLn "]"
133+
where configured = [p | InstallPlan.Configured p <- InstallPlan.toList (elaboratedPlanOriginal buildCtx)]
134+
targets = fst <$> (Map.toList . targetsMap $ buildCtx)
135+
doShowInfo unitId = showInfo verbosity baseCtx buildCtx lock configured unitId
136+
showSeparated (idx, unitId)
137+
| idx == length targets - 1 = doShowInfo unitId
138+
| otherwise = doShowInfo unitId >> putStrLn ","
139+
140+
showInfo :: Verbosity -> ProjectBaseContext -> ProjectBuildContext -> Lock -> [ElaboratedConfiguredPackage] -> UnitId -> IO ()
141+
showInfo verbosity baseCtx buildCtx lock pkgs targetUnitId
142+
| Nothing <- mbPkg = die' verbosity $ "No unit " ++ show targetUnitId
143+
| Just pkg <- mbPkg = do
144+
let shared = elaboratedShared buildCtx
145+
install = elaboratedPlanOriginal buildCtx
146+
dirLayout = distDirLayout baseCtx
147+
buildDir = distBuildDirectory dirLayout (elabDistDirParams shared pkg)
148+
flags = setupHsBuildFlags pkg shared verbosity buildDir
149+
args = setupHsBuildArgs pkg
150+
srcDir = case (elabPkgSourceLocation pkg) of
151+
LocalUnpackedPackage fp -> fp
152+
_ -> ""
153+
scriptOptions = setupHsScriptOptions
154+
(ReadyPackage pkg)
155+
install
156+
shared
157+
dirLayout
158+
srcDir
159+
buildDir
160+
False
161+
lock
162+
configureFlags = setupHsConfigureFlags (ReadyPackage pkg) shared verbosity buildDir
163+
configureArgs = setupHsConfigureArgs pkg
164+
--Configure the package if there's no existing config
165+
lbi <- tryGetPersistBuildConfig buildDir
166+
case lbi of
167+
Left _ -> setupWrapper
168+
verbosity
169+
scriptOptions
170+
(Just $ elabPkgDescription pkg)
171+
(Cabal.configureCommand defaultProgramDb)
172+
(const $ configureFlags)
173+
(const configureArgs)
174+
Right _ -> pure ()
175+
setupWrapper
176+
verbosity
177+
scriptOptions
178+
(Just $ elabPkgDescription pkg)
179+
(Cabal.showBuildInfoCommand defaultProgramDb)
180+
(const flags)
181+
(const args)
182+
where mbPkg = find ((targetUnitId ==) . elabUnitId) pkgs
183+
184+
-- | This defines what a 'TargetSelector' means for the @write-autogen-files@ command.
185+
-- It selects the 'AvailableTarget's that the 'TargetSelector' refers to,
186+
-- or otherwise classifies the problem.
187+
--
188+
-- For the @write-autogen-files@ command select all components except non-buildable and disabled
189+
-- tests\/benchmarks, fail if there are no such components
190+
--
191+
selectPackageTargets :: TargetSelector
192+
-> [AvailableTarget k] -> Either TargetProblem [k]
193+
selectPackageTargets targetSelector targets
194+
195+
-- If there are any buildable targets then we select those
196+
| not (null targetsBuildable)
197+
= Right targetsBuildable
198+
199+
-- If there are targets but none are buildable then we report those
200+
| not (null targets)
201+
= Left (TargetProblemNoneEnabled targetSelector targets')
202+
203+
-- If there are no targets at all then we report that
204+
| otherwise
205+
= Left (TargetProblemNoTargets targetSelector)
206+
where
207+
targets' = forgetTargetsDetail targets
208+
targetsBuildable = selectBuildableTargetsWith
209+
(buildable targetSelector)
210+
targets
211+
212+
-- When there's a target filter like "pkg:tests" then we do select tests,
213+
-- but if it's just a target like "pkg" then we don't build tests unless
214+
-- they are requested by default (i.e. by using --enable-tests)
215+
buildable (TargetPackage _ _ Nothing) TargetNotRequestedByDefault = False
216+
buildable (TargetAllPackages Nothing) TargetNotRequestedByDefault = False
217+
buildable _ _ = True
218+
219+
-- | For a 'TargetComponent' 'TargetSelector', check if the component can be
220+
-- selected.
221+
--
222+
-- For the @build@ command we just need the basic checks on being buildable etc.
223+
--
224+
selectComponentTarget :: SubComponentTarget
225+
-> AvailableTarget k -> Either TargetProblem k
226+
selectComponentTarget subtarget =
227+
either (Left . TargetProblemCommon) Right
228+
. selectComponentTargetBasic subtarget
229+
230+
231+
-- | The various error conditions that can occur when matching a
232+
-- 'TargetSelector' against 'AvailableTarget's for the @build@ command.
233+
--
234+
data TargetProblem =
235+
TargetProblemCommon TargetProblemCommon
236+
237+
-- | The 'TargetSelector' matches targets but none are buildable
238+
| TargetProblemNoneEnabled TargetSelector [AvailableTarget ()]
239+
240+
-- | There are no targets at all
241+
| TargetProblemNoTargets TargetSelector
242+
deriving (Eq, Show)
243+
244+
reportTargetProblems :: Verbosity -> [TargetProblem] -> IO a
245+
reportTargetProblems verbosity =
246+
die' verbosity . unlines . map renderTargetProblem
247+
248+
renderTargetProblem :: TargetProblem -> String
249+
renderTargetProblem (TargetProblemCommon problem) =
250+
renderTargetProblemCommon "build" problem
251+
renderTargetProblem (TargetProblemNoneEnabled targetSelector targets) =
252+
renderTargetProblemNoneEnabled "build" targetSelector targets
253+
renderTargetProblem(TargetProblemNoTargets targetSelector) =
254+
renderTargetProblemNoTargets "build" targetSelector

0 commit comments

Comments
 (0)