Skip to content

Commit fda5ed7

Browse files
fendorfendor
committed
Add 'status' command to cabal
Lightweight command that can query for very basic information in a cabal project. In particular, information about the compiler for the project and the location of the so-called `build-info` field. Other flags are bound to follow.
1 parent d45f3d8 commit fda5ed7

File tree

5 files changed

+375
-0
lines changed

5 files changed

+375
-0
lines changed

‎cabal-install/cabal-install.cabal

+1
Original file line numberDiff line numberDiff line change
@@ -93,6 +93,7 @@ library
9393
Distribution.Client.CmdRepl
9494
Distribution.Client.CmdRun
9595
Distribution.Client.CmdSdist
96+
Distribution.Client.CmdStatus
9697
Distribution.Client.CmdTest
9798
Distribution.Client.CmdUpdate
9899
Distribution.Client.Compat.Directory

‎cabal-install/main/Main.hs

+2
Original file line numberDiff line numberDiff line change
@@ -81,6 +81,7 @@ import qualified Distribution.Client.CmdHaddock as CmdHaddock
8181
import qualified Distribution.Client.CmdHaddockProject as CmdHaddockProject
8282
import qualified Distribution.Client.CmdInstall as CmdInstall
8383
import qualified Distribution.Client.CmdRun as CmdRun
84+
import qualified Distribution.Client.CmdStatus as CmdStatus
8485
import qualified Distribution.Client.CmdTest as CmdTest
8586
import qualified Distribution.Client.CmdBench as CmdBench
8687
import qualified Distribution.Client.CmdExec as CmdExec
@@ -262,6 +263,7 @@ mainWorker args = do
262263
, hiddenCmd actAsSetupCommand actAsSetupAction
263264
, hiddenCmd manpageCommand (manpageAction commandSpecs)
264265
, regularCmd CmdListBin.listbinCommand CmdListBin.listbinAction
266+
, regularCmd CmdStatus.statusCommand CmdStatus.statusAction
265267

