{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}

-- |
-- 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 build --enable-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-lib-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 output format needs to be validated against 'doc/json-schemas/build-info.schema.json'.
-- If the format changes, update the schema as well!
--
-- The @cabal-lib-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
  , mkBuildInfo'
  , mkCompilerInfo
  , mkComponentInfo
  ) where

import System.FilePath

import Distribution.Compat.Prelude
import Prelude ()

import qualified Distribution.Simple.GHC as GHC
import qualified Distribution.Simple.Program.GHC as GHC

import Distribution.Compiler
import Distribution.PackageDescription
import Distribution.Pretty
import Distribution.Simple.Compiler (Compiler, compilerFlavor, showCompilerId)
import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.Program
import Distribution.Simple.Setup.Build (BuildFlags)
import Distribution.Simple.Utils (cabalVersion)
import Distribution.Text
import Distribution.Types.TargetInfo
import Distribution.Utils.Json
import Distribution.Utils.Path
import Distribution.Verbosity

-- | Construct a JSON document describing the build information for a
-- package.
mkBuildInfo
  :: AbsolutePath (Dir Pkg)
  -- ^ The source directory of the package
  -> PackageDescription
  -- ^ Mostly information from the .cabal file
  -> LocalBuildInfo
  -- ^ Configuration information
  -> BuildFlags
  -- ^ Flags that the user passed to build
  -> (ConfiguredProgram, Compiler)
  -- ^ Compiler information.
  -- Needs to be passed explicitly, as we can't extract that information here
  -- without some partial function.
  -> [TargetInfo]
  -> ([String], Json)
  -- ^ Json representation of buildinfo alongside generated warnings
