{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TupleSections #-}

module Distribution.Simple.GHC.Build.Modules
  ( buildHaskellModules
  , BuildWay (..)
  , buildWayPrefix
  , componentInputs
  ) where

import Control.Monad.IO.Class
import Distribution.Compat.Prelude

import Data.List (sortOn, (\\))
import qualified Data.Set as Set
import Distribution.CabalSpecVersion
import Distribution.ModuleName (ModuleName)
import qualified Distribution.PackageDescription as PD
import Distribution.Pretty
import Distribution.Simple.Build.Inputs
import Distribution.Simple.BuildWay
import Distribution.Simple.Compiler
import Distribution.Simple.GHC.Build.Utils
import qualified Distribution.Simple.GHC.Internal as Internal
import qualified Distribution.Simple.Hpc as Hpc
import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.Program.GHC
import Distribution.Simple.Program.Types
import Distribution.Simple.Setup.Common
import Distribution.Simple.Utils
import Distribution.Types.Benchmark
import Distribution.Types.BenchmarkInterface
import Distribution.Types.BuildInfo
import Distribution.Types.Executable
import Distribution.Types.ForeignLib
import Distribution.Types.PackageName.Magic
import Distribution.Types.ParStrat
import Distribution.Types.TestSuite
import Distribution.Types.TestSuiteInterface
import Distribution.Utils.NubList
import Distribution.Utils.Path
import System.FilePath ()

{-
Note [Building Haskell Modules accounting for TH]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

There are multiple ways in which we may want to build our Haskell modules:
  * The static way (-static)
  * The dynamic/shared way (-dynamic)
  * The profiled way (-prof)

For libraries, we may /want/ to build modules in all three ways, or in any combination, depending on user options.
For executables, we just /want/ to build the executable in the requested way.

In practice, however, we may /need/ to build modules in additional ways beyonds the ones that were requested.
This can happen because of Template Haskell.

When we're using Template Haskell, we /need/ to additionally build modules with
the used GHC's default/vanilla ABI. This is because the code that TH needs to
run at compile time needs to be the vanilla ABI so it can be loaded up and run
by the compiler. With dynamic-by-default GHC the TH object files loaded at
compile-time need to be .dyn_o instead of .o.

  * If the GHC is dynamic by default, that means we may need to also build
  the dynamic way in addition the wanted way.

  * If the GHC is static by default, we may need to build statically additionally.

Of course, if the /wanted/ way is the way additionally /needed/ for TH, we don't need to do extra work.

If it turns out that in the end we need to build both statically and
dynamically, we want to make use of GHC's -static -dynamic-too capability, which
builds modules in the two ways in a single invocation.

If --dynamic-too is not supported by the GHC, then we need to be careful about
the order in which modules are built. Specifically, we must first build the
modules for TH with the vanilla ABI, and only afterwards the desired
(non-default) ways.

A few examples:

To build an executable with profiling, with a dynamic by default GHC, and TH is used:
  * Build dynamic (needed) objects
  * Build profiled objects

To build a library with profiling and dynamically, with a static by default GHC, and TH is used:
  * Build dynamic (wanted) and static (needed) objects together with --dynamic-too
  * Build profiled objects

To build an executable statically, with a static by default GHC, regardless of whether TH is used:
  * Simply build static objects

-}

-- | Compile the Haskell modules of the component being built.
buildHaskellModules
  :: Flag ParStrat
  -- ^ The parallelism strategy (e.g. num of jobs)
  -> ConfiguredProgram
  -- ^ The GHC configured program
  -> Maybe (SymbolicPath Pkg File)
  -- ^ Optional path to a Haskell Main file to build
  -> [ModuleName]
  -- ^ The Haskell modules to build
  -> SymbolicPath Pkg ('Dir Artifacts)
  -- ^ The path to the build directory for this target, which
  -- has already been created.
  -> [BuildWay]
  -- ^ The set of needed build ways according to user options
  -> PreBuildComponentInputs
  -- ^ The context and component being built in it.
  -> IO (BuildWay -> GhcOptions)
  -- ^ Returns a mapping from build ways to the 'GhcOptions' used in the
  -- invocation used to compile the component in that 'BuildWay'.
  -- This can be useful in, eg, a linker invocation, in which we want to use the
  -- same options and list the same inputs as those used for building.
buildHaskellModules :: 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)
mbMainFile [ModuleName]
inputModules SymbolicPath Pkg ('Dir Artifacts)
buildTargetDir [BuildWay]
neededLibWays PreBuildComponentInputs
pbci = do
  -- See Note [Building Haskell Modules accounting for TH]

  let
    verbosity :: Verbosity
verbosity = PreBuildComponentInputs -> Verbosity
buildVerbosity PreBuildComponentInputs
pbci
    isLib :: Bool
isLib = PreBuildComponentInputs -> Bool
buildIsLib PreBuildComponentInputs
pbci
    clbi :: ComponentLocalBuildInfo
clbi = PreBuildComponentInputs -> ComponentLocalBuildInfo
buildCLBI PreBuildComponentInputs
pbci
    lbi :: LocalBuildInfo
lbi = PreBuildComponentInputs -> LocalBuildInfo
localBuildInfo PreBuildComponentInputs
pbci
    bi :: BuildInfo
bi = PreBuildComponentInputs -> BuildInfo
buildBI PreBuildComponentInputs
pbci
    what :: BuildingWhat
what = PreBuildComponentInputs -> BuildingWhat
buildingWhat PreBuildComponentInputs
pbci
    comp :: Compiler
comp = PreBuildComponentInputs -> Compiler
buildCompiler PreBuildComponentInputs
pbci
    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

    -- If this component will be loaded into a repl, we don't compile the modules at all.
    forRepl :: Bool
forRepl
      | BuildRepl{} <- BuildingWhat
what = Bool
True
      | Bool
otherwise = Bool
False

  -- TODO: do we need to put hs-boot files into place for mutually recursive
  -- modules?  FIX: what about exeName.hi-boot?

  -- Determine if program coverage should be enabled and if so, what
  -- '-hpcdir' should be.
  let isCoverageEnabled :: Bool
isCoverageEnabled = if Bool
isLib then LocalBuildInfo -> Bool
libCoverage LocalBuildInfo
lbi else LocalBuildInfo -> Bool
exeCoverage LocalBuildInfo
lbi
      hpcdir :: Way -> Flag (SymbolicPath Pkg ('Dir Mix))
hpcdir Way
way
        | Bool
forRepl = Flag (SymbolicPath Pkg ('Dir Mix))
forall a. Monoid a => a
mempty -- HPC is not supported in ghci
        | Bool
isCoverageEnabled = SymbolicPath Pkg ('Dir Mix) -> Flag (SymbolicPath Pkg ('Dir Mix))
forall a. a -> Flag a
Flag (SymbolicPath Pkg ('Dir Mix) -> Flag (SymbolicPath Pkg ('Dir Mix)))
-> SymbolicPath Pkg ('Dir Mix)
-> Flag (SymbolicPath Pkg ('Dir Mix))
forall a b. (a -> b) -> a -> b
$ SymbolicPath Pkg ('Dir Dist) -> Way -> SymbolicPath Pkg ('Dir Mix)
Hpc.mixDir (SymbolicPath Pkg ('Dir Artifacts) -> SymbolicPath Pkg ('Dir Dist)
forall (allowAbsolute :: AllowAbsolute) from (to1 :: FileOrDir)
       (to2 :: FileOrDir).
SymbolicPathX allowAbsolute from to1
-> SymbolicPathX allowAbsolute from to2
coerceSymbolicPath (SymbolicPath Pkg ('Dir Artifacts) -> SymbolicPath Pkg ('Dir Dist))
-> SymbolicPath Pkg ('Dir Artifacts)
-> SymbolicPath Pkg ('Dir Dist)
forall a b. (a -> b) -> a -> b
$ SymbolicPath Pkg ('Dir Artifacts)
-> SymbolicPathX 'AllowAbsolute Pkg ('Dir Build)
forall (allowAbsolute :: AllowAbsolute) from (to1 :: FileOrDir)
       (to2 :: FileOrDir).
SymbolicPathX allowAbsolute from to1
-> SymbolicPathX allowAbsolute from to2
coerceSymbolicPath SymbolicPath Pkg ('Dir Artifacts)
buildTargetDir SymbolicPathX 'AllowAbsolute Pkg ('Dir Build)
-> RelativePath Build ('Dir Artifacts)
-> SymbolicPath Pkg ('Dir Artifacts)
forall p q r. PathLike p q r => p -> q -> r
</> RelativePath Build ('Dir Artifacts)
extraCompilationArtifacts) Way
way
        | Bool
otherwise = Flag (SymbolicPath Pkg ('Dir Mix))
forall a. Monoid a => a
mempty

  let
    mbWorkDir :: Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir = LocalBuildInfo -> Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDirLBI LocalBuildInfo
lbi
    runGhcProg :: GhcOptions -> IO ()
runGhcProg = Verbosity
-> ConfiguredProgram
-> Compiler
-> Platform
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> GhcOptions
-> IO ()
runGHC Verbosity
verbosity ConfiguredProgram
ghcProg Compiler
comp Platform
platform Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir
    platform :: Platform
platform = LocalBuildInfo -> Platform
hostPlatform LocalBuildInfo
lbi

    ([SymbolicPath Pkg 'File]
hsMains, [SymbolicPath Pkg 'File]
scriptMains) =
      (SymbolicPath Pkg 'File -> Bool)
-> [SymbolicPath Pkg 'File]
-> ([SymbolicPath Pkg 'File], [SymbolicPath Pkg 'File])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (FilePath -> Bool
isHaskell (FilePath -> Bool)
-> (SymbolicPath Pkg 'File -> FilePath)
-> SymbolicPath Pkg 'File
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SymbolicPath Pkg 'File -> FilePath
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> FilePath
getSymbolicPath) (Maybe (SymbolicPath Pkg 'File) -> [SymbolicPath Pkg 'File]
forall a. Maybe a -> [a]
maybeToList Maybe (SymbolicPath Pkg 'File)
mbMainFile)

    -- We define the base opts which are shared across different build ways in
    -- 'buildHaskellModules'
    baseOpts :: BuildWay -> GhcOptions
baseOpts BuildWay
way =
      (Verbosity
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> SymbolicPath Pkg ('Dir Artifacts)
-> GhcOptions
forall build.
Verbosity
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> SymbolicPath Pkg ('Dir build)
-> GhcOptions
Internal.componentGhcOptions Verbosity
verbosity LocalBuildInfo
lbi BuildInfo
bi ComponentLocalBuildInfo
clbi SymbolicPath Pkg ('Dir Artifacts)
buildTargetDir)
        GhcOptions -> GhcOptions -> GhcOptions
forall a. Monoid a => a -> a -> a
`mappend` GhcOptions
forall a. Monoid a => a
mempty
          { ghcOptMode = toFlag GhcModeMake
          , -- Previously we didn't pass -no-link when building libs,
            -- but I think that could result in a bug (e.g. if a lib module is
            -- called Main and exports main). So we really want nolink when
            -- building libs too (TODO).
            ghcOptNoLink = if isLib then NoFlag else toFlag True
          , ghcOptNumJobs = numJobs
          , ghcOptInputModules = toNubListR inputModules
          , ghcOptInputFiles = toNubListR hsMains
          , ghcOptInputScripts = toNubListR scriptMains
          , ghcOptExtra = buildWayExtraHcOptions way GHC bi
          , ghcOptHiSuffix = optSuffixFlag (buildWayPrefix way) "hi"
          , ghcOptObjSuffix = optSuffixFlag (buildWayPrefix way) "o"
          , ghcOptHPCDir = hpcdir (buildWayHpcWay way) -- maybe this should not be passed for vanilla?
          }
      where
        optSuffixFlag :: FilePath -> FilePath -> Flag FilePath
optSuffixFlag FilePath
"" FilePath
_ = Flag FilePath
forall a. Flag a
NoFlag
        optSuffixFlag FilePath
pre FilePath
x = FilePath -> Flag FilePath
forall a. a -> Flag a
toFlag (FilePath
pre FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
x)

    -- For libs we don't pass -static when building static, leaving it
    -- implicit. We should just always pass -static, but we don't want to
    -- change behaviour when doing the refactor.
    staticOpts :: GhcOptions
staticOpts = (BuildWay -> GhcOptions
baseOpts BuildWay
StaticWay){ghcOptDynLinkMode = if isLib then NoFlag else toFlag GhcStaticOnly}
    dynOpts :: GhcOptions
dynOpts =
      (BuildWay -> GhcOptions
baseOpts BuildWay
DynWay)
        { ghcOptDynLinkMode = toFlag GhcDynamicOnly -- use -dynamic
        , -- TODO: Does it hurt to set -fPIC for executables?
          ghcOptFPic = toFlag True -- use -fPIC
        }
    profOpts :: GhcOptions
profOpts =
      (BuildWay -> GhcOptions
baseOpts BuildWay
ProfWay)
        { ghcOptProfilingMode = toFlag True
        , ghcOptProfilingAuto =
            Internal.profDetailLevelFlag
              (if isLib then True else False)
              ((if isLib then withProfLibDetail else withProfExeDetail) lbi)
        }
    profDynOpts :: GhcOptions
profDynOpts =
      (BuildWay -> GhcOptions
baseOpts BuildWay
ProfDynWay)
        { ghcOptDynLinkMode = toFlag GhcDynamicOnly -- use -dynamic
        , -- TODO: Does it hurt to set -fPIC for executables?
          ghcOptFPic = toFlag True -- use -fPIC
        , ghcOptProfilingMode = toFlag True
        , ghcOptProfilingAuto =
            Internal.profDetailLevelFlag
              (if isLib then True else False)
              ((if isLib then withProfLibDetail else withProfExeDetail) lbi)
        }

    -- Options for building both static and dynamic way at the same time, using
    -- the GHC flag -static and -dynamic-too
    dynTooOpts :: GhcOptions
dynTooOpts =
      (BuildWay -> GhcOptions
baseOpts BuildWay
StaticWay)
        { ghcOptDynLinkMode = toFlag GhcStaticAndDynamic -- use -dynamic-too
        , ghcOptDynHiSuffix = toFlag (buildWayPrefix DynWay ++ "hi")
        , ghcOptDynObjSuffix = toFlag (buildWayPrefix DynWay ++ "o")
        , ghcOptHPCDir = hpcdir Hpc.Dyn
        -- Should we pass hcSharedOpts in the -dynamic-too ghc invocation?
        -- (Note that `baseOtps StaticWay = hcStaticOptions`, not hcSharedOpts)
        }

    profDynTooOpts :: GhcOptions
profDynTooOpts =
      (BuildWay -> GhcOptions
baseOpts BuildWay
ProfWay)
        { ghcOptDynLinkMode = toFlag GhcStaticAndDynamic -- use -dynamic-too
        , -- TODO: Does it hurt to set -fPIC for executables?
          ghcOptFPic = toFlag True -- use -fPIC
        , ghcOptProfilingMode = toFlag True
        , ghcOptProfilingAuto =
            Internal.profDetailLevelFlag
              (if isLib then True else False)
              ((if isLib then withProfLibDetail else withProfExeDetail) lbi)
        , ghcOptDynHiSuffix = toFlag (buildWayPrefix ProfDynWay ++ "hi")
        , ghcOptDynObjSuffix = toFlag (buildWayPrefix ProfDynWay ++ "o")
        , ghcOptHPCDir = hpcdir Hpc.ProfDyn
        -- Should we pass hcSharedOpts in the -dynamic-too ghc invocation?
        -- (Note that `baseOtps StaticWay = hcStaticOptions`, not hcSharedOpts)
        }

    -- Determines how to build for each way, also serves as the base options
    -- for loading modules in 'linkOrLoadComponent'
    buildOpts :: BuildWay -> GhcOptions
buildOpts BuildWay
way = case BuildWay
way of
      BuildWay
StaticWay -> GhcOptions
staticOpts
      BuildWay
DynWay -> GhcOptions
dynOpts
      BuildWay
ProfWay -> GhcOptions
profOpts
      BuildWay
ProfDynWay -> GhcOptions
profDynOpts

  -- If there aren't modules, or if we're loading the modules in repl, don't build.
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
forRepl Bool -> Bool -> Bool
|| (Maybe (SymbolicPath Pkg 'File) -> Bool
forall a. Maybe a -> Bool
isNothing Maybe (SymbolicPath Pkg 'File)
mbMainFile Bool -> Bool -> Bool
&& [ModuleName] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ModuleName]
inputModules)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ 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
    -- See Note [Building Haskell Modules accounting for TH]
    let
      neededLibWaysSet :: Set BuildWay
neededLibWaysSet = [BuildWay] -> Set BuildWay
forall a. Ord a => [a] -> Set a
Set.fromList [BuildWay]
neededLibWays

      -- If we need both static and dynamic, use dynamic-too instead of
      -- compiling twice (if we support it)
      useDynamicToo :: Bool
useDynamicToo =
        BuildWay
StaticWay BuildWay -> Set BuildWay -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set BuildWay
neededLibWaysSet
          Bool -> Bool -> Bool
&& BuildWay
DynWay BuildWay -> Set BuildWay -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set BuildWay
neededLibWaysSet
          Bool -> Bool -> Bool
&& Compiler -> Bool
supportsDynamicToo Compiler
comp
          Bool -> Bool -> Bool
&& [FilePath] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (CompilerFlavor -> BuildInfo -> [FilePath]
hcSharedOptions CompilerFlavor
GHC BuildInfo
bi)

      useProfDynamicToo :: Bool
useProfDynamicToo =
        BuildWay
ProfWay BuildWay -> Set BuildWay -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set BuildWay
neededLibWaysSet
          Bool -> Bool -> Bool
&& BuildWay
ProfDynWay BuildWay -> Set BuildWay -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set BuildWay
neededLibWaysSet
          Bool -> Bool -> Bool
&& Compiler -> Bool
supportsDynamicToo Compiler
comp
          Bool -> Bool -> Bool
&& [FilePath] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (CompilerFlavor -> BuildInfo -> [FilePath]
hcSharedOptions CompilerFlavor
GHC BuildInfo
bi)

      defaultGhcWay :: BuildWay
defaultGhcWay = Compiler -> BuildWay
compilerBuildWay Compiler
comp

      order :: BuildWay -> Int
order BuildWay
w
        | BuildWay
w BuildWay -> BuildWay -> Bool
forall a. Eq a => a -> a -> Bool
== BuildWay
defaultGhcWay = Int
0
        | Bool
otherwise = BuildWay -> Int
forall a. Enum a => a -> Int
fromEnum BuildWay
w Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1

      -- The ways we'll build, in order
      orderedBuilds :: [IO ()]
orderedBuilds
        -- We need to make sure that the way which is the way the compiler is built
        -- is built first so that Template Haskell works.
        | Bool
useProfDynamicToo Bool -> Bool -> Bool
&& Bool
useDynamicToo =
            if BuildWay
defaultGhcWay BuildWay -> [BuildWay] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [BuildWay
ProfDynWay, BuildWay
ProfWay]
              then [IO ()
buildProfAndProfDynamicToo, IO ()
buildStaticAndDynamicToo]
              else [IO ()
buildStaticAndDynamicToo, IO ()
buildProfAndProfDynamicToo]
        | Bool
useProfDynamicToo Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
useDynamicToo =
            if BuildWay
defaultGhcWay BuildWay -> [BuildWay] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [BuildWay
ProfDynWay, BuildWay
ProfWay]
              then
                [IO ()
buildProfAndProfDynamicToo]
                  [IO ()] -> [IO ()] -> [IO ()]
forall a. [a] -> [a] -> [a]
++ (GhcOptions -> IO ()
runGhcProg (GhcOptions -> IO ())
-> (BuildWay -> GhcOptions) -> BuildWay -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BuildWay -> GhcOptions
buildOpts (BuildWay -> IO ()) -> [BuildWay] -> [IO ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [BuildWay]
neededLibWays [BuildWay] -> [BuildWay] -> [BuildWay]
forall a. Eq a => [a] -> [a] -> [a]
\\ [BuildWay
ProfDynWay, BuildWay
ProfWay])
              else
                (GhcOptions -> IO ()
runGhcProg (GhcOptions -> IO ())
-> (BuildWay -> GhcOptions) -> BuildWay -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BuildWay -> GhcOptions
buildOpts (BuildWay -> IO ()) -> [BuildWay] -> [IO ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [BuildWay]
neededLibWays [BuildWay] -> [BuildWay] -> [BuildWay]
forall a. Eq a => [a] -> [a] -> [a]
\\ [BuildWay
ProfDynWay, BuildWay
ProfWay])
                  [IO ()] -> [IO ()] -> [IO ()]
forall a. [a] -> [a] -> [a]
++ [IO ()
buildProfAndProfDynamicToo]
        | Bool
useDynamicToo =
            if BuildWay
defaultGhcWay BuildWay -> [BuildWay] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [BuildWay
StaticWay, BuildWay
DynWay]
              then
                [IO ()
buildStaticAndDynamicToo]
                  [IO ()] -> [IO ()] -> [IO ()]
forall a. [a] -> [a] -> [a]
++ (GhcOptions -> IO ()
runGhcProg (GhcOptions -> IO ())
-> (BuildWay -> GhcOptions) -> BuildWay -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BuildWay -> GhcOptions
buildOpts (BuildWay -> IO ()) -> [BuildWay] -> [IO ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [BuildWay]
neededLibWays [BuildWay] -> [BuildWay] -> [BuildWay]
forall a. Eq a => [a] -> [a] -> [a]
\\ [BuildWay
StaticWay, BuildWay
DynWay])
              else
                (GhcOptions -> IO ()
runGhcProg (GhcOptions -> IO ())
-> (BuildWay -> GhcOptions) -> BuildWay -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BuildWay -> GhcOptions
buildOpts (BuildWay -> IO ()) -> [BuildWay] -> [IO ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [BuildWay]
neededLibWays [BuildWay] -> [BuildWay] -> [BuildWay]
forall a. Eq a => [a] -> [a] -> [a]
\\ [BuildWay
StaticWay, BuildWay
DynWay])
                  [IO ()] -> [IO ()] -> [IO ()]
forall a. [a] -> [a] -> [a]
++ [IO ()
buildStaticAndDynamicToo]
        -- Otherwise, we need to ensure the defaultGhcWay is built first
        | Bool
otherwise =
            GhcOptions -> IO ()
runGhcProg (GhcOptions -> IO ())
-> (BuildWay -> GhcOptions) -> BuildWay -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BuildWay -> GhcOptions
buildOpts (BuildWay -> IO ()) -> [BuildWay] -> [IO ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (BuildWay -> Int) -> [BuildWay] -> [BuildWay]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn BuildWay -> Int
order [BuildWay]
neededLibWays

      buildStaticAndDynamicToo :: IO ()
buildStaticAndDynamicToo = do
        GhcOptions -> IO ()
runGhcProg GhcOptions
dynTooOpts
        case (Way -> Flag (SymbolicPath Pkg ('Dir Mix))
hpcdir Way
Hpc.Dyn, Way -> Flag (SymbolicPath Pkg ('Dir Mix))
hpcdir Way
Hpc.Vanilla) of
          (Flag SymbolicPath Pkg ('Dir Mix)
dynDir, Flag SymbolicPath Pkg ('Dir Mix)
vanillaDir) ->
            -- When the vanilla and shared library builds are done
            -- in one pass, only one set of HPC module interfaces
            -- are generated. This set should suffice for both
            -- static and dynamically linked executables. We copy
            -- the modules interfaces so they are available under
            -- both ways.
            Verbosity -> FilePath -> FilePath -> IO ()
copyDirectoryRecursive Verbosity
verbosity (SymbolicPath Pkg ('Dir Mix) -> FilePath
forall {allowAbsolute :: AllowAbsolute} {to :: FileOrDir}.
SymbolicPathX allowAbsolute Pkg to -> FilePath
i SymbolicPath Pkg ('Dir Mix)
dynDir) (SymbolicPath Pkg ('Dir Mix) -> FilePath
forall {allowAbsolute :: AllowAbsolute} {to :: FileOrDir}.
SymbolicPathX allowAbsolute Pkg to -> FilePath
i SymbolicPath Pkg ('Dir Mix)
vanillaDir)
          (Flag (SymbolicPath Pkg ('Dir Mix)),
 Flag (SymbolicPath Pkg ('Dir Mix)))
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

      buildProfAndProfDynamicToo :: IO ()
buildProfAndProfDynamicToo = do
        GhcOptions -> IO ()
runGhcProg GhcOptions
profDynTooOpts
        case (Way -> Flag (SymbolicPath Pkg ('Dir Mix))
hpcdir Way
Hpc.ProfDyn, Way -> Flag (SymbolicPath Pkg ('Dir Mix))
hpcdir Way
Hpc.Prof) of
          (Flag SymbolicPath Pkg ('Dir Mix)
profDynDir, Flag SymbolicPath Pkg ('Dir Mix)
profDir) ->
            -- When the vanilla and shared library builds are done
            -- in one pass, only one set of HPC module interfaces
            -- are generated. This set should suffice for both
            -- static and dynamically linked executables. We copy
            -- the modules interfaces so they are available under
            -- both ways.
            Verbosity -> FilePath -> FilePath -> IO ()
copyDirectoryRecursive Verbosity
verbosity (SymbolicPath Pkg ('Dir Mix) -> FilePath
forall {allowAbsolute :: AllowAbsolute} {to :: FileOrDir}.
SymbolicPathX allowAbsolute Pkg to -> FilePath
i SymbolicPath Pkg ('Dir Mix)
profDynDir) (SymbolicPath Pkg ('Dir Mix) -> FilePath
forall {allowAbsolute :: AllowAbsolute} {to :: FileOrDir}.
SymbolicPathX allowAbsolute Pkg to -> FilePath
i SymbolicPath Pkg ('Dir Mix)
profDir)
          (Flag (SymbolicPath Pkg ('Dir Mix)),
 Flag (SymbolicPath Pkg ('Dir Mix)))
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
     in
      -- REVIEW:ADD? info verbosity "Building Haskell Sources..."
      [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [IO ()]
orderedBuilds
  (BuildWay -> GhcOptions) -> IO (BuildWay -> GhcOptions)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return BuildWay -> GhcOptions
buildOpts

-- | Returns the corresponding 'Hpc.Way' for a 'BuildWay'
buildWayHpcWay :: BuildWay -> Hpc.Way
buildWayHpcWay :: BuildWay -> Way
buildWayHpcWay = \case
  BuildWay
StaticWay -> Way
Hpc.Vanilla
  BuildWay
ProfWay -> Way
Hpc.Prof
  BuildWay
DynWay -> Way
Hpc.Dyn
  BuildWay
ProfDynWay -> Way
Hpc.ProfDyn

-- | Returns a function to extract the extra haskell compiler options from a
-- 'BuildInfo' and 'CompilerFlavor'
buildWayExtraHcOptions :: BuildWay -> CompilerFlavor -> BuildInfo -> [String]
buildWayExtraHcOptions :: BuildWay -> CompilerFlavor -> BuildInfo -> [FilePath]
buildWayExtraHcOptions = \case
  BuildWay
StaticWay -> CompilerFlavor -> BuildInfo -> [FilePath]
hcStaticOptions
  BuildWay
ProfWay -> CompilerFlavor -> BuildInfo -> [FilePath]
hcProfOptions
  BuildWay
DynWay -> CompilerFlavor -> BuildInfo -> [FilePath]
hcSharedOptions
  BuildWay
ProfDynWay -> CompilerFlavor -> BuildInfo -> [FilePath]
hcProfSharedOptions

-- | Returns a pair of the main file and Haskell modules of the component being
-- built. The main file is not necessarily a Haskell file. It could also be
-- e.g. a C source, or, a Haskell repl script (that does not necessarily have
-- an extension).
--
-- The main file is Nothing if the component is not executable.
componentInputs
  :: SymbolicPath Pkg (Dir Artifacts)
  -- ^ Target build dir
  -> PD.PackageDescription
  -> PreBuildComponentInputs
  -- ^ The context and component being built in it.
  -> IO (Maybe (SymbolicPath Pkg File), [ModuleName])
  -- ^ The main input file, and the Haskell modules
componentInputs :: SymbolicPath Pkg ('Dir Artifacts)
-> PackageDescription
-> PreBuildComponentInputs
-> IO (Maybe (SymbolicPath Pkg 'File), [ModuleName])
componentInputs SymbolicPath Pkg ('Dir Artifacts)
buildTargetDir PackageDescription
pkg_descr PreBuildComponentInputs
pbci =
  case Component
component of
    CLib Library
lib ->
      (Maybe (SymbolicPath Pkg 'File), [ModuleName])
-> IO (Maybe (SymbolicPath Pkg 'File), [ModuleName])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (SymbolicPath Pkg 'File)
forall a. Maybe a
Nothing, Library -> ComponentLocalBuildInfo -> [ModuleName]
allLibModules Library
lib ComponentLocalBuildInfo
clbi)
    CFLib ForeignLib
flib ->
      (Maybe (SymbolicPath Pkg 'File), [ModuleName])
-> IO (Maybe (SymbolicPath Pkg 'File), [ModuleName])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (SymbolicPath Pkg 'File)
forall a. Maybe a
Nothing, ForeignLib -> [ModuleName]
foreignLibModules ForeignLib
flib)
    CExe Executable{buildInfo :: Executable -> BuildInfo
buildInfo = BuildInfo
bi', RelativePath Source 'File
modulePath :: RelativePath Source 'File
modulePath :: Executable -> RelativePath Source 'File
modulePath} ->
      BuildInfo
-> RelativePath Source 'File
-> IO (Maybe (SymbolicPath Pkg 'File), [ModuleName])
forall {m :: * -> *}.
MonadIO m =>
BuildInfo
-> RelativePath Source 'File
-> m (Maybe (SymbolicPath Pkg 'File), [ModuleName])
exeLikeInputs BuildInfo
bi' RelativePath Source 'File
modulePath
    CTest TestSuite{testBuildInfo :: TestSuite -> BuildInfo
testBuildInfo = BuildInfo
bi', testInterface :: TestSuite -> TestSuiteInterface
testInterface = TestSuiteExeV10 Version
_ RelativePath Source 'File
mainFile} ->
      BuildInfo
-> RelativePath Source 'File
-> IO (Maybe (SymbolicPath Pkg 'File), [ModuleName])
forall {m :: * -> *}.
MonadIO m =>
BuildInfo
-> RelativePath Source 'File
-> m (Maybe (SymbolicPath Pkg 'File), [ModuleName])
exeLikeInputs BuildInfo
bi' RelativePath Source 'File
mainFile
    CBench Benchmark{benchmarkBuildInfo :: Benchmark -> BuildInfo
benchmarkBuildInfo = BuildInfo
bi', benchmarkInterface :: Benchmark -> BenchmarkInterface
benchmarkInterface = BenchmarkExeV10 Version
_ RelativePath Source 'File
mainFile} ->
      BuildInfo
-> RelativePath Source 'File
-> IO (Maybe (SymbolicPath Pkg 'File), [ModuleName])
forall {m :: * -> *}.
MonadIO m =>
BuildInfo
-> RelativePath Source 'File
-> m (Maybe (SymbolicPath Pkg 'File), [ModuleName])
exeLikeInputs BuildInfo
bi' RelativePath Source 'File
mainFile
    CTest TestSuite{} -> FilePath -> IO (Maybe (SymbolicPath Pkg 'File), [ModuleName])
forall a. HasCallStack => FilePath -> a
error FilePath
"testSuiteExeV10AsExe: wrong kind"
    CBench Benchmark{} -> FilePath -> IO (Maybe (SymbolicPath Pkg 'File), [ModuleName])
forall a. HasCallStack => FilePath -> a
error FilePath
"benchmarkExeV10asExe: wrong kind"
  where
    verbosity :: Verbosity
verbosity = PreBuildComponentInputs -> Verbosity
buildVerbosity PreBuildComponentInputs
pbci
    component :: Component
component = PreBuildComponentInputs -> Component
buildComponent PreBuildComponentInputs
pbci
    clbi :: ComponentLocalBuildInfo
clbi = PreBuildComponentInputs -> ComponentLocalBuildInfo
buildCLBI PreBuildComponentInputs
pbci
    mbWorkDir :: Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir = LocalBuildInfo -> Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDirLBI (LocalBuildInfo -> Maybe (SymbolicPath CWD ('Dir Pkg)))
-> LocalBuildInfo -> Maybe (SymbolicPath CWD ('Dir Pkg))
forall a b. (a -> b) -> a -> b
$ PreBuildComponentInputs -> LocalBuildInfo
localBuildInfo PreBuildComponentInputs
pbci
    exeLikeInputs :: BuildInfo
-> RelativePath Source 'File
-> m (Maybe (SymbolicPath Pkg 'File), [ModuleName])
exeLikeInputs BuildInfo
bnfo RelativePath Source 'File
modulePath = IO (Maybe (SymbolicPath Pkg 'File), [ModuleName])
-> m (Maybe (SymbolicPath Pkg 'File), [ModuleName])
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (SymbolicPath Pkg 'File), [ModuleName])
 -> m (Maybe (SymbolicPath Pkg 'File), [ModuleName]))
-> IO (Maybe (SymbolicPath Pkg 'File), [ModuleName])
-> m (Maybe (SymbolicPath Pkg 'File), [ModuleName])
forall a b. (a -> b) -> a -> b
$ do
      main <- Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg ('Dir Artifacts)
-> (BuildInfo, RelativePath Source 'File)
-> IO (SymbolicPath Pkg 'File)
forall build.
Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg ('Dir build)
-> (BuildInfo, RelativePath Source 'File)
-> IO (SymbolicPath Pkg 'File)
findExecutableMain Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir SymbolicPath Pkg ('Dir Artifacts)
buildTargetDir (BuildInfo
bnfo, RelativePath Source 'File
modulePath)
      let mainModName = BuildInfo -> ModuleName
exeMainModuleName BuildInfo
bnfo
          otherModNames = BuildInfo -> [ModuleName]
otherModules BuildInfo
bnfo

      -- Scripts have fakePackageId and are always Haskell but can have any extension.
      if isHaskell (getSymbolicPath main) || PD.package pkg_descr == fakePackageId
        then
          if PD.specVersion pkg_descr < CabalSpecV2_0 && (mainModName `elem` otherModNames)
            then do
              -- The cabal manual clearly states that `other-modules` is
              -- intended for non-main modules.  However, there's at least one
              -- important package on Hackage (happy-1.19.5) which
              -- violates this. We workaround this here so that we don't
              -- invoke GHC with e.g.  'ghc --make Main src/Main.hs' which
              -- would result in GHC complaining about duplicate Main
              -- modules.
              --
              -- Finally, we only enable this workaround for
              -- specVersion < 2, as 'cabal-version:>=2.0' cabal files
              -- have no excuse anymore to keep doing it wrong... ;-)
              warn verbosity $
                "Enabling workaround for Main module '"
                  ++ prettyShow mainModName
                  ++ "' listed in 'other-modules' illegally!"
              return (Just main, filter (/= mainModName) otherModNames)
            else return (Just main, otherModNames)
        else return (Just main, otherModNames)