{-# LANGUAGE CPP #-}

{-# LANGUAGE ConstraintKinds #-}

{-# LANGUAGE FlexibleContexts #-}

{-# LANGUAGE MultiParamTypeClasses #-}

{-# LANGUAGE OverloadedStrings #-}

{-# LANGUAGE RecordWildCards #-}

{-# LANGUAGE TemplateHaskell #-}

{-# LANGUAGE LambdaCase #-}

-- | Perform a build

module Stack.Build.Execute

( printPlan

, preFetch

, executePlan

-- * Running Setup.hs

, ExecuteEnv

, withExecuteEnv

, withSingleContext

) where

import Control.Applicative

import Control.Arrow ((&&&), second)

import Control.Concurrent.Execute

import Control.Concurrent.MVar.Lifted

import Control.Concurrent.STM

import Control.Exception.Enclosed (catchIO)

import Control.Exception.Lifted

import Control.Monad (liftM, when, unless, void)

import Control.Monad.Catch (MonadCatch, MonadMask)

import Control.Monad.Extra (anyM, (&&^))

import Control.Monad.IO.Class

import Control.Monad.Logger

import Control.Monad.Reader (MonadReader, asks)

import Control.Monad.Trans.Control (liftBaseWith)

import Control.Monad.Trans.Resource

import Data.Attoparsec.Text hiding (try)

import qualified Data.ByteString as S

import Data.Char (isSpace)

import Data.Conduit

import qualified Data.Conduit.Binary as CB

import qualified Data.Conduit.List as CL

import qualified Data.Conduit.Text as CT

import Data.Either (isRight)

import Data.Foldable (forM_, any)

import Data.Function

import Data.IORef.RunOnce (runOnce)

import Data.List hiding (any)

import Data.Map.Strict (Map)

import qualified Data.Map.Strict as Map

import Data.Maybe

import Data.Maybe.Extra (forMaybeM)

import Data.Monoid

import Data.Set (Set)

import qualified Data.Set as Set

import Data.Streaming.Process hiding (callProcess, env)

import Data.String

import Data.Text (Text)

import qualified Data.Text as T

import Data.Text.Encoding (decodeUtf8)

import Data.Text.Extra (stripCR)

import Data.Time.Clock (getCurrentTime)

import Data.Traversable (forM)

import Data.Tuple

import qualified Distribution.PackageDescription as C

import Distribution.System (OS (Windows),

Platform (Platform))

import qualified Distribution.Text as C

import Language.Haskell.TH as TH (location)

import Network.HTTP.Client.Conduit (HasHttpManager)

import Path

import Path.Extra (toFilePathNoTrailingSep, rejectMissingFile)

import Path.IO hiding (findExecutable, makeAbsolute)

import Prelude hiding (FilePath, writeFile, any)

import Stack.Build.Cache

import Stack.Build.Haddock

import Stack.Build.Installed

import Stack.Build.Source

import Stack.Build.Target

import Stack.Config

import Stack.Constants

import Stack.Coverage

import Stack.Fetch as Fetch

import Stack.GhcPkg

import Stack.Package

import Stack.PackageDump

import Stack.PrettyPrint

import Stack.Types.Build

import Stack.Types.Compiler

import Stack.Types.Config

import Stack.Types.GhcPkgId

import Stack.Types.Internal

import Stack.Types.Package

import Stack.Types.PackageIdentifier

import Stack.Types.PackageName

import Stack.Types.StackT

import Stack.Types.Version

import qualified System.Directory as D

import System.Environment (getExecutablePath)

import System.Exit (ExitCode (ExitSuccess))

import qualified System.FilePath as FP

import System.IO

import System.PosixCompat.Files (createLink)

import System.Process.Log (showProcessArgDebug, withProcessTimeLog)

import System.Process.Read

import System.Process.Run

#if !MIN_VERSION_process(1,2,1)

import System.Process.Internals (createProcess_)

#endif

type M env m = (MonadIO m,MonadReader env m,HasHttpManager env,HasBuildConfig env,MonadLogger m,MonadBaseControl IO m,MonadMask m,HasLogLevel env,HasEnvConfig env,HasTerminal env, HasConfig env)

-- | Fetch the packages necessary for a build, for example in combination with a dry run.

preFetch :: M env m => Plan -> m ()

preFetch plan

| Set.null idents = $logDebug "Nothing to fetch"

| otherwise = do

$logDebug $ T.pack $

"Prefetching: " ++

intercalate ", " (map packageIdentifierString $ Set.toList idents)

menv <- getMinimalEnvOverride

fetchPackages menv idents

where

idents = Set.unions $ map toIdent $ Map.toList $ planTasks plan

toIdent (name, task) =

case taskType task of

TTLocal _ -> Set.empty

TTUpstream package _ _ -> Set.singleton $ PackageIdentifier

name

(packageVersion package)

-- | Print a description of build plan for human consumption.

printPlan :: M env m

=> Plan

-> m ()

printPlan plan = do

case Map.elems $ planUnregisterLocal plan of

[] -> $logInfo "No packages would be unregistered."

xs -> do

$logInfo "Would unregister locally:"

forM_ xs $ \(ident, mreason) -> $logInfo $ T.concat

[ T.pack $ packageIdentifierString ident

, case mreason of

Nothing -> ""

Just reason -> T.concat

[ " ("

, reason

, ")"

]

]

$logInfo ""

case Map.elems $ planTasks plan of

[] -> $logInfo "Nothing to build."

xs -> do

$logInfo "Would build:"

mapM_ ($logInfo . displayTask) xs

let hasTests = not . Set.null . testComponents . taskComponents

hasBenches = not . Set.null . benchComponents . taskComponents

tests = Map.elems $ Map.filter hasTests $ planFinals plan

benches = Map.elems $ Map.filter hasBenches $ planFinals plan

unless (null tests) $ do

$logInfo ""

$logInfo "Would test:"

mapM_ ($logInfo . displayTask) tests

unless (null benches) $ do

$logInfo ""

$logInfo "Would benchmark:"

mapM_ ($logInfo . displayTask) benches

$logInfo ""

case Map.toList $ planInstallExes plan of

[] -> $logInfo "No executables to be installed."

xs -> do

$logInfo "Would install executables:"

forM_ xs $ \(name, loc) -> $logInfo $ T.concat

[ name

, " from "

, case loc of

Snap -> "snapshot"

Local -> "local"

, " database"

]

-- | For a dry run

displayTask :: Task -> Text

displayTask task = T.pack $ concat

[ packageIdentifierString $ taskProvides task

, ": database="

, case taskLocation task of

Snap -> "snapshot"

Local -> "local"

, ", source="

, case taskType task of

TTLocal lp -> concat

[ toFilePath $ lpDir lp

]

TTUpstream _ _ _ -> "package index"

, if Set.null missing

then ""

else ", after: " ++ intercalate "," (map packageIdentifierString $ Set.toList missing)

]

where

missing = tcoMissing $ taskConfigOpts task

data ExecuteEnv = ExecuteEnv

{ eeEnvOverride :: !EnvOverride

, eeConfigureLock :: !(MVar ())

, eeInstallLock :: !(MVar ())

, eeBuildOpts :: !BuildOpts

, eeBuildOptsCLI :: !BuildOptsCLI

, eeBaseConfigOpts :: !BaseConfigOpts

, eeGhcPkgIds :: !(TVar (Map PackageIdentifier Installed))

, eeTempDir :: !(Path Abs Dir)

, eeSetupHs :: !(Path Abs File)

-- ^ Temporary Setup.hs for simple builds

, eeSetupExe :: !(Maybe (Path Abs File))

-- ^ Compiled version of eeSetupHs

, eeCabalPkgVer :: !Version

, eeTotalWanted :: !Int

, eeWanted :: !(Set PackageName)

, eeLocals :: ![LocalPackage]

, eeGlobalDB :: !(Path Abs Dir)

, eeGlobalDumpPkgs :: !(Map GhcPkgId (DumpPackage () ()))

, eeSnapshotDumpPkgs :: !(TVar (Map GhcPkgId (DumpPackage () ())))

, eeLocalDumpPkgs :: !(TVar (Map GhcPkgId (DumpPackage () ())))

, eeLogFiles :: !(TChan (Path Abs Dir, Path Abs File))

}

-- | Get a compiled Setup exe

getSetupExe :: M env m

=> Path Abs File -- ^ Setup.hs input file

-> Path Abs Dir -- ^ temporary directory

-> m (Maybe (Path Abs File))

getSetupExe setupHs tmpdir = do

wc <- getWhichCompiler

econfig <- asks getEnvConfig

platformDir <- platformGhcRelDir

let config = getConfig econfig

baseNameS = concat

[ "setup-Simple-Cabal-"

, versionString $ envConfigCabalVersion econfig

, "-"

, compilerVersionString $ envConfigCompilerVersion econfig

]

exeNameS = baseNameS ++

case configPlatform config of

Platform _ Windows -> ".exe"

_ -> ""

outputNameS =

case wc of

Ghc -> exeNameS

Ghcjs -> baseNameS ++ ".jsexe"

jsExeNameS =

baseNameS ++ ".jsexe"

setupDir =

configStackRoot config </>

$(mkRelDir "setup-exe-cache") </>

platformDir

exePath <- fmap (setupDir </>) $ parseRelFile exeNameS

jsExePath <- fmap (setupDir </>) $ parseRelDir jsExeNameS

exists <- liftIO $ D.doesFileExist $ toFilePath exePath

if exists

then return $ Just exePath

else do

tmpExePath <- fmap (setupDir </>) $ parseRelFile $ "tmp-" ++ exeNameS

tmpOutputPath <- fmap (setupDir </>) $ parseRelFile $ "tmp-" ++ outputNameS

tmpJsExePath <- fmap (setupDir </>) $ parseRelDir $ "tmp-" ++ jsExeNameS

liftIO $ D.createDirectoryIfMissing True $ toFilePath setupDir

menv <- getMinimalEnvOverride

let args =

[ "-clear-package-db"

, "-global-package-db"

, "-hide-all-packages"

, "-package"

, "base"

, "-package"

, "Cabal-" ++ versionString (envConfigCabalVersion econfig)

, toFilePath setupHs

, "-o"

, toFilePath tmpOutputPath

, "-rtsopts"

] ++

["-build-runner" | wc == Ghcjs]

runCmd' (\cp -> cp { std_out = UseHandle stderr }) (Cmd (Just tmpdir) (compilerExeName wc) menv args) Nothing

when (wc == Ghcjs) $ renameDir tmpJsExePath jsExePath

renameFile tmpExePath exePath

return $ Just exePath

-- | Execute a callback that takes an 'ExecuteEnv'.

withExecuteEnv :: M env m

=> EnvOverride

-> BuildOpts

-> BuildOptsCLI

-> BaseConfigOpts

-> [LocalPackage]

-> [DumpPackage () ()] -- ^ global packages

-> [DumpPackage () ()] -- ^ snapshot packages

-> [DumpPackage () ()] -- ^ local packages

-> (ExecuteEnv -> m a)

-> m a

withExecuteEnv menv bopts boptsCli baseConfigOpts locals globalPackages snapshotPackages localPackages inner = do

withSystemTempDir stackProgName $ \tmpdir -> do

configLock <- newMVar ()

installLock <- newMVar ()

idMap <- liftIO $ newTVarIO Map.empty

let setupHs = tmpdir </> $(mkRelFile "Setup.hs")

liftIO $ writeFile (toFilePath setupHs) "import Distribution.Simple\nmain = defaultMain"

setupExe <- getSetupExe setupHs tmpdir

cabalPkgVer <- asks (envConfigCabalVersion . getEnvConfig)

globalDB <- getGlobalDB menv =<< getWhichCompiler

snapshotPackagesTVar <- liftIO $ newTVarIO (toDumpPackagesByGhcPkgId snapshotPackages)

localPackagesTVar <- liftIO $ newTVarIO (toDumpPackagesByGhcPkgId localPackages)

logFilesTChan <- liftIO $ atomically newTChan

let totalWanted = length $ filter lpWanted locals

inner ExecuteEnv

{ eeEnvOverride = menv

, eeBuildOpts = bopts

, eeBuildOptsCLI = boptsCli

-- Uncertain as to why we cannot run configures in parallel. This appears

-- to be a Cabal library bug. Original issue:

-- https://github.com/fpco/stack/issues/84. Ideally we'd be able to remove

-- this.

, eeConfigureLock = configLock

, eeInstallLock = installLock

, eeBaseConfigOpts = baseConfigOpts

, eeGhcPkgIds = idMap

, eeTempDir = tmpdir

, eeSetupHs = setupHs

, eeSetupExe = setupExe

, eeCabalPkgVer = cabalPkgVer

, eeTotalWanted = totalWanted

, eeWanted = wantedLocalPackages locals

, eeLocals = locals

, eeGlobalDB = globalDB

, eeGlobalDumpPkgs = toDumpPackagesByGhcPkgId globalPackages

, eeSnapshotDumpPkgs = snapshotPackagesTVar

, eeLocalDumpPkgs = localPackagesTVar

, eeLogFiles = logFilesTChan

} `finally` dumpLogs logFilesTChan totalWanted

where

toDumpPackagesByGhcPkgId = Map.fromList . map (\dp -> (dpGhcPkgId dp, dp))

dumpLogs chan totalWanted = do

allLogs <- fmap reverse $ liftIO $ atomically drainChan

case allLogs of

-- No log files generated, nothing to dump

[] -> return ()

firstLog:_ -> do

toDump <- asks (configDumpLogs . getConfig)

case toDump of

DumpAllLogs -> mapM_ (dumpLog "") allLogs

DumpWarningLogs -> mapM_ dumpLogIfWarning allLogs

DumpNoLogs

| totalWanted > 1 ->

$logInfo $ T.concat

[ "Build output has been captured to log files, use "

, "--dump-logs to see it on the console"

]

| otherwise -> return ()

$logInfo $ T.pack $ "Log files have been written to: "

++ toFilePath (parent (snd firstLog))

where

drainChan = do

mx <- tryReadTChan chan

case mx of

Nothing -> return []

Just x -> do

xs <- drainChan

return $ x:xs

dumpLogIfWarning (pkgDir, filepath) = do

firstWarning <- runResourceT

$ CB.sourceFile (toFilePath filepath)

$$ CT.decodeUtf8Lenient

=$ CT.lines

=$ CL.map stripCR

=$ CL.filter isWarning

=$ CL.take 1

if (null firstWarning)

then return ()

else dumpLog " due to warnings" (pkgDir, filepath)

isWarning t = ": Warning:" `T.isSuffixOf` t

dumpLog msgSuffix (pkgDir, filepath) = do

$logInfo $ T.pack $ concat ["\n-- Dumping log file", msgSuffix, ": ", toFilePath filepath, "\n"]

runResourceT

$ CB.sourceFile (toFilePath filepath)

$$ CT.decodeUtf8Lenient

=$ mungeBuildOutput True True pkgDir

=$ CL.mapM_ $logInfo

$logInfo $ T.pack $ "\n-- End of log file: " ++ toFilePath filepath ++ "\n"

-- | Perform the actual plan

executePlan :: M env m

=> EnvOverride

-> BuildOptsCLI

-> BaseConfigOpts

-> [LocalPackage]

-> [DumpPackage () ()] -- ^ global packages

-> [DumpPackage () ()] -- ^ snapshot packages

-> [DumpPackage () ()] -- ^ local packages

-> InstalledMap

-> Map PackageName SimpleTarget

-> Plan

-> m ()

executePlan menv boptsCli baseConfigOpts locals globalPackages snapshotPackages localPackages installedMap targets plan = do

$logDebug "Executing the build plan"

bopts <- asks (configBuild . getConfig)

withExecuteEnv menv bopts boptsCli baseConfigOpts locals globalPackages snapshotPackages localPackages (executePlan' installedMap targets plan)

unless (Map.null $ planInstallExes plan) $ do

snapBin <- (</> bindirSuffix) `liftM` installationRootDeps

localBin <- (</> bindirSuffix) `liftM` installationRootLocal

destDir <- asks $ configLocalBin . getConfig

ensureDir destDir

destDir' <- liftIO . D.canonicalizePath . toFilePath $ destDir

platform <- asks getPlatform

let ext =

case platform of

Platform _ Windows -> ".exe"

_ -> ""

currExe <- liftIO getExecutablePath -- needed for windows, see below

installed <- forMaybeM (Map.toList $ planInstallExes plan) $ \(name, loc) -> do

let bindir =

case loc of

Snap -> snapBin

Local -> localBin

mfp <- forgivingAbsence (resolveFile bindir $ T.unpack name ++ ext)

>>= rejectMissingFile

case mfp of

Nothing -> do

$logWarn $ T.concat

[ "Couldn't find executable "

, name

, " in directory "

, T.pack $ toFilePath bindir

]

return Nothing

Just file -> do

let destFile = destDir' FP.</> T.unpack name ++ ext

$logInfo $ T.concat

[ "Copying from "

, T.pack $ toFilePath file

, " to "

, T.pack destFile

]

liftIO $ case platform of

Platform _ Windows | FP.equalFilePath destFile currExe ->

windowsRenameCopy (toFilePath file) destFile

_ -> D.copyFile (toFilePath file) destFile

return $ Just (name <> T.pack ext)

unless (null installed) $ do

$logInfo ""

$logInfo $ T.concat

[ "Copied executables to "

, T.pack destDir'

, ":"]

forM_ installed $ \exe -> $logInfo ("- " <> exe)

searchPath <- liftIO FP.getSearchPath

destDirIsInPATH <- liftIO $

anyM (\dir -> D.doesDirectoryExist dir &&^ fmap (FP.equalFilePath destDir') (D.canonicalizePath dir)) searchPath

if destDirIsInPATH

then forM_ installed $ \exe -> do

mexePath <- (liftIO . D.findExecutable . T.unpack) exe

case mexePath of

Just exePath -> do

exeDir <- (liftIO . fmap FP.takeDirectory . D.canonicalizePath) exePath

unless (exeDir `FP.equalFilePath` destDir') $ do

$logWarn ""

$logWarn $ T.concat

[ "WARNING: The \""

, exe

, "\" executable found on the PATH environment variable is "

, T.pack exePath

, ", and not the version that was just installed."

]

$logWarn $ T.concat

[ "This means that \""

, exe

, "\" calls on the command line will not use this version."

]

Nothing -> do

$logWarn ""

$logWarn $ T.concat

[ "WARNING: Installation path "

, T.pack destDir'

, " is on the PATH but the \""

, exe

, "\" executable that was just installed could not be found on the PATH."

]

else do

$logWarn ""

$logWarn $ T.concat

[ "WARNING: Installation path "

, T.pack destDir'

, " not found on the PATH environment variable"

]

config <- asks getConfig

menv' <- liftIO $ configEnvOverride config EnvSettings

{ esIncludeLocals = True

, esIncludeGhcPackagePath = True

, esStackExe = True

, esLocaleUtf8 = False

}

forM_ (boptsCLIExec boptsCli) $ \(cmd, args) ->

$withProcessTimeLog cmd args $

callProcess (Cmd Nothing cmd menv' args)

-- | Windows can't write over the current executable. Instead, we rename the

-- current executable to something else and then do the copy.

windowsRenameCopy :: FilePath -> FilePath -> IO ()

windowsRenameCopy src dest = do

D.copyFile src new

D.renameFile dest old

D.renameFile new dest

where

new = dest ++ ".new"

old = dest ++ ".old"

-- | Perform the actual plan (internal)

executePlan' :: M env m

=> InstalledMap

-> Map PackageName SimpleTarget

-> Plan

-> ExecuteEnv

-> m ()

executePlan' installedMap0 targets plan ee@ExecuteEnv {..} = do

when (toCoverage $ boptsTestOpts eeBuildOpts) deleteHpcReports

wc <- getWhichCompiler

cv <- asks $ envConfigCompilerVersion . getEnvConfig

case Map.toList $ planUnregisterLocal plan of

[] -> return ()

ids -> do

localDB <- packageDatabaseLocal

forM_ ids $ \(id', (ident, mreason)) -> do

$logInfo $ T.concat

[ T.pack $ packageIdentifierString ident

, ": unregistering"

, case mreason of

Nothing -> ""

Just reason -> T.concat

[ " ("

, reason

, ")"

]

]

unregisterGhcPkgId eeEnvOverride wc cv localDB id' ident

liftIO $ atomically $ modifyTVar' eeLocalDumpPkgs $ \initMap ->

foldl' (flip Map.delete) initMap $ Map.keys (planUnregisterLocal plan)

-- Yes, we're explicitly discarding result values, which in general would

-- be bad. monad-unlift does this all properly at the type system level,

-- but I don't want to pull it in for this one use case, when we know that

-- stack always using transformer stacks that are safe for this use case.

runInBase <- liftBaseWith $ \run -> return (void . run)

let actions = concatMap (toActions installedMap' runInBase ee) $ Map.elems $ Map.mergeWithKey

(\_ b f -> Just (Just b, Just f))

(fmap (\b -> (Just b, Nothing)))

(fmap (\f -> (Nothing, Just f)))

(planTasks plan)

(planFinals plan)

threads <- asks $ configJobs . getConfig

concurrentTests <- asks $ configConcurrentTests . getConfig

let keepGoing =

case boptsKeepGoing eeBuildOpts of

Just kg -> kg

Nothing -> boptsTests eeBuildOpts || boptsBenchmarks eeBuildOpts

concurrentFinal =

-- TODO it probably makes more sense to use a lock for test suites

-- and just have the execution blocked. Turning off all concurrency

-- on finals based on the --test option doesn't fit in well.

if boptsTests eeBuildOpts

then concurrentTests

else True

terminal <- asks getTerminal

errs <- liftIO $ runActions threads keepGoing concurrentFinal actions $ \doneVar -> do

let total = length actions

loop prev

| prev == total =

runInBase $ $logStickyDone ("Completed " <> T.pack (show total) <> " action(s).")

| otherwise = do

when terminal $ runInBase $

$logSticky ("Progress: " <> T.pack (show prev) <> "/" <> T.pack (show total))

done <- atomically $ do

done <- readTVar doneVar

check $ done /= prev

return done

loop done

if total > 1

then loop 0

else return ()

when (toCoverage $ boptsTestOpts eeBuildOpts) $ do

generateHpcUnifiedReport

generateHpcMarkupIndex

unless (null errs) $ throwM $ ExecutionFailure errs

when (boptsHaddock eeBuildOpts) $ do

snapshotDumpPkgs <- liftIO (readTVarIO eeSnapshotDumpPkgs)

localDumpPkgs <- liftIO (readTVarIO eeLocalDumpPkgs)

generateLocalHaddockIndex eeEnvOverride wc eeBaseConfigOpts localDumpPkgs eeLocals

generateDepsHaddockIndex eeEnvOverride wc eeBaseConfigOpts eeGlobalDumpPkgs snapshotDumpPkgs localDumpPkgs eeLocals

generateSnapHaddockIndex eeEnvOverride wc eeBaseConfigOpts eeGlobalDumpPkgs snapshotDumpPkgs

when (boptsOpenHaddocks eeBuildOpts) $ do

let planPkgs, localPkgs, installedPkgs, availablePkgs

:: Map PackageName (PackageIdentifier, InstallLocation)

planPkgs = Map.map (taskProvides &&& taskLocation) (planTasks plan)

localPkgs =

Map.fromList

[(packageName p, (packageIdentifier p, Local)) | p <- map lpPackage eeLocals]

installedPkgs = Map.map (swap . second installedPackageIdentifier) installedMap'

availablePkgs = Map.unions [planPkgs, localPkgs, installedPkgs]

openHaddocksInBrowser eeBaseConfigOpts availablePkgs (Map.keysSet targets)

where

installedMap' = Map.difference installedMap0

$ Map.fromList

$ map (\(ident, _) -> (packageIdentifierName ident, ()))

$ Map.elems

$ planUnregisterLocal plan

toActions :: M env m

=> InstalledMap

-> (m () -> IO ())

-> ExecuteEnv

-> (Maybe Task, Maybe Task) -- build and final

-> [Action]

toActions installedMap runInBase ee (mbuild, mfinal) =

abuild ++ afinal

where

abuild =

case mbuild of

Nothing -> []

Just task@Task {..} ->

[ Action

{ actionId = ActionId taskProvides ATBuild

, actionDeps =

Set.map (\ident -> ActionId ident ATBuild) (tcoMissing taskConfigOpts)

, actionDo = \ac -> runInBase $ singleBuild runInBase ac ee task installedMap False

}

]

afinal =

case mfinal of

Nothing -> []

Just task@Task {..} ->

(if taskAllInOne then [] else

[Action

{ actionId = ActionId taskProvides ATBuildFinal

, actionDeps = addBuild ATBuild

(Set.map (\ident -> ActionId ident ATBuild) (tcoMissing taskConfigOpts))

, actionDo = \ac -> runInBase $ singleBuild runInBase ac ee task installedMap True

}]) ++

[ Action

{ actionId = ActionId taskProvides ATFinal

, actionDeps = addBuild (if taskAllInOne then ATBuild else ATBuildFinal) Set.empty

, actionDo = \ac -> runInBase $ do

let comps = taskComponents task

tests = testComponents comps

benches = benchComponents comps

unless (Set.null tests) $ do

singleTest runInBase topts (Set.toList tests) ac ee task installedMap

unless (Set.null benches) $ do

singleBench runInBase beopts (Set.toList benches) ac ee task installedMap

}

]

where

addBuild aty =

case mbuild of

Nothing -> id

Just _ -> Set.insert $ ActionId taskProvides aty

bopts = eeBuildOpts ee

topts = boptsTestOpts bopts

beopts = boptsBenchmarkOpts bopts

-- | Generate the ConfigCache

getConfigCache :: M env m

=> ExecuteEnv -> Task -> InstalledMap -> Bool -> Bool

-> m (Map PackageIdentifier GhcPkgId, ConfigCache)

getConfigCache ExecuteEnv {..} Task {..} installedMap enableTest enableBench = do

useExactConf <- asks (configAllowNewer . getConfig)

let extra =

-- We enable tests if the test suite dependencies are already

-- installed, so that we avoid unnecessary recompilation based on

-- cabal_macros.h changes when switching between 'stack build' and

-- 'stack test'. See:

-- https://github.com/commercialhaskell/stack/issues/805

case taskType of

TTLocal lp -> concat

-- FIXME: make this work with exact-configuration.

-- Not sure how to plumb the info atm. See

-- https://github.com/commercialhaskell/stack/issues/2049

[ [ "--enable-tests"

| enableTest ||

(not useExactConf && depsPresent installedMap (lpTestDeps lp))]

, [ "--enable-benchmarks"

| enableBench ||

(not useExactConf && depsPresent installedMap (lpBenchDeps lp))]

]

_ -> []

idMap <- liftIO $ readTVarIO eeGhcPkgIds

let getMissing ident =

case Map.lookup ident idMap of

Nothing -> error "singleBuild: invariant violated, missing package ID missing"

Just (Library ident' x) -> assert (ident == ident') $ Just (ident, x)

Just (Executable _) -> Nothing

missing' = Map.fromList $ mapMaybe getMissing $ Set.toList missing

TaskConfigOpts missing mkOpts = taskConfigOpts

opts = mkOpts missing'

allDeps = Set.fromList $ Map.elems missing' ++ Map.elems taskPresent

cache = ConfigCache

{ configCacheOpts = opts

{ coNoDirs = coNoDirs opts ++ map T.unpack extra

}

, configCacheDeps = allDeps

, configCacheComponents =

case taskType of

TTLocal lp -> Set.map renderComponent $ lpComponents lp

TTUpstream _ _ _ -> Set.empty

, configCacheHaddock =

shouldHaddockPackage eeBuildOpts eeWanted (packageIdentifierName taskProvides)

}

allDepsMap = Map.union missing' taskPresent

return (allDepsMap, cache)

-- | Ensure that the configuration for the package matches what is given

ensureConfig :: M env m

=> ConfigCache -- ^ newConfigCache

-> Path Abs Dir -- ^ package directory

-> ExecuteEnv

-> m () -- ^ announce

-> (Bool -> [String] -> m ()) -- ^ cabal

-> Path Abs File -- ^ .cabal file

-> m Bool

ensureConfig newConfigCache pkgDir ExecuteEnv {..} announce cabal cabalfp = do

newCabalMod <- liftIO (fmap modTime (D.getModificationTime (toFilePath cabalfp)))

needConfig <-

if boptsReconfigure eeBuildOpts

then return True

else do

-- We can ignore the components portion of the config

-- cache, because it's just used to inform 'construct

-- plan that we need to plan to build additional

-- components. These components don't affect the actual

-- package configuration.

let ignoreComponents cc = cc { configCacheComponents = Set.empty }

-- Determine the old and new configuration in the local directory, to

-- determine if we need to reconfigure.

mOldConfigCache <- tryGetConfigCache pkgDir

mOldCabalMod <- tryGetCabalMod pkgDir

return $ fmap ignoreComponents mOldConfigCache /= Just (ignoreComponents newConfigCache)

|| mOldCabalMod /= Just newCabalMod

let ConfigureOpts dirs nodirs = configCacheOpts newConfigCache

when needConfig $ withMVar eeConfigureLock $ \_ -> do

deleteCaches pkgDir

announce

menv <- getMinimalEnvOverride

let programNames =

if eeCabalPkgVer < $(mkVersion "1.22")

then ["ghc", "ghc-pkg"]

else ["ghc", "ghc-pkg", "ghcjs", "ghcjs-pkg"]

exes <- forM programNames $ \name -> do

mpath <- findExecutable menv name

return $ case mpath of

Nothing -> []

Just x -> return $ concat ["--with-", name, "=", toFilePath x]

-- Configure cabal with arguments determined by

-- Stack.Types.Build.configureOpts

cabal False $ "configure" : concat

[ concat exes

, dirs

, nodirs

]

writeConfigCache pkgDir newConfigCache

writeCabalMod pkgDir newCabalMod

return needConfig

announceTask :: MonadLogger m => Task -> Text -> m ()

announceTask task x = $logInfo $ T.concat

[ T.pack $ packageIdentifierString $ taskProvides task

, ": "

, x

]

withSingleContext :: M env m

=> (m () -> IO ())

-> ActionContext

-> ExecuteEnv

-> Task

-> Maybe (Map PackageIdentifier GhcPkgId)

-- ^ All dependencies' package ids to provide to Setup.hs. If

-- Nothing, just provide global and snapshot package

-- databases.

-> Maybe String

-> ( Package

-> Path Abs File

-> Path Abs Dir

-> (Bool -> [String] -> m ())

-> (Text -> m ())

-> Bool

-> Maybe (Path Abs File, Handle)

-> m a)

-> m a

withSingleContext runInBase ActionContext {..} ExecuteEnv {..} task@Task {..} mdeps msuffix inner0 =

withPackage $ \package cabalfp pkgDir ->

withLogFile pkgDir package $ \mlogFile ->

withCabal package pkgDir mlogFile $ \cabal ->

inner0 package cabalfp pkgDir cabal announce console mlogFile

where

announce = announceTask task

wanted =

case taskType of

TTLocal lp -> lpWanted lp

TTUpstream _ _ _ -> False

console = wanted

&& all (\(ActionId ident _) -> ident == taskProvides) (Set.toList acRemaining)

&& eeTotalWanted == 1

withPackage inner =

case taskType of

TTLocal lp -> inner (lpPackage lp) (lpCabalFile lp) (lpDir lp)

TTUpstream package _ gitSHA1 -> do

mdist <- liftM Just distRelativeDir

m <- unpackPackageIdents eeEnvOverride eeTempDir mdist

$ Map.singleton taskProvides gitSHA1

case Map.toList m of

[(ident, dir)]

| ident == taskProvides -> do

let name = packageIdentifierName taskProvides

cabalfpRel <- parseRelFile $ packageNameString name ++ ".cabal"

let cabalfp = dir </> cabalfpRel

inner package cabalfp dir

_ -> error $ "withPackage: invariant violated: " ++ show m

withLogFile pkgDir package inner

| console = inner Nothing

| otherwise = do

logPath <- buildLogPath package msuffix

ensureDir (parent logPath)

let fp = toFilePath logPath

-- We only want to dump logs for local non-dependency packages

case taskType of

TTLocal lp | lpWanted lp ->

liftIO $ atomically $ writeTChan eeLogFiles (pkgDir, logPath)

_ -> return ()

bracket

(liftIO $ openBinaryFile fp WriteMode)

(liftIO . hClose)

$ \h -> inner (Just (logPath, h))

withCabal package pkgDir mlogFile inner = do

config <- asks getConfig

unless (configAllowDifferentUser config) $

checkOwnership (pkgDir </> configWorkDir config)

let envSettings = EnvSettings

{ esIncludeLocals = taskLocation task == Local

, esIncludeGhcPackagePath = False

, esStackExe = False

, esLocaleUtf8 = True

}

menv <- liftIO $ configEnvOverride config envSettings

getGhcPath <- runOnce $ getCompilerPath Ghc

getGhcjsPath <- runOnce $ getCompilerPath Ghcjs

distRelativeDir' <- distRelativeDir

esetupexehs <-

-- Avoid broken Setup.hs files causing problems for simple build

-- types, see:

-- https://github.com/commercialhaskell/stack/issues/370

case (packageSimpleType package, eeSetupExe) of

(True, Just setupExe) -> return $ Left setupExe

_ -> liftIO $ fmap Right $ getSetupHs pkgDir

inner $ \stripTHLoading args -> do

let cabalPackageArg

-- Omit cabal package dependency when building

-- Cabal. See

-- https://github.com/commercialhaskell/stack/issues/1356

| packageName package == $(mkPackageName "Cabal") = []

| otherwise =

["-package=" ++ packageIdentifierString

(PackageIdentifier cabalPackageName

eeCabalPkgVer)]

packageArgs =

case mdeps of

-- This branch is taken when

-- 'explicit-setup-deps' is requested in your

-- stack.yaml file.

Just deps | explicitSetupDeps (packageName package) config ->

-- Stack always builds with the global Cabal for various

-- reproducibility issues.

let depsMinusCabal

= map ghcPkgIdString

$ Set.toList

$ addGlobalPackages deps (Map.elems eeGlobalDumpPkgs)

in

( "-clear-package-db"

: "-global-package-db"

: map (("-package-db=" ++) . toFilePathNoTrailingSep) (bcoExtraDBs eeBaseConfigOpts)

) ++

( ("-package-db=" ++ toFilePathNoTrailingSep (bcoSnapDB eeBaseConfigOpts))

: ("-package-db=" ++ toFilePathNoTrailingSep (bcoLocalDB eeBaseConfigOpts))

: ["-hide-all-packages"]

) ++

cabalPackageArg ++

map ("-package-id=" ++) depsMinusCabal

-- This branch is usually taken for builds, and

-- is always taken for `stack sdist`.

--

-- This approach is debatable. It adds access to the

-- snapshot package database for Cabal. There are two

-- possible objections:

--

-- 1. This doesn't isolate the build enough; arbitrary

-- other packages available could cause the build to

-- succeed or fail.

--

-- 2. This doesn't provide enough packages: we should also

-- include the local database when building local packages.

--

-- Currently, this branch is only taken via `stack

-- sdist` or when explicitly requested in the

-- stack.yaml file.

_ ->

cabalPackageArg ++

("-clear-package-db"

: "-global-package-db"

: map (("-package-db=" ++) . toFilePathNoTrailingSep) (bcoExtraDBs eeBaseConfigOpts)

++ ["-package-db=" ++ toFilePathNoTrailingSep (bcoSnapDB eeBaseConfigOpts)])

setupArgs = ("--builddir=" ++ toFilePathNoTrailingSep distRelativeDir') : args

runExe exeName fullArgs =

runAndOutput `catch` \(ProcessExitedUnsuccessfully _ ec) -> do

bss <-

case mlogFile of

Nothing -> return []

Just (logFile, h) -> do

liftIO $ hClose h

runResourceT

$ CB.sourceFile (toFilePath logFile)

=$= CT.decodeUtf8Lenient

$$ mungeBuildOutput stripTHLoading makeAbsolute pkgDir

=$ CL.consume

throwM $ CabalExitedUnsuccessfully

ec

taskProvides

exeName

fullArgs

(fmap fst mlogFile)

bss

where

runAndOutput = case mlogFile of

Just (_, h) ->

sinkProcessStderrStdoutHandle (Just pkgDir) menv (toFilePath exeName) fullArgs h h

Nothing ->

void $ sinkProcessStderrStdout (Just pkgDir) menv (toFilePath exeName) fullArgs

(outputSink False LevelWarn)

(outputSink stripTHLoading LevelInfo)

outputSink excludeTH level =

CT.decodeUtf8Lenient

=$ mungeBuildOutput excludeTH makeAbsolute pkgDir

=$ CL.mapM_ (runInBase . monadLoggerLog $(TH.location >>= liftLoc) "" level)

-- If users want control, we should add a config option for this

makeAbsolute = stripTHLoading

wc <- getWhichCompiler

(exeName, fullArgs) <- case (esetupexehs, wc) of

(Left setupExe, _) -> return (setupExe, setupArgs)

(Right setuphs, compiler) -> do

distDir <- distDirFromDir pkgDir

let setupDir = distDir </> $(mkRelDir "setup")

outputFile = setupDir </> $(mkRelFile "setup")

ensureDir setupDir

compilerPath <-

case compiler of

Ghc -> getGhcPath