mkBuildInfo :: AbsolutePath ('Dir Pkg)
-> PackageDescription
-> LocalBuildInfo
-> BuildFlags
-> (ConfiguredProgram, Compiler)
-> [TargetInfo]
-> ([[Char]], Json)
mkBuildInfo AbsolutePath ('Dir Pkg)
wdir PackageDescription
pkg_descr LocalBuildInfo
lbi BuildFlags
_flags (ConfiguredProgram, Compiler)
compilerInfo [TargetInfo]
targetsToBuild = ([[Char]]
warnings, [([Char], Json)] -> Json
JsonObject [([Char], Json)]
buildInfoFields)
  where
    buildInfoFields :: [([Char], Json)]
buildInfoFields = Json -> [Json] -> [([Char], Json)]
mkBuildInfo' ((ConfiguredProgram -> Compiler -> Json)
-> (ConfiguredProgram, Compiler) -> Json
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ConfiguredProgram -> Compiler -> Json
mkCompilerInfo (ConfiguredProgram, Compiler)
compilerInfo) [Json]
componentInfos
    componentInfosWithWarnings :: [([[Char]], Json)]
componentInfosWithWarnings = (TargetInfo -> ([[Char]], Json))
-> [TargetInfo] -> [([[Char]], Json)]
forall a b. (a -> b) -> [a] -> [b]
map (AbsolutePath ('Dir Pkg)
-> PackageDescription
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> ([[Char]], Json)
mkComponentInfo AbsolutePath ('Dir Pkg)
wdir PackageDescription
pkg_descr LocalBuildInfo
lbi (ComponentLocalBuildInfo -> ([[Char]], Json))
-> (TargetInfo -> ComponentLocalBuildInfo)
-> TargetInfo
-> ([[Char]], Json)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TargetInfo -> ComponentLocalBuildInfo
targetCLBI) [TargetInfo]
targetsToBuild
    componentInfos :: [Json]
componentInfos = (([[Char]], Json) -> Json) -> [([[Char]], Json)] -> [Json]
forall a b. (a -> b) -> [a] -> [b]
map ([[Char]], Json) -> Json
forall a b. (a, b) -> b
snd [([[Char]], Json)]
componentInfosWithWarnings
    warnings :: [[Char]]
warnings = (([[Char]], Json) -> [[Char]]) -> [([[Char]], Json)] -> [[Char]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([[Char]], Json) -> [[Char]]
forall a b. (a, b) -> a
fst [([[Char]], Json)]
componentInfosWithWarnings

-- | A variant of 'mkBuildInfo' if you need to call 'mkCompilerInfo' and
-- 'mkComponentInfo' yourself.
--
-- If you change the format or any name in the output json, don't forget to update
-- the schema at @\/doc\/json-schemas\/build-info.schema.json@ and the docs of
-- @--enable-build-info@\/@--disable-build-info@.
mkBuildInfo'
  :: Json
  -- ^ The 'Json' from 'mkCompilerInfo'
  -> [Json]
  -- ^ The 'Json' from 'mkComponentInfo'
  -> [(String, Json)]
mkBuildInfo' :: Json -> [Json] -> [([Char], Json)]
mkBuildInfo' Json
compilerInfo [Json]
componentInfos =
  [ [Char]
"cabal-lib-version" [Char] -> Json -> ([Char], Json)
.= [Char] -> Json
JsonString (Version -> [Char]
forall a. Pretty a => a -> [Char]
display Version
cabalVersion)
  , [Char]
"compiler" [Char] -> Json -> ([Char], Json)
.= Json
compilerInfo
  , [Char]
"components" [Char] -> Json -> ([Char], Json)
.= [Json] -> Json
JsonArray [Json]
componentInfos
  ]

mkCompilerInfo :: ConfiguredProgram -> Compiler -> Json
mkCompilerInfo :: ConfiguredProgram -> Compiler -> Json
mkCompilerInfo ConfiguredProgram
compilerProgram Compiler
compilerInfo =
  [([Char], Json)] -> Json
JsonObject
    [ [Char]
"flavour" [Char] -> Json -> ([Char], Json)
.= [Char] -> Json
JsonString (CompilerFlavor -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow (CompilerFlavor -> [Char]) -> CompilerFlavor -> [Char]
forall a b. (a -> b) -> a -> b
$ Compiler -> CompilerFlavor
compilerFlavor Compiler
compilerInfo)
    , [Char]
"compiler-id" [Char] -> Json -> ([Char], Json)
.= [Char] -> Json
JsonString (Compiler -> [Char]
showCompilerId Compiler
compilerInfo)
    , [Char]
"path" [Char] -> Json -> ([Char], Json)
.= [Char] -> Json
JsonString (ConfiguredProgram -> [Char]
programPath ConfiguredProgram
compilerProgram)
    ]

mkComponentInfo :: AbsolutePath (Dir Pkg) -> PackageDescription -> LocalBuildInfo -> ComponentLocalBuildInfo -> ([String], Json)
mkComponentInfo :: AbsolutePath ('Dir Pkg)
-> PackageDescription
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> ([[Char]], Json)
mkComponentInfo AbsolutePath ('Dir Pkg)
wdir PackageDescription
pkg_descr LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi =
  ( [[Char]]
warnings
  , [([Char], Json)] -> Json
JsonObject ([([Char], Json)] -> Json) -> [([Char], Json)] -> Json
forall a b. (a -> b) -> a -> b
$
      [ [Char]
"type" [Char] -> Json -> ([Char], Json)
.= [Char] -> Json
JsonString [Char]
compType
      , [Char]
"name" [Char] -> Json -> ([Char], Json)
.= [Char] -> Json
JsonString (ComponentName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow ComponentName
name)
      , [Char]
"unit-id" [Char] -> Json -> ([Char], Json)
.= [Char] -> Json
JsonString (UnitId -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow (UnitId -> [Char]) -> UnitId -> [Char]
forall a b. (a -> b) -> a -> b
$ ComponentLocalBuildInfo -> UnitId
componentUnitId ComponentLocalBuildInfo
clbi)
      , [Char]
"compiler-args" [Char] -> Json -> ([Char], Json)
.= [Json] -> Json
JsonArray (([Char] -> Json) -> [[Char]] -> [Json]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Json
JsonString [[Char]]
compilerArgs)
      , [Char]
"modules" [Char] -> Json -> ([Char], Json)
.= [Json] -> Json
JsonArray ((ModuleName -> Json) -> [ModuleName] -> [Json]
forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> Json
JsonString ([Char] -> Json) -> (ModuleName -> [Char]) -> ModuleName -> Json
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> [Char]
forall a. Pretty a => a -> [Char]
display) [ModuleName]
modules)
      , [Char]
"src-files" [Char] -> Json -> ([Char], Json)
.= [Json] -> Json
JsonArray ((SymbolicPathX 'OnlyRelative Source 'File -> Json)
-> [SymbolicPathX 'OnlyRelative Source 'File] -> [Json]
forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> Json
JsonString ([Char] -> Json)
-> (SymbolicPathX 'OnlyRelative Source 'File -> [Char])
-> SymbolicPathX 'OnlyRelative Source 'File
-> Json
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SymbolicPathX 'OnlyRelative Source 'File -> [Char]
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> [Char]
getSymbolicPath) [SymbolicPathX 'OnlyRelative Source 'File]
sourceFiles)
      , [Char]
"hs-src-dirs" [Char] -> Json -> ([Char], Json)
.= [Json] -> Json
JsonArray ((SymbolicPath Pkg ('Dir Source) -> Json)
-> [SymbolicPath Pkg ('Dir Source)] -> [Json]
forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> Json
JsonString ([Char] -> Json)
-> (SymbolicPath Pkg ('Dir Source) -> [Char])
-> SymbolicPath Pkg ('Dir Source)
-> Json
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SymbolicPath Pkg ('Dir Source) -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow) ([SymbolicPath Pkg ('Dir Source)] -> [Json])
-> [SymbolicPath Pkg ('Dir Source)] -> [Json]
forall a b. (a -> b) -> a -> b
$ BuildInfo -> [SymbolicPath Pkg ('Dir Source)]
hsSourceDirs BuildInfo
bi)
      , [Char]
"src-dir" [Char] -> Json -> ([Char], Json)
.= [Char] -> Json
JsonString ([Char] -> [Char]
addTrailingPathSeparator (AbsolutePath ('Dir Pkg) -> [Char]
forall (to :: FileOrDir). AbsolutePath to -> [Char]
getAbsolutePath AbsolutePath ('Dir Pkg)
wdir))
      ]
        [([Char], Json)] -> [([Char], Json)] -> [([Char], Json)]
forall a. Semigroup a => a -> a -> a
<> [([Char], Json)]
cabalFile
  )
  where
    ([[Char]]
warnings, [[Char]]
compilerArgs) = BuildInfo
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> ([[Char]], [[Char]])
getCompilerArgs BuildInfo
bi LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi
    name :: ComponentName
name = ComponentLocalBuildInfo -> ComponentName
componentLocalName ComponentLocalBuildInfo
clbi
    bi :: BuildInfo
bi = Component -> BuildInfo
componentBuildInfo Component
comp
    -- If this error happens, a cabal invariant has been violated
    comp :: Component
comp = Component -> Maybe Component -> Component
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> Component
forall a. HasCallStack => [Char] -> a
error ([Char] -> Component) -> [Char] -> Component
forall a b. (a -> b) -> a -> b
$ [Char]
"mkBuildInfo: no component " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ComponentName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow ComponentName
name) (Maybe Component -> Component) -> Maybe Component -> Component
forall a b. (a -> b) -> a -> b
$ PackageDescription -> ComponentName -> Maybe Component
lookupComponent PackageDescription
pkg_descr ComponentName
name
    compType :: [Char]
compType = case Component
comp of
      CLib Library
_ -> [Char]
"lib"
      CExe Executable
_ -> [Char]
"exe"
      CTest TestSuite
_ -> [Char]
"test"
      CBench Benchmark
_ -> [Char]
"bench"
      CFLib ForeignLib
_ -> [Char]
"flib"
    modules :: [ModuleName]
modules = case Component
comp of
      CLib Library
lib -> Library -> [ModuleName]
explicitLibModules Library
lib
      CExe Executable
exe -> Executable -> [ModuleName]
exeModules Executable
exe
      CTest TestSuite
test ->
        case TestSuite -> TestSuiteInterface
testInterface TestSuite
test of
          TestSuiteExeV10 Version
_ SymbolicPathX 'OnlyRelative Source 'File
_ -> []
          TestSuiteLibV09 Version
_ ModuleName
modName -> [ModuleName
modName]
          TestSuiteUnsupported TestType
_ -> []
      CBench Benchmark
bench -> Benchmark -> [ModuleName]
benchmarkModules Benchmark
bench
      CFLib ForeignLib
flib -> ForeignLib -> [ModuleName]
foreignLibModules ForeignLib
flib
    sourceFiles :: [SymbolicPathX 'OnlyRelative Source 'File]
sourceFiles = case Component
comp of
      CLib Library
_ -> []
      CExe Executable
exe -> [Executable -> SymbolicPathX 'OnlyRelative Source 'File
modulePath Executable
exe]
      CTest TestSuite
test ->
        case TestSuite -> TestSuiteInterface
testInterface TestSuite
test of
          TestSuiteExeV10 Version
_ SymbolicPathX 'OnlyRelative Source 'File
fp -> [SymbolicPathX 'OnlyRelative Source 'File
fp]
          TestSuiteLibV09 Version
_ ModuleName
_ -> []
          TestSuiteUnsupported TestType
_ -> []
      CBench Benchmark
bench -> case Benchmark -> BenchmarkInterface
benchmarkInterface Benchmark
bench of
        BenchmarkExeV10 Version
_ SymbolicPathX 'OnlyRelative Source 'File
fp -> [SymbolicPathX 'OnlyRelative Source 'File
fp]
        BenchmarkUnsupported BenchmarkType
_ -> []
      CFLib ForeignLib
_ -> []
    cabalFile :: [([Char], Json)]
cabalFile
      | Just SymbolicPath Pkg 'File
fp <- LocalBuildInfo -> Maybe (SymbolicPath Pkg 'File)
pkgDescrFile LocalBuildInfo
lbi = [([Char]
"cabal-file", [Char] -> Json
JsonString ([Char] -> Json) -> [Char] -> Json
forall a b. (a -> b) -> a -> b
$ SymbolicPath Pkg 'File -> [Char]
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> [Char]
getSymbolicPath SymbolicPath Pkg 'File
fp)]
      | Bool
otherwise = []

-- | Get the command-line arguments that would be passed
-- to the compiler to build the given component.
getCompilerArgs
  :: BuildInfo
  -> LocalBuildInfo
  -> ComponentLocalBuildInfo
  -> ([String], [String])
getCompilerArgs :: BuildInfo
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> ([[Char]], [[Char]])
getCompilerArgs BuildInfo
bi LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi =
  case Compiler -> CompilerFlavor
compilerFlavor (Compiler -> CompilerFlavor) -> Compiler -> CompilerFlavor
forall a b. (a -> b) -> a -> b
$ LocalBuildInfo -> Compiler
compiler LocalBuildInfo
lbi of
    CompilerFlavor
GHC -> ([], [[Char]]
ghcArgs)
    CompilerFlavor
GHCJS -> ([], [[Char]]
ghcArgs)
    CompilerFlavor
c ->
      (
        [ [Char]
"ShowBuildInfo.getCompilerArgs: Don't know how to get build "
            [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" arguments for compiler "
            [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ CompilerFlavor -> [Char]
forall a. Show a => a -> [Char]
show CompilerFlavor
c
        ]
      , []
      )
  where
    -- This is absolutely awful
    ghcArgs :: [[Char]]
ghcArgs =
      Compiler -> Platform -> GhcOptions -> [[Char]]
GHC.renderGhcOptions (LocalBuildInfo -> Compiler
compiler LocalBuildInfo
lbi) (LocalBuildInfo -> Platform
hostPlatform LocalBuildInfo
lbi) GhcOptions
baseOpts
    baseOpts :: GhcOptions
baseOpts =
      Verbosity
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> SymbolicPath Pkg ('Dir Build)
-> GhcOptions
forall build.
Verbosity
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> SymbolicPath Pkg ('Dir build)
-> GhcOptions
GHC.componentGhcOptions Verbosity
normal LocalBuildInfo
lbi BuildInfo
bi ComponentLocalBuildInfo
clbi (SymbolicPath Pkg ('Dir Build) -> GhcOptions)
-> SymbolicPath Pkg ('Dir Build) -> GhcOptions
forall a b. (a -> b) -> a -> b
$
        LocalBuildInfo -> SymbolicPath Pkg ('Dir Build)
buildDir LocalBuildInfo
lbi