Skip to content

Commit 84aa560

Browse files
lukel97lukel97
committed
Rework show-build-info to use ProjectPlanning/Building infrastructure
This fixes a lot of edge cases for example where the package db wasn't created at the time of configuring. Manually doing the setup.hs wrapper stuff was hairy. It also changes the internal representation of JSON to Text rather than String, and introduces the buildinfo-components-only flag in the Cabal part to make it easier to stitch back the JSON into an array in cabal-install. Turns out we do need to keep the show-build-info part inside Cabal as we rely on LocalBuildInfo which can change between versions, and we would need to do this anyway if we wanted to utilise the ProjectPlanning/Building infrastructure.
1 parent 25aef99 commit 84aa560

37 files changed

+328
-239
lines changed

‎Cabal/Distribution/Simple.hs

Lines changed: 19 additions & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -108,6 +108,8 @@ import Data.List (unionBy, (\\))
108108

109109
import Distribution.PackageDescription.Parsec
110110

111+
import qualified Data.Text.IO as T
112+
111113
-- | A simple implementation of @main@ for a Cabal setup script.
112114
-- It reads the package description file using IO, and performs the
113115
-- action specified on the command line.
@@ -265,31 +267,34 @@ buildAction hooks flags args = do
265267
hooks flags' { buildArgs = args } args
266268

267269
showBuildInfoAction :: UserHooks -> ShowBuildInfoFlags -> Args -> IO ()
268-
showBuildInfoAction hooks (ShowBuildInfoFlags flags fileOutput) args = do
269-
distPref <- findDistPrefOrDefault (buildDistPref flags)
270-
let verbosity = fromFlag $ buildVerbosity flags
270+
showBuildInfoAction hooks flags args = do
271+
let buildFlags = buildInfoBuildFlags flags
272+
distPref <- findDistPrefOrDefault (buildDistPref buildFlags)
273+
let verbosity = fromFlag $ buildVerbosity buildFlags
271274
lbi <- getBuildConfig hooks verbosity distPref
272-
let flags' = flags { buildDistPref = toFlag distPref
273-
, buildCabalFilePath = maybeToFlag (cabalFilePath lbi)
274-
}
275+
let buildFlags' =
276+
buildFlags { buildDistPref = toFlag distPref
277+
, buildCabalFilePath = maybeToFlag (cabalFilePath lbi)
278+
}
275279

