{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE RoleAnnotations #-}
{-# LANGUAGE TypeFamilies #-}

-- |

-- Module      :  BuildEnv.BuildOne

-- Description :  Configure, build and install a single unit

--

-- 'setupPackage' prepares a package for building, returning instructions

-- that compile its @Setup@ script.

--

-- 'buildUnit' computes build instructions to configure, build and install

-- the unit using its @Setup@ script. If the unit is a library, the instructions

-- will also register it into a local package database using @ghc-pkg@.

module BuildEnv.BuildOne
  ( -- * Building packages

    setupPackage, buildUnit

    -- * Package directory structure helpers


    -- $twoDBs


  , PkgDir(..)
  , getPkgDir
  , PkgDbDirs(..)
  , getPkgDbDirsForPrep, getPkgDbDirsForBuild
  ) where

-- base

import Control.Concurrent
  ( QSem, newQSem )
import Data.Foldable
  ( for_ )
import Data.Kind
  ( Type )
import Data.Maybe
  ( maybeToList )

-- containers

import Data.Map.Strict
  ( Map )
import qualified Data.Map.Strict as Map
  ( lookup )

-- directory

import System.Directory

-- filepath

import System.FilePath
  ( (</>), (<.>)
  , makeRelative
  )

-- text

import Data.Text
  ( Text )
import qualified Data.Text as Text
  ( unpack )

-- build-env

import BuildEnv.Config
import BuildEnv.CabalPlan
import BuildEnv.Script
import BuildEnv.Utils
  ( ProgPath(..), CallProcess(..)
  , abstractQSem, noSem
  )

--------------------------------------------------------------------------------

-- Setup


-- | Setup a single package.

--

-- Returns a build script which compiles the @Setup@ script.

setupPackage :: Verbosity
             -> Compiler
             -> BuildPaths ForBuild -- ^ Overall build directory structure.

             -> PkgDbDirs  ForBuild -- ^ Package database directories (see 'getPkgDbDirsForBuild').

             -> PkgDir     ForPrep  -- ^ Package directory (to find the @Setup.hs@).

             -> PkgDir     ForBuild -- ^ Package directory (to build the @Setup.hs@).

             -> Map UnitId PlanUnit -- ^ All dependencies in the build plan.

             -> ConfiguredUnit      -- ^ The unit to build.

             -> IO BuildScript
setupPackage :: Verbosity
-> Compiler
-> BuildPaths 'ForBuild
-> PkgDbDirs 'ForBuild
-> PkgDir 'ForPrep
-> PkgDir 'ForBuild
-> Map UnitId PlanUnit
-> ConfiguredUnit
-> IO BuildScript
setupPackage Verbosity
verbosity
             ( Compiler { String
$sel:ghcPath:Compiler :: Compiler -> String
ghcPath :: String
ghcPath } )
             paths :: BuildPaths 'ForBuild
paths@( BuildPaths { String
$sel:installDir:BuildPaths :: BuildPaths 'ForBuild -> String
installDir :: String
installDir, String
$sel:logDir:BuildPaths :: BuildPaths 'ForBuild -> String
logDir :: String
logDir } )
             ( PkgDbDirsForBuild { String
$sel:tempPkgDbDir:PkgDbDirsForBuild :: PkgDbDirs 'ForBuild -> String
tempPkgDbDir :: String
tempPkgDbDir } )
             ( PkgDir { String
$sel:pkgNameVer:PkgDir :: forall (use :: PathUsability). PkgDir use -> String
pkgNameVer :: String
pkgNameVer, $sel:pkgDir:PkgDir :: forall (use :: PathUsability). PkgDir use -> String
pkgDir = String
prepPkgDir } )
             ( PkgDir { $sel:pkgDir:PkgDir :: forall (use :: PathUsability). PkgDir use -> String
pkgDir = String
buildPkgDir } )
             Map UnitId PlanUnit
plan
             unit :: ConfiguredUnit
unit@( ConfiguredUnit { UnitId
$sel:puId:ConfiguredUnit :: ConfiguredUnit -> UnitId
puId :: UnitId
puId, [UnitId]
$sel:puSetupDepends:ConfiguredUnit :: ConfiguredUnit -> [UnitId]
puSetupDepends :: [UnitId]
puSetupDepends, [UnitId]
$sel:puExeDepends:ConfiguredUnit :: ConfiguredUnit -> [UnitId]
puExeDepends :: [UnitId]
puExeDepends } )

  = do let logPath :: Maybe String
logPath
             | Verbosity
verbosity forall a. Ord a => a -> a -> Bool
<= Verbosity
Quiet
             = forall a. Maybe a
Nothing
             | Bool
otherwise
             = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ String
logDir String -> String -> String
</> Text -> String
Text.unpack ( UnitId -> Text
unUnitId UnitId
puId )
       -- Find the appropriate Setup.hs file (creating one if necessary)

       String
setupHs <- String -> IO String
findSetupHs String
prepPkgDir
       forall (m :: * -> *) a. Monad m => a -> m a
return do
         ScriptConfig
scriptCfg <- BuildScriptM ScriptConfig
askScriptConfig
         let setupArgs :: [String]
setupArgs = [ forall r.
(IsString r, Monoid r) =>
EscapeVars -> ScriptConfig -> String -> r
quoteArg EscapeVars
ExpandVars ScriptConfig
scriptCfg ( String
buildPkgDir String -> String -> String
</> String
setupHs )
                         , String
"-o"
                         , forall r.
(IsString r, Monoid r) =>
EscapeVars -> ScriptConfig -> String -> r
quoteArg EscapeVars
ExpandVars ScriptConfig
scriptCfg ( String
buildPkgDir String -> String -> String
</> String
"Setup" )
                         , String
"-package-db=" forall a. Semigroup a => a -> a -> a
<> forall r.
(IsString r, Monoid r) =>
EscapeVars -> ScriptConfig -> String -> r
quoteArg EscapeVars
ExpandVars ScriptConfig
scriptCfg String
tempPkgDbDir
                         , Verbosity -> String
ghcVerbosity Verbosity
verbosity
                         ] forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map UnitId -> String
unitIdArg [UnitId]
puSetupDepends

             -- Specify location of binaries and data directories.

             --

             -- See the commentary around 'depDataDirs' in 'buildUnit'.

             binDirs :: [String]
binDirs = [ forall r.
(IsString r, Monoid r) =>
EscapeVars -> ScriptConfig -> String -> r
quoteArg EscapeVars
ExpandVars ScriptConfig
scriptCfg forall a b. (a -> b) -> a -> b
$ String
installDir String -> String -> String
</> String
"bin" String -> String -> String
</> Text -> String
Text.unpack ( UnitId -> Text
unUnitId UnitId
exeUnitId )
                       | UnitId
exeUnitId <- [UnitId]
puExeDepends ]
             setupDepDataDirs :: [(String, String)]
setupDepDataDirs =
               ScriptConfig
-> BuildPaths 'ForBuild -> [ConfiguredUnit] -> [(String, String)]
dataDirs ScriptConfig
scriptCfg BuildPaths 'ForBuild
paths
                 [ ConfiguredUnit
dep_cu
                 | UnitId
depUnitId <- [UnitId]
puSetupDepends
                 , let dep :: PlanUnit
dep = ConfiguredUnit -> UnitId -> Map UnitId PlanUnit -> PlanUnit
lookupDependency ConfiguredUnit
unit UnitId
depUnitId Map UnitId PlanUnit
plan
                 , ConfiguredUnit
dep_cu <- forall a. Maybe a -> [a]
maybeToList forall a b. (a -> b) -> a -> b
$ PlanUnit -> Maybe ConfiguredUnit
configuredUnitMaybe PlanUnit
dep
                 ]
         Verbosity -> Verbosity -> String -> BuildScript
logMessage Verbosity
verbosity Verbosity
Verbose forall a b. (a -> b) -> a -> b
$
           String
"Compiling Setup.hs for " forall a. Semigroup a => a -> a -> a
<> String
pkgNameVer
         CallProcess -> BuildScript
callProcess forall a b. (a -> b) -> a -> b
$
           CP { cwd :: String
cwd          = String
"."
              , prog :: ProgPath
prog         = String -> ProgPath
AbsPath String
ghcPath
              , args :: [String]
args         = [String]
setupArgs
              , extraPATH :: [String]
extraPATH    = [String]
binDirs
              , extraEnvVars :: [(String, String)]
extraEnvVars = [(String, String)]
setupDepDataDirs
              , logBasePath :: Maybe String
logBasePath  = Maybe String
logPath
              , sem :: AbstractSem
sem          = AbstractSem
noSem
              }

-- | Find the @Setup.hs@/@Setup.lhs@ file to use,

-- or create one using @main = defaultMain@ if none exist.

findSetupHs :: FilePath -> IO FilePath
findSetupHs :: String -> IO String
findSetupHs String
root = [String] -> IO String
trySetupsOrUseDefault [ String
"Setup.hs", String
"Setup.lhs" ]
  where
    useDefaultSetupHs :: IO String
useDefaultSetupHs = do
        let path :: String
path = String
root String -> String -> String
</> String
"Setup.hs"
        String -> String -> IO ()
writeFile String
path String
defaultSetupHs
        forall (m :: * -> *) a. Monad m => a -> m a
return String
"Setup.hs"

    try :: String -> IO (Maybe String)
try String
fname = do
        let path :: String
path = String
root String -> String -> String
</> String
fname
        Bool
exists <- String -> IO Bool
doesFileExist String
path
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if Bool
exists then forall a. a -> Maybe a
Just String
fname else forall a. Maybe a
Nothing

    defaultSetupHs :: String
defaultSetupHs = [String] -> String
unlines
        [ String
"import Distribution.Simple"
        , String
"main = defaultMain"
        ]

    trySetupsOrUseDefault :: [String] -> IO String
trySetupsOrUseDefault [] = IO String
useDefaultSetupHs
    trySetupsOrUseDefault (String
setupPath:[String]
setups) = do
      Maybe String
res <- String -> IO (Maybe String)
try String
setupPath
      case Maybe String
res of
        Maybe String
Nothing    -> [String] -> IO String
trySetupsOrUseDefault [String]
setups
        Just String
setup -> forall (m :: * -> *) a. Monad m => a -> m a
return String
setup

--------------------------------------------------------------------------------

-- Build


-- | Return build steps to to configure, build and and installing the unit,

-- including registering it in the package database if it is a library.

--

-- You can run the build script with 'executeBuildScript', or you can

-- turn it into a shell script with 'script'.

--

-- Note: executing the build script will fail if the unit has already been

-- registered in the package database.

buildUnit :: Verbosity
          -> Compiler
          -> BuildPaths ForBuild -- ^ Overall build directory structure.

          -> PkgDbDirs  ForBuild -- ^ Package database directories (see 'getPkgDbDirsForBuild').

          -> PkgDir     ForBuild -- ^ This package's directory (see 'getPkgDir').

          -> UnitArgs            -- ^ Extra arguments for this unit.

          -> Map UnitId PlanUnit -- ^ All dependencies in the build plan.

          -> ConfiguredUnit      -- ^ The unit to build.

          -> BuildScript
buildUnit :: Verbosity
-> Compiler
-> BuildPaths 'ForBuild
-> PkgDbDirs 'ForBuild
-> PkgDir 'ForBuild
-> UnitArgs
-> Map UnitId PlanUnit
-> ConfiguredUnit
-> BuildScript
buildUnit Verbosity
verbosity
          ( Compiler { String
ghcPath :: String
$sel:ghcPath:Compiler :: Compiler -> String
ghcPath, String
$sel:ghcPkgPath:Compiler :: Compiler -> String
ghcPkgPath :: String
ghcPkgPath } )
          paths :: BuildPaths 'ForBuild
paths@( BuildPaths { String
installDir :: String
$sel:installDir:BuildPaths :: BuildPaths 'ForBuild -> String
installDir, String
$sel:prefix:BuildPaths :: BuildPaths 'ForBuild -> String
prefix :: String
prefix, String
$sel:destDir:BuildPaths :: BuildPaths 'ForBuild -> String
destDir :: String
destDir, String
logDir :: String
$sel:logDir:BuildPaths :: BuildPaths 'ForBuild -> String
logDir } )
          ( PkgDbDirsForBuild
            { String
tempPkgDbDir :: String
$sel:tempPkgDbDir:PkgDbDirsForBuild :: PkgDbDirs 'ForBuild -> String
tempPkgDbDir
            , String
$sel:finalPkgDbDir:PkgDbDirsForBuild :: PkgDbDirs 'ForBuild -> String
finalPkgDbDir :: String
finalPkgDbDir
            , QSem
$sel:tempPkgDbSem:PkgDbDirsForBuild :: PkgDbDirs 'ForBuild -> QSem
tempPkgDbSem :: QSem
tempPkgDbSem
            , QSem
$sel:finalPkgDbSem:PkgDbDirsForBuild :: PkgDbDirs 'ForBuild -> QSem
finalPkgDbSem :: QSem
finalPkgDbSem } )
          ( PkgDir { String
pkgDir :: String
$sel:pkgDir:PkgDir :: forall (use :: PathUsability). PkgDir use -> String
pkgDir, String
pkgNameVer :: String
$sel:pkgNameVer:PkgDir :: forall (use :: PathUsability). PkgDir use -> String
pkgNameVer } )
          ( UnitArgs { $sel:configureArgs:UnitArgs :: UnitArgs -> [String]
configureArgs = [String]
userConfigureArgs
                     , $sel:mbHaddockArgs:UnitArgs :: UnitArgs -> Maybe [String]
mbHaddockArgs = Maybe [String]
mbUserHaddockArgs
                     , $sel:registerArgs:UnitArgs :: UnitArgs -> [String]
registerArgs  = [String]
userGhcPkgArgs } )
          Map UnitId PlanUnit
plan unit :: ConfiguredUnit
unit@( ConfiguredUnit { UnitId
puId :: UnitId
$sel:puId:ConfiguredUnit :: ConfiguredUnit -> UnitId
puId, [UnitId]
$sel:puDepends:ConfiguredUnit :: ConfiguredUnit -> [UnitId]
puDepends :: [UnitId]
puDepends, [UnitId]
puExeDepends :: [UnitId]
$sel:puExeDepends:ConfiguredUnit :: ConfiguredUnit -> [UnitId]
puExeDepends } )
  = let compName :: String
compName = Text -> String
Text.unpack forall a b. (a -> b) -> a -> b
$ ComponentName -> Text
cabalComponent ( ConfiguredUnit -> ComponentName
puComponentName ConfiguredUnit
unit )
        thisUnit'sId :: String
thisUnit'sId = Text -> String
Text.unpack ( UnitId -> Text
unUnitId UnitId
puId )
        logPath :: Maybe String
logPath
          | Verbosity
verbosity forall a. Ord a => a -> a -> Bool
<= Verbosity
Quiet
          = forall a. Maybe a
Nothing
          | Bool
otherwise
          = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ String
logDir String -> String -> String
</> String
thisUnit'sId
        unitPrintableName :: String
unitPrintableName
          | Verbosity
verbosity forall a. Ord a => a -> a -> Bool
>= Verbosity
Verbose
          = String
pkgNameVer forall a. Semigroup a => a -> a -> a
<> String
":" forall a. Semigroup a => a -> a -> a
<> String
compName
          | Bool
otherwise
          = String
compName

    in do
      ScriptConfig
scriptCfg <- BuildScriptM ScriptConfig
askScriptConfig

      let -- Specify the data directories for all dependencies,

          -- including executable dependencies (see (**)).

          -- This is important so that e.g. 'happy' can find its datadir.

          depDataDirs :: [(String, String)]
depDataDirs =
            ScriptConfig
-> BuildPaths 'ForBuild -> [ConfiguredUnit] -> [(String, String)]
dataDirs ScriptConfig
scriptCfg BuildPaths 'ForBuild
paths
              [ ConfiguredUnit
dep_cu
              | UnitId
depUnitId <- ConfiguredUnit -> [UnitId]
unitDepends ConfiguredUnit
unit -- (**) depends ++ exeDepends

              , let dep :: PlanUnit
dep = ConfiguredUnit -> UnitId -> Map UnitId PlanUnit -> PlanUnit
lookupDependency ConfiguredUnit
unit UnitId
depUnitId Map UnitId PlanUnit
plan
              , ConfiguredUnit
dep_cu <- forall a. Maybe a -> [a]
maybeToList forall a b. (a -> b) -> a -> b
$ PlanUnit -> Maybe ConfiguredUnit
configuredUnitMaybe PlanUnit
dep
              ]

      -- Configure

      let flagsArg :: [String]
flagsArg = case ConfiguredUnit -> FlagSpec
puFlags ConfiguredUnit
unit of
            FlagSpec
flags
              | FlagSpec -> Bool
flagSpecIsEmpty FlagSpec
flags
              -> []
              | Bool
otherwise
              -> [ String
"--flags=" forall a. Semigroup a => a -> a -> a
<> forall r.
(IsString r, Monoid r) =>
EscapeVars -> ScriptConfig -> String -> r
quoteArg EscapeVars
ExpandVars ScriptConfig
scriptCfg ( Text -> String
Text.unpack (FlagSpec -> Text
showFlagSpec FlagSpec
flags) ) ]

          -- NB: make sure to update the readme after changing

          -- the arguments that are passed here.


          -- Non-essential arguments (can be overriden by the user).

          overridableConfigureArgs :: [String]
overridableConfigureArgs =
            [ String
"--libdir="     forall a. Semigroup a => a -> a -> a
<> forall r.
(IsString r, Monoid r) =>
EscapeVars -> ScriptConfig -> String -> r
quoteArg EscapeVars
EscapeVars ScriptConfig
scriptCfg ( String
"$prefix" String -> String -> String
</> String
"lib" )
            , String
"--libsubdir="  forall a. Semigroup a => a -> a -> a
<> String
thisUnit'sId
            , String
"--dynlibdir="  forall a. Semigroup a => a -> a -> a
<> forall r.
(IsString r, Monoid r) =>
EscapeVars -> ScriptConfig -> String -> r
quoteArg EscapeVars
EscapeVars ScriptConfig
scriptCfg ( String
"$prefix" String -> String -> String
</> String
"dynlib"  String -> String -> String
</> String
pkgNameVer )
            , String
"--libexecdir=" forall a. Semigroup a => a -> a -> a
<> forall r.
(IsString r, Monoid r) =>
EscapeVars -> ScriptConfig -> String -> r
quoteArg EscapeVars
EscapeVars ScriptConfig
scriptCfg ( String
"$prefix" String -> String -> String
</> String
"libexec" String -> String -> String
</> String
pkgNameVer )
            , String
"--docdir="     forall a. Semigroup a => a -> a -> a
<> forall r.
(IsString r, Monoid r) =>
EscapeVars -> ScriptConfig -> String -> r
quoteArg EscapeVars
EscapeVars ScriptConfig
scriptCfg ( String
"$prefix" String -> String -> String
</> String
"doc"     String -> String -> String
</> String
pkgNameVer )
            , Verbosity -> String
setupVerbosity Verbosity
verbosity
            ] forall a. [a] -> [a] -> [a]
++ [String]
flagsArg -- Flags shouldn't really be overridden,

                          -- but we allow it as an expert feature.


          -- Set a different build directory for each unit,

          -- to avoid clashes when building multiple units from the same

          -- package concurrently.

          buildDir :: String
buildDir = forall r.
(IsString r, Monoid r) =>
EscapeVars -> ScriptConfig -> String -> r
quoteArg EscapeVars
ExpandVars ScriptConfig
scriptCfg -- Quote to escape \ on Windows.

                   forall a b. (a -> b) -> a -> b
$ String
"temp-build" String -> String -> String
</> String
thisUnit'sId

          -- Arguments essential to the build; can't be overriden by the user.

          essentialConfigureArgs :: [String]
essentialConfigureArgs =
            [ String
"--exact-configuration"
            , String
"--with-compiler", forall r.
(IsString r, Monoid r) =>
EscapeVars -> ScriptConfig -> String -> r
quoteArg EscapeVars
ExpandVars ScriptConfig
scriptCfg String
ghcPath
            , String
"--prefix"       , forall r.
(IsString r, Monoid r) =>
EscapeVars -> ScriptConfig -> String -> r
quoteArg EscapeVars
ExpandVars ScriptConfig
scriptCfg String
prefix
            , String
"--cid="        forall a. Semigroup a => a -> a -> a
<> Text -> String
Text.unpack ( UnitId -> Text
unUnitId UnitId
puId )
            , String
"--package-db=" forall a. Semigroup a => a -> a -> a
<> forall r.
(IsString r, Monoid r) =>
EscapeVars -> ScriptConfig -> String -> r
quoteArg EscapeVars
ExpandVars ScriptConfig
scriptCfg String
tempPkgDbDir
            , String
"--datadir="    forall a. Semigroup a => a -> a -> a
<> forall r.
(IsString r, Monoid r) =>
EscapeVars -> ScriptConfig -> String -> r
quoteArg EscapeVars
EscapeVars ScriptConfig
scriptCfg ( String
"$prefix" String -> String -> String
</> String
"share" )
                -- Keep datadir in sync with the 'dataDirs' function.

            , String
"--datasubdir=" forall a. Semigroup a => a -> a -> a
<> String
pkgNameVer
            , String
"--builddir="   forall a. Semigroup a => a -> a -> a
<> String
buildDir
            , String
"--bindir="     forall a. Semigroup a => a -> a -> a
<> forall r.
(IsString r, Monoid r) =>
EscapeVars -> ScriptConfig -> String -> r
quoteArg EscapeVars
EscapeVars ScriptConfig
scriptCfg ( String
"$prefix" String -> String -> String
</> String
"bin" String -> String -> String
</> String
thisUnit'sId )
                -- Set a different binDir for each executable unit,

                -- so that we can know precisely which executables have been built

                -- for the purpose of resumable builds.

                -- Keep bindir in sync with 'binDirs' below.

            ] forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map ( Map UnitId PlanUnit -> ConfiguredUnit -> UnitId -> String
dependencyArg Map UnitId PlanUnit
plan ConfiguredUnit
unit ) [UnitId]
puDepends
              forall a. [a] -> [a] -> [a]
++ [ ConfiguredUnit -> String
buildTarget ConfiguredUnit
unit ]

          configureArgs :: [String]
configureArgs
            =  [String]
overridableConfigureArgs
            forall a. [a] -> [a] -> [a]
++ [String]
userConfigureArgs
            forall a. [a] -> [a] -> [a]
++ [String]
essentialConfigureArgs

          -- Add the output binary directories to PATH, to satisfy executable

          -- dependencies during the build.

          -- Keep this in sync with --bindir in essentialConfigureArgs.

          binDirs :: [String]
binDirs = [ forall r.
(IsString r, Monoid r) =>
EscapeVars -> ScriptConfig -> String -> r
quoteArg EscapeVars
ExpandVars ScriptConfig
scriptCfg forall a b. (a -> b) -> a -> b
$
                      String
installDir String -> String -> String
</> String
"bin" String -> String -> String
</> Text -> String
Text.unpack ( UnitId -> Text
unUnitId UnitId
exeUnitId )
                    | UnitId
exeUnitId <- [UnitId]
puExeDepends ]

          setupExe :: ProgPath
setupExe = String -> ProgPath
RelPath forall a b. (a -> b) -> a -> b
$ ScriptConfig -> String -> String
runCwdExe ScriptConfig
scriptCfg String
"Setup" -- relative to pkgDir


      Verbosity -> Verbosity -> String -> BuildScript
logMessage Verbosity
verbosity Verbosity
Verbose forall a b. (a -> b) -> a -> b
$
        String
"Configuring " forall a. Semigroup a => a -> a -> a
<> String
unitPrintableName
      Verbosity -> Verbosity -> String -> BuildScript
logMessage Verbosity
verbosity Verbosity
Debug forall a b. (a -> b) -> a -> b
$
        String
"Configure arguments:\n" forall a. Semigroup a => a -> a -> a
<> [String] -> String
unlines (forall a b. (a -> b) -> [a] -> [b]
map (String
"  " forall a. Semigroup a => a -> a -> a
<>) [String]
configureArgs)
      CallProcess -> BuildScript
callProcess forall a b. (a -> b) -> a -> b
$
        CP { cwd :: String
cwd          = String
pkgDir
           , prog :: ProgPath
prog         = ProgPath
setupExe
           , args :: [String]
args         = String
"configure" forall a. a -> [a] -> [a]
: [String]
configureArgs
           , extraPATH :: [String]
extraPATH    = [String]
binDirs
           , extraEnvVars :: [(String, String)]
extraEnvVars = [(String, String)]
depDataDirs -- Not sure this is needed for 'Setup configure'.

           , logBasePath :: Maybe String
logBasePath  = Maybe String
logPath
           , sem :: AbstractSem
sem          = AbstractSem
noSem
           }

      -- Build

      Verbosity -> Verbosity -> String -> BuildScript
logMessage Verbosity
verbosity Verbosity
Verbose forall a b. (a -> b) -> a -> b
$
        String
"Building " forall a. Semigroup a => a -> a -> a
<> String
unitPrintableName
      CallProcess -> BuildScript
callProcess forall a b. (a -> b) -> a -> b
$
        CP { cwd :: String
cwd          = String
pkgDir
           , prog :: ProgPath
prog         = ProgPath
setupExe
           , args :: [String]
args         = [ String
"build"
                            , String
"--builddir=" forall a. Semigroup a => a -> a -> a
<> String
buildDir
                            , Verbosity -> String
setupVerbosity Verbosity
verbosity ]
           , extraPATH :: [String]
extraPATH    = [String]
binDirs
           , extraEnvVars :: [(String, String)]
extraEnvVars = [(String, String)]
depDataDirs
           , logBasePath :: Maybe String
logBasePath  = Maybe String
logPath
           , sem :: AbstractSem
sem          = AbstractSem
noSem
           }

      -- Haddock

      forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe [String]
mbUserHaddockArgs \ [String]
userHaddockArgs -> do
        Verbosity -> Verbosity -> String -> BuildScript
logMessage Verbosity
verbosity Verbosity
Verbose forall a b. (a -> b) -> a -> b
$
          String
"Building documentation for " forall a. Semigroup a => a -> a -> a
<> String
unitPrintableName
        CallProcess -> BuildScript
callProcess forall a b. (a -> b) -> a -> b
$
          CP { cwd :: String
cwd          = String
pkgDir
             , prog :: ProgPath
prog         = ProgPath
setupExe
             , args :: [String]
args         = [ String
"haddock"
                              , Verbosity -> String
setupVerbosity Verbosity
verbosity ]
                              forall a. [a] -> [a] -> [a]
++ [String]
userHaddockArgs
                              forall a. [a] -> [a] -> [a]
++ [ String
"--builddir=" forall a. Semigroup a => a -> a -> a
<> String
buildDir ]
             , extraPATH :: [String]
extraPATH    = [String]
binDirs
             , extraEnvVars :: [(String, String)]
extraEnvVars = [(String, String)]
depDataDirs
             , logBasePath :: Maybe String
logBasePath  = Maybe String
logPath
             , sem :: AbstractSem
sem          = AbstractSem
noSem
             }

       -- Copy

      Verbosity -> Verbosity -> String -> BuildScript
logMessage Verbosity
verbosity Verbosity
Verbose forall a b. (a -> b) -> a -> b
$
        String
"Copying " forall a. Semigroup a => a -> a -> a
<> String
unitPrintableName
      CallProcess -> BuildScript
callProcess forall a b. (a -> b) -> a -> b
$
        CP { cwd :: String
cwd          = String
pkgDir
           , prog :: ProgPath
prog         = ProgPath
setupExe
           , args :: [String]
args         = [ String
"copy", Verbosity -> String
setupVerbosity Verbosity
verbosity
                            , String
"--builddir=" forall a. Semigroup a => a -> a -> a
<> String
buildDir
                            , String
"--destdir", forall r.
(IsString r, Monoid r) =>
EscapeVars -> ScriptConfig -> String -> r
quoteArg EscapeVars
ExpandVars ScriptConfig
scriptCfg String
destDir ]
           , extraPATH :: [String]
extraPATH    = []
           , extraEnvVars :: [(String, String)]
extraEnvVars = []
           , logBasePath :: Maybe String
logBasePath  = Maybe String
logPath
           , sem :: AbstractSem
sem          = AbstractSem
noSem
           }

       -- Register

      case ConfiguredUnit -> ComponentType
cuComponentType ConfiguredUnit
unit of
        ComponentType
Lib -> do
          -- Register library (in both the local and final package databases)

          -- See Note [Using two package databases].

          let pkgRegsFile :: String
pkgRegsFile = String
thisUnit'sId forall a. Semigroup a => a -> a -> a
<> String
"-pkg-reg.conf"
              dirs :: [(String, QSem, String, [String], [String])]
dirs = [ ( String
tempPkgDbDir,  QSem
tempPkgDbSem, String
"temporary", [String
"--inplace"], [])
                     , (String
finalPkgDbDir, QSem
finalPkgDbSem, String
"final"    , [], String
"--force" forall a. a -> [a] -> [a]
: [String]
userGhcPkgArgs) ]

          forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [(String, QSem, String, [String], [String])]
dirs \ (String
pkgDbDir, QSem
pkgDbSem, String
desc, [String]
extraSetupArgs, [String]
extraPkgArgs) -> do

            Verbosity -> Verbosity -> String -> BuildScript
logMessage Verbosity
verbosity Verbosity
Verbose forall a b. (a -> b) -> a -> b
$
             forall a. Monoid a => [a] -> a
mconcat [ String
"Registering ", String
unitPrintableName, String
" in "
                     , String
desc, String
" package database at:\n  "
                     , String
pkgDbDir ]

            -- Setup register

            CallProcess -> BuildScript
callProcess forall a b. (a -> b) -> a -> b
$
              CP { cwd :: String
cwd          = String
pkgDir
                 , prog :: ProgPath
prog         = ProgPath
setupExe
                 , args :: [String]
args         = [ String
"register", Verbosity -> String
setupVerbosity Verbosity
verbosity ]
                                  forall a. [a] -> [a] -> [a]
++ [String]
extraSetupArgs
                                  forall a. [a] -> [a] -> [a]
++ [ String
"--builddir=" forall a. Semigroup a => a -> a -> a
<> String
buildDir
                                     , String
"--gen-pkg-config=" forall a. Semigroup a => a -> a -> a
<> String
pkgRegsFile ]
                 , extraPATH :: [String]
extraPATH    = []
                 , extraEnvVars :: [(String, String)]
extraEnvVars = []
                 , logBasePath :: Maybe String
logBasePath  = Maybe String
logPath
                 , sem :: AbstractSem
sem          = AbstractSem
noSem
                 }

            -- NB: we have configured & built a single target,

            -- so there should be a single "pkg-reg.conf" file,

            -- and not a directory of registration files.


            -- ghc-pkg register

            CallProcess -> BuildScript
callProcess forall a b. (a -> b) -> a -> b
$
              CP { cwd :: String
cwd          = String
pkgDir
                 , prog :: ProgPath
prog         = String -> ProgPath
AbsPath String
ghcPkgPath
                 , args :: [String]
args         = [ String
"register"
                                  , Verbosity -> String
ghcPkgVerbosity Verbosity
verbosity ]
                                  forall a. [a] -> [a] -> [a]
++ [String]
extraPkgArgs
                                  forall a. [a] -> [a] -> [a]
++ [ String
"--package-db", forall r.
(IsString r, Monoid r) =>
EscapeVars -> ScriptConfig -> String -> r
quoteArg EscapeVars
ExpandVars ScriptConfig
scriptCfg String
pkgDbDir
                                     , String
pkgRegsFile ]
                 , extraPATH :: [String]
extraPATH    = []
                 , extraEnvVars :: [(String, String)]
extraEnvVars = []
                 , logBasePath :: Maybe String
logBasePath  = Maybe String
logPath
                 , sem :: AbstractSem
sem          = QSem -> AbstractSem
abstractQSem QSem
pkgDbSem
                   -- Take a lock to avoid contention on the package database

                   -- when building units concurrently.

                 }

        ComponentType
_notALib -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

      Verbosity -> Verbosity -> String -> BuildScript
logMessage Verbosity
verbosity Verbosity
Normal forall a b. (a -> b) -> a -> b
$ String
"Finished building " forall a. Semigroup a => a -> a -> a
<> String
unitPrintableName
      Verbosity -> BuildScript
reportProgress Verbosity
verbosity

-- | The argument @-package-id PKG_ID@.

unitIdArg :: UnitId -> String
unitIdArg :: UnitId -> String
unitIdArg (UnitId Text
unitId) = String
"-package-id " forall a. Semigroup a => a -> a -> a
<> Text -> String
Text.unpack Text
unitId

-- | The target to configure and build.

buildTarget :: ConfiguredUnit -> String
buildTarget :: ConfiguredUnit -> String
buildTarget ( ConfiguredUnit { $sel:puComponentName:ConfiguredUnit :: ConfiguredUnit -> ComponentName
puComponentName = ComponentName
comp } )
  = Text -> String
Text.unpack forall a b. (a -> b) -> a -> b
$ ComponentName -> Text
cabalComponent ComponentName
comp

-- | The argument @--dependency=PKG:COMP=UNIT_ID@.

--

-- Used to specify the 'UnitId' of a dependency to the configure script.

-- This allows us to perform a build using the specific dependencies we have

-- available, ignoring any bounds in the cabal file.

dependencyArg :: Map UnitId PlanUnit -> ConfiguredUnit -> UnitId -> String
dependencyArg :: Map UnitId PlanUnit -> ConfiguredUnit -> UnitId -> String
dependencyArg Map UnitId PlanUnit
fullPlan ConfiguredUnit
unitWeAreBuilding UnitId
depUnitId
  = String
"--dependency=" forall a. Semigroup a => a -> a -> a
<> Text -> String
Text.unpack ( PlanUnit -> Text
mkDependency PlanUnit
pu )
  where
    pu :: PlanUnit
    pu :: PlanUnit
pu = ConfiguredUnit -> UnitId -> Map UnitId PlanUnit -> PlanUnit
lookupDependency ConfiguredUnit
unitWeAreBuilding UnitId
depUnitId Map UnitId PlanUnit
fullPlan

    mkDependency :: PlanUnit -> Text
    mkDependency :: PlanUnit -> Text
mkDependency ( PU_Preexisting ( PreexistingUnit { $sel:puPkgName:PreexistingUnit :: PreexistingUnit -> PkgName
puPkgName = PkgName Text
nm } ) )
      = Text
nm forall a. Semigroup a => a -> a -> a
<> Text
"=" forall a. Semigroup a => a -> a -> a
<> UnitId -> Text
unUnitId UnitId
depUnitId
    mkDependency ( PU_Configured ( ConfiguredUnit { $sel:puPkgName:ConfiguredUnit :: ConfiguredUnit -> PkgName
puPkgName = PkgName Text
pkg
                                                  , $sel:puComponentName:ConfiguredUnit :: ConfiguredUnit -> ComponentName
puComponentName = ComponentName
comp } ) )
      = Text
pkg forall a. Semigroup a => a -> a -> a
<> Text
":" forall a. Semigroup a => a -> a -> a
<> ComponentName -> Text
componentName ComponentName
comp forall a. Semigroup a => a -> a -> a
<> Text
"=" forall a. Semigroup a => a -> a -> a
<> UnitId -> Text
unUnitId UnitId
depUnitId

-- | Look up a dependency in the full build plan.

--

-- Throws an error if the dependency can't be found.

lookupDependency :: ConfiguredUnit      -- ^ the unit which has the dependency

                                        -- (for error messages only)

                 -> UnitId              -- ^ dependency to look up

                 -> Map UnitId PlanUnit -- ^ build plan

                 -> PlanUnit
lookupDependency :: ConfiguredUnit -> UnitId -> Map UnitId PlanUnit -> PlanUnit
lookupDependency ( ConfiguredUnit { $sel:puPkgName:ConfiguredUnit :: ConfiguredUnit -> PkgName
puPkgName = PkgName
pkgWeAreBuilding } ) UnitId
depUnitId Map UnitId PlanUnit
plan
  | Just PlanUnit
pu <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UnitId
depUnitId Map UnitId PlanUnit
plan
  = PlanUnit
pu
  | Bool
otherwise
  = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"buildUnit: can't find dependency in build plan\n\
            \package: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show PkgName
pkgWeAreBuilding forall a. Semigroup a => a -> a -> a
<> String
"\n\
            \dependency: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show UnitId
depUnitId

--------------------------------------------------------------------------------

-- Directory structure computation helpers


{- $twoDBs
__Note [Using two package databases]__

We need __two__ distinct package databases: we might want to perform the build
in a temporary location, before everything gets placed into its final
destination. The final package database might use a specific, baked-in
installation prefix (in the sense of @Setup configure --prefix pfx@). As a
result, this package database won't be immediately usable, as we won't have
copied over the build products yet.

In order to be able to build packages in a temporary directory, we create a
temporary package database that is used for the build, making use of it
with @Setup register --inplace@.
We also register the packages into the final package database using
@ghc-pkg --force@: otherwise, @ghc-pkg@ would error because the relevant files
haven't been copied over yet.
-}

-- | The package database directories.

--

-- See Note [Using two package databases].

type PkgDbDirs :: PathUsability -> Type
data family PkgDbDirs use

data instance PkgDbDirs ForPrep
  = PkgDbDirsForPrep
    { PkgDbDirs 'ForPrep -> String
tempPkgDbDir  :: !FilePath
        -- ^ Local package database directory.

    }
data instance PkgDbDirs ForBuild
  = PkgDbDirsForBuild
    { PkgDbDirs 'ForBuild -> String
tempPkgDbDir  :: !FilePath
        -- ^ Local package database directory.

    , PkgDbDirs 'ForBuild -> QSem
tempPkgDbSem  :: !QSem
        -- ^ Semaphore controlling access to the temporary

        -- package database.

    , PkgDbDirs 'ForBuild -> String
finalPkgDbDir :: !FilePath
        -- ^ Installation package database directory.

    , PkgDbDirs 'ForBuild -> QSem
finalPkgDbSem :: !QSem
        -- ^ Semaphore controlling access to the installation

        -- package database.

    }

-- | Compute the paths of the package database directories we are going

-- to use.

--

-- See Note [Using two package databases].

getPkgDbDirsForPrep :: Paths ForPrep -> PkgDbDirs ForPrep
getPkgDbDirsForPrep :: Paths 'ForPrep -> PkgDbDirs 'ForPrep
getPkgDbDirsForPrep ( Paths { String
$sel:fetchDir:Paths :: forall (use :: PathUsability). Paths use -> String
fetchDir :: String
fetchDir } ) =
    PkgDbDirsForPrep { $sel:tempPkgDbDir:PkgDbDirsForPrep :: String
tempPkgDbDir = String
fetchDir String -> String -> String
</> String
"package.conf" }

-- | Compute the paths of the package database directories we are going

-- to use, and create some semaphores to control access to them

-- in order to avoid contention.

--

-- See Note [Using two package databases].

getPkgDbDirsForBuild :: Paths ForBuild -> IO (PkgDbDirs ForBuild)
getPkgDbDirsForBuild :: Paths 'ForBuild -> IO (PkgDbDirs 'ForBuild)
getPkgDbDirsForBuild ( Paths { String
fetchDir :: String
$sel:fetchDir:Paths :: forall (use :: PathUsability). Paths use -> String
fetchDir, $sel:buildPaths:Paths :: forall (use :: PathUsability). Paths use -> BuildPaths use
buildPaths = BuildPaths { String
installDir :: String
$sel:installDir:BuildPaths :: BuildPaths 'ForBuild -> String
installDir } } ) = do
  QSem
tempPkgDbSem  <- Int -> IO QSem
newQSem Int
1
  QSem
finalPkgDbSem <- Int -> IO QSem
newQSem Int
1
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
    PkgDbDirsForBuild { String
tempPkgDbDir :: String
$sel:tempPkgDbDir:PkgDbDirsForBuild :: String
tempPkgDbDir, String
finalPkgDbDir :: String
$sel:finalPkgDbDir:PkgDbDirsForBuild :: String
finalPkgDbDir, QSem
tempPkgDbSem :: QSem
$sel:tempPkgDbSem:PkgDbDirsForBuild :: QSem
tempPkgDbSem, QSem
finalPkgDbSem :: QSem
$sel:finalPkgDbSem:PkgDbDirsForBuild :: QSem
finalPkgDbSem }
    where
      tempPkgDbDir :: String
tempPkgDbDir  = String
fetchDir   String -> String -> String
</> String
"package.conf"
      finalPkgDbDir :: String
finalPkgDbDir = String
installDir String -> String -> String
</> String
"package.conf"

-- | The package @name-version@ string and its directory.

type PkgDir :: PathUsability -> Type
data PkgDir use
  = PkgDir
    { forall (use :: PathUsability). PkgDir use -> String
pkgNameVer :: !String
        -- ^ Package @name-version@ string.

    , forall (use :: PathUsability). PkgDir use -> String
pkgDir     :: !FilePath
        -- ^ Package directory.

    }
type role PkgDir representational
  -- Don't allow accidentally passing a @PkgDir ForPrep@ where one expects

  -- a @PkgDir ForBuild@.


-- | Compute the package directory location.

getPkgDir :: FilePath
              -- ^ Working directory

              -- (used only to relativise paths to local packages).

          -> Paths use
              -- ^ Overall directory structure to base the computation off.

          -> ConfiguredUnit
              -- ^ Any unit from the package in question.

          -> PkgDir use
getPkgDir :: forall (use :: PathUsability).
String -> Paths use -> ConfiguredUnit -> PkgDir use
getPkgDir String
workDir ( Paths { String
fetchDir :: String
$sel:fetchDir:Paths :: forall (use :: PathUsability). Paths use -> String
fetchDir } )
          ( ConfiguredUnit { PkgName
puPkgName :: PkgName
$sel:puPkgName:ConfiguredUnit :: ConfiguredUnit -> PkgName
puPkgName, Version
$sel:puVersion:ConfiguredUnit :: ConfiguredUnit -> Version
puVersion :: Version
puVersion, PkgSrc
$sel:puPkgSrc:ConfiguredUnit :: ConfiguredUnit -> PkgSrc
puPkgSrc :: PkgSrc
puPkgSrc } )
  = PkgDir { String
pkgNameVer :: String
$sel:pkgNameVer:PkgDir :: String
pkgNameVer, String
pkgDir :: String
$sel:pkgDir:PkgDir :: String
pkgDir }
    where
      pkgNameVer :: String
pkgNameVer = Text -> String
Text.unpack forall a b. (a -> b) -> a -> b
$ PkgName -> Version -> Text
pkgNameVersion PkgName
puPkgName Version
puVersion
      pkgDir :: String
pkgDir
        | Local String
dir <- PkgSrc
puPkgSrc
        = String -> String -> String
makeRelative String
workDir String
dir
          -- Give local packages paths relative to the working directory,

          -- to enable relocatable build scripts.

        | Bool
otherwise
        = String
fetchDir String -> String -> String
</> String
pkgNameVer

-- | Command to run an executable located the current working directory.

runCwdExe :: ScriptConfig -> FilePath -> FilePath
runCwdExe :: ScriptConfig -> String -> String
runCwdExe ( ScriptConfig { ScriptOutput
scriptOutput :: ScriptConfig -> ScriptOutput
scriptOutput :: ScriptOutput
scriptOutput, Style
scriptStyle :: ScriptConfig -> Style
scriptStyle :: Style
scriptStyle } )
  = String -> String
pre forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
ext
  where
    pre :: String -> String
pre
      | ScriptOutput
Run <- ScriptOutput
scriptOutput
      = forall a. a -> a
id
      | Bool
otherwise
      = ( String
"./" forall a. Semigroup a => a -> a -> a
<> )
    ext :: String -> String
ext
      | Style
WinStyle <- Style
scriptStyle
      = ( String -> String -> String
<.> String
"exe" )
      | Bool
otherwise
      = forall a. a -> a
id

-- | An environment containing the data directory paths for the given units.

dataDirs :: ScriptConfig
         -> BuildPaths ForBuild
         -> [ ConfiguredUnit ]
         -> [ ( String, FilePath ) ]
dataDirs :: ScriptConfig
-> BuildPaths 'ForBuild -> [ConfiguredUnit] -> [(String, String)]
dataDirs ScriptConfig
scriptCfg ( BuildPaths { String
installDir :: String
$sel:installDir:BuildPaths :: BuildPaths 'ForBuild -> String
installDir } ) [ConfiguredUnit]
units =
    [ ( PkgName -> String
mangledPkgName PkgName
puPkgName forall a. Semigroup a => a -> a -> a
<> String
"_datadir"
      , forall r.
(IsString r, Monoid r) =>
EscapeVars -> ScriptConfig -> String -> r
quoteArg EscapeVars
ExpandVars ScriptConfig
scriptCfg forall a b. (a -> b) -> a -> b
$
          String
installDir String -> String -> String
</> String
"share" String -> String -> String
</> Text -> String
Text.unpack (PkgName -> Version -> Text
pkgNameVersion PkgName
puPkgName Version
puVersion) )
        -- Keep this in sync with --datadir in essentialConfigureArgs.

    | ConfiguredUnit { PkgName
puPkgName :: PkgName
$sel:puPkgName:ConfiguredUnit :: ConfiguredUnit -> PkgName
puPkgName, Version
puVersion :: Version
$sel:puVersion:ConfiguredUnit :: ConfiguredUnit -> Version
puVersion } <- [ConfiguredUnit]
units ]