266268
] ++ concat
267269
[ newCmd CmdConfigure.configureCommand CmdConfigure.configureAction

‎cabal-install/src/Distribution/Client/CmdStatus.hs

+366
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,366 @@
1+
{-# LANGUAGE CPP #-}
2+
{-# LANGUAGE RecordWildCards #-}
3+
{-# LANGUAGE NamedFieldPuns #-}
4+
{-# LANGUAGE LambdaCase #-}
5+
-----------------------------------------------------------------------------
6+
-- |
7+
-- Module : Distribution.Client.CmdStatus
8+
-- Maintainer : [email protected]
9+
-- Portability : portable
10+
--
11+
-- Implementation of the 'status' command. Query for project information
12+
-- such as targets in the project or which ghc version is going to be used
13+
-- to build the project.
14+
-----------------------------------------------------------------------------
15+
16+
module Distribution.Client.CmdStatus (
17+
statusCommand, statusAction,
18+
) where
19+
20+
import qualified Data.Map as Map
21+
22+
import Prelude ()
23+
import Distribution.Client.Compat.Prelude
24+
25+
import Distribution.Client.DistDirLayout
26+
import Distribution.Client.TargetProblem
27+
import Distribution.Client.CmdErrorMessages
28+
import qualified Distribution.Client.InstallPlan as InstallPlan
29+
import Distribution.Client.NixStyleOptions
30+
( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags )
31+
import Distribution.Client.ProjectOrchestration
32+
import Distribution.Client.ProjectPlanning
33+
import Distribution.Client.ProjectPlanning.Types
34+
import Distribution.Client.Setup
35+
( GlobalFlags, ConfigFlags(..), yesNoOpt )
36+
import Distribution.Client.Utils.Json
37+
( (.=) )
38+
import qualified Distribution.Client.Utils.Json as Json
39+
import Distribution.Client.Version
40+
( cabalInstallVersion )
41+
import Distribution.InstalledPackageInfo
42+
( InstalledPackageInfo )
43+
import Distribution.Parsec (parsecCommaList, parsecToken)
44+
import Distribution.ReadE
45+
( ReadE(ReadE), parsecToReadE )
46+
import Distribution.Simple.BuildPaths (buildInfoPref)
47+
import Distribution.Simple.Command
48+
( CommandUI(..), option, reqArg, ShowOrParseArgs, OptionField )
49+
import Distribution.Simple.Compiler
50+
import Distribution.Simple.Program
51+
import Distribution.Simple.Flag
52+
( Flag(..), fromFlagOrDefault )
53+
import Distribution.Simple.Utils
54+
( wrapText, die', withOutputMarker, ordNub )
55+
import Distribution.Verbosity
56+
( normal )
57+
import Distribution.Version
58+
59+
-------------------------------------------------------------------------------
60+
-- Command
61+
-------------------------------------------------------------------------------
62+
63+
statusCommand :: CommandUI (NixStyleFlags StatusFlags)
64+
statusCommand = CommandUI
65+
{ commandName = "status"
66+
, commandSynopsis = "Query for simple project information"
67+
, commandDescription = Just $ \_ -> wrapText $
68+
"Query for available targets and project information such as project GHC."
69+
, commandNotes = Just $ \pname ->
70+
"Examples:\n"
71+
++ " " ++ pname ++ " status --output-format=json --compiler-info\n"
72+
++ " Print the compiler that is used for this project in the json format.\n"
73+
++ " " ++ pname ++ " status --output-format=json --build-info=./src/Foo.hs\n"
74+
++ " Print the location of the component \"src/Foo.hs\" belongs to.\n"
75+
++ " " ++ pname ++ " status --output-format=json --build-info=./src/Foo.hs\n"
76+
++ " Print both, compiler information and build-info location for the given target.\n"
77+
++ " " ++ pname ++ " status --output-format=json --build-info=./src/Foo.hs --build-info=./test/Bar.hs\n"
78+
++ " Print build-info location for multiple targets.\n"
79+
, commandUsage = \pname ->
80+
"Usage: " ++ pname ++ " status [FLAGS]\n"
81+
, commandDefaultFlags = defaultNixStyleFlags defaultStatusFlags
82+
, commandOptions = nixStyleOptions statusOptions
83+
84+
}
85+
86+
-------------------------------------------------------------------------------
87+
-- Flags
88+
-------------------------------------------------------------------------------
89+
90+
data StatusOutputFormat
91+
= JSON
92+
deriving (Eq, Ord, Show, Read)
93+
94+
data StatusFlags = StatusFlags
95+
{ statusBuildInfo :: [String]
96+
, statusCompiler :: Flag Bool
97+
, statusOutputFormat :: Flag StatusOutputFormat
98+
} deriving (Eq, Show, Read)
99+
100+
defaultStatusFlags :: StatusFlags
101+
defaultStatusFlags = StatusFlags
102+
{ statusBuildInfo = mempty
103+
, statusCompiler = mempty
104+
, statusOutputFormat = mempty
105+
}
106+
107+
statusOutputFormatParser :: ReadE (Flag StatusOutputFormat)
108+
statusOutputFormatParser = ReadE $ \case
109+
"json" -> Right $ Flag JSON
110+
policy -> Left $ "Cannot parse the status output format '"
111+
<> policy <> "'"
112+
113+
statusOutputFormatPrinter
114+
:: Flag StatusOutputFormat -> [String]
115+
statusOutputFormatPrinter = \case
116+
(Flag JSON) -> ["json"]
117+
NoFlag -> []
118+
119+
statusOptions :: ShowOrParseArgs -> [OptionField StatusFlags]
120+
statusOptions showOrParseArgs =
121+
[ option [] ["output-format"]
122+
"Output Format for the information"
123+
statusOutputFormat (\v flags -> flags { statusOutputFormat = v })
124+
(reqArg "json"
125+
statusOutputFormatParser
126+
statusOutputFormatPrinter
127+
)
128+
, option [] ["build-info"]
129+
"List all available targets in the project"
130+
statusBuildInfo (\v flags -> flags { statusBuildInfo = v ++ statusBuildInfo flags})
131+
(reqArg "TARGET" buildInfoTargetReadE (fmap show))
132+
, option [] ["compiler-info"]
133+
"Print information of the project compiler"
134+
statusCompiler (\v flags -> flags { statusCompiler = v })
135+
(yesNoOpt showOrParseArgs)
136+
]
137+
where
138+
buildInfoTargetReadE :: ReadE [String]
139+
buildInfoTargetReadE =
140+
parsecToReadE
141+
-- This error should never be shown
142+
("couldn't parse targets: " ++)
143+
-- TODO: wrong parser, kills filepaths with spaces
144+
(parsecCommaList parsecToken)
145+
146+
-------------------------------------------------------------------------------
147+
-- Action
148+
-------------------------------------------------------------------------------
149+
150+
-- | Entry point for the 'status' command.
151+
statusAction :: NixStyleFlags StatusFlags -> [String] -> GlobalFlags -> IO ()
152+
statusAction flags@NixStyleFlags { extraFlags = statusFlags, ..} cliTargetStrings globalFlags = do
153+
when (NoFlag == statusOutputFormat statusFlags) $ do
154+
die' verbosity "The status command requires the flag '--output-format'."
155+
when (not $ null cliTargetStrings) $
156+
die' verbosity "The status command takes not target arguments directly. Use appropriate flags to pass in target information."
157+
158+
baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand
159+
(_, elaboratedPlan, elabSharedConfig, _, _) <-
160+
rebuildInstallPlan verbosity
161+
(distDirLayout baseCtx)
162+
(cabalDirLayout baseCtx)
163+
(projectConfig baseCtx)
164+
(localPackages baseCtx)
165+
166+
let initialJson = Json.object
167+
[ "cabal-version" .= jdisplay cabalInstallVersion
168+
]
169+
170+
compilerJson <- if not $ fromFlagOrDefault False (statusCompiler statusFlags)
171+
then pure $ Json.object [] -- Neutral element
172+
else do
173+
let compiler = pkgConfigCompiler elabSharedConfig
174+
compilerProg <- requireCompilerProg verbosity compiler
175+
let progDb = pkgConfigCompilerProgs elabSharedConfig
176+
(configuredCompilerProg, _) <- requireProgram verbosity compilerProg progDb
177+
pure $ mkCompilerInfo configuredCompilerProg compiler
178+
179+
buildInfoJson <- if null (statusBuildInfo statusFlags)
180+
then pure $ Json.object [] -- Neutral element
181+
else do
182+
let targetStrings = statusBuildInfo statusFlags
183+
targetSelectors <- readTargetSelectors (localPackages baseCtx) Nothing targetStrings >>= \case
184+
Left err -> reportTargetSelectorProblems verbosity err
185+
Right sels -> pure sels
186+
187+
-- Interpret the targets on the command line as build targets
188+
-- (as opposed to say repl or haddock targets).
189+
-- TODO: don't throw on targets that are invalid.
190+
targets <- either (reportBuildTargetProblems verbosity) return
191+
$ resolveTargets
192+
selectPackageTargets
193+
selectComponentTarget
194+
elaboratedPlan
195+
Nothing
196+
targetSelectors
197+
198+
pure $ mkBuildInfoJson (distDirLayout baseCtx) elabSharedConfig
199+
elaboratedPlan targets targetSelectors targetStrings
200+
201+
let statusJson = mergeJsonObjects [initialJson, compilerJson, buildInfoJson]
202+
203+
-- Final output
204+
putStrLn $ withOutputMarker verbosity $ Json.encodeToString statusJson
205+
where
206+
verbosity = fromFlagOrDefault normal (configVerbosity configFlags)
207+
cliConfig = commandLineFlagsToProjectConfig globalFlags flags mempty
208+
209+
-- ----------------------------------------------------------------------------
210+
-- Helpers for determining and serialising compiler information
211+
-- ----------------------------------------------------------------------------
212+
213+
requireCompilerProg :: Verbosity -> Compiler -> IO Program
214+
requireCompilerProg verbosity compiler =
215+
case compilerFlavor compiler of
216+
GHC -> pure ghcProgram
217+
GHCJS -> pure ghcjsProgram
218+
flavour -> die' verbosity $
219+
"status: Unsupported compiler flavour: "
220+
<> prettyShow flavour
221+
222+
mkCompilerInfo :: ConfiguredProgram -> Compiler -> Json.Value
223+
mkCompilerInfo compilerProgram compiler =
224+
Json.object
225+
[ "compiler" .= Json.object
226+
[ "flavour" .= Json.String (prettyShow $ compilerFlavor compiler)
227+
, "compiler-id" .= Json.String (showCompilerId compiler)
228+
, "path" .= Json.String (programPath compilerProgram)
229+
]
230+
]
231+
232+
-- ----------------------------------------------------------------------------
233+
-- Helpers for determining and serialising build info
234+
-- ----------------------------------------------------------------------------
235+
236+
mkBuildInfoJson :: DistDirLayout -> ElaboratedSharedConfig -> ElaboratedInstallPlan -> TargetsMap -> [TargetSelector] -> [String] -> Json.Value
237+
mkBuildInfoJson distDirLayout elaboratedSharedConfig elaboratedPlan targetsMap targetSelectors targetStrings = Json.object
238+
[ "build-info" .= Json.Array allTargetsJsons
239+
]
240+
where
241+
allTargetsJsons =
242+
[ planPackageToJ elab ts
243+
| (uid, elab) <- Map.assocs subsetInstallPlan
244+
, (_, tss) <- targetsMap Map.! uid
245+
, ts <- ordNub $ toList tss
246+
]
247+
248+
subsetInstallPlan = Map.restrictKeys (InstallPlan.toMap elaboratedPlan) (Map.keysSet targetsMap)
249+
250+
targetsTable = Map.fromList $ zip targetSelectors targetStrings
251+
252+
tsToOriginalTarget ts = targetsTable Map.! ts
253+
254+
planPackageToJ :: ElaboratedPlanPackage -> TargetSelector -> Json.Value
255+
planPackageToJ pkg ts =
256+
case pkg of
257+
InstallPlan.PreExisting ipi -> installedPackageInfoToJ ipi
258+
InstallPlan.Configured elab -> elaboratedPackageToJ elab ts
259+
InstallPlan.Installed elab -> elaboratedPackageToJ elab ts
260+
-- Note that the --build-info currently only uses the elaborated plan,
261+
-- not the improved plan. So we will not get the Installed state for
262+
-- that case, but the code supports it in case we want to use this
263+
-- later in some use case where we want the status of the build.
264+
265+
-- TODO: what should we do if we run in this case?
266+
-- Happens on `--build-info=containers` while we are not in the containers project.
267+
installedPackageInfoToJ :: InstalledPackageInfo -> Json.Value
268+
installedPackageInfoToJ _ipi =
269+
-- Pre-existing packages lack configuration information such as their flag
270+
-- settings or non-lib components. We only get pre-existing packages for
271+
-- the global/core packages however, so this isn't generally a problem.
272+
-- So these packages are never local to the project.
273+
--
274+
Json.object []
275+
276+
elaboratedPackageToJ :: ElaboratedConfiguredPackage -> TargetSelector -> Json.Value
277+
elaboratedPackageToJ elab ts = Json.object
278+
[ "target" .= Json.String (tsToOriginalTarget ts)
279+
, "path" .= maybe Json.Null Json.String buildInfoFileLocation
280+
]
281+
where
282+
dist_dir :: FilePath
283+
dist_dir = distBuildDirectory distDirLayout
284+
(elabDistDirParams elaboratedSharedConfig elab)
285+
286+
-- | Only add build-info file location if the Setup.hs CLI
287+
-- is recent enough to be able to generate build info files.
288+
-- Otherwise, write 'null'.
289+
--
290+
-- Consumers of `status` can use the nullability of this file location
291+
-- to indicate that the given component uses `build-type: Custom`
292+
-- with an old lib:Cabal version.
293+
buildInfoFileLocation :: Maybe FilePath
294+
buildInfoFileLocation
295+
| elabSetupScriptCliVersion elab < mkVersion [3, 7, 0, 0]
296+
= Nothing
297+
| otherwise
298+
= Just (buildInfoPref dist_dir)
299+
300+
-- ----------------------------------------------------------------------------
301+
-- Target selectors and helpers
302+
-- ----------------------------------------------------------------------------
303+
304+
-- | This defines what a 'TargetSelector' means for the @status@ command.
305+
-- It selects the 'AvailableTarget's that the 'TargetSelector' refers to,
306+
-- or otherwise classifies the problem.
307+
--
308+
-- For the @status@ command select all components except non-buildable
309+
-- and disabled tests\/benchmarks, fail if there are no such
310+
-- components
311+
--
312+
selectPackageTargets :: TargetSelector
313+
-> [AvailableTarget k] -> Either TargetProblem' [k]
314+
selectPackageTargets targetSelector targets
315+
316+
-- If there are any buildable targets then we select those
317+
| not (null targetsBuildable)
318+
= Right targetsBuildable
319+
320+
-- If there are targets but none are buildable then we report those
321+
| not (null targets)
322+
= Left (TargetProblemNoneEnabled targetSelector targets')
323+
324+
-- If there are no targets at all then we report that
325+
| otherwise
326+
= Left (TargetProblemNoTargets targetSelector)
327+
where
328+
targets' = forgetTargetsDetail targets
329+
targetsBuildable = selectBuildableTargetsWith
330+
(buildable targetSelector)
331+
targets
332+
333+
-- When there's a target filter like "pkg:tests" then we do select tests,
334+
-- but if it's just a target like "pkg" then we don't build tests unless
335+
-- they are requested by default (i.e. by using --enable-tests)
336+
buildable (TargetPackage _ _ Nothing) TargetNotRequestedByDefault = False
337+
buildable (TargetAllPackages Nothing) TargetNotRequestedByDefault = False
338+
buildable _ _ = True
339+
340+
-- | For a 'TargetComponent' 'TargetSelector', check if the component can be
341+
-- selected.
342+
--
343+
-- For the @build@ command we just need the basic checks on being buildable etc.
344+
--
345+
selectComponentTarget :: SubComponentTarget
346+
-> AvailableTarget k -> Either TargetProblem' k
347+
selectComponentTarget = selectComponentTargetBasic
348+
349+
reportBuildTargetProblems :: Verbosity -> [TargetProblem'] -> IO a
350+
reportBuildTargetProblems verbosity problems =
351+
reportTargetProblems verbosity "status" problems
352+
353+
-- ----------------------------------------------------------------------------
354+
-- JSON serialisation helpers
355+
-- ----------------------------------------------------------------------------
356+
357+
jdisplay :: Pretty a => a -> Json.Value
358+
jdisplay = Json.String . prettyShow
359+
360+
mergeJsonObjects :: [Json.Value] -> Json.Value
361+
mergeJsonObjects = Json.object . foldl' go []
362+
where
363+
go acc (Json.Object objs) =
364+
acc <> objs
365+
go _ _ =
366+
error "mergeJsonObjects: Only objects can be merged"

‎cabal-install/src/Distribution/Client/Setup.hs

+1
Original file line numberDiff line numberDiff line change
@@ -273,6 +273,7 @@ globalCommand commands = CommandUI {
273273
, addCmd "hscolour"
274274
, addCmd "exec"
275275
, addCmd "list-bin"
276+
, addCmd "status"
276277
, par
277278
, startGroup "new-style projects (forwards-compatible aliases)"
278279
, addCmd "v2-build"

0 commit comments

Comments
 (0)