Merge pull request #6108 from haskell/pr/show-build-info-libcabal

show-build-info (lib:Cabal part)

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)

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)

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

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
 -- ------------------------------------------------------------

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)

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