Skip to content

Commit a75aa0b

Browse files
lukel97lukel97
committed
Rework show-build-info command to avoid wrapper
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.
1 parent f10457e commit a75aa0b

17 files changed

+169
-211
lines changed

‎Cabal/Cabal.cabal

+2-2
Original file line numberDiff line numberDiff line change
@@ -506,6 +506,7 @@ library
506506
Distribution.Utils.NubList
507507
Distribution.Utils.ShortText
508508
Distribution.Utils.Progress
509+
Distribution.Utils.Json
509510
Distribution.Verbosity
510511
Distribution.Verbosity.Internal
511512
Distribution.Version
@@ -585,7 +586,6 @@ library
585586
Distribution.Simple.GHC.EnvironmentParser
586587
Distribution.Simple.GHC.Internal
587588
Distribution.Simple.GHC.ImplInfo
588-
Distribution.Simple.Utils.Json
589589
Distribution.ZinzaPrelude
590590
Paths_Cabal
591591

@@ -665,7 +665,7 @@ test-suite unit-tests
665665
Distribution.Described
666666
Distribution.Utils.CharSet
667667
Distribution.Utils.GrammarRegex
668-
668+
669669
main-is: UnitTests.hs
670670
build-depends:
671671
array,

‎Cabal/Distribution/Simple/Build.hs

