Skip to content

Commit 7a02cda

Browse files
23Skidoo23Skidoo
authored
Merge pull request #6108 from haskell/pr/show-build-info-libcabal
show-build-info (lib:Cabal part)
2 parents f64cee9 + ac1fc0f commit 7a02cda

File tree

6 files changed

+325
-1
lines changed

6 files changed

+325
-1
lines changed

‎Cabal/Cabal.cabal

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -375,6 +375,7 @@ library
375375
Distribution.Simple.Program.Types
376376
Distribution.Simple.Register
377377
Distribution.Simple.Setup
378+
Distribution.Simple.ShowBuildInfo
378379
Distribution.Simple.SrcDist
379380
Distribution.Simple.Test
380381
Distribution.Simple.Test.ExeV10
@@ -534,6 +535,7 @@ library
534535
Distribution.Simple.GHC.EnvironmentParser
535536
Distribution.Simple.GHC.Internal
536537
Distribution.Simple.GHC.ImplInfo
538+
Distribution.Simple.Utils.Json
537539
Paths_Cabal
538540

539541
if flag(bundled-binary-generic)

‎Cabal/Distribution/Simple.hs

Lines changed: 28 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -179,6 +179,7 @@ defaultMainHelper hooks args = topHandler $ do
179179
[configureCommand progs `commandAddAction`
180180
\fs as -> configureAction hooks fs as >> return ()
181181
,buildCommand progs `commandAddAction` buildAction hooks
182+
,showBuildInfoCommand progs `commandAddAction` showBuildInfoAction hooks
182183
,replCommand progs `commandAddAction` replAction hooks
183184
,installCommand `commandAddAction` installAction hooks
184185
,copyCommand `commandAddAction` copyAction hooks
@@ -264,6 +265,33 @@ buildAction hooks flags args = do
264265
(return lbi { withPrograms = progs })
265266
hooks flags' { buildArgs = args } args
266267

268+
showBuildInfoAction :: UserHooks -> ShowBuildInfoFlags -> Args -> IO ()
269+
showBuildInfoAction hooks (ShowBuildInfoFlags flags fileOutput) args = do
270+
distPref <- findDistPrefOrDefault (buildDistPref flags)
271+
let verbosity = fromFlag $ buildVerbosity flags
272+
lbi <- getBuildConfig hooks verbosity distPref
273+
let flags' = flags { buildDistPref = toFlag distPref
274+
, buildCabalFilePath = maybeToFlag (cabalFilePath lbi)
275+
}
276+
277+
progs <- reconfigurePrograms verbosity
278+
(buildProgramPaths flags')
279+
(buildProgramArgs flags')
280+
(withPrograms lbi)
281+
282+
pbi <- preBuild hooks args flags'
283+
let lbi' = lbi { withPrograms = progs }
284+
pkg_descr0 = localPkgDescr lbi'
285+
pkg_descr = updatePackageDescription pbi pkg_descr0
286+
-- TODO: Somehow don't ignore build hook?
287+
buildInfoString <- showBuildInfo pkg_descr lbi' flags
288+
289+
case fileOutput of
290+
Nothing -> putStr buildInfoString
291+
Just fp -> writeFile fp buildInfoString
292+
293+
postBuild hooks args flags' pkg_descr lbi'
294+
267295
replAction :: UserHooks -> ReplFlags -> Args -> IO ()
268296
replAction hooks flags args = do
269297
distPref <- findDistPrefOrDefault (replDistPref flags)

‎Cabal/Distribution/Simple/Build.hs

Lines changed: 15 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -19,7 +19,7 @@
1919
--
2020

2121
module Distribution.Simple.Build (
22-
build, repl,
22+
build, showBuildInfo, repl,
2323
startInterpreter,
2424

2525
initialBuildSteps,
@@ -69,11 +69,13 @@ import Distribution.Simple.PreProcess
6969
import Distribution.Simple.LocalBuildInfo
7070
import Distribution.Simple.Program.Types
7171
import Distribution.Simple.Program.Db
72+
import Distribution.Simple.ShowBuildInfo
7273
import Distribution.Simple.BuildPaths
7374
import Distribution.Simple.Configure
7475
import Distribution.Simple.Register
7576
import Distribution.Simple.Test.LibV09
7677
import Distribution.Simple.Utils
78+
import Distribution.Simple.Utils.Json
7779

7880
import Distribution.System
7981
import Distribution.Pretty
@@ -128,6 +130,18 @@ build pkg_descr lbi flags suffixes = do
128130
verbosity = fromFlag (buildVerbosity flags)
129131

130132

133+
showBuildInfo :: PackageDescription -- ^ Mostly information from the .cabal file
134+
-> LocalBuildInfo -- ^ Configuration information
135+
-> BuildFlags -- ^ Flags that the user passed to build
136+
-> IO String
137+
showBuildInfo pkg_descr lbi flags = do
138+
let verbosity = fromFlag (buildVerbosity flags)
139+
targets <- readTargetInfos verbosity pkg_descr lbi (buildArgs flags)
140+
let targetsToBuild = neededTargetsInBuildOrder' pkg_descr lbi (map nodeKey targets)
141+
doc = mkBuildInfo pkg_descr lbi flags targetsToBuild
142+
return $ renderJson doc ""
143+
144+
131145
repl :: PackageDescription -- ^ Mostly information from the .cabal file
132146
-> LocalBuildInfo -- ^ Configuration information
133147
-> ReplFlags -- ^ Flags that the user passed to build

‎Cabal/Distribution/Simple/Setup.hs

Lines changed: 76 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -45,6 +45,7 @@ module Distribution.Simple.Setup (
4545
HaddockFlags(..), emptyHaddockFlags, defaultHaddockFlags, haddockCommand,
4646
HscolourFlags(..), emptyHscolourFlags, defaultHscolourFlags, hscolourCommand,
4747
BuildFlags(..), emptyBuildFlags, defaultBuildFlags, buildCommand,
48+
ShowBuildInfoFlags(..), defaultShowBuildFlags, showBuildInfoCommand,
4849
ReplFlags(..), defaultReplFlags, replCommand,
4950
CleanFlags(..), emptyCleanFlags, defaultCleanFlags, cleanCommand,
5051
RegisterFlags(..), emptyRegisterFlags, defaultRegisterFlags, registerCommand,
@@ -2205,6 +2206,81 @@ optionNumJobs get set =
22052206
| otherwise -> Right (Just n)
22062207
_ -> Left "The jobs value should be a number or '$ncpus'"
22072208

2209+
2210+
-- ------------------------------------------------------------
2211+
-- * show-build-info command flags
2212+
-- ------------------------------------------------------------
2213+
2214+
data ShowBuildInfoFlags = ShowBuildInfoFlags
2215+
{ buildInfoBuildFlags :: BuildFlags
2216+
, buildInfoOutputFile :: Maybe FilePath
2217+
} deriving Show
2218+
2219+
defaultShowBuildFlags :: ShowBuildInfoFlags
2220+
defaultShowBuildFlags =
2221+
ShowBuildInfoFlags
2222+
{ buildInfoBuildFlags = defaultBuildFlags
2223+
, buildInfoOutputFile = Nothing
2224+
}
2225+
2226+
showBuildInfoCommand :: ProgramDb -> CommandUI ShowBuildInfoFlags
2227+
showBuildInfoCommand progDb = CommandUI
2228+
{ commandName = "show-build-info"
2229+
, commandSynopsis = "Emit details about how a package would be built."
2230+
, commandDescription = Just $ \_ -> wrapText $
2231+
"Components encompass executables, tests, and benchmarks.\n"
2232+
++ "\n"
2233+
++ "Affected by configuration options, see `configure`.\n"
2234+
, commandNotes = Just $ \pname ->
2235+
"Examples:\n"
2236+
++ " " ++ pname ++ " show-build-info "
2237+
++ " All the components in the package\n"
2238+
++ " " ++ pname ++ " show-build-info foo "
2239+
++ " A component (i.e. lib, exe, test suite)\n\n"
2240+
++ programFlagsDescription progDb
2241+
--TODO: re-enable once we have support for module/file targets
2242+
-- ++ " " ++ pname ++ " show-build-info Foo.Bar "
2243+
-- ++ " A module\n"
2244+
-- ++ " " ++ pname ++ " show-build-info Foo/Bar.hs"
2245+
-- ++ " A file\n\n"
2246+
-- ++ "If a target is ambiguous it can be qualified with the component "
2247+
-- ++ "name, e.g.\n"
2248+
-- ++ " " ++ pname ++ " show-build-info foo:Foo.Bar\n"
2249+
-- ++ " " ++ pname ++ " show-build-info testsuite1:Foo/Bar.hs\n"
2250+
, commandUsage = usageAlternatives "show-build-info" $
2251+
[ "[FLAGS]"
2252+
, "COMPONENTS [FLAGS]"
2253+
]
2254+
, commandDefaultFlags = defaultShowBuildFlags
2255+
, commandOptions = \showOrParseArgs ->
2256+
parseBuildFlagsForShowBuildInfoFlags showOrParseArgs progDb
2257+
++
2258+
[ option [] ["buildinfo-json-output"]
2259+
"Write the result to the given file instead of stdout"
2260+
buildInfoOutputFile (\pf flags -> flags { buildInfoOutputFile = pf })
2261+
(reqArg' "FILE" Just (maybe [] pure))
2262+
]
2263+
2264+
}
2265+
2266+
parseBuildFlagsForShowBuildInfoFlags :: ShowOrParseArgs -> ProgramDb -> [OptionField ShowBuildInfoFlags]
2267+
parseBuildFlagsForShowBuildInfoFlags showOrParseArgs progDb =
2268+
map
2269+
(liftOption
2270+
buildInfoBuildFlags
2271+
(\bf flags -> flags { buildInfoBuildFlags = bf } )
2272+
)
2273+
buildFlags
2274+
where
2275+
buildFlags = buildOptions progDb showOrParseArgs
2276+
++
2277+
[ optionVerbosity
2278+
buildVerbosity (\v flags -> flags { buildVerbosity = v })
2279+
2280+
, optionDistPref
2281+
buildDistPref (\d flags -> flags { buildDistPref = d }) showOrParseArgs
2282+
]
2283+
22082284
-- ------------------------------------------------------------
22092285
-- * Other Utils
22102286
-- ------------------------------------------------------------

‎Cabal/Distribution/Simple/ShowBuildInfo.hs

Lines changed: 158 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,158 @@
1+
-- |
2+
-- This module defines a simple JSON-based format for exporting basic
3+
-- information about a Cabal package and the compiler configuration Cabal
4+
-- would use to build it. This can be produced with the
5+
-- @cabal new-show-build-info@ command.
6+
--
7+
--
8+
-- This format is intended for consumption by external tooling and should
9+
-- therefore be rather stable. Moreover, this allows tooling users to avoid
10+
-- linking against Cabal. This is an important advantage as direct API usage
11+
-- tends to be rather fragile in the presence of user-initiated upgrades of
12+
-- Cabal.
13+
--
14+
-- Below is an example of the output this module produces,
15+
--
16+
-- @
17+
-- { "cabal-version": "1.23.0.0",
18+
-- "compiler": {
19+
-- "flavour": "GHC",
20+
-- "compiler-id": "ghc-7.10.2",
21+
-- "path": "/usr/bin/ghc",
22+
-- },
23+
-- "components": [
24+
-- { "type": "lib",
25+
-- "name": "lib:Cabal",
26+
-- "compiler-args":
27+
-- ["-O", "-XHaskell98", "-Wall",
28+
-- "-package-id", "parallel-3.2.0.6-b79c38c5c25fff77f3ea7271851879eb"]
29+
-- "modules": ["Project.ModA", "Project.ModB", "Paths_project"],
30+
-- "src-files": [],
31+
-- "src-dirs": ["src"]
32+
-- }
33+
-- ]
34+
-- }
35+
-- @
36+
--
37+
-- The @cabal-version@ property provides the version of the Cabal library
38+
-- which generated the output. The @compiler@ property gives some basic
39+
-- information about the compiler Cabal would use to compile the package.
40+
--
41+
-- The @components@ property gives a list of the Cabal 'Component's defined by
42+
-- the package. Each has,
43+
--
44+
-- * @type@: the type of the component (one of @lib@, @exe@,
45+
-- @test@, @bench@, or @flib@)
46+
-- * @name@: a string serving to uniquely identify the component within the
47+
-- package.
48+
-- * @compiler-args@: the command-line arguments Cabal would pass to the
49+
-- compiler to compile the component
50+
-- * @modules@: the modules belonging to the component
51+
-- * @src-dirs@: a list of directories where the modules might be found
52+
-- * @src-files@: any other Haskell sources needed by the component
53+
--
54+
-- Note: At the moment this is only supported when using the GHC compiler.
55+
--
56+
57+
module Distribution.Simple.ShowBuildInfo (mkBuildInfo) where
58+
59+
import qualified Distribution.Simple.GHC as GHC
60+
import qualified Distribution.Simple.Program.GHC as GHC
61+
62+
import Distribution.PackageDescription
63+
import Distribution.Compiler
64+
import Distribution.Verbosity
65+
import Distribution.Simple.Compiler
66+
import Distribution.Simple.LocalBuildInfo
67+
import Distribution.Simple.Program
68+
import Distribution.Simple.Setup
69+
import Distribution.Simple.Utils (cabalVersion)
70+
import Distribution.Simple.Utils.Json
71+
import Distribution.Types.TargetInfo
72+
import Distribution.Text
73+
import Distribution.Pretty
74+
75+
-- | Construct a JSON document describing the build information for a
76+
-- package.
77+
mkBuildInfo
78+
:: PackageDescription -- ^ Mostly information from the .cabal file
79+
-> LocalBuildInfo -- ^ Configuration information
80+
-> BuildFlags -- ^ Flags that the user passed to build
81+
-> [TargetInfo]
82+
-> Json
83+
mkBuildInfo pkg_descr lbi _flags targetsToBuild = info
84+
where
85+
targetToNameAndLBI target =
86+
(componentLocalName $ targetCLBI target, targetCLBI target)
87+
componentsToBuild = map targetToNameAndLBI targetsToBuild
88+
(.=) :: String -> Json -> (String, Json)
89+
k .= v = (k, v)
90+
91+
info = JsonObject
92+
[ "cabal-version" .= JsonString (display cabalVersion)
93+
, "compiler" .= mkCompilerInfo
94+
, "components" .= JsonArray (map mkComponentInfo componentsToBuild)
95+
]
96+
97+
mkCompilerInfo = JsonObject
98+
[ "flavour" .= JsonString (prettyShow $ compilerFlavor $ compiler lbi)
99+
, "compiler-id" .= JsonString (showCompilerId $ compiler lbi)
100+
, "path" .= path
101+
]
102+
where
103+
path = maybe JsonNull (JsonString . programPath)
104+
$ (flavorToProgram . compilerFlavor $ compiler lbi)
105+
>>= flip lookupProgram (withPrograms lbi)
106+
107+
flavorToProgram :: CompilerFlavor -> Maybe Program
108+
flavorToProgram GHC = Just ghcProgram
109+
flavorToProgram GHCJS = Just ghcjsProgram
110+
flavorToProgram UHC = Just uhcProgram
111+
flavorToProgram JHC = Just jhcProgram
112+
flavorToProgram _ = Nothing
113+
114+
mkComponentInfo (name, clbi) = JsonObject
115+
[ "type" .= JsonString compType
116+
, "name" .= JsonString (prettyShow name)
117+
, "unit-id" .= JsonString (prettyShow $ componentUnitId clbi)
118+
, "compiler-args" .= JsonArray (map JsonString $ getCompilerArgs bi lbi clbi)
119+
, "modules" .= JsonArray (map (JsonString . display) modules)
120+
, "src-files" .= JsonArray (map JsonString sourceFiles)
121+
, "src-dirs" .= JsonArray (map JsonString $ hsSourceDirs bi)
122+
]
123+
where
124+
bi = componentBuildInfo comp
125+
Just comp = lookupComponent pkg_descr name
126+
compType = case comp of
127+
CLib _ -> "lib"
128+
CExe _ -> "exe"
129+
CTest _ -> "test"
130+
CBench _ -> "bench"
131+
CFLib _ -> "flib"
132+
modules = case comp of
133+
CLib lib -> explicitLibModules lib
134+
CExe exe -> exeModules exe
135+
_ -> []
136+
sourceFiles = case comp of
137+
CLib _ -> []
138+
CExe exe -> [modulePath exe]
139+
_ -> []
140+
141+
-- | Get the command-line arguments that would be passed
142+
-- to the compiler to build the given component.
143+
getCompilerArgs
144+
:: BuildInfo
145+
-> LocalBuildInfo
146+
-> ComponentLocalBuildInfo
147+
-> [String]
148+
getCompilerArgs bi lbi clbi =
149+
case compilerFlavor $ compiler lbi of
150+
GHC -> ghc
151+
GHCJS -> ghc
152+
c -> error $ "ShowBuildInfo.getCompilerArgs: Don't know how to get "++
153+
"build arguments for compiler "++show c
154+
where
155+
-- This is absolutely awful
156+
ghc = GHC.renderGhcOptions (compiler lbi) (hostPlatform lbi) baseOpts
157+
where
158+
baseOpts = GHC.componentGhcOptions normal lbi bi clbi (buildDir lbi)

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

Lines changed: 46 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,46 @@
1+
-- | Utility json lib for Cabal
2+
-- TODO: Remove it again.
3+
module Distribution.Simple.Utils.Json
4+
( Json(..)
5+
, renderJson
6+
) where
7+
8+
data Json = JsonArray [Json]
9+
| JsonBool !Bool
10+
| JsonNull
11+
| JsonNumber !Int
12+
| JsonObject [(String, Json)]
13+
| JsonString !String
14+
15+
renderJson :: Json -> ShowS
16+
renderJson (JsonArray objs) =
17+
surround "[" "]" $ intercalate "," $ map renderJson objs
18+
renderJson (JsonBool True) = showString "true"
19+
renderJson (JsonBool False) = showString "false"
20+
renderJson JsonNull = showString "null"
21+
renderJson (JsonNumber n) = shows n
22+
renderJson (JsonObject attrs) =
23+
surround "{" "}" $ intercalate "," $ map render attrs
24+
where
25+
render (k,v) = (surround "\"" "\"" $ showString' k) . showString ":" . renderJson v
26+
renderJson (JsonString s) = surround "\"" "\"" $ showString' s
27+
28+
surround :: String -> String -> ShowS -> ShowS
29+
surround begin end middle = showString begin . middle . showString end
30+
31+
showString' :: String -> ShowS
32+
showString' xs = showStringWorker xs
33+
where
34+
showStringWorker :: String -> ShowS
35+
showStringWorker ('\"':as) = showString "\\\"" . showStringWorker as
36+
showStringWorker ('\\':as) = showString "\\\\" . showStringWorker as
37+
showStringWorker ('\'':as) = showString "\\\'" . showStringWorker as
38+
showStringWorker (x:as) = showString [x] . showStringWorker as
39+
showStringWorker [] = showString ""
40+
41+
intercalate :: String -> [ShowS] -> ShowS
42+
intercalate sep = go
43+
where
44+
go [] = id
45+
go [x] = x
46+
go (x:xs) = x . showString' sep . go xs

0 commit comments

Comments
 (0)