{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE RoleAnnotations #-}
{-# LANGUAGE TypeApplications #-}
{-# 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
  , PkgDbDir(..)
  , getPkgDbDirForPrep, getPkgDbDirForBuild,
  ) 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

-- 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.Path
import BuildEnv.Utils
  ( ProgPath(..), CallProcess(..)
  , abstractQSem, noSem
  )

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

-- Setup


-- | Setup a single package.

--

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

setupPackage :: Verbosity
             -> Compiler
             -> SymbolicPath CWD ( Dir Project )
             -> BuildPaths ForBuild -- ^ Overall build directory structure.

             -> PkgDbDir   ForBuild -- ^ Package database directory (see 'getPkgDbDirForBuild').

             -> 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
-> SymbolicPath CWD ('Dir Project)
-> BuildPaths 'ForBuild
-> PkgDbDir 'ForBuild
-> PkgDir 'ForPrep
-> PkgDir 'ForBuild
-> Map UnitId PlanUnit
-> ConfiguredUnit
-> IO BuildScript
setupPackage Verbosity
verbosity
             ( Compiler { AbsolutePath 'File
ghcPath :: AbsolutePath 'File
$sel:ghcPath:Compiler :: Compiler -> AbsolutePath 'File
ghcPath } )
             SymbolicPath CWD ('Dir Project)
workDir
             paths :: BuildPaths 'ForBuild
paths@( BuildPaths { AbsolutePath ('Dir Install)
installDir :: AbsolutePath ('Dir Install)
$sel:installDir:BuildPaths :: BuildPaths 'ForBuild -> AbsolutePath ('Dir Install)
installDir, AbsolutePath ('Dir Logs)
logDir :: AbsolutePath ('Dir Logs)
$sel:logDir:BuildPaths :: BuildPaths 'ForBuild -> AbsolutePath ('Dir Logs)
logDir } )
             ( PkgDbDirForBuild { AbsolutePath ('Dir PkgDb)
finalPkgDbDir :: AbsolutePath ('Dir PkgDb)
$sel:finalPkgDbDir:PkgDbDirForBuild :: PkgDbDir 'ForBuild -> AbsolutePath ('Dir PkgDb)
finalPkgDbDir } )
             ( PkgDir { String
pkgNameVer :: String
$sel:pkgNameVer:PkgDir :: forall (use :: PathUsability). PkgDir use -> String
pkgNameVer, $sel:pkgDir:PkgDir :: forall (use :: PathUsability).
PkgDir use -> SymbolicPath Project ('Dir Pkg)
pkgDir = SymbolicPath Project ('Dir Pkg)
prepPkgDir } )
             ( PkgDir { $sel:pkgDir:PkgDir :: forall (use :: PathUsability).
PkgDir use -> SymbolicPath Project ('Dir Pkg)
pkgDir = SymbolicPath Project ('Dir Pkg)
buildPkgDir } )
             Map UnitId PlanUnit
plan
             unit :: ConfiguredUnit
unit@( ConfiguredUnit { UnitId
puId :: UnitId
$sel:puId:ConfiguredUnit :: ConfiguredUnit -> UnitId
puId, [UnitId]
puSetupDepends :: [UnitId]
$sel:puSetupDepends:ConfiguredUnit :: ConfiguredUnit -> [UnitId]
puSetupDepends, [UnitId]
puExeDepends :: [UnitId]
$sel:puExeDepends:ConfiguredUnit :: ConfiguredUnit -> [UnitId]
puExeDepends } )

  = do let logPath :: Maybe ( AbsolutePath File )
           logPath :: Maybe (AbsolutePath 'File)
logPath
             | Verbosity
verbosity Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
<= Verbosity
Quiet
             = Maybe (AbsolutePath 'File)
forall a. Maybe a
Nothing
             | Bool
otherwise
             = AbsolutePath 'File -> Maybe (AbsolutePath 'File)
forall a. a -> Maybe a
Just (AbsolutePath 'File -> Maybe (AbsolutePath 'File))
-> AbsolutePath 'File -> Maybe (AbsolutePath 'File)
forall a b. (a -> b) -> a -> b
$ AbsolutePath ('Dir Logs)
logDir AbsolutePath ('Dir Logs)
-> RelativePath Logs 'File -> AbsolutePath 'File
forall p q r. PathLike p q r => p -> q -> r
</> String -> RelativePath Logs 'File
forall from (to :: FileOrDir). String -> RelativePath from to
mkRelativePath ( Text -> String
Text.unpack ( UnitId -> Text
unUnitId UnitId
puId ) )
       -- Find the appropriate Setup.hs file (creating one if necessary)

       RelativePath Pkg 'File
setupHs <- SymbolicPath CWD ('Dir Project)
-> SymbolicPath Project ('Dir Pkg) -> IO (RelativePath Pkg 'File)
findSetupHs SymbolicPath CWD ('Dir Project)
workDir SymbolicPath Project ('Dir Pkg)
prepPkgDir
       BuildScript -> IO BuildScript
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return do
         ScriptConfig
scriptCfg <- BuildScriptM ScriptConfig
askScriptConfig
         let isCabalDep :: UnitId -> Bool
isCabalDep UnitId
uid = case UnitId -> Map UnitId PlanUnit -> Maybe PlanUnit
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UnitId
uid Map UnitId PlanUnit
plan of
               Maybe PlanUnit
Nothing -> String -> Bool
forall a. HasCallStack => String -> a
error (String -> Bool) -> String -> Bool
forall a b. (a -> b) -> a -> b
$ String
"setupPackage: cannot find setup dependency " String -> String -> String
forall a. [a] -> [a] -> [a]
++ UnitId -> String
forall a. Show a => a -> String
show UnitId
uid
               Just PlanUnit
pu -> PlanUnit -> PkgName
planUnitPkgName PlanUnit
pu PkgName -> PkgName -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> PkgName
PkgName Text
"Cabal"
             extraCabalSetupDep :: Bool
extraCabalSetupDep = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (UnitId -> Bool) -> [UnitId] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any UnitId -> Bool
isCabalDep [UnitId]
puSetupDepends
             setupArgs :: [String]
setupArgs = [ EscapeVars -> ScriptConfig -> String -> String
forall r.
(IsString r, Monoid r) =>
EscapeVars -> ScriptConfig -> String -> r
quoteArg EscapeVars
ExpandVars ScriptConfig
scriptCfg ( RelativePath Pkg 'File -> String
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> String
getSymbolicPath (RelativePath Pkg 'File -> String)
-> RelativePath Pkg 'File -> String
forall a b. (a -> b) -> a -> b
$ RelativePath Pkg 'File
setupHs )
                         , String
"-o"
                         , EscapeVars -> ScriptConfig -> String -> String
forall r.
(IsString r, Monoid r) =>
EscapeVars -> ScriptConfig -> String -> r
quoteArg EscapeVars
ExpandVars ScriptConfig
scriptCfg ( SymbolicPathX 'OnlyRelative Any Any -> String
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> String
getSymbolicPath (SymbolicPathX 'OnlyRelative Any Any -> String)
-> SymbolicPathX 'OnlyRelative Any Any -> String
forall a b. (a -> b) -> a -> b
$ String -> SymbolicPathX 'OnlyRelative Any Any
forall from (to :: FileOrDir). String -> RelativePath from to
mkRelativePath String
"Setup" )
                         , String
"-package-db=" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> EscapeVars -> ScriptConfig -> String -> String
forall r.
(IsString r, Monoid r) =>
EscapeVars -> ScriptConfig -> String -> r
quoteArg EscapeVars
ExpandVars ScriptConfig
scriptCfg ( AbsolutePath ('Dir PkgDb) -> String
forall (to :: FileOrDir). AbsolutePath to -> String
getAbsolutePath AbsolutePath ('Dir PkgDb)
finalPkgDbDir )
                         , Verbosity -> String
ghcVerbosity Verbosity
verbosity
                         ] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (UnitId -> String) -> [UnitId] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map UnitId -> String
unitIdArg [UnitId]
puSetupDepends
                           [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [ String
"-package Cabal" | Bool
extraCabalSetupDep ]
                              -- Add an implicit dependency on the 'Cabal' library

                              -- if there isn't an explicit dependency on it.


             -- Specify location of binaries and data directories.

             --

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

             binDirs :: [String]
binDirs = [ EscapeVars -> ScriptConfig -> String -> String
forall r.
(IsString r, Monoid r) =>
EscapeVars -> ScriptConfig -> String -> r
quoteArg EscapeVars
ExpandVars ScriptConfig
scriptCfg (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ AbsolutePath Any -> String
forall (to :: FileOrDir). AbsolutePath to -> String
getAbsolutePath (AbsolutePath Any -> String) -> AbsolutePath Any -> String
forall a b. (a -> b) -> a -> b
$ AbsolutePath ('Dir Install)
installDir AbsolutePath ('Dir Install)
-> RelativePath Install Any -> AbsolutePath Any
forall p q r. PathLike p q r => p -> q -> r
</> String -> RelativePath Install Any
forall from (to :: FileOrDir). String -> RelativePath from to
mkRelativePath ( String
"bin" String -> String -> String
forall p q r. PathLike p q r => p -> q -> r
</> 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 <- Maybe ConfiguredUnit -> [ConfiguredUnit]
forall a. Maybe a -> [a]
maybeToList (Maybe ConfiguredUnit -> [ConfiguredUnit])
-> Maybe ConfiguredUnit -> [ConfiguredUnit]
forall a b. (a -> b) -> a -> b
$ PlanUnit -> Maybe ConfiguredUnit
configuredUnitMaybe PlanUnit
dep
                 ]
         Verbosity -> Verbosity -> String -> BuildScript
logMessage Verbosity
verbosity Verbosity
Verbose (String -> BuildScript) -> String -> BuildScript
forall a b. (a -> b) -> a -> b
$
           String
"Compiling Setup.hs for " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
pkgNameVer
         forall dir. CallProcess dir -> BuildScript
callProcess @Pkg (CallProcess Pkg -> BuildScript) -> CallProcess Pkg -> BuildScript
forall a b. (a -> b) -> a -> b
$
           CP { cwd :: SymbolicPath CWD ('Dir Pkg)
cwd          = SymbolicPath CWD ('Dir Project)
workDir SymbolicPath CWD ('Dir Project)
-> SymbolicPath Project ('Dir Pkg) -> SymbolicPath CWD ('Dir Pkg)
forall p q r. PathLike p q r => p -> q -> r
</> SymbolicPath Project ('Dir Pkg)
buildPkgDir
              , prog :: ProgPath Pkg
prog         = AbsolutePath 'File -> ProgPath Pkg
forall from. AbsolutePath 'File -> ProgPath from
AbsPath AbsolutePath 'File
ghcPath
              , args :: [String]
args         = [String]
setupArgs
              , extraPATH :: [String]
extraPATH    = [String]
binDirs
              , extraEnvVars :: [(String, String)]
extraEnvVars = [(String, String)]
setupDepDataDirs
              , logBasePath :: Maybe (AbsolutePath 'File)
logBasePath  = Maybe (AbsolutePath 'File)
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 :: SymbolicPath CWD ( Dir Project )
            -> SymbolicPath Project ( Dir Pkg )
            -> IO ( RelativePath Pkg File )
findSetupHs :: SymbolicPath CWD ('Dir Project)
-> SymbolicPath Project ('Dir Pkg) -> IO (RelativePath Pkg 'File)
findSetupHs SymbolicPath CWD ('Dir Project)
workDir SymbolicPath Project ('Dir Pkg)
root =
  [RelativePath Pkg 'File] -> IO (RelativePath Pkg 'File)
trySetupsOrUseDefault [ String -> RelativePath Pkg 'File
forall from (to :: FileOrDir). String -> RelativePath from to
mkRelativePath String
"Setup.hs", String -> RelativePath Pkg 'File
forall from (to :: FileOrDir). String -> RelativePath from to
mkRelativePath String
"Setup.lhs" ]
  where

    useDefaultSetupHs :: IO (RelativePath Pkg 'File)
useDefaultSetupHs = do
        let path :: SymbolicPathX 'AllowAbsolute Project Any
path = SymbolicPath Project ('Dir Pkg)
root SymbolicPath Project ('Dir Pkg)
-> RelativePath Pkg Any -> SymbolicPathX 'AllowAbsolute Project Any
forall p q r. PathLike p q r => p -> q -> r
</> String -> RelativePath Pkg Any
forall from (to :: FileOrDir). String -> RelativePath from to
mkRelativePath String
"Setup.hs"
        String -> String -> IO ()
writeFile ( SymbolicPath CWD ('Dir Project)
-> SymbolicPathX 'AllowAbsolute Project Any -> String
forall dir (allowAbsolute :: AllowAbsolute) (to :: FileOrDir).
SymbolicPath CWD ('Dir dir)
-> SymbolicPathX allowAbsolute dir to -> String
interpretSymbolicPath SymbolicPath CWD ('Dir Project)
workDir SymbolicPathX 'AllowAbsolute Project Any
path ) String
defaultSetupHs
        RelativePath Pkg 'File -> IO (RelativePath Pkg 'File)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (RelativePath Pkg 'File -> IO (RelativePath Pkg 'File))
-> RelativePath Pkg 'File -> IO (RelativePath Pkg 'File)
forall a b. (a -> b) -> a -> b
$ String -> RelativePath Pkg 'File
forall from (to :: FileOrDir). String -> RelativePath from to
mkRelativePath String
"Setup.hs"

    try :: RelativePath Pkg 'File -> IO (Maybe (RelativePath Pkg 'File))
try RelativePath Pkg 'File
fname = do
        let path :: SymbolicPathX 'AllowAbsolute Project 'File
path = SymbolicPath Project ('Dir Pkg)
root SymbolicPath Project ('Dir Pkg)
-> RelativePath Pkg 'File
-> SymbolicPathX 'AllowAbsolute Project 'File
forall p q r. PathLike p q r => p -> q -> r
</> RelativePath Pkg 'File
fname
        Bool
exists <- String -> IO Bool
doesFileExist ( SymbolicPath CWD ('Dir Project)
-> SymbolicPathX 'AllowAbsolute Project 'File -> String
forall dir (allowAbsolute :: AllowAbsolute) (to :: FileOrDir).
SymbolicPath CWD ('Dir dir)
-> SymbolicPathX allowAbsolute dir to -> String
interpretSymbolicPath SymbolicPath CWD ('Dir Project)
workDir SymbolicPathX 'AllowAbsolute Project 'File
path )
        Maybe (RelativePath Pkg 'File)
-> IO (Maybe (RelativePath Pkg 'File))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (RelativePath Pkg 'File)
 -> IO (Maybe (RelativePath Pkg 'File)))
-> Maybe (RelativePath Pkg 'File)
-> IO (Maybe (RelativePath Pkg 'File))
forall a b. (a -> b) -> a -> b
$ if Bool
exists then RelativePath Pkg 'File -> Maybe (RelativePath Pkg 'File)
forall a. a -> Maybe a
Just RelativePath Pkg 'File
fname else Maybe (RelativePath Pkg 'File)
forall a. Maybe a
Nothing

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

    trySetupsOrUseDefault :: [RelativePath Pkg 'File] -> IO (RelativePath Pkg 'File)
trySetupsOrUseDefault [] = IO (RelativePath Pkg 'File)
useDefaultSetupHs
    trySetupsOrUseDefault ( RelativePath Pkg 'File
setupPath : [RelativePath Pkg 'File]
setups ) = do
      Maybe (RelativePath Pkg 'File)
res <- RelativePath Pkg 'File -> IO (Maybe (RelativePath Pkg 'File))
try RelativePath Pkg 'File
setupPath
      case Maybe (RelativePath Pkg 'File)
res of
        Maybe (RelativePath Pkg 'File)
Nothing    -> [RelativePath Pkg 'File] -> IO (RelativePath Pkg 'File)
trySetupsOrUseDefault [RelativePath Pkg 'File]
setups
        Just RelativePath Pkg 'File
setup -> RelativePath Pkg 'File -> IO (RelativePath Pkg 'File)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return RelativePath Pkg 'File
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
          -> SymbolicPath CWD ( Dir Project )
          -> BuildPaths ForBuild -- ^ Overall build directory structure.

          -> PkgDbDir   ForBuild -- ^ Package database directory (see 'getPkgDbDirForBuild').

          -> 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
-> SymbolicPath CWD ('Dir Project)
-> BuildPaths 'ForBuild
-> PkgDbDir 'ForBuild
-> PkgDir 'ForBuild
-> UnitArgs
-> Map UnitId PlanUnit
-> ConfiguredUnit
-> BuildScript
buildUnit Verbosity
verbosity
          ( Compiler { AbsolutePath 'File
$sel:ghcPath:Compiler :: Compiler -> AbsolutePath 'File
ghcPath :: AbsolutePath 'File
ghcPath, AbsolutePath 'File
ghcPkgPath :: AbsolutePath 'File
$sel:ghcPkgPath:Compiler :: Compiler -> AbsolutePath 'File
ghcPkgPath } )
          SymbolicPath CWD ('Dir Project)
workDir
          paths :: BuildPaths 'ForBuild
paths@( BuildPaths { AbsolutePath ('Dir Install)
$sel:installDir:BuildPaths :: BuildPaths 'ForBuild -> AbsolutePath ('Dir Install)
installDir :: AbsolutePath ('Dir Install)
installDir, AbsolutePath ('Dir Prefix)
prefix :: AbsolutePath ('Dir Prefix)
$sel:prefix:BuildPaths :: BuildPaths 'ForBuild -> AbsolutePath ('Dir Prefix)
prefix, AbsolutePath ('Dir Logs)
$sel:logDir:BuildPaths :: BuildPaths 'ForBuild -> AbsolutePath ('Dir Logs)
logDir :: AbsolutePath ('Dir Logs)
logDir } )
          ( PkgDbDirForBuild
            { AbsolutePath ('Dir PkgDb)
$sel:finalPkgDbDir:PkgDbDirForBuild :: PkgDbDir 'ForBuild -> AbsolutePath ('Dir PkgDb)
finalPkgDbDir :: AbsolutePath ('Dir PkgDb)
finalPkgDbDir
            , QSem
finalPkgDbSem :: QSem
$sel:finalPkgDbSem:PkgDbDirForBuild :: PkgDbDir 'ForBuild -> QSem
finalPkgDbSem } )
          ( PkgDir { SymbolicPath Project ('Dir Pkg)
$sel:pkgDir:PkgDir :: forall (use :: PathUsability).
PkgDir use -> SymbolicPath Project ('Dir Pkg)
pkgDir :: SymbolicPath Project ('Dir Pkg)
pkgDir, String
$sel:pkgNameVer:PkgDir :: forall (use :: PathUsability). PkgDir use -> String
pkgNameVer :: 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
$sel:puId:ConfiguredUnit :: ConfiguredUnit -> UnitId
puId :: UnitId
puId, [UnitId]
puDepends :: [UnitId]
$sel:puDepends:ConfiguredUnit :: ConfiguredUnit -> [UnitId]
puDepends, [UnitId]
$sel:puExeDepends:ConfiguredUnit :: ConfiguredUnit -> [UnitId]
puExeDepends :: [UnitId]
puExeDepends } )
  = let compName :: String
compName     = Text -> String
Text.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ ComponentName -> Text
cabalComponent ( ConfiguredUnit -> ComponentName
puComponentName ConfiguredUnit
unit )
        thisUnit'sId :: String
thisUnit'sId = Text -> String
Text.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ UnitId -> Text
unUnitId UnitId
puId
        logPath :: Maybe ( AbsolutePath File )
        logPath :: Maybe (AbsolutePath 'File)
logPath
          | Verbosity
verbosity Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
<= Verbosity
Quiet
          = Maybe (AbsolutePath 'File)
forall a. Maybe a
Nothing
          | Bool
otherwise
          = AbsolutePath 'File -> Maybe (AbsolutePath 'File)
forall a. a -> Maybe a
Just (AbsolutePath 'File -> Maybe (AbsolutePath 'File))
-> AbsolutePath 'File -> Maybe (AbsolutePath 'File)
forall a b. (a -> b) -> a -> b
$ AbsolutePath ('Dir Logs)
logDir AbsolutePath ('Dir Logs)
-> RelativePath Logs 'File -> AbsolutePath 'File
forall p q r. PathLike p q r => p -> q -> r
</> String -> RelativePath Logs 'File
forall from (to :: FileOrDir). String -> RelativePath from to
mkRelativePath String
thisUnit'sId
        unitPrintableName :: String
unitPrintableName
          | Verbosity
verbosity Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
>= Verbosity
Verbose
          = String
pkgNameVer String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
":" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
compName
          | Bool
otherwise
          = String
compName
        setupDir :: SymbolicPath CWD ( Dir Pkg )
        setupDir :: SymbolicPath CWD ('Dir Pkg)
setupDir = SymbolicPath CWD ('Dir Project)
workDir SymbolicPath CWD ('Dir Project)
-> SymbolicPath Project ('Dir Pkg) -> SymbolicPath CWD ('Dir Pkg)
forall p q r. PathLike p q r => p -> q -> r
</> SymbolicPath Project ('Dir Pkg)
pkgDir

    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.

          setupEnvVars :: [(String, String)]
setupEnvVars =
            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 <- Maybe ConfiguredUnit -> [ConfiguredUnit]
forall a. Maybe a -> [a]
maybeToList (Maybe ConfiguredUnit -> [ConfiguredUnit])
-> Maybe ConfiguredUnit -> [ConfiguredUnit]
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=" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> EscapeVars -> ScriptConfig -> String -> String
forall r.
(IsString r, Monoid r) =>
EscapeVars -> ScriptConfig -> String -> r
quoteArg EscapeVars
ExpandVars ScriptConfig
scriptCfg ( Text -> String
Text.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ 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="     String -> String -> String
forall a. Semigroup a => a -> a -> a
<> EscapeVars -> ScriptConfig -> String -> String
forall r.
(IsString r, Monoid r) =>
EscapeVars -> ScriptConfig -> String -> r
quoteArg EscapeVars
EscapeVars ScriptConfig
scriptCfg ( String
"$prefix" String -> String -> String
forall p q r. PathLike p q r => p -> q -> r
</> String
"lib" )
            , String
"--libsubdir="  String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
thisUnit'sId
            , String
"--dynlibdir="  String -> String -> String
forall a. Semigroup a => a -> a -> a
<> EscapeVars -> ScriptConfig -> String -> String
forall r.
(IsString r, Monoid r) =>
EscapeVars -> ScriptConfig -> String -> r
quoteArg EscapeVars
EscapeVars ScriptConfig
scriptCfg ( String
"$prefix" String -> String -> String
forall p q r. PathLike p q r => p -> q -> r
</> String
"dynlib"  String -> String -> String
forall p q r. PathLike p q r => p -> q -> r
</> String
pkgNameVer )
            , String
"--libexecdir=" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> EscapeVars -> ScriptConfig -> String -> String
forall r.
(IsString r, Monoid r) =>
EscapeVars -> ScriptConfig -> String -> r
quoteArg EscapeVars
EscapeVars ScriptConfig
scriptCfg ( String
"$prefix" String -> String -> String
forall p q r. PathLike p q r => p -> q -> r
</> String
"libexec" String -> String -> String
forall p q r. PathLike p q r => p -> q -> r
</> String
pkgNameVer )
            , String
"--docdir="     String -> String -> String
forall a. Semigroup a => a -> a -> a
<> EscapeVars -> ScriptConfig -> String -> String
forall r.
(IsString r, Monoid r) =>
EscapeVars -> ScriptConfig -> String -> r
quoteArg EscapeVars
EscapeVars ScriptConfig
scriptCfg ( String
"$prefix" String -> String -> String
forall p q r. PathLike p q r => p -> q -> r
</> String
"doc"     String -> String -> String
forall p q r. PathLike p q r => p -> q -> r
</> String
pkgNameVer )
            , Verbosity -> String
setupVerbosity Verbosity
verbosity
            ] [String] -> [String] -> [String]
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 = EscapeVars -> ScriptConfig -> String -> String
forall r.
(IsString r, Monoid r) =>
EscapeVars -> ScriptConfig -> String -> r
quoteArg EscapeVars
ExpandVars ScriptConfig
scriptCfg -- Quote to escape \ on Windows.

                   (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
"temp-build" String -> String -> String
forall p q r. PathLike p q r => p -> q -> r
</> String
thisUnit'sId

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

          essentialConfigureArgs :: [String]
essentialConfigureArgs =
            [ String
"--exact-configuration"
            , String
"--with-compiler", EscapeVars -> ScriptConfig -> String -> String
forall r.
(IsString r, Monoid r) =>
EscapeVars -> ScriptConfig -> String -> r
quoteArg EscapeVars
ExpandVars ScriptConfig
scriptCfg ( AbsolutePath 'File -> String
forall (to :: FileOrDir). AbsolutePath to -> String
getAbsolutePath AbsolutePath 'File
ghcPath )
            , String
"--prefix"       , EscapeVars -> ScriptConfig -> String -> String
forall r.
(IsString r, Monoid r) =>
EscapeVars -> ScriptConfig -> String -> r
quoteArg EscapeVars
ExpandVars ScriptConfig
scriptCfg ( AbsolutePath ('Dir Prefix) -> String
forall (to :: FileOrDir). AbsolutePath to -> String
getAbsolutePath AbsolutePath ('Dir Prefix)
prefix )
            , String
"--cid="        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
Text.unpack ( UnitId -> Text
unUnitId UnitId
puId )
            , String
"--package-db=" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> EscapeVars -> ScriptConfig -> String -> String
forall r.
(IsString r, Monoid r) =>
EscapeVars -> ScriptConfig -> String -> r
quoteArg EscapeVars
ExpandVars ScriptConfig
scriptCfg ( AbsolutePath ('Dir PkgDb) -> String
forall (to :: FileOrDir). AbsolutePath to -> String
getAbsolutePath AbsolutePath ('Dir PkgDb)
finalPkgDbDir )
            , String
"--datadir="    String -> String -> String
forall a. Semigroup a => a -> a -> a
<> EscapeVars -> ScriptConfig -> String -> String
forall r.
(IsString r, Monoid r) =>
EscapeVars -> ScriptConfig -> String -> r
quoteArg EscapeVars
EscapeVars ScriptConfig
scriptCfg ( String
"$prefix" String -> String -> String
forall p q r. PathLike p q r => p -> q -> r
</> String
"share" )
                -- Keep datadir in sync with the 'dataDirs' function.

            , String
"--datasubdir=" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
pkgNameVer
            , String
"--builddir="   String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
buildDir
            , String
"--bindir="     String -> String -> String
forall a. Semigroup a => a -> a -> a
<> EscapeVars -> ScriptConfig -> String -> String
forall r.
(IsString r, Monoid r) =>
EscapeVars -> ScriptConfig -> String -> r
quoteArg EscapeVars
EscapeVars ScriptConfig
scriptCfg ( String
"$prefix" String -> String -> String
forall p q r. PathLike p q r => p -> q -> r
</> String
"bin" String -> String -> String
forall p q r. PathLike p q r => p -> q -> r
</> 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.

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

          configureArgs :: [String]
configureArgs
            =  [String]
overridableConfigureArgs
            [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
userConfigureArgs
            [String] -> [String] -> [String]
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 = [ EscapeVars -> ScriptConfig -> String -> String
forall r.
(IsString r, Monoid r) =>
EscapeVars -> ScriptConfig -> String -> r
quoteArg EscapeVars
ExpandVars ScriptConfig
scriptCfg (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$
                      AbsolutePath Any -> String
forall (to :: FileOrDir). AbsolutePath to -> String
getAbsolutePath (AbsolutePath Any -> String) -> AbsolutePath Any -> String
forall a b. (a -> b) -> a -> b
$
                      AbsolutePath ('Dir Install)
installDir AbsolutePath ('Dir Install)
-> RelativePath Install Any -> AbsolutePath Any
forall p q r. PathLike p q r => p -> q -> r
</> String -> RelativePath Install Any
forall from (to :: FileOrDir). String -> RelativePath from to
mkRelativePath ( String
"bin" String -> String -> String
forall p q r. PathLike p q r => p -> q -> r
</> Text -> String
Text.unpack ( UnitId -> Text
unUnitId UnitId
exeUnitId ) )
                    | UnitId
exeUnitId <- [UnitId]
puExeDepends ]

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


      Verbosity -> Verbosity -> String -> BuildScript
logMessage Verbosity
verbosity Verbosity
Verbose (String -> BuildScript) -> String -> BuildScript
forall a b. (a -> b) -> a -> b
$
        String
"Configuring " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
unitPrintableName
      Verbosity -> Verbosity -> String -> BuildScript
logMessage Verbosity
verbosity Verbosity
Debug (String -> BuildScript) -> String -> BuildScript
forall a b. (a -> b) -> a -> b
$
        String
"Configure arguments:\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [String] -> String
unlines ( (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ( String
"  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ) [String]
configureArgs )
      forall dir. CallProcess dir -> BuildScript
callProcess @Pkg (CallProcess Pkg -> BuildScript) -> CallProcess Pkg -> BuildScript
forall a b. (a -> b) -> a -> b
$
        CP { cwd :: SymbolicPath CWD ('Dir Pkg)
cwd          = SymbolicPath CWD ('Dir Pkg)
setupDir
           , prog :: ProgPath Pkg
prog         = ProgPath Pkg
setupExe
           , args :: [String]
args         = String
"configure" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
configureArgs
           , extraPATH :: [String]
extraPATH    = [String]
binDirs
           , extraEnvVars :: [(String, String)]
extraEnvVars = [(String, String)]
setupEnvVars
           , logBasePath :: Maybe (AbsolutePath 'File)
logBasePath  = Maybe (AbsolutePath 'File)
logPath
           , sem :: AbstractSem
sem          = AbstractSem
noSem
           }

      -- Build

      Verbosity -> Verbosity -> String -> BuildScript
logMessage Verbosity
verbosity Verbosity
Verbose (String -> BuildScript) -> String -> BuildScript
forall a b. (a -> b) -> a -> b
$
        String
"Building " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
unitPrintableName
      forall dir. CallProcess dir -> BuildScript
callProcess @Pkg (CallProcess Pkg -> BuildScript) -> CallProcess Pkg -> BuildScript
forall a b. (a -> b) -> a -> b
$
        CP { cwd :: SymbolicPath CWD ('Dir Pkg)
cwd          = SymbolicPath CWD ('Dir Pkg)
setupDir
           , prog :: ProgPath Pkg
prog         = ProgPath Pkg
setupExe
           , args :: [String]
args         = [ String
"build"
                            , String
"--builddir=" String -> String -> String
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)]
setupEnvVars
           , logBasePath :: Maybe (AbsolutePath 'File)
logBasePath  = Maybe (AbsolutePath 'File)
logPath
           , sem :: AbstractSem
sem          = AbstractSem
noSem
           }

      -- Haddock

      Maybe [String] -> ([String] -> BuildScript) -> BuildScript
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 (String -> BuildScript) -> String -> BuildScript
forall a b. (a -> b) -> a -> b
$
          String
"Building documentation for " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
unitPrintableName
        forall dir. CallProcess dir -> BuildScript
callProcess @Pkg (CallProcess Pkg -> BuildScript) -> CallProcess Pkg -> BuildScript
forall a b. (a -> b) -> a -> b
$
          CP { cwd :: SymbolicPath CWD ('Dir Pkg)
cwd          = SymbolicPath CWD ('Dir Pkg)
setupDir
             , prog :: ProgPath Pkg
prog         = ProgPath Pkg
setupExe
             , args :: [String]
args         = [ String
"haddock"
                              , Verbosity -> String
setupVerbosity Verbosity
verbosity ]
                              [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
userHaddockArgs
                              [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [ String
"--builddir=" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
buildDir ]
             , extraPATH :: [String]
extraPATH    = [String]
binDirs
             , extraEnvVars :: [(String, String)]
extraEnvVars = [(String, String)]
setupEnvVars
             , logBasePath :: Maybe (AbsolutePath 'File)
logBasePath  = Maybe (AbsolutePath 'File)
logPath
             , sem :: AbstractSem
sem          = AbstractSem
noSem
             }

       -- Copy

      Verbosity -> Verbosity -> String -> BuildScript
logMessage Verbosity
verbosity Verbosity
Verbose (String -> BuildScript) -> String -> BuildScript
forall a b. (a -> b) -> a -> b
$
        String
"Copying " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
unitPrintableName
      forall dir. CallProcess dir -> BuildScript
callProcess @Pkg (CallProcess Pkg -> BuildScript) -> CallProcess Pkg -> BuildScript
forall a b. (a -> b) -> a -> b
$
        CP { cwd :: SymbolicPath CWD ('Dir Pkg)
cwd          = SymbolicPath CWD ('Dir Pkg)
setupDir
           , prog :: ProgPath Pkg
prog         = ProgPath Pkg
setupExe
           , args :: [String]
args         = [ String
"copy", Verbosity -> String
setupVerbosity Verbosity
verbosity
                            , String
"--builddir=" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
buildDir
                            , String
"--target-package-db=" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> EscapeVars -> ScriptConfig -> String -> String
forall r.
(IsString r, Monoid r) =>
EscapeVars -> ScriptConfig -> String -> r
quoteArg EscapeVars
ExpandVars ScriptConfig
scriptCfg (AbsolutePath Any -> String
forall (to :: FileOrDir). AbsolutePath to -> String
getAbsolutePath (AbsolutePath Any -> String) -> AbsolutePath Any -> String
forall a b. (a -> b) -> a -> b
$ AbsolutePath ('Dir Install)
installDir AbsolutePath ('Dir Install)
-> RelativePath Install Any -> AbsolutePath Any
forall p q r. PathLike p q r => p -> q -> r
</> String -> RelativePath Install Any
forall from (to :: FileOrDir). String -> RelativePath from to
mkRelativePath String
"package.conf")
                            ]
           , extraPATH :: [String]
extraPATH    = []
           , extraEnvVars :: [(String, String)]
extraEnvVars = [(String, String)]
setupEnvVars
           , logBasePath :: Maybe (AbsolutePath 'File)
logBasePath  = Maybe (AbsolutePath 'File)
logPath
           , sem :: AbstractSem
sem          = AbstractSem
noSem
           }

       -- Register

      case ConfiguredUnit -> ComponentType
cuComponentType ConfiguredUnit
unit of
        ComponentType
Lib -> do
          -- Register library.

          let pkgRegsFile :: String
pkgRegsFile = String
thisUnit'sId String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"-pkg-reg.conf"

          Verbosity -> Verbosity -> String -> BuildScript
logMessage Verbosity
verbosity Verbosity
Verbose (String -> BuildScript) -> String -> BuildScript
forall a b. (a -> b) -> a -> b
$
           [String] -> String
forall a. Monoid a => [a] -> a
mconcat [ String
"Writing package registration for ", String
unitPrintableName
                   , String
" to:\n"
                   , String
pkgRegsFile ]

          -- Setup register

          forall dir. CallProcess dir -> BuildScript
callProcess @Pkg (CallProcess Pkg -> BuildScript) -> CallProcess Pkg -> BuildScript
forall a b. (a -> b) -> a -> b
$
            CP { cwd :: SymbolicPath CWD ('Dir Pkg)
cwd          = SymbolicPath CWD ('Dir Pkg)
setupDir
               , prog :: ProgPath Pkg
prog         = ProgPath Pkg
setupExe
               , args :: [String]
args         = [ String
"register", Verbosity -> String
setupVerbosity Verbosity
verbosity
                                , String
"--builddir=" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
buildDir
                                , String
"--gen-pkg-config=" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
pkgRegsFile ]
               , extraPATH :: [String]
extraPATH    = []
               , extraEnvVars :: [(String, String)]
extraEnvVars = []
               , logBasePath :: Maybe (AbsolutePath 'File)
logBasePath  = Maybe (AbsolutePath 'File)
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.


          Verbosity -> Verbosity -> String -> BuildScript
logMessage Verbosity
verbosity Verbosity
Verbose (String -> BuildScript) -> String -> BuildScript
forall a b. (a -> b) -> a -> b
$
           [String] -> String
forall a. Monoid a => [a] -> a
mconcat [ String
"Registering ", String
unitPrintableName
                   , String
" in package database at:\n"
                   , AbsolutePath ('Dir PkgDb) -> String
forall a. Show a => a -> String
show AbsolutePath ('Dir PkgDb)
finalPkgDbDir ]

          -- ghc-pkg register

          forall dir. CallProcess dir -> BuildScript
callProcess @Pkg (CallProcess Pkg -> BuildScript) -> CallProcess Pkg -> BuildScript
forall a b. (a -> b) -> a -> b
$
            CP { cwd :: SymbolicPath CWD ('Dir Pkg)
cwd          = SymbolicPath CWD ('Dir Pkg)
setupDir
               , prog :: ProgPath Pkg
prog         = AbsolutePath 'File -> ProgPath Pkg
forall from. AbsolutePath 'File -> ProgPath from
AbsPath AbsolutePath 'File
ghcPkgPath
               , args :: [String]
args         = [ String
"register"
                                , Verbosity -> String
ghcPkgVerbosity Verbosity
verbosity
                                , String
"--force" ]
                                [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
userGhcPkgArgs
                                [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [ String
"--package-db", EscapeVars -> ScriptConfig -> String -> String
forall r.
(IsString r, Monoid r) =>
EscapeVars -> ScriptConfig -> String -> r
quoteArg EscapeVars
ExpandVars ScriptConfig
scriptCfg ( AbsolutePath ('Dir PkgDb) -> String
forall (to :: FileOrDir). AbsolutePath to -> String
getAbsolutePath AbsolutePath ('Dir PkgDb)
finalPkgDbDir )
                                   , String
pkgRegsFile ]
               , extraPATH :: [String]
extraPATH    = []
               , extraEnvVars :: [(String, String)]
extraEnvVars = []
               , logBasePath :: Maybe (AbsolutePath 'File)
logBasePath  = Maybe (AbsolutePath 'File)
logPath
               , sem :: AbstractSem
sem          = QSem -> AbstractSem
abstractQSem QSem
finalPkgDbSem
                 -- Take a lock to avoid contention on the package database

                 -- when building units concurrently.

               }

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

      Verbosity -> Verbosity -> String -> BuildScript
logMessage Verbosity
verbosity Verbosity
Normal (String -> BuildScript) -> String -> BuildScript
forall a b. (a -> b) -> a -> b
$ String
"Finished building " String -> String -> String
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 " String -> String -> String
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 (Text -> String) -> Text -> String
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=" String -> String -> String
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 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"=" Text -> Text -> 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 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ComponentName -> Text
componentName ComponentName
comp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"=" Text -> Text -> 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 <- UnitId -> Map UnitId PlanUnit -> Maybe PlanUnit
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UnitId
depUnitId Map UnitId PlanUnit
plan
  = PlanUnit
pu
  | Bool
otherwise
  = String -> PlanUnit
forall a. HasCallStack => String -> a
error (String -> PlanUnit) -> String -> PlanUnit
forall a b. (a -> b) -> a -> b
$ String
"buildUnit: can't find dependency in build plan\n\
            \package: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> PkgName -> String
forall a. Show a => a -> String
show PkgName
pkgWeAreBuilding String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n\
            \dependency: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> UnitId -> String
forall a. Show a => a -> String
show UnitId
depUnitId

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

-- Directory structure computation helpers


-- | The package database directory.

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

data instance PkgDbDir ForPrep
  = PkgDbDirForPrep
    { PkgDbDir 'ForPrep -> AbsolutePath ('Dir PkgDb)
finalPkgDbDir  :: !( AbsolutePath ( Dir PkgDb ) )
        -- ^ Installation package database directory.

    }
data instance PkgDbDir ForBuild
  = PkgDbDirForBuild
    { PkgDbDir 'ForBuild -> AbsolutePath ('Dir PkgDb)
finalPkgDbDir :: !( AbsolutePath ( Dir PkgDb ) )
        -- ^ Installation package database directory.

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

        -- package database.

    }

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

-- to use.

getPkgDbDirForPrep :: Paths ForPrep -> PkgDbDir ForPrep
getPkgDbDirForPrep :: Paths 'ForPrep -> PkgDbDir 'ForPrep
getPkgDbDirForPrep ( Paths { $sel:buildPaths:Paths :: forall (use :: PathUsability). Paths use -> BuildPaths use
buildPaths = BuildPathsForPrep { AbsolutePath ('Dir Install)
installDir :: AbsolutePath ('Dir Install)
$sel:installDir:BuildPathsForPrep :: BuildPaths 'ForPrep -> AbsolutePath ('Dir Install)
installDir } } ) =
    PkgDbDirForPrep { $sel:finalPkgDbDir:PkgDbDirForPrep :: AbsolutePath ('Dir PkgDb)
finalPkgDbDir = AbsolutePath ('Dir Install)
installDir AbsolutePath ('Dir Install)
-> RelativePath Install ('Dir PkgDb) -> AbsolutePath ('Dir PkgDb)
forall p q r. PathLike p q r => p -> q -> r
</> String -> RelativePath Install ('Dir PkgDb)
forall from (to :: FileOrDir). String -> RelativePath from to
mkRelativePath String
"package.conf" }

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

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

-- in order to avoid contention.

getPkgDbDirForBuild :: Paths ForBuild -> IO (PkgDbDir ForBuild)
getPkgDbDirForBuild :: Paths 'ForBuild -> IO (PkgDbDir 'ForBuild)
getPkgDbDirForBuild ( Paths { $sel:buildPaths:Paths :: forall (use :: PathUsability). Paths use -> BuildPaths use
buildPaths = BuildPaths { AbsolutePath ('Dir Install)
$sel:installDir:BuildPaths :: BuildPaths 'ForBuild -> AbsolutePath ('Dir Install)
installDir :: AbsolutePath ('Dir Install)
installDir } } ) = do
  QSem
finalPkgDbSem <- Int -> IO QSem
newQSem Int
1
  PkgDbDir 'ForBuild -> IO (PkgDbDir 'ForBuild)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (PkgDbDir 'ForBuild -> IO (PkgDbDir 'ForBuild))
-> PkgDbDir 'ForBuild -> IO (PkgDbDir 'ForBuild)
forall a b. (a -> b) -> a -> b
$
    PkgDbDirForBuild { AbsolutePath ('Dir PkgDb)
$sel:finalPkgDbDir:PkgDbDirForBuild :: AbsolutePath ('Dir PkgDb)
finalPkgDbDir :: AbsolutePath ('Dir PkgDb)
finalPkgDbDir, QSem
$sel:finalPkgDbSem:PkgDbDirForBuild :: QSem
finalPkgDbSem :: QSem
finalPkgDbSem }
    where
      finalPkgDbDir :: AbsolutePath ('Dir PkgDb)
finalPkgDbDir = AbsolutePath ('Dir Install)
installDir AbsolutePath ('Dir Install)
-> RelativePath Install ('Dir PkgDb) -> AbsolutePath ('Dir PkgDb)
forall p q r. PathLike p q r => p -> q -> r
</> String -> RelativePath Install ('Dir PkgDb)
forall from (to :: FileOrDir). String -> RelativePath from to
mkRelativePath 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 -> SymbolicPath Project ('Dir Pkg)
pkgDir     :: !( SymbolicPath Project ( Dir Pkg ) )
        -- ^ 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 :: Paths use
              -- ^ Overall directory structure to base the computation off.

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

          -> PkgDir use
getPkgDir :: forall (use :: PathUsability).
Paths use -> ConfiguredUnit -> PkgDir use
getPkgDir ( Paths { SymbolicPath Project ('Dir Fetch)
fetchDir :: SymbolicPath Project ('Dir Fetch)
$sel:fetchDir:Paths :: forall (use :: PathUsability).
Paths use -> SymbolicPath Project ('Dir Fetch)
fetchDir } )
          ( ConfiguredUnit { PkgName
$sel:puPkgName:ConfiguredUnit :: ConfiguredUnit -> PkgName
puPkgName :: PkgName
puPkgName, Version
puVersion :: Version
$sel:puVersion:ConfiguredUnit :: ConfiguredUnit -> Version
puVersion, PkgSrc
puPkgSrc :: PkgSrc
$sel:puPkgSrc:ConfiguredUnit :: ConfiguredUnit -> PkgSrc
puPkgSrc } )
  = PkgDir { String
$sel:pkgNameVer:PkgDir :: String
pkgNameVer :: String
pkgNameVer, SymbolicPath Project ('Dir Pkg)
$sel:pkgDir:PkgDir :: SymbolicPath Project ('Dir Pkg)
pkgDir :: SymbolicPath Project ('Dir Pkg)
pkgDir }
    where
      pkgNameVer :: String
pkgNameVer = Text -> String
Text.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ PkgName -> Version -> Text
pkgNameVersion PkgName
puPkgName Version
puVersion
      pkgDir :: SymbolicPath Project ('Dir Pkg)
pkgDir
        | Local SymbolicPath Project ('Dir Pkg)
dir <- PkgSrc
puPkgSrc
        = SymbolicPath Project ('Dir Pkg)
dir
        | Bool
otherwise
        = SymbolicPath Project ('Dir Fetch)
fetchDir SymbolicPath Project ('Dir Fetch)
-> RelativePath Fetch ('Dir Pkg) -> SymbolicPath Project ('Dir Pkg)
forall p q r. PathLike p q r => p -> q -> r
</> String -> RelativePath Fetch ('Dir Pkg)
forall from (to :: FileOrDir). String -> RelativePath from to
mkRelativePath String
pkgNameVer

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

runCwdExe :: ScriptConfig -> String -> SymbolicPath from File
runCwdExe :: forall from. ScriptConfig -> String -> SymbolicPath from 'File
runCwdExe ( ScriptConfig { ScriptOutput
scriptOutput :: ScriptOutput
scriptOutput :: ScriptConfig -> ScriptOutput
scriptOutput, Style
scriptStyle :: Style
scriptStyle :: ScriptConfig -> Style
scriptStyle } )
  = String -> SymbolicPath from 'File
forall from (to :: FileOrDir). String -> SymbolicPath from to
mkSymbolicPath (String -> SymbolicPath from 'File)
-> (String -> String) -> String -> SymbolicPath from 'File
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
pre (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
ext
  where
    pre :: String -> String
pre
      | ScriptOutput
Run <- ScriptOutput
scriptOutput
      = String -> String
forall a. a -> a
id
      | Bool
otherwise
      = ( String
"./" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> )
    ext :: String -> String
ext
      | Style
WinStyle <- Style
scriptStyle
      = ( String -> String -> String
forall p. FileLike p => p -> String -> p
<.> String
"exe" )
      | Bool
otherwise
      = String -> String
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 { AbsolutePath ('Dir Install)
$sel:installDir:BuildPaths :: BuildPaths 'ForBuild -> AbsolutePath ('Dir Install)
installDir :: AbsolutePath ('Dir Install)
installDir } ) [ConfiguredUnit]
units =
    [ ( PkgName -> String
mangledPkgName PkgName
puPkgName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"_datadir"
      , EscapeVars -> ScriptConfig -> String -> String
forall r.
(IsString r, Monoid r) =>
EscapeVars -> ScriptConfig -> String -> r
quoteArg EscapeVars
ExpandVars ScriptConfig
scriptCfg (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$
          AbsolutePath Any -> String
forall (to :: FileOrDir). AbsolutePath to -> String
getAbsolutePath (AbsolutePath Any -> String) -> AbsolutePath Any -> String
forall a b. (a -> b) -> a -> b
$ AbsolutePath ('Dir Install)
installDir AbsolutePath ('Dir Install)
-> RelativePath Install Any -> AbsolutePath Any
forall p q r. PathLike p q r => p -> q -> r
</> String -> RelativePath Install Any
forall from (to :: FileOrDir). String -> RelativePath from to
mkRelativePath ( String
"share" String -> String -> String
forall p q r. PathLike p q r => p -> q -> r
</> Text -> String
Text.unpack ( PkgName -> Version -> Text
pkgNameVersion PkgName
puPkgName Version
puVersion ) ) )
        -- Keep this in sync with --datadir in essentialConfigureArgs.

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