+1-1
Original file line numberDiff line numberDiff line change
@@ -31,6 +31,7 @@ module Distribution.Simple.Build (
3131
import Prelude ()
3232
import Distribution.Compat.Prelude
3333
import Distribution.Utils.Generic
34+
import Distribution.Utils.Json
3435

3536
import Distribution.Types.ComponentLocalBuildInfo
3637
import Distribution.Types.ComponentRequestedSpec
@@ -76,7 +77,6 @@ import Distribution.Simple.Configure
7677
import Distribution.Simple.Register
7778
import Distribution.Simple.Test.LibV09
7879
import Distribution.Simple.Utils
79-
import Distribution.Simple.Utils.Json
8080

8181
import Distribution.System
8282
import Distribution.Pretty

‎Cabal/Distribution/Simple/ShowBuildInfo.hs

+62-55
Original file line numberDiff line numberDiff line change
@@ -54,7 +54,8 @@
5454
-- Note: At the moment this is only supported when using the GHC compiler.
5555
--
5656

57-
module Distribution.Simple.ShowBuildInfo (mkBuildInfo) where
57+
module Distribution.Simple.ShowBuildInfo
58+
( mkBuildInfo, mkBuildInfo', mkCompilerInfo, mkComponentInfo ) where
5859

5960
import Distribution.Compat.Prelude
6061
import Prelude ()
@@ -70,7 +71,7 @@ import Distribution.Simple.LocalBuildInfo
7071
import Distribution.Simple.Program
7172
import Distribution.Simple.Setup
7273
import Distribution.Simple.Utils (cabalVersion)
73-
import Distribution.Simple.Utils.Json
74+
import Distribution.Utils.Json
7475
import Distribution.Types.TargetInfo
7576
import Distribution.Text
7677
import Distribution.Pretty
@@ -83,63 +84,69 @@ mkBuildInfo
8384
-> BuildFlags -- ^ Flags that the user passed to build
8485
-> [TargetInfo]
8586
-> Json
86-
mkBuildInfo pkg_descr lbi _flags targetsToBuild = info
87-
where
88-
targetToNameAndLBI target =
89-
(componentLocalName $ targetCLBI target, targetCLBI target)
90-
componentsToBuild = map targetToNameAndLBI targetsToBuild
91-
(.=) :: String -> Json -> (String, Json)
92-
k .= v = (k, v)
87+
mkBuildInfo pkg_descr lbi _flags targetsToBuild =
88+
mkBuildInfo' (mkCompilerInfo (withPrograms lbi) (compiler lbi))
89+
(map (mkComponentInfo pkg_descr lbi . targetCLBI) targetsToBuild)
9390

94-
info = JsonObject
95-
[ "cabal-version" .= JsonString (display cabalVersion)
96-
, "compiler" .= mkCompilerInfo
97-
, "components" .= JsonArray (map mkComponentInfo componentsToBuild)
98-
]
91+
-- | A variant of 'mkBuildInfo' if you need to call 'mkCompilerInfo' and
92+
-- 'mkComponentInfo' yourself.
93+
mkBuildInfo'
94+
:: Json -- ^ The 'Json' from 'mkCompilerInfo'
95+
-> [Json] -- ^ The 'Json' from 'mkComponentInfo'
96+
-> Json
97+
mkBuildInfo' cmplrInfo componentInfos =
98+
JsonObject
99+
[ "cabal-version" .= JsonString (display cabalVersion)
100+
, "compiler" .= cmplrInfo
101+
, "components" .= JsonArray componentInfos
102+
]
99103

100-
mkCompilerInfo = JsonObject
101-
[ "flavour" .= JsonString (prettyShow $ compilerFlavor $ compiler lbi)
102-
, "compiler-id" .= JsonString (showCompilerId $ compiler lbi)
103-
, "path" .= path
104-
]
105-
where
106-
path = maybe JsonNull (JsonString . programPath)
107-
$ (flavorToProgram . compilerFlavor $ compiler lbi)
108-
>>= flip lookupProgram (withPrograms lbi)
104+
mkCompilerInfo :: ProgramDb -> Compiler -> Json
105+
mkCompilerInfo programDb cmplr = JsonObject
106+
[ "flavour" .= JsonString (prettyShow $ compilerFlavor cmplr)
107+
, "compiler-id" .= JsonString (showCompilerId cmplr)
108+
, "path" .= path
109+
]
110+
where
111+
path = maybe JsonNull (JsonString . programPath)
112+
$ (flavorToProgram . compilerFlavor $ cmplr)
113+
>>= flip lookupProgram programDb
109114

110-
flavorToProgram :: CompilerFlavor -> Maybe Program
111-
flavorToProgram GHC = Just ghcProgram
112-
flavorToProgram GHCJS = Just ghcjsProgram
113-
flavorToProgram UHC = Just uhcProgram
114-
flavorToProgram JHC = Just jhcProgram
115-
flavorToProgram _ = Nothing
115+
flavorToProgram :: CompilerFlavor -> Maybe Program
116+
flavorToProgram GHC = Just ghcProgram
117+
flavorToProgram GHCJS = Just ghcjsProgram
118+
flavorToProgram UHC = Just uhcProgram
119+
flavorToProgram JHC = Just jhcProgram
120+
flavorToProgram _ = Nothing
116121

117-
mkComponentInfo (name, clbi) = JsonObject
118-
[ "type" .= JsonString compType
119-
, "name" .= JsonString (prettyShow name)
120-
, "unit-id" .= JsonString (prettyShow $ componentUnitId clbi)
121-
, "compiler-args" .= JsonArray (map JsonString $ getCompilerArgs bi lbi clbi)
122-
, "modules" .= JsonArray (map (JsonString . display) modules)
123-
, "src-files" .= JsonArray (map JsonString sourceFiles)
124-
, "src-dirs" .= JsonArray (map JsonString $ hsSourceDirs bi)
125-
]
126-
where
127-
bi = componentBuildInfo comp
128-
comp = fromMaybe (error $ "mkBuildInfo: no component " ++ prettyShow name) $ lookupComponent pkg_descr name
129-
compType = case comp of
130-
CLib _ -> "lib"
131-
CExe _ -> "exe"
132-
CTest _ -> "test"
133-
CBench _ -> "bench"
134-
CFLib _ -> "flib"
135-
modules = case comp of
136-
CLib lib -> explicitLibModules lib
137-
CExe exe -> exeModules exe
138-
_ -> []
139-
sourceFiles = case comp of
140-
CLib _ -> []
141-
CExe exe -> [modulePath exe]
142-
_ -> []
122+
mkComponentInfo :: PackageDescription -> LocalBuildInfo -> ComponentLocalBuildInfo -> Json
123+
mkComponentInfo pkg_descr lbi clbi = JsonObject
124+
[ "type" .= JsonString compType
125+
, "name" .= JsonString (prettyShow name)
126+
, "unit-id" .= JsonString (prettyShow $ componentUnitId clbi)
127+
, "compiler-args" .= JsonArray (map JsonString $ getCompilerArgs bi lbi clbi)
128+
, "modules" .= JsonArray (map (JsonString . display) modules)
129+
, "src-files" .= JsonArray (map JsonString sourceFiles)
130+
, "src-dirs" .= JsonArray (map JsonString $ hsSourceDirs bi)
131+
]
132+
where
133+
name = componentLocalName clbi
134+
bi = componentBuildInfo comp
135+
comp = fromMaybe (error $ "mkBuildInfo: no component " ++ prettyShow name) $ lookupComponent pkg_descr name
136+
compType = case comp of
137+
CLib _ -> "lib"
138+
CExe _ -> "exe"
139+
CTest _ -> "test"
140+
CBench _ -> "bench"
141+
CFLib _ -> "flib"
142+
modules = case comp of
143+
CLib lib -> explicitLibModules lib
144+
CExe exe -> exeModules exe
145+
_ -> []
146+
sourceFiles = case comp of
147+
CLib _ -> []
148+
CExe exe -> [modulePath exe]
149+
_ -> []
143150

144151
-- | Get the command-line arguments that would be passed
145152
-- to the compiler to build the given component.

‎Cabal/Distribution/Simple/Utils/Json.hs renamed to ‎Cabal/Distribution/Utils/Json.hs

+7-3
Original file line numberDiff line numberDiff line change
@@ -1,7 +1,8 @@
1-
-- | Utility json lib for Cabal
2-
-- TODO: Remove it again.
3-
module Distribution.Simple.Utils.Json
1+
-- | Extremely simple JSON helper. Don't do anything too fancy with this!
2+
3+
module Distribution.Utils.Json
44
( Json(..)
5+
, (.=)
56
, renderJson
67
) where
78

@@ -44,3 +45,6 @@ intercalate sep = go
4445
go [] = id
4546
go [x] = x
4647
go (x:xs) = x . showString' sep . go xs
48+
49+
(.=) :: String -> Json -> (String, Json)
50+
k .= v = (k, v)

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

+40-77
Original file line numberDiff line numberDiff line change
@@ -23,7 +23,7 @@ import Distribution.Simple.Command
2323
import Distribution.Verbosity
2424
( Verbosity, silent )
2525
import Distribution.Simple.Utils
26-
( wrapText, die', withTempDirectory )
26+
( wrapText, die' )
2727
import Distribution.Types.UnitId
2828
( UnitId, mkUnitId )
2929
import Distribution.Types.Version
@@ -36,13 +36,11 @@ import Distribution.Pretty
3636
import qualified Data.Map as Map
3737
import qualified Distribution.Simple.Setup as Cabal
3838
import Distribution.Client.SetupWrapper
39-
import Distribution.Simple.Program
40-
( defaultProgramDb )
4139
import qualified Distribution.Client.InstallPlan as InstallPlan
4240
import Distribution.Client.ProjectPlanning.Types
4341
import Distribution.Client.ProjectPlanning
4442
( setupHsConfigureFlags, setupHsConfigureArgs, setupHsBuildFlags
45-
, setupHsBuildArgs, setupHsScriptOptions )
43+
, setupHsScriptOptions )
4644
import Distribution.Client.NixStyleOptions
4745
( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags )
4846
import Distribution.Client.DistDirLayout
@@ -52,12 +50,16 @@ import Distribution.Client.Types
5250
import Distribution.Client.JobControl
5351
( newLock, Lock )
5452
import Distribution.Simple.Configure
55-
( tryGetPersistBuildConfig )
53+
(getPersistBuildConfig, tryGetPersistBuildConfig )
5654

57-
import System.Directory
58-
( getTemporaryDirectory )
59-
import System.FilePath
60-
( (</>) )
55+
import Distribution.Simple.ShowBuildInfo
56+
import Distribution.Utils.Json
57+
58+
import Distribution.Simple.BuildTarget (readTargetInfos)
59+
import Distribution.Types.LocalBuildInfo (neededTargetsInBuildOrder')
60+
import Distribution.Compat.Graph (IsNode(nodeKey))
61+
import Distribution.Simple.Setup (BuildFlags(buildArgs))
62+
import Distribution.Types.TargetInfo (TargetInfo(targetCLBI))
6163

6264
showBuildInfoCommand :: CommandUI (NixStyleFlags ShowBuildInfoFlags)
6365
showBuildInfoCommand = CommandUI {
@@ -137,51 +139,26 @@ showBuildInfoAction flags@NixStyleFlags { extraFlags = (ShowBuildInfoFlags fileO
137139
cliConfig = commandLineFlagsToProjectConfig globalFlags flags
138140
mempty -- ClientInstallFlags, not needed here
139141

140-
-- Pretty nasty piecemeal out of json, but I can't see a way to retrieve output of the setupWrapper'd tasks
141142
showTargets :: Maybe FilePath -> Maybe [String] -> Verbosity -> ProjectBaseContext -> ProjectBuildContext -> Lock -> IO ()
142143
showTargets fileOutput unitIds verbosity baseCtx buildCtx lock = do
143-
tempDir <- getTemporaryDirectory
144-
withTempDirectory verbosity tempDir "show-build-info" $ \dir -> do
145-
mapM_ (doShowInfo dir) targets
146-
case fileOutput of
147-
Nothing -> outputResult dir putStr targets
148-
Just fp -> do
149-
writeFile fp ""
150-
outputResult dir (appendFile fp) targets
144+
let configured = [p | InstallPlan.Configured p <- InstallPlan.toList (elaboratedPlanOriginal buildCtx)]
145+
targets = maybe (fst <$> (Map.toList . targetsMap $ buildCtx)) (map mkUnitId) unitIds
146+
147+
components <- concat <$> mapM (getComponentInfo verbosity baseCtx buildCtx
148+
lock configured) targets
151149

152-
where configured = [p | InstallPlan.Configured p <- InstallPlan.toList (elaboratedPlanOriginal buildCtx)]
153-
targets = maybe (fst <$> (Map.toList . targetsMap $ buildCtx)) (map mkUnitId) unitIds
154-
doShowInfo :: FilePath -> UnitId -> IO ()
155-
doShowInfo dir unitId =
156-
showInfo
157-
(dir </> unitIdToFilePath unitId)
158-
verbosity
159-
baseCtx
160-
buildCtx
161-
lock
162-
configured
163-
unitId
150+
let compilerInfo = mkCompilerInfo (pkgConfigCompilerProgs (elaboratedShared buildCtx))
151+
(pkgConfigCompiler (elaboratedShared buildCtx))
164152

165-
outputResult :: FilePath -> (String -> IO ()) -> [UnitId] -> IO ()
166-
outputResult dir printer units = do
167-
let unroll [] = return ()
168-
unroll [x] = do
169-
content <- readFile (dir </> unitIdToFilePath x)
170-
printer content
171-
unroll (x:xs) = do
172-
content <- readFile (dir </> unitIdToFilePath x)
173-
printer content
174-
printer ","
175-
unroll xs
176-
printer "["
177-
unroll units
178-
printer "]"
153+
json = mkBuildInfo' compilerInfo components
154+
res = renderJson json ""
179155

180-
unitIdToFilePath :: UnitId -> FilePath
181-
unitIdToFilePath unitId = "build-info-" ++ prettyShow unitId ++ ".json"
156+
case fileOutput of
157+
Nothing -> putStrLn res
158+
Just fp -> writeFile fp res
182159

183-
showInfo :: FilePath -> Verbosity -> ProjectBaseContext -> ProjectBuildContext -> Lock -> [ElaboratedConfiguredPackage] -> UnitId -> IO ()
184-
showInfo fileOutput verbosity baseCtx buildCtx lock pkgs targetUnitId =
160+
getComponentInfo :: Verbosity -> ProjectBaseContext -> ProjectBuildContext -> Lock -> [ElaboratedConfiguredPackage] -> UnitId -> IO [Json]
161+
getComponentInfo verbosity baseCtx buildCtx lock pkgs targetUnitId =
185162
case mbPkg of
186163
Nothing -> die' verbosity $ "No unit " ++ prettyShow targetUnitId
187164
Just pkg -> do
@@ -191,7 +168,6 @@ showInfo fileOutput verbosity baseCtx buildCtx lock pkgs targetUnitId =
191168
buildDir = distBuildDirectory dirLayout (elabDistDirParams shared pkg)
192169
buildType' = buildType (elabPkgDescription pkg)
193170
flags = setupHsBuildFlags pkg shared verbosity buildDir
194-
args = setupHsBuildArgs pkg
195171
srcDir = case (elabPkgSourceLocation pkg) of
196172
LocalUnpackedPackage fp -> fp
197173
_ -> ""
@@ -216,29 +192,25 @@ showInfo fileOutput verbosity baseCtx buildCtx lock pkgs targetUnitId =
216192
++ "For component: " ++ prettyShow targetUnitId
217193
)
218194
-- Configure the package if there's no existing config
219-
lbi <- tryGetPersistBuildConfig buildDir
220-
case lbi of
195+
lbi' <- tryGetPersistBuildConfig buildDir
196+
case lbi' of
221197
Left _ -> setupWrapper
222198
verbosity
223199
scriptOptions
224200
(Just $ elabPkgDescription pkg)
225-
(Cabal.configureCommand defaultProgramDb)
201+
(Cabal.configureCommand
202+
(pkgConfigCompilerProgs (elaboratedShared buildCtx)))
226203
(const configureFlags)
227204
(const configureArgs)
228205
Right _ -> pure ()
229206

230-
setupWrapper
231-
verbosity
232-
scriptOptions
233-
(Just $ elabPkgDescription pkg)
234-
(Cabal.showBuildInfoCommand defaultProgramDb)
235-
(const (Cabal.ShowBuildInfoFlags
236-
{ Cabal.buildInfoBuildFlags = flags
237-
, Cabal.buildInfoOutputFile = Just fileOutput
238-
}
239-
)
240-
)
241-
(const args)
207+
-- Do the bit the Cabal library would normally do here
208+
lbi <- getPersistBuildConfig buildDir
209+
let pkgDesc = elabPkgDescription pkg
210+
targets <- readTargetInfos verbosity pkgDesc lbi (buildArgs flags)
211+
let targetsToBuild = neededTargetsInBuildOrder' pkgDesc lbi (map nodeKey targets)
212+
return $ map (mkComponentInfo pkgDesc lbi . targetCLBI) targetsToBuild
213+
242214
where
243215
mbPkg :: Maybe ElaboratedConfiguredPackage
244216
mbPkg = find ((targetUnitId ==) . elabUnitId) pkgs
@@ -247,9 +219,9 @@ showInfo fileOutput verbosity baseCtx buildCtx lock pkgs targetUnitId =
247219
-- It selects the 'AvailableTarget's that the 'TargetSelector' refers to,
248220
-- or otherwise classifies the problem.
249221
--
250-
-- For the @show-build-info@ command select all components except non-buildable and disabled
251-
-- tests\/benchmarks, fail if there are no such components
252-
--
222+
-- For the @show-build-info@ command select all components. Unlike the @build@
223+
-- command, we want to show info for tests and benchmarks even without the
224+
-- @--enable-tests@\/@--enable-benchmarks@ flag set.
253225
selectPackageTargets :: TargetSelector
254226
-> [AvailableTarget k] -> Either TargetProblem' [k]
255227
selectPackageTargets targetSelector targets
@@ -267,16 +239,7 @@ selectPackageTargets targetSelector targets
267239
= Left (TargetProblemNoTargets targetSelector)
268240
where
269241
targets' = forgetTargetsDetail targets
270-
targetsBuildable = selectBuildableTargetsWith
271-
(buildable targetSelector)
272-
targets
273-
274-
-- When there's a target filter like "pkg:tests" then we do select tests,
275-
-- but if it's just a target like "pkg" then we don't build tests unless
276-
-- they are requested by default (i.e. by using --enable-tests)
277-
buildable (TargetPackage _ _ Nothing) TargetNotRequestedByDefault = False
278-
buildable (TargetAllPackages Nothing) TargetNotRequestedByDefault = False
279-
buildable _ _ = True
242+
targetsBuildable = selectBuildableTargets targets
280243

281244
-- | For a 'TargetComponent' 'TargetSelector', check if the component can be
282245
-- selected.

0 commit comments

Comments
 (0)