{-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}

module Distribution.Simple.GHC.Build.ExtraSources where

import Control.Monad
import Data.Foldable
import Distribution.Simple.Flag
import qualified Distribution.Simple.GHC.Internal as Internal
import Distribution.Simple.Program.GHC
import Distribution.Simple.Utils
import Distribution.Utils.NubList

import Distribution.Types.BuildInfo
import Distribution.Types.Component
import Distribution.Types.TargetInfo

import Distribution.Simple.GHC.Build.Utils
import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.Program.Types
import Distribution.System (Arch (JavaScript), Platform (..))
import Distribution.Types.ComponentLocalBuildInfo
import Distribution.Types.Executable
import Distribution.Verbosity (Verbosity)

import Distribution.Simple.Build.Inputs

-- | An action that builds all the extra build sources of a component, i.e. C,
-- C++, Js, Asm, C-- sources.
buildAllExtraSources
  :: ConfiguredProgram
  -- ^ The GHC configured program
  -> FilePath
  -- ^ The build directory for this target
  -> PreBuildComponentInputs
  -- ^ The context and component being built in it.
  -> IO (NubListR FilePath)
  -- ^ Returns the (nubbed) list of extra sources that were built
buildAllExtraSources :: ConfiguredProgram
-> FilePath -> PreBuildComponentInputs -> IO (NubListR FilePath)
buildAllExtraSources =
  [ConfiguredProgram
 -> FilePath -> PreBuildComponentInputs -> IO (NubListR FilePath)]
-> ConfiguredProgram
-> FilePath
-> PreBuildComponentInputs
-> IO (NubListR FilePath)
forall a. Monoid a => [a] -> a
mconcat
    [ ConfiguredProgram
-> FilePath -> PreBuildComponentInputs -> IO (NubListR FilePath)
buildCSources
    , ConfiguredProgram
-> FilePath -> PreBuildComponentInputs -> IO (NubListR FilePath)
buildCxxSources
    , ConfiguredProgram
-> FilePath -> PreBuildComponentInputs -> IO (NubListR FilePath)
buildJsSources
    , ConfiguredProgram
-> FilePath -> PreBuildComponentInputs -> IO (NubListR FilePath)
buildAsmSources
    , ConfiguredProgram
-> FilePath -> PreBuildComponentInputs -> IO (NubListR FilePath)
buildCmmSources
    ]

buildCSources
  , buildCxxSources
  , buildJsSources
  , buildAsmSources
  , buildCmmSources
    :: ConfiguredProgram
    -- ^ The GHC configured program
    -> FilePath
    -- ^ The build directory for this target
    -> PreBuildComponentInputs
    -- ^ The context and component being built in it.
    -> IO (NubListR FilePath)
    -- ^ Returns the list of extra sources that were built
buildCSources :: ConfiguredProgram
-> FilePath -> PreBuildComponentInputs -> IO (NubListR FilePath)
buildCSources =
  FilePath
-> (Verbosity
    -> LocalBuildInfo
    -> BuildInfo
    -> ComponentLocalBuildInfo
    -> FilePath
    -> FilePath
    -> GhcOptions)
-> Bool
-> (Component -> [FilePath])
-> ConfiguredProgram
-> FilePath
-> PreBuildComponentInputs
-> IO (NubListR FilePath)
buildExtraSources
    FilePath
"C Sources"
    Verbosity
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> FilePath
-> FilePath
-> GhcOptions
Internal.componentCcGhcOptions
    Bool