276280
progs <- reconfigurePrograms verbosity
277-
(buildProgramPaths flags')
278-
(buildProgramArgs flags')
281+
(buildProgramPaths buildFlags')
282+
(buildProgramArgs buildFlags')
279283
(withPrograms lbi)
280284

281-
pbi <- preBuild hooks args flags'
285+
pbi <- preBuild hooks args buildFlags'
282286
let lbi' = lbi { withPrograms = progs }
283287
pkg_descr0 = localPkgDescr lbi'
284288
pkg_descr = updatePackageDescription pbi pkg_descr0
285289
-- TODO: Somehow don't ignore build hook?
286-
buildInfoString <- showBuildInfo pkg_descr lbi' flags
287290

288-
case fileOutput of
289-
Nothing -> putStr buildInfoString
290-
Just fp -> writeFile fp buildInfoString
291+
buildInfoText <- showBuildInfo pkg_descr lbi' flags
292+
293+
case buildInfoOutputFile flags of
294+
Nothing -> T.putStr buildInfoText
295+
Just fp -> T.writeFile fp buildInfoText
291296

292-
postBuild hooks args flags' pkg_descr lbi'
297+
postBuild hooks args buildFlags' pkg_descr lbi'
293298

294299
replAction :: UserHooks -> ReplFlags -> Args -> IO ()
295300
replAction hooks flags args = do

‎Cabal/Distribution/Simple/Build.hs

Lines changed: 17 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -89,6 +89,7 @@ import Control.Monad
8989
import qualified Data.Set as Set
9090
import System.FilePath ( (</>), (<.>), takeDirectory )
9191
import System.Directory ( getCurrentDirectory )
92+
import qualified Data.Text as Text
9293

9394
-- -----------------------------------------------------------------------------
9495
-- |Build the libraries and executables in this package.
@@ -133,15 +134,24 @@ build pkg_descr lbi flags suffixes = do
133134

134135

135136
showBuildInfo :: PackageDescription -- ^ Mostly information from the .cabal file
136-
-> LocalBuildInfo -- ^ Configuration information
137-
-> BuildFlags -- ^ Flags that the user passed to build
138-
-> IO String
137+
-> LocalBuildInfo -- ^ Configuration information
138+
-> ShowBuildInfoFlags -- ^ Flags that the user passed to build
139+
-> IO Text.Text
139140
showBuildInfo pkg_descr lbi flags = do
140-
let verbosity = fromFlag (buildVerbosity flags)
141-
targets <- readTargetInfos verbosity pkg_descr lbi (buildArgs flags)
141+
let buildFlags = buildInfoBuildFlags flags
142+
verbosity = fromFlag (buildVerbosity buildFlags)
143+
targets <- readTargetInfos verbosity pkg_descr lbi (buildArgs buildFlags)
144+
pwd <- getCurrentDirectory
142145
let targetsToBuild = neededTargetsInBuildOrder' pkg_descr lbi (map nodeKey targets)
143-
doc = mkBuildInfo pkg_descr lbi flags targetsToBuild
144-
return $ renderJson doc ""
146+
result
147+
| fromFlag (buildInfoComponentsOnly flags) =
148+
let components = map (mkComponentInfo pwd pkg_descr lbi . targetCLBI)
149+
targetsToBuild
150+
in Text.unlines $ map (flip renderJson mempty) components
151+
| otherwise =
152+
let json = mkBuildInfo pwd pkg_descr lbi buildFlags targetsToBuild
153+
in renderJson json mempty
154+
return result
145155

146156

147157
repl :: PackageDescription -- ^ Mostly information from the .cabal file

‎Cabal/Distribution/Simple/Setup.hs

Lines changed: 12 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -2217,15 +2217,18 @@ optionNumJobs get set =
22172217
-- ------------------------------------------------------------
22182218

22192219
data ShowBuildInfoFlags = ShowBuildInfoFlags
2220-
{ buildInfoBuildFlags :: BuildFlags
2221-
, buildInfoOutputFile :: Maybe FilePath
2220+
{ buildInfoBuildFlags :: BuildFlags
2221+
, buildInfoOutputFile :: Maybe FilePath
2222+
, buildInfoComponentsOnly :: Flag Bool
2223+
-- ^ If 'True' then only print components, each separated by a newline
22222224
} deriving (Show, Typeable)
22232225

22242226
defaultShowBuildFlags :: ShowBuildInfoFlags
22252227
defaultShowBuildFlags =
22262228
ShowBuildInfoFlags
2227-
{ buildInfoBuildFlags = defaultBuildFlags
2228-
, buildInfoOutputFile = Nothing
2229+
{ buildInfoBuildFlags = defaultBuildFlags
2230+
, buildInfoOutputFile = Nothing
2231+
, buildInfoComponentsOnly = Flag False
22292232
}
22302233

22312234
showBuildInfoCommand :: ProgramDb -> CommandUI ShowBuildInfoFlags
@@ -2262,8 +2265,12 @@ showBuildInfoCommand progDb = CommandUI
22622265
++
22632266
[ option [] ["buildinfo-json-output"]
22642267
"Write the result to the given file instead of stdout"
2265-
buildInfoOutputFile (\pf flags -> flags { buildInfoOutputFile = pf })
2268+
buildInfoOutputFile (\v flags -> flags { buildInfoOutputFile = v })
22662269
(reqArg' "FILE" Just (maybe [] pure))
2270+
, option [] ["buildinfo-components-only"]
2271+
"Print out only the component info, each separated by a newline"
2272+
buildInfoComponentsOnly (\v flags -> flags { buildInfoComponentsOnly = v})
2273+
trueArg
22672274
]
22682275

22692276
}

‎Cabal/Distribution/Simple/ShowBuildInfo.hs

Lines changed: 30 additions & 20 deletions
Original file line numberDiff line numberDiff line change
@@ -54,9 +54,13 @@
5454
-- Note: At the moment this is only supported when using the GHC compiler.
5555
--
5656

57+
{-# LANGUAGE OverloadedStrings #-}
58+
5759
module Distribution.Simple.ShowBuildInfo
5860
( mkBuildInfo, mkBuildInfo', mkCompilerInfo, mkComponentInfo ) where
5961

62+
import qualified Data.Text as T
63+
6064
import Distribution.Compat.Prelude
6165
import Prelude ()
6266

@@ -79,36 +83,37 @@ import Distribution.Pretty
7983
-- | Construct a JSON document describing the build information for a
8084
-- package.
8185
mkBuildInfo
82-
:: PackageDescription -- ^ Mostly information from the .cabal file
86+
:: FilePath -- ^ The source directory of the package
87+
-> PackageDescription -- ^ Mostly information from the .cabal file
8388
-> LocalBuildInfo -- ^ Configuration information
8489
-> BuildFlags -- ^ Flags that the user passed to build
8590
-> [TargetInfo]
8691
-> Json
87-
mkBuildInfo pkg_descr lbi _flags targetsToBuild =
88-
mkBuildInfo' (mkCompilerInfo (withPrograms lbi) (compiler lbi))
89-
(map (mkComponentInfo pkg_descr lbi . targetCLBI) targetsToBuild)
92+
mkBuildInfo wdir pkg_descr lbi _flags targetsToBuild =
93+
JsonObject $
94+
mkBuildInfo' (mkCompilerInfo (withPrograms lbi) (compiler lbi))
95+
(map (mkComponentInfo wdir pkg_descr lbi . targetCLBI) targetsToBuild)
9096

9197
-- | A variant of 'mkBuildInfo' if you need to call 'mkCompilerInfo' and
9298
-- 'mkComponentInfo' yourself.
9399
mkBuildInfo'
94100
:: Json -- ^ The 'Json' from 'mkCompilerInfo'
95101
-> [Json] -- ^ The 'Json' from 'mkComponentInfo'
96-
-> Json
102+
-> [(T.Text, Json)]
97103
mkBuildInfo' cmplrInfo componentInfos =
98-
JsonObject
99-
[ "cabal-version" .= JsonString (display cabalVersion)
104+
[ "cabal-version" .= JsonString (T.pack (display cabalVersion))
100105
, "compiler" .= cmplrInfo
101106
, "components" .= JsonArray componentInfos
102107
]
103108

104109
mkCompilerInfo :: ProgramDb -> Compiler -> Json
105110
mkCompilerInfo programDb cmplr = JsonObject
106-
[ "flavour" .= JsonString (prettyShow $ compilerFlavor cmplr)
107-
, "compiler-id" .= JsonString (showCompilerId cmplr)
111+
[ "flavour" .= JsonString (T.pack (prettyShow $ compilerFlavor cmplr))
112+
, "compiler-id" .= JsonString (T.pack (showCompilerId cmplr))
108113
, "path" .= path
109114
]
110115
where
111-
path = maybe JsonNull (JsonString . programPath)
116+
path = maybe JsonNull (JsonString . T.pack . programPath)
112117
$ (flavorToProgram . compilerFlavor $ cmplr)
113118
>>= flip lookupProgram programDb
114119

@@ -119,16 +124,17 @@ mkCompilerInfo programDb cmplr = JsonObject
119124
flavorToProgram JHC = Just jhcProgram
120125
flavorToProgram _ = Nothing
121126

122-
mkComponentInfo :: PackageDescription -> LocalBuildInfo -> ComponentLocalBuildInfo -> Json
123-
mkComponentInfo pkg_descr lbi clbi = JsonObject
127+
mkComponentInfo :: FilePath -> PackageDescription -> LocalBuildInfo -> ComponentLocalBuildInfo -> Json
128+
mkComponentInfo wdir pkg_descr lbi clbi = JsonObject $
124129
[ "type" .= JsonString compType
125-
, "name" .= JsonString (prettyShow name)
126-
, "unit-id" .= JsonString (prettyShow $ componentUnitId clbi)
130+
, "name" .= JsonString (T.pack $ prettyShow name)
131+
, "unit-id" .= JsonString (T.pack $ prettyShow $ componentUnitId clbi)
127132
, "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-
]
133+
, "modules" .= JsonArray (map (JsonString . T.pack . display) modules)
134+
, "src-files" .= JsonArray (map (JsonString . T.pack) sourceFiles)
135+
, "hs-src-dirs" .= JsonArray (map (JsonString . T.pack) $ hsSourceDirs bi)
136+
, "src-dir" .= JsonString (T.pack wdir)
137+
] <> cabalFile
132138
where
133139
name = componentLocalName clbi
134140
bi = componentBuildInfo comp
@@ -147,14 +153,17 @@ mkComponentInfo pkg_descr lbi clbi = JsonObject
147153
CLib _ -> []
148154
CExe exe -> [modulePath exe]
149155
_ -> []
156+
cabalFile
157+
| Just fp <- pkgDescrFile lbi = [("cabal-file", JsonString (T.pack fp))]
158+
| otherwise = []
150159

151160
-- | Get the command-line arguments that would be passed
152161
-- to the compiler to build the given component.
153162
getCompilerArgs
154163
:: BuildInfo
155164
-> LocalBuildInfo
156165
-> ComponentLocalBuildInfo
157-
-> [String]
166+
-> [T.Text]
158167
getCompilerArgs bi lbi clbi =
159168
case compilerFlavor $ compiler lbi of
160169
GHC -> ghc
@@ -163,6 +172,7 @@ getCompilerArgs bi lbi clbi =
163172
"build arguments for compiler "++show c
164173
where
165174
-- This is absolutely awful
166-
ghc = GHC.renderGhcOptions (compiler lbi) (hostPlatform lbi) baseOpts
175+
ghc = T.pack <$>
176+
GHC.renderGhcOptions (compiler lbi) (hostPlatform lbi) baseOpts
167177
where
168178
baseOpts = GHC.componentGhcOptions normal lbi bi clbi (buildDir lbi)

‎Cabal/Distribution/Utils/Json.hs

Lines changed: 42 additions & 27 deletions
Original file line numberDiff line numberDiff line change
@@ -1,50 +1,65 @@
1-
-- | Extremely simple JSON helper. Don't do anything too fancy with this!
1+
{-# LANGUAGE OverloadedStrings #-}
22

3+
-- | Extremely simple JSON helper. Don't do anything too fancy with this!
34
module Distribution.Utils.Json
45
( Json(..)
56
, (.=)
67
, renderJson
78
) where
89

10+
import Data.Text (Text)
11+
import qualified Data.Text as Text
12+
913
data Json = JsonArray [Json]
1014
| JsonBool !Bool
1115
| JsonNull
1216
| JsonNumber !Int
13-
| JsonObject [(String, Json)]
14-
| JsonString !String
17+
| JsonObject [(Text, Json)]
18+
| JsonRaw !Text
19+
| JsonString !Text
1520

16-
renderJson :: Json -> ShowS
21+
-- | A type to mirror 'ShowS'
22+
type ShowT = Text -> Text
23+
24+
renderJson :: Json -> ShowT
1725
renderJson (JsonArray objs) =
1826
surround "[" "]" $ intercalate "," $ map renderJson objs
19-
renderJson (JsonBool True) = showString "true"
20-
renderJson (JsonBool False) = showString "false"
21-
renderJson JsonNull = showString "null"
22-
renderJson (JsonNumber n) = shows n
27+
renderJson (JsonBool True) = showText "true"
28+
renderJson (JsonBool False) = showText "false"
29+
renderJson JsonNull = showText "null"
30+
renderJson (JsonNumber n) = showText $ Text.pack (show n)
2331
renderJson (JsonObject attrs) =
2432
surround "{" "}" $ intercalate "," $ map render attrs
2533
where
26-
render (k,v) = (surround "\"" "\"" $ showString' k) . showString ":" . renderJson v
27-
renderJson (JsonString s) = surround "\"" "\"" $ showString' s
28-
29-
surround :: String -> String -> ShowS -> ShowS
30-
surround begin end middle = showString begin . middle . showString end
31-
32-
showString' :: String -> ShowS
33-
showString' xs = showStringWorker xs
34-
where
35-
showStringWorker :: String -> ShowS
36-
showStringWorker ('\"':as) = showString "\\\"" . showStringWorker as
37-
showStringWorker ('\\':as) = showString "\\\\" . showStringWorker as
38-
showStringWorker ('\'':as) = showString "\\\'" . showStringWorker as
39-
showStringWorker (x:as) = showString [x] . showStringWorker as
40-
showStringWorker [] = showString ""
41-
42-
intercalate :: String -> [ShowS] -> ShowS
34+
render (k,v) = (surround "\"" "\"" $ showText' k) . showText ":" . renderJson v
35+
renderJson (JsonString s) = surround "\"" "\"" $ showText' s
36+
renderJson (JsonRaw s) = showText s
37+
38+
surround :: Text -> Text -> ShowT -> ShowT
39+
surround begin end middle = showText begin . middle . showText end
40+
41+
showText :: Text -> ShowT
42+
showText = (<>)
43+
44+
showText' :: Text -> ShowT
45+
showText' xs = showStringWorker xs
46+
where
47+
showStringWorker :: Text -> ShowT
48+
showStringWorker t =
49+
case Text.uncons t of
50+
Just ('\r', as) -> showText "\\r" . showStringWorker as
51+
Just ('\n', as) -> showText "\\n" . showStringWorker as
52+
Just ('\"', as) -> showText "\\\"" . showStringWorker as
53+
Just ('\\', as) -> showText "\\\\" . showStringWorker as
54+
Just (x, as) -> showText (Text.singleton x) . showStringWorker as
55+
Nothing -> showText ""
56+
57+
intercalate :: Text -> [ShowT] -> ShowT
4358
intercalate sep = go
4459
where
4560
go [] = id
4661
go [x] = x
47-
go (x:xs) = x . showString' sep . go xs
62+
go (x:xs) = x . showText' sep . go xs
4863

49-
(.=) :: String -> Json -> (String, Json)
64+
(.=) :: Text -> Json -> (Text, Json)
5065
k .= v = (k, v)

0 commit comments

Comments
 (0)