diff --git a/Cabal/Cabal.cabal b/Cabal/Cabal.cabal index d4a408124c3..889c8de37bd 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 16a5adff1a6..e632acc88e8 100644 --- a/Cabal/Distribution/Simple.hs +++ b/Cabal/Distribution/Simple.hs @@ -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,33 @@ buildAction hooks flags args = do (return lbi { withPrograms = progs }) hooks flags' { buildArgs = args } args +showBuildInfoAction :: UserHooks -> ShowBuildInfoFlags -> Args -> IO () +showBuildInfoAction hooks (ShowBuildInfoFlags flags fileOutput) args = do + distPref <- findDistPrefOrDefault (buildDistPref flags) + let verbosity = fromFlag $ buildVerbosity flags + lbi <- getBuildConfig hooks verbosity distPref + let flags' = flags { buildDistPref = toFlag distPref + , buildCabalFilePath = maybeToFlag (cabalFilePath lbi) + } + + 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? + buildInfoString <- showBuildInfo pkg_descr lbi' flags + + case fileOutput of + Nothing -> putStr buildInfoString + Just fp -> writeFile fp buildInfoString + + 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 95c576a5781..331c367d8de 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,13 @@ import Distribution.Simple.PreProcess import Distribution.Simple.LocalBuildInfo import Distribution.Simple.Program.Types import Distribution.Simple.Program.Db +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 +import Distribution.Simple.Utils.Json import Distribution.System import Distribution.Pretty @@ -128,6 +130,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 String +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 + return $ 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 c778d407a61..4630f20e064 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, + ShowBuildInfoFlags(..), defaultShowBuildFlags, showBuildInfoCommand, ReplFlags(..), defaultReplFlags, replCommand, CleanFlags(..), emptyCleanFlags, defaultCleanFlags, cleanCommand, RegisterFlags(..), emptyRegisterFlags, defaultRegisterFlags, registerCommand, @@ -2205,6 +2206,81 @@ optionNumJobs get set = | otherwise -> Right (Just n) _ -> Left "The jobs value should be a number or '$ncpus'" + +-- ------------------------------------------------------------ +-- * show-build-info command flags +-- ------------------------------------------------------------ + +data ShowBuildInfoFlags = ShowBuildInfoFlags + { buildInfoBuildFlags :: BuildFlags + , buildInfoOutputFile :: Maybe FilePath + } deriving Show + +defaultShowBuildFlags :: ShowBuildInfoFlags +defaultShowBuildFlags = + ShowBuildInfoFlags + { buildInfoBuildFlags = defaultBuildFlags + , buildInfoOutputFile = Nothing + } + +showBuildInfoCommand :: ProgramDb -> CommandUI ShowBuildInfoFlags +showBuildInfoCommand progDb = 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 progDb +--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 = defaultShowBuildFlags + , commandOptions = \showOrParseArgs -> + parseBuildFlagsForShowBuildInfoFlags showOrParseArgs progDb + ++ + [ option [] ["buildinfo-json-output"] + "Write the result to the given file instead of stdout" + buildInfoOutputFile (\pf flags -> flags { buildInfoOutputFile = pf }) + (reqArg' "FILE" Just (maybe [] pure)) + ] + + } + +parseBuildFlagsForShowBuildInfoFlags :: ShowOrParseArgs -> ProgramDb -> [OptionField ShowBuildInfoFlags] +parseBuildFlagsForShowBuildInfoFlags showOrParseArgs progDb = + map + (liftOption + buildInfoBuildFlags + (\bf flags -> flags { buildInfoBuildFlags = bf } ) + ) + buildFlags + where + buildFlags = buildOptions progDb showOrParseArgs + ++ + [ optionVerbosity + buildVerbosity (\v flags -> flags { buildVerbosity = v }) + + , optionDistPref + buildDistPref (\d flags -> flags { buildDistPref = d }) showOrParseArgs + ] + -- ------------------------------------------------------------ -- * Other Utils -- ------------------------------------------------------------ diff --git a/Cabal/Distribution/Simple/ShowBuildInfo.hs b/Cabal/Distribution/Simple/ShowBuildInfo.hs new file mode 100644 index 00000000000..2a41962fb6e --- /dev/null +++ b/Cabal/Distribution/Simple/ShowBuildInfo.hs @@ -0,0 +1,158 @@ +-- | +-- 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 new-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": { +-- "flavour": "GHC", +-- "compiler-id": "ghc-7.10.2", +-- "path": "/usr/bin/ghc", +-- }, +-- "components": [ +-- { "type": "lib", +-- "name": "lib:Cabal", +-- "compiler-args": +-- ["-O", "-XHaskell98", "-Wall", +-- "-package-id", "parallel-3.2.0.6-b79c38c5c25fff77f3ea7271851879eb"] +-- "modules": ["Project.ModA", "Project.ModB", "Paths_project"], +-- "src-files": [], +-- "src-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 @lib@, @exe@, +-- @test@, @bench@, or @flib@) +-- * @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 +-- * @src-dirs@: a list of directories where the modules might be found +-- * @src-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 +import Distribution.Pretty + +-- | 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 + targetToNameAndLBI target = + (componentLocalName $ targetCLBI target, targetCLBI target) + componentsToBuild = map targetToNameAndLBI 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 (prettyShow $ compilerFlavor $ compiler lbi) + , "compiler-id" .= JsonString (showCompilerId $ compiler lbi) + , "path" .= path + ] + where + path = maybe JsonNull (JsonString . programPath) + $ (flavorToProgram . compilerFlavor $ compiler lbi) + >>= flip lookupProgram (withPrograms lbi) + + flavorToProgram :: CompilerFlavor -> Maybe Program + flavorToProgram GHC = Just ghcProgram + flavorToProgram GHCJS = Just ghcjsProgram + flavorToProgram UHC = Just uhcProgram + flavorToProgram JHC = Just jhcProgram + flavorToProgram _ = Nothing + + mkComponentInfo (name, clbi) = JsonObject + [ "type" .= JsonString compType + , "name" .= JsonString (prettyShow name) + , "unit-id" .= JsonString (prettyShow $ componentUnitId clbi) + , "compiler-args" .= JsonArray (map JsonString $ getCompilerArgs bi lbi clbi) + , "modules" .= JsonArray (map (JsonString . display) modules) + , "src-files" .= JsonArray (map JsonString sourceFiles) + , "src-dirs" .= JsonArray (map JsonString $ hsSourceDirs bi) + ] + where + bi = componentBuildInfo comp + Just comp = lookupComponent pkg_descr name + compType = case comp of + CLib _ -> "lib" + CExe _ -> "exe" + CTest _ -> "test" + CBench _ -> "bench" + CFLib _ -> "flib" + modules = case comp of + CLib lib -> explicitLibModules lib + CExe exe -> exeModules exe + _ -> [] + sourceFiles = 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/Utils/Json.hs b/Cabal/Distribution/Simple/Utils/Json.hs new file mode 100644 index 00000000000..f90f2f38aa2 --- /dev/null +++ b/Cabal/Distribution/Simple/Utils/Json.hs @@ -0,0 +1,46 @@ +-- | Utility json lib for Cabal +-- TODO: Remove it again. +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 + +showString' :: String -> ShowS +showString' xs = showStringWorker xs + where + showStringWorker :: String -> ShowS + showStringWorker ('\"':as) = showString "\\\"" . showStringWorker as + showStringWorker ('\\':as) = showString "\\\\" . showStringWorker as + showStringWorker ('\'':as) = showString "\\\'" . showStringWorker as + showStringWorker (x:as) = showString [x] . showStringWorker as + showStringWorker [] = showString "" + +intercalate :: String -> [ShowS] -> ShowS +intercalate sep = go + where + go [] = id + go [x] = x + go (x:xs) = x . showString' sep . go xs