True
    ( \Component
c ->
        BuildInfo -> [FilePath]
cSources (Component -> BuildInfo
componentBuildInfo Component
c)
          [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ case Component
c of
            CExe Executable
exe | FilePath -> Bool
isC (Executable -> FilePath
modulePath Executable
exe) -> [Executable -> FilePath
modulePath Executable
exe]
            Component
_otherwise -> []
    )
buildCxxSources :: ConfiguredProgram
-> FilePath -> PreBuildComponentInputs -> IO (NubListR FilePath)
buildCxxSources =
  FilePath
-> (Verbosity
    -> LocalBuildInfo
    -> BuildInfo
    -> ComponentLocalBuildInfo
    -> FilePath
    -> FilePath
    -> GhcOptions)
-> Bool
-> (Component -> [FilePath])
-> ConfiguredProgram
-> FilePath
-> PreBuildComponentInputs
-> IO (NubListR FilePath)
buildExtraSources
    FilePath
"C++ Sources"
    Verbosity
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> FilePath
-> FilePath
-> GhcOptions
Internal.componentCxxGhcOptions
    Bool
True
    ( \Component
c ->
        BuildInfo -> [FilePath]
cxxSources (Component -> BuildInfo
componentBuildInfo Component
c)
          [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ case Component
c of
            CExe Executable
exe | FilePath -> Bool
isCxx (Executable -> FilePath
modulePath Executable
exe) -> [Executable -> FilePath
modulePath Executable
exe]
            Component
_otherwise -> []
    )
buildJsSources :: ConfiguredProgram
-> FilePath -> PreBuildComponentInputs -> IO (NubListR FilePath)
buildJsSources ConfiguredProgram
ghcProg FilePath
buildTargetDir = do
  Platform Arch
hostArch OS
_ <- LocalBuildInfo -> Platform
hostPlatform (LocalBuildInfo -> Platform)
-> (PreBuildComponentInputs -> LocalBuildInfo)
-> PreBuildComponentInputs
-> Platform
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PreBuildComponentInputs -> LocalBuildInfo
localBuildInfo
  let hasJsSupport :: Bool
hasJsSupport = Arch
hostArch Arch -> Arch -> Bool
forall a. Eq a => a -> a -> Bool
== Arch
JavaScript
  FilePath
-> (Verbosity
    -> LocalBuildInfo
    -> BuildInfo
    -> ComponentLocalBuildInfo
    -> FilePath
    -> FilePath
    -> GhcOptions)
-> Bool
-> (Component -> [FilePath])
-> ConfiguredProgram
-> FilePath
-> PreBuildComponentInputs
-> IO (NubListR FilePath)
buildExtraSources
    FilePath
"JS Sources"
    Verbosity
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> FilePath
-> FilePath
-> GhcOptions
Internal.componentJsGhcOptions
    Bool
False
    ( \Component
c ->
        if Bool
hasJsSupport
          then -- JS files are C-like with GHC's JS backend: they are
          -- "compiled" into `.o` files (renamed with a header).
          -- This is a difference from GHCJS, for which we only
          -- pass the JS files at link time.
            BuildInfo -> [FilePath]
jsSources (Component -> BuildInfo
componentBuildInfo Component
c)
          else [FilePath]
forall a. Monoid a => a
mempty
    )
    ConfiguredProgram
ghcProg
    FilePath
buildTargetDir
buildAsmSources :: ConfiguredProgram
-> FilePath -> PreBuildComponentInputs -> IO (NubListR FilePath)
buildAsmSources =
  FilePath
-> (Verbosity
    -> LocalBuildInfo
    -> BuildInfo
    -> ComponentLocalBuildInfo
    -> FilePath
    -> FilePath
    -> GhcOptions)
-> Bool
-> (Component -> [FilePath])
-> ConfiguredProgram
-> FilePath
-> PreBuildComponentInputs
-> IO (NubListR FilePath)
buildExtraSources
    FilePath
"Assembler Sources"
    Verbosity
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> FilePath
-> FilePath
-> GhcOptions
Internal.componentAsmGhcOptions
    Bool
True
    (BuildInfo -> [FilePath]
asmSources (BuildInfo -> [FilePath])
-> (Component -> BuildInfo) -> Component -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Component -> BuildInfo
componentBuildInfo)
buildCmmSources :: ConfiguredProgram
-> FilePath -> PreBuildComponentInputs -> IO (NubListR FilePath)
buildCmmSources =
  FilePath
-> (Verbosity
    -> LocalBuildInfo
    -> BuildInfo
    -> ComponentLocalBuildInfo
    -> FilePath
    -> FilePath
    -> GhcOptions)
-> Bool
-> (Component -> [FilePath])
-> ConfiguredProgram
-> FilePath
-> PreBuildComponentInputs
-> IO (NubListR FilePath)
buildExtraSources
    FilePath
"C-- Sources"
    Verbosity
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> FilePath
-> FilePath
-> GhcOptions
Internal.componentCmmGhcOptions
    Bool
True
    (BuildInfo -> [FilePath]
cmmSources (BuildInfo -> [FilePath])
-> (Component -> BuildInfo) -> Component -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Component -> BuildInfo
componentBuildInfo)

-- | Create 'PreBuildComponentRules' for a given type of extra build sources
-- which are compiled via a GHC invocation with the given options. Used to
-- define built-in extra sources, such as, C, Cxx, Js, Asm, and Cmm sources.
buildExtraSources
  :: String
  -- ^ String describing the extra sources being built, for printing.
  -> (Verbosity -> LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo -> FilePath -> FilePath -> GhcOptions)
  -- ^ Function to determine the @'GhcOptions'@ for the
  -- invocation of GHC when compiling these extra sources (e.g.
  -- @'Internal.componentCxxGhcOptions'@,
  -- @'Internal.componentCmmGhcOptions'@)
  -> Bool
  -- ^ Some types of build sources should not be built in the dynamic way, namely, JS sources.
  -- I'm not entirely sure this remains true after we migrate to supporting GHC's JS backend rather than GHCJS.
  -- Boolean for "do we allow building these sources the dynamic way?"
  -> (Component -> [FilePath])
  -- ^ View the extra sources of a component, typically from
  -- the build info (e.g. @'asmSources'@, @'cSources'@).
  -- @'Executable'@ components might additionally add the
  -- program entry point (@main-is@ file) to the extra sources,
  -- if it should be compiled as the rest of them.
  -> ConfiguredProgram
  -- ^ The GHC configured program
  -> FilePath
  -- ^ The build directory for this target
  -> PreBuildComponentInputs
  -- ^ The context and component being built in it.
  -> IO (NubListR FilePath)
  -- ^ Returns the list of extra sources that were built
buildExtraSources :: FilePath
-> (Verbosity
    -> LocalBuildInfo
    -> BuildInfo
    -> ComponentLocalBuildInfo
    -> FilePath
    -> FilePath
    -> GhcOptions)
-> Bool
-> (Component -> [FilePath])
-> ConfiguredProgram
-> FilePath
-> PreBuildComponentInputs
-> IO (NubListR FilePath)
buildExtraSources FilePath
description Verbosity
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> FilePath
-> FilePath
-> GhcOptions
componentSourceGhcOptions Bool
wantDyn Component -> [FilePath]
viewSources ConfiguredProgram
ghcProg FilePath
buildTargetDir =
  \PreBuildComponentInputs{BuildingWhat
buildingWhat :: BuildingWhat
buildingWhat :: PreBuildComponentInputs -> BuildingWhat
buildingWhat, localBuildInfo :: PreBuildComponentInputs -> LocalBuildInfo
localBuildInfo = LocalBuildInfo
lbi, TargetInfo
targetInfo :: TargetInfo
targetInfo :: PreBuildComponentInputs -> TargetInfo
targetInfo} ->
    let
      bi :: BuildInfo
bi = Component -> BuildInfo
componentBuildInfo (TargetInfo -> Component
targetComponent TargetInfo
targetInfo)
      verbosity :: Verbosity
verbosity = BuildingWhat -> Verbosity
buildingWhatVerbosity BuildingWhat
buildingWhat
      clbi :: ComponentLocalBuildInfo
clbi = TargetInfo -> ComponentLocalBuildInfo
targetCLBI TargetInfo
targetInfo

      sources :: [FilePath]
sources = Component -> [FilePath]
viewSources (TargetInfo -> Component
targetComponent TargetInfo
targetInfo)

      comp :: Compiler
comp = LocalBuildInfo -> Compiler
compiler LocalBuildInfo
lbi
      platform :: Platform
platform = LocalBuildInfo -> Platform
hostPlatform LocalBuildInfo
lbi
      -- Instead of keeping this logic here, we really just want to
      -- receive as an input the `neededWays` from GHC/Build.build and build
      -- accordingly, since we've already determined the extra needed ways
      -- needed for e.g. template haskell. Although we'd have to account for 'wantDyn'.
      isGhcDynamic :: Bool
isGhcDynamic = Compiler -> Bool
isDynamic Compiler
comp
      doingTH :: Bool
doingTH = BuildInfo -> Bool
usesTemplateHaskellOrQQ BuildInfo
bi
      forceSharedLib :: Bool
forceSharedLib = Bool
doingTH Bool -> Bool -> Bool
&& Bool
isGhcDynamic
      runGhcProg :: GhcOptions -> IO ()
runGhcProg = Verbosity
-> ConfiguredProgram -> Compiler -> Platform -> GhcOptions -> IO ()
runGHC Verbosity
verbosity ConfiguredProgram
ghcProg Compiler
comp Platform
platform

      buildAction :: FilePath -> IO ()
buildAction FilePath
sourceFile = do
        let baseSrcOpts :: GhcOptions
baseSrcOpts =
              Verbosity
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> FilePath
-> FilePath
-> GhcOptions
componentSourceGhcOptions
                Verbosity
verbosity
                LocalBuildInfo
lbi
                BuildInfo
bi
                ComponentLocalBuildInfo
clbi
                FilePath
buildTargetDir
                FilePath
sourceFile
            vanillaSrcOpts :: GhcOptions
vanillaSrcOpts
              -- Dynamic GHC requires C sources to be built
              -- with -fPIC for REPL to work. See #2207.
              | Bool
isGhcDynamic Bool -> Bool -> Bool
&& Bool
wantDyn = GhcOptions
baseSrcOpts{ghcOptFPic = toFlag True}
              | Bool
otherwise = GhcOptions
baseSrcOpts
            profSrcOpts :: GhcOptions
profSrcOpts =
              GhcOptions
vanillaSrcOpts
                GhcOptions -> GhcOptions -> GhcOptions
forall a. Monoid a => a -> a -> a
`mappend` GhcOptions
forall a. Monoid a => a
mempty
                  { ghcOptProfilingMode = toFlag True
                  }
            sharedSrcOpts :: GhcOptions
sharedSrcOpts =
              GhcOptions
vanillaSrcOpts
                GhcOptions -> GhcOptions -> GhcOptions
forall a. Monoid a => a -> a -> a
`mappend` GhcOptions
forall a. Monoid a => a
mempty
                  { ghcOptFPic = toFlag True
                  , ghcOptDynLinkMode = toFlag GhcDynamicOnly
                  }
            -- TODO: Placing all Haskell, C, & C++ objects in a single directory
            --       Has the potential for file collisions. In general we would
            --       consider this a user error. However, we should strive to
            --       add a warning if this occurs.
            odir :: FilePath
odir = Flag FilePath -> FilePath
forall a. WithCallStack (Flag a -> a)
fromFlag (GhcOptions -> Flag FilePath
ghcOptObjDir GhcOptions
vanillaSrcOpts)
            compileIfNeeded :: GhcOptions -> IO ()
compileIfNeeded GhcOptions
opts = do
              Bool
needsRecomp <- FilePath -> GhcOptions -> IO Bool
checkNeedsRecompilation FilePath
sourceFile GhcOptions
opts
              Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
needsRecomp (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ GhcOptions -> IO ()
runGhcProg GhcOptions
opts

        -- TODO: This whole section can be streamlined to the
        -- wantedWays+neededWays logic used in Build/Modules.hs
        Verbosity -> Bool -> FilePath -> IO ()
createDirectoryIfMissingVerbose Verbosity
verbosity Bool
True FilePath
odir
        case TargetInfo -> Component
targetComponent TargetInfo
targetInfo of
          -- For libraries, we compile extra objects in the three ways: vanilla, shared, and profiled.
          -- We suffix shared objects with .dyn_o and profiled ones with .p_o.
          CLib Library
_lib
            -- Unless for repl, in which case we only need the vanilla way
            | BuildRepl ReplFlags
_ <- BuildingWhat
buildingWhat ->
                GhcOptions -> IO ()
compileIfNeeded GhcOptions
vanillaSrcOpts
            | Bool
otherwise ->
                do
                  GhcOptions -> IO ()
compileIfNeeded GhcOptions
vanillaSrcOpts
                  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
wantDyn Bool -> Bool -> Bool
&& (Bool
forceSharedLib Bool -> Bool -> Bool
|| LocalBuildInfo -> Bool
withSharedLib LocalBuildInfo
lbi)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                    GhcOptions -> IO ()
compileIfNeeded GhcOptions
sharedSrcOpts{ghcOptObjSuffix = toFlag "dyn_o"}
                  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LocalBuildInfo -> Bool
withProfLib LocalBuildInfo
lbi) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                    GhcOptions -> IO ()
compileIfNeeded GhcOptions
profSrcOpts{ghcOptObjSuffix = toFlag "p_o"}

          -- For foreign libraries, we determine with which options to build the
          -- objects (vanilla vs shared vs profiled)
          CFLib ForeignLib
flib
            | LocalBuildInfo -> Bool
withProfExe LocalBuildInfo
lbi -> -- It doesn't sound right to query "ProfExe" for a foreign library...
                GhcOptions -> IO ()
compileIfNeeded GhcOptions
profSrcOpts
            | ForeignLib -> Bool
withDynFLib ForeignLib
flib Bool -> Bool -> Bool
&& Bool
wantDyn ->
                GhcOptions -> IO ()
compileIfNeeded GhcOptions
sharedSrcOpts
            | Bool
otherwise ->
                GhcOptions -> IO ()
compileIfNeeded GhcOptions
vanillaSrcOpts
          -- For the remaining component types (Exec, Test, Bench), we also
          -- determine with which options to build the objects (vanilla vs shared vs
          -- profiled), but predicate is the same for the three kinds.
          Component
_exeLike
            | LocalBuildInfo -> Bool
withProfExe LocalBuildInfo
lbi ->
                GhcOptions -> IO ()
compileIfNeeded GhcOptions
profSrcOpts
            | LocalBuildInfo -> Bool
withDynExe LocalBuildInfo
lbi Bool -> Bool -> Bool
&& Bool
wantDyn ->
                GhcOptions -> IO ()
compileIfNeeded GhcOptions
sharedSrcOpts
            | Bool
otherwise ->
                GhcOptions -> IO ()
compileIfNeeded GhcOptions
vanillaSrcOpts
     in
      -- build any sources
      if ([FilePath] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
sources Bool -> Bool -> Bool
|| ComponentLocalBuildInfo -> Bool
componentIsIndefinite ComponentLocalBuildInfo
clbi)
        then NubListR FilePath -> IO (NubListR FilePath)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return NubListR FilePath
forall a. Monoid a => a
mempty
        else do
          Verbosity -> FilePath -> IO ()
info Verbosity
verbosity (FilePath
"Building " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
description FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"...")
          (FilePath -> IO ()) -> [FilePath] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ FilePath -> IO ()
buildAction [FilePath]
sources
          NubListR FilePath -> IO (NubListR FilePath)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([FilePath] -> NubListR FilePath
forall a. Ord a => [a] -> NubListR a
toNubListR [FilePath]
sources)