{-# LANGUAGE DataKinds #-}

module Distribution.Simple.GHC.Build where

import Distribution.Compat.Prelude
import Prelude ()

import Control.Monad.IO.Class
import Distribution.PackageDescription as PD hiding (buildInfo)
import Distribution.Simple.Build.Inputs
import Distribution.Simple.Flag (Flag)
import Distribution.Simple.GHC.Build.ExtraSources
import Distribution.Simple.GHC.Build.Link
import Distribution.Simple.GHC.Build.Modules
import Distribution.Simple.GHC.Build.Utils (isHaskell)
import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.Program.Builtin (ghcProgram)
import Distribution.Simple.Program.Db (requireProgram)
import Distribution.Simple.Utils

import Distribution.Types.ComponentLocalBuildInfo
import Distribution.Types.PackageName.Magic (fakePackageId)
import Distribution.Types.ParStrat
import Distribution.Utils.NubList (fromNubListR)
import Distribution.Utils.Path

import System.FilePath (splitDirectories)

{- Note [Build Target Dir vs Target Dir]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Where to place the build result (targetDir) and the build artifacts (buildTargetDir).

\* For libraries, targetDir == buildTargetDir, where both the library and
artifacts are put together.

\* For executables or foreign libs, buildTargetDir == targetDir/<name-of-target-dir>-tmp, where
    the targetDir is the location where the target (e.g. the executable) is written to
    and buildTargetDir is where the compilation artifacts (e.g. Main.o) will live
  Arguably, this difference should not exist (#9498) (TODO)

For instance, for a component `cabal-benchmarks`:
  targetDir == <buildDir>/cabal-benchmarks
  buildTargetDir == <buildDir>/cabal-benchmarks/cabal-benchmarks-tmp

Or, for a library `Cabal`:
  targetDir == <buildDir>/.
  buildTargetDir == targetDir

Furthermore, we need to account for the limit of characters in ghc
invocations that different OSes constrain us to. Cabal invocations can
rapidly reach this limit, in part, due to the long length of cabal v2
prefixes. To minimize the likelihood, we use
`tryMakeRelativeToWorkingDir` to shorten the paths used in invocations
(see da6321bb).

However, in executables, we don't do this. It seems that we don't need to do it
for executable-like components because the linking step, instead of passing as
an argument the path to each module, it simply passes the module name, the sources dir, and --make.
RM: I believe we can use --make + module names instead of paths-to-objects
for linking libraries too (2024-01) (TODO)
-}

-- | The main build phase of building a component.
-- Includes building Haskell modules, extra build sources, and linking.
build
  :: Flag ParStrat
  -> PackageDescription
  -> PreBuildComponentInputs
  -- ^ The context and component being built in it.
  -> IO ()
build :: Flag ParStrat
-> PackageDescription -> PreBuildComponentInputs -> IO ()
build Flag ParStrat
numJobs PackageDescription
pkg_descr PreBuildComponentInputs
pbci = do
  let
    verbosity :: Verbosity
verbosity = PreBuildComponentInputs -> Verbosity
buildVerbosity PreBuildComponentInputs
pbci
    isLib :: Bool
isLib = PreBuildComponentInputs -> Bool
buildIsLib PreBuildComponentInputs
pbci
    lbi :: LocalBuildInfo
lbi = PreBuildComponentInputs -> LocalBuildInfo
localBuildInfo PreBuildComponentInputs
pbci
    clbi :: ComponentLocalBuildInfo
clbi = PreBuildComponentInputs -> ComponentLocalBuildInfo
buildCLBI PreBuildComponentInputs
pbci
    isIndef :: Bool
isIndef = ComponentLocalBuildInfo -> Bool
componentIsIndefinite ComponentLocalBuildInfo
clbi
    mbWorkDir :: Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir = LocalBuildInfo -> Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDirLBI LocalBuildInfo
lbi
    i :: SymbolicPathX allowAbsolute Pkg to -> FilePath
i = LocalBuildInfo -> SymbolicPathX allowAbsolute Pkg to -> FilePath
forall (allowAbsolute :: AllowAbsolute) (to :: FileOrDir).
LocalBuildInfo -> SymbolicPathX allowAbsolute Pkg to -> FilePath
interpretSymbolicPathLBI LocalBuildInfo
lbi -- See Note [Symbolic paths] in Distribution.Utils.Path

  -- Create a few directories for building the component
  -- See Note [Build Target Dir vs Target Dir]
  let targetDir0 :: SymbolicPath Pkg ('Dir Build)
      targetDir0 :: SymbolicPath Pkg ('Dir Build)
targetDir0 = LocalBuildInfo
-> ComponentLocalBuildInfo -> SymbolicPath Pkg ('Dir Build)
componentBuildDir LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi
      buildTargetDir0 :: SymbolicPath Pkg ('Dir Artifacts)
      buildTargetDir0 :: SymbolicPath Pkg ('Dir Artifacts)
buildTargetDir0
        -- Libraries use the target dir for building (see above)
        | Bool
isLib = SymbolicPath Pkg ('Dir Build) -> SymbolicPath Pkg ('Dir Artifacts)
forall (allowAbsolute :: AllowAbsolute) from (to1 :: FileOrDir)
       (to2 :: FileOrDir).
SymbolicPathX allowAbsolute from to1
-> SymbolicPathX allowAbsolute from to2
coerceSymbolicPath SymbolicPath Pkg ('Dir Build)
targetDir0
        -- In other cases, use targetDir/<name-of-target-dir>-tmp
        | FilePath
targetDirName : [FilePath]
_ <- [FilePath] -> [FilePath]
forall a. [a] -> [a]
reverse ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath]
splitDirectories (FilePath -> [FilePath]) -> FilePath -> [FilePath]
forall a b. (a -> b) -> a -> b
$ SymbolicPath Pkg ('Dir Build) -> FilePath
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> FilePath
getSymbolicPath SymbolicPath Pkg ('Dir Build)
targetDir0 =
            SymbolicPath Pkg ('Dir Build)
-> SymbolicPathX 'AllowAbsolute Pkg ('Dir Any)
forall (allowAbsolute :: AllowAbsolute) from (to1 :: FileOrDir)
       (to2 :: FileOrDir).
SymbolicPathX allowAbsolute from to1
-> SymbolicPathX allowAbsolute from to2
coerceSymbolicPath SymbolicPath Pkg ('Dir Build)
targetDir0 SymbolicPathX 'AllowAbsolute Pkg ('Dir Any)
-> RelativePath Any ('Dir Artifacts)
-> SymbolicPath Pkg ('Dir Artifacts)
forall p q r. PathLike p q r => p -> q -> r
</> FilePath -> RelativePath Any ('Dir Artifacts)
forall from (to :: FileOrDir).
HasCallStack =>
FilePath -> RelativePath from to
makeRelativePathEx (FilePath
targetDirName FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"-tmp")
        | Bool
otherwise = FilePath -> SymbolicPath Pkg ('Dir Artifacts)
forall a. HasCallStack => FilePath -> a
error FilePath
"GHC.build: targetDir is empty"

  IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Verbosity -> Bool -> FilePath -> IO ()
createDirectoryIfMissingVerbose Verbosity
verbosity Bool
True (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ SymbolicPath Pkg ('Dir Build) -> FilePath
forall {allowAbsolute :: AllowAbsolute} {to :: FileOrDir}.
SymbolicPathX allowAbsolute Pkg to -> FilePath
i SymbolicPath Pkg ('Dir Build)
targetDir0
    Verbosity -> Bool -> FilePath -> IO ()
createDirectoryIfMissingVerbose Verbosity
verbosity Bool
True (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ SymbolicPath Pkg ('Dir Artifacts) -> FilePath
forall {allowAbsolute :: AllowAbsolute} {to :: FileOrDir}.
SymbolicPathX allowAbsolute Pkg to -> FilePath
i SymbolicPath Pkg ('Dir Artifacts)
buildTargetDir0

  -- See Note [Build Target Dir vs Target Dir] as well
  let targetDir :: SymbolicPath Pkg ('Dir Build)
targetDir = SymbolicPath Pkg ('Dir Build)
targetDir0 -- NB: no 'makeRelative'
  SymbolicPath Pkg ('Dir Artifacts)
buildTargetDir <-
    if Bool
isLib
      then -- NB: this might fail to make the buildTargetDir relative,
      -- as noted in #9776. Oh well.
        Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg ('Dir Artifacts)
-> IO (SymbolicPath Pkg ('Dir Artifacts))
forall dir (to :: FileOrDir).
Maybe (SymbolicPath CWD ('Dir dir))
-> SymbolicPath dir to -> IO (SymbolicPath dir to)
tryMakeRelative Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir SymbolicPath Pkg ('Dir Artifacts)
buildTargetDir0
      else SymbolicPath Pkg ('Dir Artifacts)
-> IO (SymbolicPath Pkg ('Dir Artifacts))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return SymbolicPath Pkg ('Dir Artifacts)
buildTargetDir0
  -- To preserve the previous behaviour, we don't use relative dirs for
  -- executables. Historically, this isn't needed to reduce the CLI limit
  -- (unlike for libraries) because we link executables with the module names
  -- instead of passing the path to object file -- that's something else we
  -- can now fix after the refactor lands.

  (ConfiguredProgram
ghcProg, ProgramDb
_) <- IO (ConfiguredProgram, ProgramDb)
-> IO (ConfiguredProgram, ProgramDb)
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ConfiguredProgram, ProgramDb)
 -> IO (ConfiguredProgram, ProgramDb))
-> IO (ConfiguredProgram, ProgramDb)
-> IO (ConfiguredProgram, ProgramDb)
forall a b. (a -> b) -> a -> b
$ Verbosity
-> Program -> ProgramDb -> IO (ConfiguredProgram, ProgramDb)
requireProgram Verbosity
verbosity Program
ghcProgram (LocalBuildInfo -> ProgramDb
withPrograms LocalBuildInfo
lbi)

  let wantedWays :: (Bool -> [BuildWay], Bool -> BuildWay, BuildWay)
wantedWays@(Bool -> [BuildWay]
wantedLibWays, Bool -> BuildWay
_, BuildWay
wantedExeWay) = LocalBuildInfo -> (Bool -> [BuildWay], Bool -> BuildWay, BuildWay)
buildWays LocalBuildInfo
lbi

  IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Verbosity -> FilePath -> IO ()
info Verbosity
verbosity (FilePath
"Wanted build ways(" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Bool -> FilePath
forall a. Show a => a -> FilePath
show Bool
isLib FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"): " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ [BuildWay] -> FilePath
forall a. Show a => a -> FilePath
show (if Bool
isLib then Bool -> [BuildWay]
wantedLibWays Bool
isIndef else [BuildWay
wantedExeWay]))
  -- We need a separate build and link phase, and C sources must be compiled
  -- after Haskell modules, because C sources may depend on stub headers
  -- generated from compiling Haskell modules (#842, #3294).
  (Maybe (SymbolicPath Pkg 'File)
mbMainFile, [ModuleName]
inputModules) <- SymbolicPath Pkg ('Dir Artifacts)
-> PackageDescription
-> PreBuildComponentInputs
-> IO (Maybe (SymbolicPath Pkg 'File), [ModuleName])
componentInputs SymbolicPath Pkg ('Dir Artifacts)
buildTargetDir PackageDescription
pkg_descr PreBuildComponentInputs
pbci
  let (Maybe (SymbolicPath Pkg 'File)
hsMainFile, Maybe (SymbolicPath Pkg 'File)
nonHsMainFile) =
        case Maybe (SymbolicPath Pkg 'File)
mbMainFile of
          Just SymbolicPath Pkg 'File
mainFile
            | PackageDescription -> PackageIdentifier
PD.package PackageDescription
pkg_descr PackageIdentifier -> PackageIdentifier -> Bool
forall a. Eq a => a -> a -> Bool
== PackageIdentifier
fakePackageId
                Bool -> Bool -> Bool
|| FilePath -> Bool
isHaskell (SymbolicPath Pkg 'File -> FilePath
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> FilePath
getSymbolicPath SymbolicPath Pkg 'File
mainFile) ->
                (SymbolicPath Pkg 'File -> Maybe (SymbolicPath Pkg 'File)
forall a. a -> Maybe a
Just SymbolicPath Pkg 'File
mainFile, Maybe (SymbolicPath Pkg 'File)
forall a. Maybe a
Nothing)
            | Bool
otherwise ->
                (Maybe (SymbolicPath Pkg 'File)
forall a. Maybe a
Nothing, SymbolicPath Pkg 'File -> Maybe (SymbolicPath Pkg 'File)
forall a. a -> Maybe a
Just SymbolicPath Pkg 'File
mainFile)
          Maybe (SymbolicPath Pkg 'File)
Nothing -> (Maybe (SymbolicPath Pkg 'File)
forall a. Maybe a
Nothing, Maybe (SymbolicPath Pkg 'File)
forall a. Maybe a
Nothing)
  BuildWay -> GhcOptions
buildOpts <- Flag ParStrat
-> ConfiguredProgram
-> Maybe (SymbolicPath Pkg 'File)
-> [ModuleName]
-> SymbolicPath Pkg ('Dir Artifacts)
-> [BuildWay]
-> PreBuildComponentInputs
-> IO (BuildWay -> GhcOptions)
buildHaskellModules Flag ParStrat
numJobs ConfiguredProgram
ghcProg Maybe (SymbolicPath Pkg 'File)
hsMainFile [ModuleName]
inputModules SymbolicPath Pkg ('Dir Artifacts)
buildTargetDir (Bool -> [BuildWay]
wantedLibWays Bool
isIndef) PreBuildComponentInputs
pbci
  NubListR (SymbolicPath Pkg 'File)
extraSources <- Maybe (SymbolicPath Pkg 'File)
-> ConfiguredProgram
-> SymbolicPath Pkg ('Dir Artifacts)
-> (Bool -> [BuildWay], Bool -> BuildWay, BuildWay)
-> PreBuildComponentInputs
-> IO (NubListR (SymbolicPath Pkg 'File))
buildAllExtraSources Maybe (SymbolicPath Pkg 'File)
nonHsMainFile ConfiguredProgram
ghcProg SymbolicPath Pkg ('Dir Artifacts)
buildTargetDir (Bool -> [BuildWay], Bool -> BuildWay, BuildWay)
wantedWays PreBuildComponentInputs
pbci
  ConfiguredProgram
-> PackageDescription
-> [SymbolicPath Pkg 'File]
-> (SymbolicPath Pkg ('Dir Artifacts),
    SymbolicPath Pkg ('Dir Build))
-> ((Bool -> [BuildWay], Bool -> BuildWay, BuildWay),
    BuildWay -> GhcOptions)
-> PreBuildComponentInputs
-> IO ()
linkOrLoadComponent
    ConfiguredProgram
ghcProg
    PackageDescription
pkg_descr
    (NubListR (SymbolicPath Pkg 'File) -> [SymbolicPath Pkg 'File]
forall a. NubListR a -> [a]
fromNubListR NubListR (SymbolicPath Pkg 'File)
extraSources)
    (SymbolicPath Pkg ('Dir Artifacts)
buildTargetDir, SymbolicPath Pkg ('Dir Build)
targetDir)
    ((Bool -> [BuildWay], Bool -> BuildWay, BuildWay)
wantedWays, BuildWay -> GhcOptions
buildOpts)
    PreBuildComponentInputs
pbci