From 11bede9fb31eaaebe2af4ee3f790d028fc2fc4d7 Mon Sep 17 00:00:00 2001 From: Ben Gamari Date: Sun, 16 Aug 2015 19:50:39 +0200 Subject: [PATCH] Add show-build-info command in lib:Cabal This allows users to get a JSON representation of various information about how Cabal would go about building a package. The output of this command is intended for external tools and therefore the format should remain stable. --- Cabal/Cabal.cabal | 2 + Cabal/Distribution/Simple.hs | 26 +++++- Cabal/Distribution/Simple/Build.hs | 19 +++- Cabal/Distribution/Simple/Setup.hs | 44 +++++++++ Cabal/Distribution/Simple/ShowBuildInfo.hs | 142 +++++++++++++++++++++++++++++ Cabal/Distribution/Simple/UserHooks.hs | 1 - Cabal/Distribution/Simple/Utils/Json.hs | 34 +++++++ 7 files changed, 264 insertions(+), 4 deletions(-) create mode 100644 Cabal/Distribution/Simple/ShowBuildInfo.hs create mode 100644 Cabal/Distribution/Simple/Utils/Json.hs diff --git a/Cabal/Cabal.cabal b/Cabal/Cabal.cabal index d4a408124..889c8de37 100644 --- a/Cabal/Cabal.cabal +++ b/Cabal/Cabal.cabal @@ -375,6 +375,7 @@ library Distribution.Simple.Program.Types Distribution.Simple.Register Distribution.Simple.Setup + Distribution.Simple.ShowBuildInfo Distribution.Simple.SrcDist Distribution.Simple.Test Distribution.Simple.Test.ExeV10 @@ -534,6 +535,7 @@ library Distribution.Simple.GHC.EnvironmentParser Distribution.Simple.GHC.Internal Distribution.Simple.GHC.ImplInfo + Distribution.Simple.Utils.Json Paths_Cabal if flag(bundled-binary-generic) diff --git a/Cabal/Distribution/Simple.hs b/Cabal/Distribution/Simple.hs index 16a5adff1..ae9b36a78 100644 --- a/Cabal/Distribution/Simple.hs +++ b/Cabal/Distribution/Simple.hs @@ -72,8 +72,8 @@ import Distribution.Simple.PreProcess import Distribution.Simple.Setup import Distribution.Simple.Command -import Distribution.Simple.Build -import Distribution.Simple.SrcDist +import Distribution.Simple.Build ( build, showBuildInfo, repl ) +import Distribution.Simple.SrcDist ( sdist ) import Distribution.Simple.Register import Distribution.Simple.Configure @@ -179,6 +179,7 @@ defaultMainHelper hooks args = topHandler $ do [configureCommand progs `commandAddAction` \fs as -> configureAction hooks fs as >> return () ,buildCommand progs `commandAddAction` buildAction hooks + ,showBuildInfoCommand progs `commandAddAction` showBuildInfoAction hooks ,replCommand progs `commandAddAction` replAction hooks ,installCommand `commandAddAction` installAction hooks ,copyCommand `commandAddAction` copyAction hooks @@ -264,6 +265,27 @@ buildAction hooks flags args = do (return lbi { withPrograms = progs }) hooks flags' { buildArgs = args } args +showBuildInfoAction :: UserHooks -> BuildFlags -> Args -> IO () +showBuildInfoAction hooks flags args = do + distPref <- findDistPrefOrDefault (buildDistPref flags) + let verbosity = fromFlag $ buildVerbosity flags + flags' = flags { buildDistPref = toFlag distPref } + + lbi <- getBuildConfig hooks verbosity distPref + progs <- reconfigurePrograms verbosity + (buildProgramPaths flags') + (buildProgramArgs flags') + (withPrograms lbi) + + pbi <- preBuild hooks args flags' + let lbi' = lbi { withPrograms = progs } + pkg_descr0 = localPkgDescr lbi' + pkg_descr = updatePackageDescription pbi pkg_descr0 + -- TODO: Somehow don't ignore build hook? + showBuildInfo pkg_descr lbi' flags + + postBuild hooks args flags' pkg_descr lbi' + replAction :: UserHooks -> ReplFlags -> Args -> IO () replAction hooks flags args = do distPref <- findDistPrefOrDefault (replDistPref flags) diff --git a/Cabal/Distribution/Simple/Build.hs b/Cabal/Distribution/Simple/Build.hs index 95c576a57..3747d1f48 100644 --- a/Cabal/Distribution/Simple/Build.hs +++ b/Cabal/Distribution/Simple/Build.hs @@ -19,7 +19,7 @@ -- module Distribution.Simple.Build ( - build, repl, + build, showBuildInfo, repl, startInterpreter, initialBuildSteps, @@ -69,11 +69,16 @@ import Distribution.Simple.PreProcess import Distribution.Simple.LocalBuildInfo import Distribution.Simple.Program.Types import Distribution.Simple.Program.Db +import qualified Distribution.Simple.Program.HcPkg as HcPkg +import Distribution.Simple.ShowBuildInfo import Distribution.Simple.BuildPaths import Distribution.Simple.Configure import Distribution.Simple.Register import Distribution.Simple.Test.LibV09 import Distribution.Simple.Utils + ( createDirectoryIfMissingVerbose, rewriteFile, rewriteFileEx + , die, die', info, debug, warn, setupMessage ) +import Distribution.Simple.Utils.Json import Distribution.System import Distribution.Pretty @@ -128,6 +133,18 @@ build pkg_descr lbi flags suffixes = do verbosity = fromFlag (buildVerbosity flags) +showBuildInfo :: PackageDescription -- ^ Mostly information from the .cabal file + -> LocalBuildInfo -- ^ Configuration information + -> BuildFlags -- ^ Flags that the user passed to build + -> IO () +showBuildInfo pkg_descr lbi flags = do + let verbosity = fromFlag (buildVerbosity flags) + targets <- readTargetInfos verbosity pkg_descr lbi (buildArgs flags) + let targetsToBuild = neededTargetsInBuildOrder' pkg_descr lbi (map nodeKey targets) + doc = mkBuildInfo pkg_descr lbi flags targetsToBuild + putStrLn $ renderJson doc "" + + repl :: PackageDescription -- ^ Mostly information from the .cabal file -> LocalBuildInfo -- ^ Configuration information -> ReplFlags -- ^ Flags that the user passed to build diff --git a/Cabal/Distribution/Simple/Setup.hs b/Cabal/Distribution/Simple/Setup.hs index c778d407a..cb3082801 100644 --- a/Cabal/Distribution/Simple/Setup.hs +++ b/Cabal/Distribution/Simple/Setup.hs @@ -45,6 +45,7 @@ module Distribution.Simple.Setup ( HaddockFlags(..), emptyHaddockFlags, defaultHaddockFlags, haddockCommand, HscolourFlags(..), emptyHscolourFlags, defaultHscolourFlags, hscolourCommand, BuildFlags(..), emptyBuildFlags, defaultBuildFlags, buildCommand, + showBuildInfoCommand, ReplFlags(..), defaultReplFlags, replCommand, CleanFlags(..), emptyCleanFlags, defaultCleanFlags, cleanCommand, RegisterFlags(..), emptyRegisterFlags, defaultRegisterFlags, registerCommand, @@ -1622,6 +1623,49 @@ instance Semigroup CleanFlags where (<>) = gmappend -- ------------------------------------------------------------ +-- * show-build-info flags +-- ------------------------------------------------------------ + +showBuildInfoCommand :: ProgramConfiguration -> CommandUI BuildFlags +showBuildInfoCommand progConf = CommandUI + { commandName = "show-build-info" + , commandSynopsis = "Emit details about how a package would be built." + , commandDescription = Just $ \_ -> wrapText $ + "Components encompass executables, tests, and benchmarks.\n" + ++ "\n" + ++ "Affected by configuration options, see `configure`.\n" + , commandNotes = Just $ \pname -> + "Examples:\n" + ++ " " ++ pname ++ " show-build-info " + ++ " All the components in the package\n" + ++ " " ++ pname ++ " show-build-info foo " + ++ " A component (i.e. lib, exe, test suite)\n\n" + ++ programFlagsDescription progConf +--TODO: re-enable once we have support for module/file targets +-- ++ " " ++ pname ++ " show-build-info Foo.Bar " +-- ++ " A module\n" +-- ++ " " ++ pname ++ " show-build-info Foo/Bar.hs" +-- ++ " A file\n\n" +-- ++ "If a target is ambiguous it can be qualified with the component " +-- ++ "name, e.g.\n" +-- ++ " " ++ pname ++ " show-build-info foo:Foo.Bar\n" +-- ++ " " ++ pname ++ " show-build-info testsuite1:Foo/Bar.hs\n" + , commandUsage = usageAlternatives "show-build-info" $ + [ "[FLAGS]" + , "COMPONENTS [FLAGS]" + ] + , commandDefaultFlags = defaultBuildFlags + , commandOptions = \showOrParseArgs -> + [ optionVerbosity + buildVerbosity (\v flags -> flags { buildVerbosity = v }) + + , optionDistPref + buildDistPref (\d flags -> flags { buildDistPref = d }) showOrParseArgs + ] + ++ buildOptions progConf showOrParseArgs + } + +-- ------------------------------------------------------------ -- * Build flags -- ------------------------------------------------------------ diff --git a/Cabal/Distribution/Simple/ShowBuildInfo.hs b/Cabal/Distribution/Simple/ShowBuildInfo.hs new file mode 100644 index 000000000..21bbb44c8 --- /dev/null +++ b/Cabal/Distribution/Simple/ShowBuildInfo.hs @@ -0,0 +1,142 @@ +-- | +-- This module defines a simple JSON-based format for exporting basic +-- information about a Cabal package and the compiler configuration Cabal +-- would use to build it. This can be produced with the @cabal show-build-info@ +-- command. +-- +-- This format is intended for consumption by external tooling and should +-- therefore be rather stable. Moreover, this allows tooling users to avoid +-- linking against Cabal. This is an important advantage as direct API usage +-- tends to be rather fragile in the presence of user-initiated upgrades of +-- Cabal. +-- +-- Below is an example of the output this module produces, +-- +-- @ +-- { "cabal_version": "1.23.0.0", +-- "compiler": { +-- "flavor": "GHC", +-- "compiler_id": "ghc-7.10.2", +-- "path": "/usr/bin/ghc", +-- }, +-- "components": [ +-- { "type": "library", +-- "name": "CLibName", +-- "compiler_args": +-- ["-O", "-XHaskell98", "-Wall", +-- "-package-id", "parallel-3.2.0.6-b79c38c5c25fff77f3ea7271851879eb"] +-- "modules": ["Project.ModA", "Project.ModB", "Paths_project"], +-- "source_files": [], +-- "source_dirs": ["src"] +-- } +-- ] +-- } +-- @ +-- +-- The @cabal_version@ property provides the version of the Cabal library +-- which generated the output. The @compiler@ property gives some basic +-- information about the compiler Cabal would use to compile the package. +-- +-- The @components@ property gives a list of the Cabal 'Component's defined by +-- the package. Each has, +-- +-- * @type@: the type of the component (one of @library@, @executable@, +-- @test-suite@, or @benchmark@) +-- * @name@: a string serving to uniquely identify the component within the +-- package. +-- * @compiler_args@: the command-line arguments Cabal would pass to the +-- compiler to compile the component +-- * @modules@: the modules belonging to the component +-- * @source_dirs@: a list of directories where the modules might be found +-- * @source_files@: any other Haskell sources needed by the component +-- +-- Note: At the moment this is only supported when using the GHC compiler. +-- + +module Distribution.Simple.ShowBuildInfo (mkBuildInfo) where + +import qualified Distribution.Simple.GHC as GHC +import qualified Distribution.Simple.Program.GHC as GHC + +import Distribution.PackageDescription +import Distribution.Compiler +import Distribution.Verbosity +import Distribution.Simple.Compiler +import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.Program +import Distribution.Simple.Setup +import Distribution.Simple.Utils (cabalVersion) +import Distribution.Simple.Utils.Json +import Distribution.Types.TargetInfo +import Distribution.Text + +-- | Construct a JSON document describing the build information for a package +mkBuildInfo :: PackageDescription -- ^ Mostly information from the .cabal file + -> LocalBuildInfo -- ^ Configuration information + -> BuildFlags -- ^ Flags that the user passed to build + -> [TargetInfo] + -> Json +mkBuildInfo pkg_descr lbi _flags targetsToBuild = info + where + componentsToBuild = map (\target -> (componentLocalName $ targetCLBI target,targetCLBI target)) targetsToBuild + (.=) :: String -> Json -> (String, Json) + k .= v = (k, v) + + info = JsonObject + [ "cabal_version" .= JsonString (display cabalVersion) + , "compiler" .= mkCompilerInfo + , "components" .= JsonArray (map mkComponentInfo componentsToBuild) + ] + + mkCompilerInfo = JsonObject + [ "flavour" .= JsonString (show $ compilerFlavor $ compiler lbi) + , "compiler_id" .= JsonString (showCompilerId $ compiler lbi) + , "path" .= path + ] + where + path = maybe JsonNull (JsonString . programPath) + $ lookupProgram ghcProgram (withPrograms lbi) + + mkComponentInfo (name, clbi) = JsonObject + [ "type" .= JsonString compType + , "name" .= JsonString (show name) + , "compiler_args" .= JsonArray (map JsonString $ getCompilerArgs bi lbi clbi) + , "modules" .= JsonArray (map (JsonString . display) modules) + , "source_files" .= JsonArray (map JsonString source_files) + , "source_dirs" .= JsonArray (map JsonString $ hsSourceDirs bi) + ] + where + bi = componentBuildInfo comp + Just comp = lookupComponent pkg_descr name + compType = case comp of + CLib _ -> "library" + CExe _ -> "executable" + CTest _ -> "test-suite" + CBench _ -> "benchmark" + CFLib _ -> "foreign-library" + modules = case comp of + CLib lib -> explicitLibModules lib + CExe exe -> exeModules exe + _ -> [] + source_files = case comp of + CLib _ -> [] + CExe exe -> [modulePath exe] + _ -> [] + +-- | Get the command-line arguments that would be passed +-- to the compiler to build the given component. +getCompilerArgs :: BuildInfo + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> [String] +getCompilerArgs bi lbi clbi = + case compilerFlavor $ compiler lbi of + GHC -> ghc + GHCJS -> ghc + c -> error $ "ShowBuildInfo.getCompilerArgs: Don't know how to get "++ + "build arguments for compiler "++show c + where + -- This is absolutely awful + ghc = GHC.renderGhcOptions (compiler lbi) (hostPlatform lbi) baseOpts + where + baseOpts = GHC.componentGhcOptions normal lbi bi clbi (buildDir lbi) diff --git a/Cabal/Distribution/Simple/UserHooks.hs b/Cabal/Distribution/Simple/UserHooks.hs index 306092186..97f22933c 100644 --- a/Cabal/Distribution/Simple/UserHooks.hs +++ b/Cabal/Distribution/Simple/UserHooks.hs @@ -69,7 +69,6 @@ data UserHooks = UserHooks { -- |Hook to run before build command. Second arg indicates verbosity level. preBuild :: Args -> BuildFlags -> IO HookedBuildInfo, - -- |Over-ride this hook to get different behavior during build. buildHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> BuildFlags -> IO (), -- |Hook to run after build command. Second arg indicates verbosity level. diff --git a/Cabal/Distribution/Simple/Utils/Json.hs b/Cabal/Distribution/Simple/Utils/Json.hs new file mode 100644 index 000000000..b8447fc50 --- /dev/null +++ b/Cabal/Distribution/Simple/Utils/Json.hs @@ -0,0 +1,34 @@ +module Distribution.Simple.Utils.Json + ( Json(..) + , renderJson + ) where + +data Json = JsonArray [Json] + | JsonBool !Bool + | JsonNull + | JsonNumber !Int + | JsonObject [(String, Json)] + | JsonString !String + +renderJson :: Json -> ShowS +renderJson (JsonArray objs) = + surround "[" "]" $ intercalate "," $ map renderJson objs +renderJson (JsonBool True) = showString "true" +renderJson (JsonBool False) = showString "false" +renderJson JsonNull = showString "null" +renderJson (JsonNumber n) = shows n +renderJson (JsonObject attrs) = + surround "{" "}" $ intercalate "," $ map render attrs + where + render (k,v) = (surround "\"" "\"" $ showString k) . showString ":" . renderJson v +renderJson (JsonString s) = surround "\"" "\"" $ showString s + +surround :: String -> String -> ShowS -> ShowS +surround begin end middle = showString begin . middle . showString end + +intercalate :: String -> [ShowS] -> ShowS +intercalate sep = go + where + go [] = id + go [x] = x + go (x:xs) = x . showString sep . go xs -- 2.11.4.GIT