{-# LANGUAGE NoImplicitPrelude   #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE TypeFamilies        #-}

{-|
Module      : Stack.Build.Execute
Description : Perform a build.
License     : BSD-3-Clause

Perform a build.
-}

module Stack.Build.Execute
  ( printPlan
  , preFetch
  , executePlan
  -- * Running Setup.hs

  , ExcludeTHLoading (..)
  , KeepOutputOpen (..)
  ) where

import           Control.Concurrent.Execute
                   ( Action (..), ActionId (..), ActionType (..)
                   , Concurrency (..), runActions
                   )
import           Control.Concurrent.STM ( check )
import           Control.Monad.Extra ( whenJust )
import qualified Data.List as L
import           Data.List.Split ( chunksOf )
import qualified Data.Map.Merge.Strict as Map
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified Data.Text as T
import           Data.Tuple ( swap )
import           Distribution.System ( OS (..), Platform (..) )
import           Path ( (</>),  parent )
import           Path.CheckInstall ( warnInstallSearchPathIssues )
import           Path.Extra ( forgivingResolveFile, rejectMissingFile )
import           Path.IO ( ensureDir )
import           RIO.NonEmpty ( nonEmpty )
import qualified RIO.NonEmpty as NE
import           RIO.Process ( HasProcessContext (..), proc, runProcess_ )
import           Stack.Build.ExecuteEnv ( ExecuteEnv (..), withExecuteEnv )
import           Stack.Build.ExecutePackage
                   ( singleBench, singleBuild, singleTest )
import           Stack.Build.Haddock
                   ( generateDepsHaddockIndex
                   , generateLocalHaddockForHackageArchives
                   , generateLocalHaddockIndex, generateSnapHaddockIndex
                   , openHaddocksInBrowser
                   )
import           Stack.Constants ( bindirSuffix )
import           Stack.Coverage
                   ( deleteHpcReports, generateHpcMarkupIndex
                   , generateHpcUnifiedReport
                   )
import           Stack.GhcPkg ( unregisterGhcPkgIds )
import           Stack.Prelude
import           Stack.Types.Build
                   ( ExcludeTHLoading (..), KeepOutputOpen (..) )
import           Stack.Types.Build.Exception ( BuildPrettyException (..) )
import           Stack.Types.BuildOpts
                   ( BenchmarkOpts (..), BuildOpts (..), TestOpts (..) )
import           Stack.Types.BuildOptsCLI ( BuildOptsCLI (..) )
import           Stack.Types.BuildOptsMonoid ( ProgressBarFormat (..) )
import           Stack.Types.CompilerPaths ( HasCompiler (..), getGhcPkgExe )
import           Stack.Types.ComponentUtils
                   ( StackUnqualCompName, unqualCompToString )
import           Stack.Types.Config ( Config (..), HasConfig (..), buildOptsL )
import           Stack.Types.ConfigureOpts ( BaseConfigOpts (..) )
import           Stack.Types.DumpPackage ( DumpPackage (..) )
import           Stack.Types.EnvConfig
                   ( HasEnvConfig (..), bindirCompilerTools
                   , installationRootDeps, installationRootLocal
                   , packageDatabaseLocal
                   )
import           Stack.Types.EnvSettings ( EnvSettings (..) )
import           Stack.Types.GhcPkgId ( GhcPkgId )
import           Stack.Types.Installed
                   ( InstallLocation (..), InstalledMap
                   , installedPackageIdentifier
                   )
import           Stack.Types.NamedComponent
                   ( NamedComponent, benchComponents, testComponents )
import           Stack.Types.Package
                   ( LocalPackage (..), Package (..), packageIdentifier )
import           Stack.Types.Plan
                   ( Plan (..), Task (..), TaskConfigOpts (..), TaskType (..)
                   , taskLocation, taskProvides
                   )
import           Stack.Types.Platform ( HasPlatform (..) )
import           Stack.Types.Runner ( terminalL, viewExecutablePath )
import           Stack.Types.SourceMap ( Target )
import qualified System.Directory as D
import qualified System.FilePath as FP

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

-- a dry run.

preFetch :: HasEnvConfig env => Plan -> RIO env ()
preFetch :: forall env. HasEnvConfig env => Plan -> RIO env ()
preFetch Plan
plan
  | Set PackageLocationImmutable -> Bool
forall a. Set a -> Bool
Set.null Set PackageLocationImmutable
pkgLocs = Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Nothing to fetch"
  | Bool
otherwise = do
      Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$
           Utf8Builder
"Prefetching: "
        Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> [Utf8Builder] -> Utf8Builder
forall a. Monoid a => [a] -> a
mconcat (Utf8Builder -> [Utf8Builder] -> [Utf8Builder]
forall a. a -> [a] -> [a]
L.intersperse Utf8Builder
", " (PackageLocationImmutable -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display (PackageLocationImmutable -> Utf8Builder)
-> [PackageLocationImmutable] -> [Utf8Builder]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set PackageLocationImmutable -> [PackageLocationImmutable]
forall a. Set a -> [a]
Set.toList Set PackageLocationImmutable
pkgLocs))
      Set PackageLocationImmutable -> RIO env ()
forall env (f :: * -> *).
(HasPantryConfig env, HasLogFunc env, HasProcessContext env,
 Foldable f) =>
f PackageLocationImmutable -> RIO env ()
fetchPackages Set PackageLocationImmutable
pkgLocs
 where
  pkgLocs :: Set PackageLocationImmutable
pkgLocs = [Set PackageLocationImmutable] -> Set PackageLocationImmutable
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions ([Set PackageLocationImmutable] -> Set PackageLocationImmutable)
-> [Set PackageLocationImmutable] -> Set PackageLocationImmutable
forall a b. (a -> b) -> a -> b
$ (Task -> Set PackageLocationImmutable)
-> [Task] -> [Set PackageLocationImmutable]
forall a b. (a -> b) -> [a] -> [b]
map Task -> Set PackageLocationImmutable
forall {r}.
HasField "taskType" r TaskType =>
r -> Set PackageLocationImmutable
toPkgLoc ([Task] -> [Set PackageLocationImmutable])
-> [Task] -> [Set PackageLocationImmutable]
forall a b. (a -> b) -> a -> b
$ Map PackageName Task -> [Task]
forall k a. Map k a -> [a]
Map.elems Plan
plan.tasks

  toPkgLoc :: r -> Set PackageLocationImmutable
toPkgLoc r
task =
    case r
task.taskType of
      TTLocalMutable{} -> Set PackageLocationImmutable
forall a. Set a
Set.empty
      TTRemotePackage IsMutable
_ Package
_ PackageLocationImmutable
pkgloc -> PackageLocationImmutable -> Set PackageLocationImmutable
forall a. a -> Set a
Set.singleton PackageLocationImmutable
pkgloc

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

printPlan :: HasEnvConfig env => Plan -> RIO env ()
printPlan :: forall env. HasEnvConfig env => Plan -> RIO env ()
printPlan Plan
plan = do
  case Map GhcPkgId (PackageIdentifier, Text)
-> [(PackageIdentifier, Text)]
forall k a. Map k a -> [a]
Map.elems Plan
plan.unregisterLocal of
    [] -> StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyInfo (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$
               [Char] -> StyleDoc
flow [Char]
"No packages would be unregistered."
            StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    [(PackageIdentifier, Text)]
xs -> do
      let unregisterMsg :: (PackageIdentifier, Text) -> StyleDoc
unregisterMsg (PackageIdentifier
ident, Text
reason) = [StyleDoc] -> StyleDoc
fillSep ([StyleDoc] -> StyleDoc) -> [StyleDoc] -> StyleDoc
forall a b. (a -> b) -> a -> b
$
              [Char] -> StyleDoc
forall a. IsString a => [Char] -> a
fromString (PackageIdentifier -> [Char]
packageIdentifierString PackageIdentifier
ident)
            StyleDoc -> [StyleDoc] -> [StyleDoc]
forall a. a -> [a] -> [a]
: [ StyleDoc -> StyleDoc
parens (StyleDoc -> StyleDoc) -> StyleDoc -> StyleDoc
forall a b. (a -> b) -> a -> b
$ [Char] -> StyleDoc
flow (Text -> [Char]
T.unpack Text
reason) | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Text -> Bool
T.null Text
reason ]
      StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyInfo (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$
           [Char] -> StyleDoc
flow [Char]
"Would unregister locally:"
        StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
        StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
bulletedList (((PackageIdentifier, Text) -> StyleDoc)
-> [(PackageIdentifier, Text)] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map (PackageIdentifier, Text) -> StyleDoc
unregisterMsg [(PackageIdentifier, Text)]
xs)
        StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line

  case Map PackageName Task -> [Task]
forall k a. Map k a -> [a]
Map.elems Plan
plan.tasks of
    [] -> StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyInfo (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$
               [Char] -> StyleDoc
flow [Char]
"Nothing to build."
            StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    [Task]
xs -> do
      StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyInfo (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$
           [Char] -> StyleDoc
flow [Char]
"Would build:"
        StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
        StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
bulletedList ((Task -> StyleDoc) -> [Task] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map Task -> StyleDoc
displayTask [Task]
xs)
        StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line

  buildOpts <- Getting BuildOpts env BuildOpts -> RIO env BuildOpts
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting BuildOpts env BuildOpts
forall s. HasConfig s => Lens' s BuildOpts
Lens' env BuildOpts
buildOptsL
  let hasTests = Bool -> Bool
not (Bool -> Bool) -> (Task -> Bool) -> Task -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set StackUnqualCompName -> Bool
forall a. Set a -> Bool
Set.null (Set StackUnqualCompName -> Bool)
-> (Task -> Set StackUnqualCompName) -> Task -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set NamedComponent -> Set StackUnqualCompName
testComponents (Set NamedComponent -> Set StackUnqualCompName)
-> (Task -> Set NamedComponent) -> Task -> Set StackUnqualCompName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Task -> Set NamedComponent
taskComponents
      hasBenches = Bool -> Bool
not (Bool -> Bool) -> (Task -> Bool) -> Task -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set StackUnqualCompName -> Bool
forall a. Set a -> Bool
Set.null (Set StackUnqualCompName -> Bool)
-> (Task -> Set StackUnqualCompName) -> Task -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set NamedComponent -> Set StackUnqualCompName
benchComponents (Set NamedComponent -> Set StackUnqualCompName)
-> (Task -> Set NamedComponent) -> Task -> Set StackUnqualCompName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Task -> Set NamedComponent
taskComponents
      tests = Map PackageName Task -> [Task]
forall k a. Map k a -> [a]
Map.elems (Map PackageName Task -> [Task]) -> Map PackageName Task -> [Task]
forall a b. (a -> b) -> a -> b
$ (Task -> Bool) -> Map PackageName Task -> Map PackageName Task
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter Task -> Bool
hasTests Plan
plan.finals
      benches = Map PackageName Task -> [Task]
forall k a. Map k a -> [a]
Map.elems (Map PackageName Task -> [Task]) -> Map PackageName Task -> [Task]
forall a b. (a -> b) -> a -> b
$ (Task -> Bool) -> Map PackageName Task -> Map PackageName Task
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter Task -> Bool
hasBenches Plan
plan.finals
      runTests = BuildOpts
buildOpts.testOpts.runTests
      runBenchmarks = BuildOpts
buildOpts.benchmarkOpts.runBenchmarks

  unless (null tests) $
    if runTests
      then
        prettyInfo $
             flow "Would test:"
          <> line
          <> bulletedList (map displayTask tests)
          <> line
      else
        prettyInfo $
             fillSep
               [ flow "Would not test, as running disabled by"
               , style Shell "--no-run-tests"
               , "flag."
               ]
          <> line

  unless (null benches) $
    if runBenchmarks
      then
        prettyInfo $
             flow "Would benchmark:"
          <> line
          <> bulletedList (map displayTask benches)
          <> line
      else
        prettyInfo $
             fillSep
               [ flow "Would not benchmark, as running disabled by"
               , style Shell "--no-run-benchmarks"
               , "flag."
               ]
          <> line

  case Map.toList plan.installExes of
    [] -> StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyInfo (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$
               [Char] -> StyleDoc
flow [Char]
"No executables to be installed."
            StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    [(StackUnqualCompName, InstallLocation)]
xs -> do
      let executableMsg :: (StackUnqualCompName, InstallLocation) -> StyleDoc
executableMsg (StackUnqualCompName
name, InstallLocation
loc) = [StyleDoc] -> StyleDoc
fillSep ([StyleDoc] -> StyleDoc) -> [StyleDoc] -> StyleDoc
forall a b. (a -> b) -> a -> b
$
              [Char] -> StyleDoc
forall a. IsString a => [Char] -> a
fromString (StackUnqualCompName -> [Char]
unqualCompToString StackUnqualCompName
name)
            StyleDoc -> [StyleDoc] -> [StyleDoc]
forall a. a -> [a] -> [a]
: StyleDoc
"from"
            StyleDoc -> [StyleDoc] -> [StyleDoc]
forall a. a -> [a] -> [a]
: ( case InstallLocation
loc of
                  InstallLocation
Snap -> StyleDoc
"snapshot" :: StyleDoc
                  InstallLocation
Local -> StyleDoc
"local" :: StyleDoc
              )
            StyleDoc -> [StyleDoc] -> [StyleDoc]
forall a. a -> [a] -> [a]
: [StyleDoc
"database."]
      StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyInfo (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$
           [Char] -> StyleDoc
flow [Char]
"Would install executables:"
        StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
        StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
bulletedList (((StackUnqualCompName, InstallLocation) -> StyleDoc)
-> [(StackUnqualCompName, InstallLocation)] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map (StackUnqualCompName, InstallLocation) -> StyleDoc
executableMsg [(StackUnqualCompName, InstallLocation)]
xs)
        StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line

-- | For a dry run

displayTask :: Task -> StyleDoc
displayTask :: Task -> StyleDoc
displayTask Task
task = [StyleDoc] -> StyleDoc
fillSep ([StyleDoc] -> StyleDoc) -> [StyleDoc] -> StyleDoc
forall a b. (a -> b) -> a -> b
$
     [ [Char] -> StyleDoc
forall a. IsString a => [Char] -> a
fromString (PackageIdentifier -> [Char]
packageIdentifierString (Task -> PackageIdentifier
taskProvides Task
task)) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
":"
     ,    StyleDoc
"database="
       StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> ( case Task -> InstallLocation
taskLocation Task
task of
              InstallLocation
Snap -> StyleDoc
"snapshot" :: StyleDoc
              InstallLocation
Local -> StyleDoc
"local" :: StyleDoc
          )
       StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
","
     ,    StyleDoc
"source="
       StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> ( case Task
task.taskType of
              TTLocalMutable LocalPackage
lp -> Path Abs Dir -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty (Path Abs Dir -> StyleDoc) -> Path Abs Dir -> StyleDoc
forall a b. (a -> b) -> a -> b
$ Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent LocalPackage
lp.cabalFP
              TTRemotePackage IsMutable
_ Package
_ PackageLocationImmutable
pl -> [Char] -> StyleDoc
forall a. IsString a => [Char] -> a
fromString ([Char] -> StyleDoc) -> [Char] -> StyleDoc
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack (Text -> [Char]) -> Text -> [Char]
forall a b. (a -> b) -> a -> b
$ PackageLocationImmutable -> Text
forall a. Display a => a -> Text
textDisplay PackageLocationImmutable
pl
          )
       StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> if Set PackageIdentifier -> Bool
forall a. Set a -> Bool
Set.null Set PackageIdentifier
missing
            then StyleDoc
forall a. Monoid a => a
mempty
            else StyleDoc
","
     ]
  [StyleDoc] -> [StyleDoc] -> [StyleDoc]
forall a. Semigroup a => a -> a -> a
<> [ [StyleDoc] -> StyleDoc
fillSep ([StyleDoc] -> StyleDoc) -> [StyleDoc] -> StyleDoc
forall a b. (a -> b) -> a -> b
$
           StyleDoc
"after:"
         StyleDoc -> [StyleDoc] -> [StyleDoc]
forall a. a -> [a] -> [a]
: Maybe Style -> Bool -> [StyleDoc] -> [StyleDoc]
forall a. Pretty a => Maybe Style -> Bool -> [a] -> [StyleDoc]
mkNarrativeList Maybe Style
forall a. Maybe a
Nothing Bool
False
             ((PackageIdentifier -> StyleDoc)
-> [PackageIdentifier] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map PackageIdentifier -> StyleDoc
forall a. IsString a => PackageIdentifier -> a
fromPackageId (Set PackageIdentifier -> [PackageIdentifier]
forall a. Set a -> [a]
Set.toList Set PackageIdentifier
missing) :: [StyleDoc])
     | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Set PackageIdentifier -> Bool
forall a. Set a -> Bool
Set.null Set PackageIdentifier
missing
     ]
 where
  missing :: Set PackageIdentifier
missing = Task
task.configOpts.missing

-- | Perform the actual plan

executePlan ::
     HasEnvConfig env
  => BuildOptsCLI
  -> BaseConfigOpts
  -> [LocalPackage]
  -> [DumpPackage]
     -- ^ global packages

  -> [DumpPackage]
     -- ^ snapshot packages

  -> [DumpPackage]
     -- ^ project packages and local extra-deps

  -> InstalledMap
  -> Map PackageName Target
  -> Plan
  -> RIO env ()
executePlan :: forall env.
HasEnvConfig env =>
BuildOptsCLI
-> BaseConfigOpts
-> [LocalPackage]
-> [DumpPackage]
-> [DumpPackage]
-> [DumpPackage]
-> InstalledMap
-> Map PackageName Target
-> Plan
-> RIO env ()
executePlan
    BuildOptsCLI
boptsCli
    BaseConfigOpts
baseConfigOpts
    [LocalPackage]
locals
    [DumpPackage]
globalPackages
    [DumpPackage]
snapshotPackages
    [DumpPackage]
localPackages
    InstalledMap
installedMap
    Map PackageName Target
targets
    Plan
plan
  = do
    Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Executing the build plan"
    bopts <- Getting BuildOpts env BuildOpts -> RIO env BuildOpts
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting BuildOpts env BuildOpts
forall s. HasConfig s => Lens' s BuildOpts
Lens' env BuildOpts
buildOptsL
    withExecuteEnv
      bopts
      boptsCli
      baseConfigOpts
      locals
      globalPackages
      snapshotPackages
      localPackages
      mlargestPackageName
      (executePlan' installedMap targets plan)

    copyExecutables plan.installExes

    config <- view configL
    menv' <- liftIO $ config.processContextSettings EnvSettings
               { includeLocals = True
               , includeGhcPackagePath = True
               , stackExe = True
               , localeUtf8 = False
               , keepGhcRts = False
               }
    withProcessContext menv' $
      forM_ boptsCli.exec $ \([Char]
cmd, [[Char]]
args) ->
      [Char]
-> [[Char]] -> (ProcessConfig () () () -> RIO env ()) -> RIO env ()
forall env (m :: * -> *) a.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
 MonadIO m, HasCallStack) =>
[Char] -> [[Char]] -> (ProcessConfig () () () -> m a) -> m a
proc [Char]
cmd [[Char]]
args ProcessConfig () () () -> RIO env ()
forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
ProcessConfig stdin stdout stderr -> m ()
runProcess_
 where
  mlargestPackageName :: Maybe Int
mlargestPackageName =
    Set Int -> Maybe Int
forall a. Set a -> Maybe a
Set.lookupMax (Set Int -> Maybe Int) -> Set Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$
    (PackageName -> Int) -> Set PackageName -> Set Int
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map ([Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Char] -> Int) -> (PackageName -> [Char]) -> PackageName -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> [Char]
packageNameString) (Set PackageName -> Set Int) -> Set PackageName -> Set Int
forall a b. (a -> b) -> a -> b
$
    Map PackageName Task -> Set PackageName
forall k a. Map k a -> Set k
Map.keysSet Plan
plan.tasks Set PackageName -> Set PackageName -> Set PackageName
forall a. Semigroup a => a -> a -> a
<> Map PackageName Task -> Set PackageName
forall k a. Map k a -> Set k
Map.keysSet Plan
plan.finals

copyExecutables ::
     HasEnvConfig env
  => Map StackUnqualCompName InstallLocation
  -> RIO env ()
copyExecutables :: forall env.
HasEnvConfig env =>
Map StackUnqualCompName InstallLocation -> RIO env ()
copyExecutables Map StackUnqualCompName InstallLocation
exes | Map StackUnqualCompName InstallLocation -> Bool
forall k a. Map k a -> Bool
Map.null Map StackUnqualCompName InstallLocation
exes = () -> RIO env ()
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
copyExecutables Map StackUnqualCompName InstallLocation
exes = do
  snapBin <- (Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
bindirSuffix) (Path Abs Dir -> Path Abs Dir)
-> RIO env (Path Abs Dir) -> RIO env (Path Abs Dir)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RIO env (Path Abs Dir)
forall env. HasEnvConfig env => RIO env (Path Abs Dir)
installationRootDeps
  localBin <- (</> bindirSuffix) <$> installationRootLocal
  compilerSpecific <- (.installCompilerTool) <$> view buildOptsL
  destDir <- if compilerSpecific
               then bindirCompilerTools
               else view $ configL . to (.localBin)
  ensureDir destDir

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

  platform <- view platformL
  let ext =
        case Platform
platform of
          Platform Arch
_ OS
Windows -> [Char]
".exe"
          Platform
_ -> [Char]
""

  -- needed for windows, see below

  currExe <- toFilePath <$> viewExecutablePath

  installed <- forMaybeM (Map.toList exes) $ \(StackUnqualCompName
name, InstallLocation
loc) -> do
    let strName :: [Char]
strName = StackUnqualCompName -> [Char]
unqualCompToString StackUnqualCompName
name
        bindir :: Path Abs Dir
bindir =
            case InstallLocation
loc of
                InstallLocation
Snap -> Path Abs Dir
snapBin
                InstallLocation
Local -> Path Abs Dir
localBin
    mfp <- Path Abs Dir -> [Char] -> RIO env (Maybe (Path Abs File))
forall (m :: * -> *).
MonadIO m =>
Path Abs Dir -> [Char] -> m (Maybe (Path Abs File))
forgivingResolveFile Path Abs Dir
bindir ([Char]
strName [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
ext)
      RIO env (Maybe (Path Abs File))
-> (Maybe (Path Abs File) -> RIO env (Maybe (Path Abs File)))
-> RIO env (Maybe (Path Abs File))
forall a b. RIO env a -> (a -> RIO env b) -> RIO env b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe (Path Abs File) -> RIO env (Maybe (Path Abs File))
forall (m :: * -> *).
MonadIO m =>
Maybe (Path Abs File) -> m (Maybe (Path Abs File))
rejectMissingFile
    case mfp of
      Maybe (Path Abs File)
Nothing -> do
        [StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyWarnL
          [ [Char] -> StyleDoc
flow [Char]
"Couldn't find executable"
          , Style -> StyleDoc -> StyleDoc
style Style
Current ([Char] -> StyleDoc
forall a. IsString a => [Char] -> a
fromString [Char]
strName)
          , [Char] -> StyleDoc
flow [Char]
"in directory"
          , Path Abs Dir -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Abs Dir
bindir StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
          ]
        Maybe [Char] -> RIO env (Maybe [Char])
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe [Char]
forall a. Maybe a
Nothing
      Just Path Abs File
file -> do
        let destFile :: [Char]
destFile = [Char]
destDir' [Char] -> [Char] -> [Char]
FP.</> [Char]
strName [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
ext
        [StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyInfoL
          [ [Char] -> StyleDoc
flow [Char]
"Copying from"
          , Path Abs File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
file
          , StyleDoc
"to"
          , Style -> StyleDoc -> StyleDoc
style Style
File ([Char] -> StyleDoc
forall a. IsString a => [Char] -> a
fromString [Char]
destFile) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
          ]

        IO () -> RIO env ()
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO env ()) -> IO () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ case Platform
platform of
          Platform Arch
_ OS
Windows | [Char] -> [Char] -> Bool
FP.equalFilePath [Char]
destFile [Char]
currExe ->
              [Char] -> [Char] -> IO ()
windowsRenameCopy (Path Abs File -> [Char]
forall b t. Path b t -> [Char]
toFilePath Path Abs File
file) [Char]
destFile
          Platform
_ -> [Char] -> [Char] -> IO ()
D.copyFile (Path Abs File -> [Char]
forall b t. Path b t -> [Char]
toFilePath Path Abs File
file) [Char]
destFile
        Maybe [Char] -> RIO env (Maybe [Char])
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe [Char] -> RIO env (Maybe [Char]))
-> Maybe [Char] -> RIO env (Maybe [Char])
forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char]
strName [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
ext)

  unless (null installed) $ do
    prettyInfo $
         fillSep
           [ flow "Copied executables to"
           , pretty destDir <> ":"
           ]
      <> line
      <> bulletedList
           (map fromString installed :: [StyleDoc])
  unless compilerSpecific $ warnInstallSearchPathIssues destDir' installed

-- | 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 :: [Char] -> [Char] -> IO ()
windowsRenameCopy [Char]
src [Char]
dest = do
  [Char] -> [Char] -> IO ()
D.copyFile [Char]
src [Char]
new
  [Char] -> [Char] -> IO ()
D.renameFile [Char]
dest [Char]
old
  [Char] -> [Char] -> IO ()
D.renameFile [Char]
new [Char]
dest
 where
  new :: [Char]
new = [Char]
dest [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
".new"
  old :: [Char]
old = [Char]
dest [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
".old"

-- | Perform the actual plan (internal)

executePlan' ::
     HasEnvConfig env
  => InstalledMap
  -> Map PackageName Target
  -> Plan
  -> ExecuteEnv
  -> RIO env ()
executePlan' :: forall env.
HasEnvConfig env =>
InstalledMap
-> Map PackageName Target -> Plan -> ExecuteEnv -> RIO env ()
executePlan' InstalledMap
installedMap0 Map PackageName Target
targets Plan
plan ExecuteEnv
ee = do
  config <- Getting Config env Config -> RIO env Config
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Config env Config
forall env. HasConfig env => Lens' env Config
Lens' env Config
configL
  let !buildOpts = ExecuteEnv
ee.buildOpts
      !testOpts = BuildOpts
buildOpts.testOpts
      !benchmarkOpts = BuildOpts
buildOpts.benchmarkOpts
      runTests = TestOpts
testOpts.runTests
      runBenchmarks = BenchmarkOpts
benchmarkOpts.runBenchmarks
      noNotifyIfNoRunTests = Bool -> Bool
not Config
config.notifyIfNoRunTests
      noNotifyIfNoRunBenchmarks = Bool -> Bool
not Config
config.notifyIfNoRunBenchmarks
      hasTests = Bool -> Bool
not (Bool -> Bool) -> (Task -> Bool) -> Task -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set StackUnqualCompName -> Bool
forall a. Set a -> Bool
Set.null (Set StackUnqualCompName -> Bool)
-> (Task -> Set StackUnqualCompName) -> Task -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set NamedComponent -> Set StackUnqualCompName
testComponents (Set NamedComponent -> Set StackUnqualCompName)
-> (Task -> Set NamedComponent) -> Task -> Set StackUnqualCompName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Task -> Set NamedComponent
taskComponents
      hasBenches = Bool -> Bool
not (Bool -> Bool) -> (Task -> Bool) -> Task -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set StackUnqualCompName -> Bool
forall a. Set a -> Bool
Set.null (Set StackUnqualCompName -> Bool)
-> (Task -> Set StackUnqualCompName) -> Task -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set NamedComponent -> Set StackUnqualCompName
benchComponents (Set NamedComponent -> Set StackUnqualCompName)
-> (Task -> Set NamedComponent) -> Task -> Set StackUnqualCompName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Task -> Set NamedComponent
taskComponents
      tests = Map PackageName Task -> [Task]
forall k a. Map k a -> [a]
Map.elems (Map PackageName Task -> [Task]) -> Map PackageName Task -> [Task]
forall a b. (a -> b) -> a -> b
$ (Task -> Bool) -> Map PackageName Task -> Map PackageName Task
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter Task -> Bool
hasTests Plan
plan.finals
      benches = Map PackageName Task -> [Task]
forall k a. Map k a -> [a]
Map.elems (Map PackageName Task -> [Task]) -> Map PackageName Task -> [Task]
forall a b. (a -> b) -> a -> b
$ (Task -> Bool) -> Map PackageName Task -> Map PackageName Task
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter Task -> Bool
hasBenches Plan
plan.finals
  when testOpts.coverage deleteHpcReports
  whenJust (nonEmpty $ Map.toList plan.unregisterLocal) $ \NonEmpty (GhcPkgId, (PackageIdentifier, Text))
ids -> do
    localDB <- RIO env (Path Abs Dir)
forall env. HasEnvConfig env => RIO env (Path Abs Dir)
packageDatabaseLocal
    unregisterPackages localDB ids

  liftIO $ atomically $ modifyTVar' ee.localDumpPkgs $ \Map GhcPkgId DumpPackage
initMap ->
    (Map GhcPkgId DumpPackage -> GhcPkgId -> Map GhcPkgId DumpPackage)
-> Map GhcPkgId DumpPackage
-> [GhcPkgId]
-> Map GhcPkgId DumpPackage
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ((GhcPkgId -> Map GhcPkgId DumpPackage -> Map GhcPkgId DumpPackage)
-> Map GhcPkgId DumpPackage -> GhcPkgId -> Map GhcPkgId DumpPackage
forall a b c. (a -> b -> c) -> b -> a -> c
flip GhcPkgId -> Map GhcPkgId DumpPackage -> Map GhcPkgId DumpPackage
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete) Map GhcPkgId DumpPackage
initMap ([GhcPkgId] -> Map GhcPkgId DumpPackage)
-> [GhcPkgId] -> Map GhcPkgId DumpPackage
forall a b. (a -> b) -> a -> b
$ Map GhcPkgId (PackageIdentifier, Text) -> [GhcPkgId]
forall k a. Map k a -> [k]
Map.keys Plan
plan.unregisterLocal

  run <- askRunInIO

  -- If running tests concurrently with each other, then create an MVar

  -- which is empty while each test is being run.

  concurrentTests <- view $ configL . to (.concurrentTests)
  mtestLock <- if concurrentTests
                 then pure Nothing
                 else Just <$> liftIO (newMVar ())

  let actions = ((Maybe Task, Maybe Task) -> [Action])
-> [(Maybe Task, Maybe Task)] -> [Action]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (InstalledMap
-> Maybe (MVar ())
-> (RIO env () -> IO ())
-> ExecuteEnv
-> (Maybe Task, Maybe Task)
-> [Action]
forall env.
HasEnvConfig env =>
InstalledMap
-> Maybe (MVar ())
-> (RIO env () -> IO ())
-> ExecuteEnv
-> (Maybe Task, Maybe Task)
-> [Action]
toActions InstalledMap
installedMap' Maybe (MVar ())
mtestLock RIO env () -> IO ()
run ExecuteEnv
ee) ([(Maybe Task, Maybe Task)] -> [Action])
-> [(Maybe Task, Maybe Task)] -> [Action]
forall a b. (a -> b) -> a -> b
$
        Map PackageName (Maybe Task, Maybe Task)
-> [(Maybe Task, Maybe Task)]
forall k a. Map k a -> [a]
Map.elems (Map PackageName (Maybe Task, Maybe Task)
 -> [(Maybe Task, Maybe Task)])
-> Map PackageName (Maybe Task, Maybe Task)
-> [(Maybe Task, Maybe Task)]
forall a b. (a -> b) -> a -> b
$ SimpleWhenMissing PackageName Task (Maybe Task, Maybe Task)
-> SimpleWhenMissing PackageName Task (Maybe Task, Maybe Task)
-> SimpleWhenMatched PackageName Task Task (Maybe Task, Maybe Task)
-> Map PackageName Task
-> Map PackageName Task
-> Map PackageName (Maybe Task, Maybe Task)
forall k a c b.
Ord k =>
SimpleWhenMissing k a c
-> SimpleWhenMissing k b c
-> SimpleWhenMatched k a b c
-> Map k a
-> Map k b
-> Map k c
Map.merge
          ((PackageName -> Task -> (Maybe Task, Maybe Task))
-> SimpleWhenMissing PackageName Task (Maybe Task, Maybe Task)
forall (f :: * -> *) k x y.
Applicative f =>
(k -> x -> y) -> WhenMissing f k x y
Map.mapMissing (\PackageName
_ Task
b -> (Task -> Maybe Task
forall a. a -> Maybe a
Just Task
b, Maybe Task
forall a. Maybe a
Nothing)))
          ((PackageName -> Task -> (Maybe Task, Maybe Task))
-> SimpleWhenMissing PackageName Task (Maybe Task, Maybe Task)
forall (f :: * -> *) k x y.
Applicative f =>
(k -> x -> y) -> WhenMissing f k x y
Map.mapMissing (\PackageName
_ Task
f -> (Maybe Task
forall a. Maybe a
Nothing, Task -> Maybe Task
forall a. a -> Maybe a
Just Task
f)))
          ((PackageName -> Task -> Task -> (Maybe Task, Maybe Task))
-> SimpleWhenMatched PackageName Task Task (Maybe Task, Maybe Task)
forall (f :: * -> *) k x y z.
Applicative f =>
(k -> x -> y -> z) -> WhenMatched f k x y z
Map.zipWithMatched (\PackageName
_ Task
b Task
f -> (Task -> Maybe Task
forall a. a -> Maybe a
Just Task
b, Task -> Maybe Task
forall a. a -> Maybe a
Just Task
f)))
          Plan
plan.tasks
          Plan
plan.finals
  threads <- view $ configL . to (.jobs)
  let keepGoing = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe
        (Bool -> Bool
not (Map PackageName Task -> Bool
forall k a. Map k a -> Bool
Map.null Plan
plan.finals))
        BuildOpts
buildOpts.keepGoing
  terminal <- view terminalL
  terminalWidth <- view termWidthL
  unless (noNotifyIfNoRunTests || runTests || null tests) $
    prettyInfo $
      fillSep
        [ flow "All test running disabled by"
        , style Shell "--no-run-tests"
        , flow "flag. To mute this message in future, set"
        , style Shell (flow "notify-if-no-run-tests: false")
        , flow "in Stack's configuration."
        ]
  unless (noNotifyIfNoRunBenchmarks || runBenchmarks || null benches) $
    prettyInfo $
      fillSep
        [ flow "All benchmark running disabled by"
        , style Shell "--no-run-benchmarks"
        , flow "flag. To mute this message in future, set"
        , style Shell (flow "notify-if-no-run-benchmarks: false")
        , flow "in Stack's configuration."
        ]
  errs <- liftIO $ runActions threads keepGoing actions $
    \TVar Int
doneVar TVar (Set ActionId)
actionsVar -> do
      let total :: Int
total = [Action] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Action]
actions
          loop :: Int -> IO ()
loop Int
prev
            | Int
prev Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
total =
                RIO env () -> IO ()
run (RIO env () -> IO ()) -> RIO env () -> IO ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, HasCallStack, MonadReader env m, HasLogFunc env) =>
Utf8Builder -> m ()
logStickyDone
                  ( Utf8Builder
"Completed " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Int
total Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" action(s).")
            | Bool
otherwise = do
                inProgress <- TVar (Set ActionId) -> IO (Set ActionId)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar (Set ActionId)
actionsVar
                let packageNames = (ActionId -> PackageName) -> [ActionId] -> [PackageName]
forall a b. (a -> b) -> [a] -> [b]
map
                      (\(ActionId PackageIdentifier
pkgID ActionType
_) -> PackageIdentifier -> PackageName
pkgName PackageIdentifier
pkgID)
                      (Set ActionId -> [ActionId]
forall a. Set a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Set ActionId
inProgress)
                    nowBuilding :: [PackageName] -> Utf8Builder
                    nowBuilding []    = Utf8Builder
""
                    nowBuilding [PackageName]
names = [Utf8Builder] -> Utf8Builder
forall a. Monoid a => [a] -> a
mconcat ([Utf8Builder] -> Utf8Builder) -> [Utf8Builder] -> Utf8Builder
forall a b. (a -> b) -> a -> b
$
                        Utf8Builder
": "
                      Utf8Builder -> [Utf8Builder] -> [Utf8Builder]
forall a. a -> [a] -> [a]
: Utf8Builder -> [Utf8Builder] -> [Utf8Builder]
forall a. a -> [a] -> [a]
L.intersperse Utf8Builder
", " ((PackageName -> Utf8Builder) -> [PackageName] -> [Utf8Builder]
forall a b. (a -> b) -> [a] -> [b]
map PackageName -> Utf8Builder
forall a. IsString a => PackageName -> a
fromPackageName [PackageName]
names)
                    progressFormat = BuildOpts
buildOpts.progressBar
                    progressLine Int
prev' Int
total' =
                         Utf8Builder
"Progress "
                      Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Int
prev' Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"/" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Int
total'
                      Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> if ProgressBarFormat
progressFormat ProgressBarFormat -> ProgressBarFormat -> Bool
forall a. Eq a => a -> a -> Bool
== ProgressBarFormat
CountOnlyBar
                           then Utf8Builder
forall a. Monoid a => a
mempty
                           else [PackageName] -> Utf8Builder
nowBuilding [PackageName]
packageNames
                    ellipsize Int
n Text
text =
                      if Text -> Int
T.length Text
text Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
n Bool -> Bool -> Bool
|| ProgressBarFormat
progressFormat ProgressBarFormat -> ProgressBarFormat -> Bool
forall a. Eq a => a -> a -> Bool
/= ProgressBarFormat
CappedBar
                        then Text
text
                        else Int -> Text -> Text
T.take (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Text
text Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"…"
                when (terminal && progressFormat /= NoBar) $
                  run $ logSticky $ display $ ellipsize terminalWidth $
                    utf8BuilderToText $ progressLine prev total
                done <- atomically $ do
                  done <- readTVar doneVar
                  check $ done /= prev
                  pure done
                loop done
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
total Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
loop Int
0
  when testOpts.coverage $ do
    generateHpcUnifiedReport
    generateHpcMarkupIndex
  unless (null errs) $
    prettyThrowM $ ExecutionFailure errs
  when buildOpts.buildHaddocks $ do
    if buildOpts.haddockForHackage
      then
        generateLocalHaddockForHackageArchives ee.locals
      else do
        snapshotDumpPkgs <- liftIO (readTVarIO ee.snapshotDumpPkgs)
        localDumpPkgs <- liftIO (readTVarIO ee.localDumpPkgs)
        generateLocalHaddockIndex ee.baseConfigOpts localDumpPkgs ee.locals
        generateDepsHaddockIndex
          ee.baseConfigOpts
          ee.globalDumpPkgs
          snapshotDumpPkgs
          localDumpPkgs
          ee.locals
        generateSnapHaddockIndex
          ee.baseConfigOpts
          ee.globalDumpPkgs
          snapshotDumpPkgs
        when buildOpts.openHaddocks $ do
          let planPkgs, localPkgs, installedPkgs, availablePkgs
                :: Map PackageName (PackageIdentifier, InstallLocation)
              planPkgs =
                (Task -> (PackageIdentifier, InstallLocation))
-> Map PackageName Task
-> Map PackageName (PackageIdentifier, InstallLocation)
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (Task -> PackageIdentifier
taskProvides (Task -> PackageIdentifier)
-> (Task -> InstallLocation)
-> Task
-> (PackageIdentifier, InstallLocation)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Task -> InstallLocation
taskLocation) Plan
plan.tasks
              localPkgs =
                [(PackageName, (PackageIdentifier, InstallLocation))]
-> Map PackageName (PackageIdentifier, InstallLocation)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
                  [ (Package
p.name, (Package -> PackageIdentifier
packageIdentifier Package
p, InstallLocation
Local))
                  | Package
p <- (LocalPackage -> Package) -> [LocalPackage] -> [Package]
forall a b. (a -> b) -> [a] -> [b]
map (.package) ExecuteEnv
ee.locals
                  ]
              installedPkgs =
                ((InstallLocation, Installed)
 -> (PackageIdentifier, InstallLocation))
-> InstalledMap
-> Map PackageName (PackageIdentifier, InstallLocation)
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map ((InstallLocation, PackageIdentifier)
-> (PackageIdentifier, InstallLocation)
forall a b. (a, b) -> (b, a)
swap ((InstallLocation, PackageIdentifier)
 -> (PackageIdentifier, InstallLocation))
-> ((InstallLocation, Installed)
    -> (InstallLocation, PackageIdentifier))
-> (InstallLocation, Installed)
-> (PackageIdentifier, InstallLocation)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Installed -> PackageIdentifier)
-> (InstallLocation, Installed)
-> (InstallLocation, PackageIdentifier)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Installed -> PackageIdentifier
installedPackageIdentifier) InstalledMap
installedMap'
              availablePkgs = [Map PackageName (PackageIdentifier, InstallLocation)]
-> Map PackageName (PackageIdentifier, InstallLocation)
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions [Map PackageName (PackageIdentifier, InstallLocation)
planPkgs, Map PackageName (PackageIdentifier, InstallLocation)
localPkgs, Map PackageName (PackageIdentifier, InstallLocation)
installedPkgs]
          openHaddocksInBrowser
            ee.baseConfigOpts
            availablePkgs
            (Map.keysSet targets)
 where
  installedMap' :: InstalledMap
installedMap' = InstalledMap -> Map PackageName () -> InstalledMap
forall k a b. Ord k => Map k a -> Map k b -> Map k a
Map.difference InstalledMap
installedMap0
                (Map PackageName () -> InstalledMap)
-> Map PackageName () -> InstalledMap
forall a b. (a -> b) -> a -> b
$ [(PackageName, ())] -> Map PackageName ()
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
                ([(PackageName, ())] -> Map PackageName ())
-> [(PackageName, ())] -> Map PackageName ()
forall a b. (a -> b) -> a -> b
$ ((PackageIdentifier, Text) -> (PackageName, ()))
-> [(PackageIdentifier, Text)] -> [(PackageName, ())]
forall a b. (a -> b) -> [a] -> [b]
map (\(PackageIdentifier
ident, Text
_) -> (PackageIdentifier -> PackageName
pkgName PackageIdentifier
ident, ()))
                ([(PackageIdentifier, Text)] -> [(PackageName, ())])
-> [(PackageIdentifier, Text)] -> [(PackageName, ())]
forall a b. (a -> b) -> a -> b
$ Map GhcPkgId (PackageIdentifier, Text)
-> [(PackageIdentifier, Text)]
forall k a. Map k a -> [a]
Map.elems Plan
plan.unregisterLocal

unregisterPackages ::
     (HasCompiler env, HasPlatform env, HasProcessContext env, HasTerm env)
  => Path Abs Dir
  -> NonEmpty (GhcPkgId, (PackageIdentifier, Text))
  -> RIO env ()
unregisterPackages :: forall env.
(HasCompiler env, HasPlatform env, HasProcessContext env,
 HasTerm env) =>
Path Abs Dir
-> NonEmpty (GhcPkgId, (PackageIdentifier, Text)) -> RIO env ()
unregisterPackages Path Abs Dir
localDB NonEmpty (GhcPkgId, (PackageIdentifier, Text))
ids = do
  let logReason :: PackageIdentifier -> Text -> m ()
logReason PackageIdentifier
ident Text
reason =
        [StyleDoc] -> m ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyInfoL
          (  [ [Char] -> StyleDoc
forall a. IsString a => [Char] -> a
fromString (PackageIdentifier -> [Char]
packageIdentifierString PackageIdentifier
ident) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
":"
             , StyleDoc
"unregistering"
             ]
          [StyleDoc] -> [StyleDoc] -> [StyleDoc]
forall a. Semigroup a => a -> a -> a
<> [ StyleDoc -> StyleDoc
parens ([Char] -> StyleDoc
flow ([Char] -> StyleDoc) -> [Char] -> StyleDoc
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
reason) | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Text -> Bool
T.null Text
reason ]
          )
  -- GHC versions >= 8.2.1 support batch unregistering of packages. See

  -- https://gitlab.haskell.org/ghc/ghc/issues/12637

  platform <- Getting Platform env Platform -> RIO env Platform
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Platform env Platform
forall env. HasPlatform env => Lens' env Platform
Lens' env Platform
platformL
  -- According to

  -- https://support.microsoft.com/en-us/help/830473/command-prompt-cmd-exe-command-line-string-limitation

  -- the maximum command line length on Windows since XP is 8191 characters. We

  -- use conservative batch size of 100 ids on this OS thus argument name

  -- '-ipid', package name, its version and a hash should fit well into this

  -- limit. On Unix-like systems we're limited by ARG_MAX which is normally

  -- hundreds of kilobytes so batch size of 500 should work fine.

  let batchSize = case Platform
platform of
        Platform Arch
_ OS
Windows -> Int
100
        Platform
_ -> Int
500
  let chunksOfNE Int
size = ([a] -> Maybe (NonEmpty a)) -> [[a]] -> [NonEmpty a]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe [a] -> Maybe (NonEmpty a)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty ([[a]] -> [NonEmpty a])
-> (NonEmpty a -> [[a]]) -> NonEmpty a -> [NonEmpty a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [a] -> [[a]]
forall e. Int -> [e] -> [[e]]
chunksOf Int
size ([a] -> [[a]]) -> (NonEmpty a -> [a]) -> NonEmpty a -> [[a]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty a -> [a]
forall a. NonEmpty a -> [a]
NE.toList
  for_ (chunksOfNE batchSize ids) $ \NonEmpty (GhcPkgId, (PackageIdentifier, Text))
batch -> do
    NonEmpty (GhcPkgId, (PackageIdentifier, Text))
-> ((GhcPkgId, (PackageIdentifier, Text)) -> RIO env ())
-> RIO env ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ NonEmpty (GhcPkgId, (PackageIdentifier, Text))
batch (((GhcPkgId, (PackageIdentifier, Text)) -> RIO env ())
 -> RIO env ())
-> ((GhcPkgId, (PackageIdentifier, Text)) -> RIO env ())
-> RIO env ()
forall a b. (a -> b) -> a -> b
$ \(GhcPkgId
_, (PackageIdentifier
ident, Text
reason)) -> PackageIdentifier -> Text -> RIO env ()
forall {env} {m :: * -> *}.
(HasTerm env, MonadReader env m, MonadIO m) =>
PackageIdentifier -> Text -> m ()
logReason PackageIdentifier
ident Text
reason
    pkg <- RIO env GhcPkgExe
forall env. HasCompiler env => RIO env GhcPkgExe
getGhcPkgExe
    unregisterGhcPkgIds True pkg localDB $ fmap (Right . fst) batch

toActions ::
     HasEnvConfig env
  => InstalledMap
  -> Maybe (MVar ())
  -> (RIO env () -> IO ())
  -> ExecuteEnv
  -> (Maybe Task, Maybe Task) -- build and final

  -> [Action]
toActions :: forall env.
HasEnvConfig env =>
InstalledMap
-> Maybe (MVar ())
-> (RIO env () -> IO ())
-> ExecuteEnv
-> (Maybe Task, Maybe Task)
-> [Action]
toActions InstalledMap
installedMap Maybe (MVar ())
mtestLock RIO env () -> IO ()
runInBase ExecuteEnv
ee (Maybe Task
mbuild, Maybe Task
mfinal) =
  [Action]
abuild [Action] -> [Action] -> [Action]
forall a. [a] -> [a] -> [a]
++ [Action]
afinal
 where
  abuild :: [Action]
abuild = case Maybe Task
mbuild of
    Maybe Task
Nothing -> []
    Just Task
task ->
      [ Action
          { actionId :: ActionId
actionId = PackageIdentifier -> ActionType -> ActionId
ActionId (Task -> PackageIdentifier
taskProvides Task
task) ActionType
ATBuild
          , actionDeps :: Set ActionId
actionDeps =
              (PackageIdentifier -> ActionId)
-> Set PackageIdentifier -> Set ActionId
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (PackageIdentifier -> ActionType -> ActionId
`ActionId` ActionType
ATBuild) Task
task.configOpts.missing
          , action :: ActionContext -> IO ()
action =
              \ActionContext
ac -> RIO env () -> IO ()
runInBase (RIO env () -> IO ()) -> RIO env () -> IO ()
forall a b. (a -> b) -> a -> b
$ ActionContext
-> ExecuteEnv -> Task -> InstalledMap -> Bool -> RIO env ()
forall env.
(HasEnvConfig env, HasRunner env) =>
ActionContext
-> ExecuteEnv -> Task -> InstalledMap -> Bool -> RIO env ()
singleBuild ActionContext
ac ExecuteEnv
ee Task
task InstalledMap
installedMap Bool
False
          , concurrency :: Concurrency
concurrency = Concurrency
ConcurrencyAllowed
          }
      ]
  afinal :: [Action]
afinal = case Maybe Task
mfinal of
    Maybe Task
Nothing -> []
    Just Task
task ->
      ( if Task
task.allInOne
          then [Action] -> [Action]
forall a. a -> a
id
          else (:) Action
            { actionId :: ActionId
actionId = PackageIdentifier -> ActionType -> ActionId
ActionId PackageIdentifier
pkgId ActionType
ATBuildFinal
            , actionDeps :: Set ActionId
actionDeps = Set ActionId -> Set ActionId
addBuild
                ((PackageIdentifier -> ActionId)
-> Set PackageIdentifier -> Set ActionId
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (PackageIdentifier -> ActionType -> ActionId
`ActionId` ActionType
ATBuild) Task
task.configOpts.missing)
            , action :: ActionContext -> IO ()
action =
                \ActionContext
ac -> RIO env () -> IO ()
runInBase (RIO env () -> IO ()) -> RIO env () -> IO ()
forall a b. (a -> b) -> a -> b
$ ActionContext
-> ExecuteEnv -> Task -> InstalledMap -> Bool -> RIO env ()
forall env.
(HasEnvConfig env, HasRunner env) =>
ActionContext
-> ExecuteEnv -> Task -> InstalledMap -> Bool -> RIO env ()
singleBuild ActionContext
ac ExecuteEnv
ee Task
task InstalledMap
installedMap Bool
True
            , concurrency :: Concurrency
concurrency = Concurrency
ConcurrencyAllowed
            }
      ) ([Action] -> [Action]) -> [Action] -> [Action]
forall a b. (a -> b) -> a -> b
$
      -- These are the "final" actions - running test suites and benchmarks,

      -- unless --no-run-tests or --no-run-benchmarks is enabled.

      ( if Set StackUnqualCompName -> Bool
forall a. Set a -> Bool
Set.null Set StackUnqualCompName
tests Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
runTests
          then [Action] -> [Action]
forall a. a -> a
id
          else (:) Action
            { actionId :: ActionId
actionId = PackageIdentifier -> ActionType -> ActionId
ActionId PackageIdentifier
pkgId ActionType
ATRunTests
            , actionDeps :: Set ActionId
actionDeps = Set ActionId
finalDeps
            , action :: ActionContext -> IO ()
action = \ActionContext
ac -> Maybe (MVar ()) -> IO () -> IO ()
forall {m :: * -> *} {b}.
MonadUnliftIO m =>
Maybe (MVar ()) -> m b -> m b
withLock Maybe (MVar ())
mtestLock (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ RIO env () -> IO ()
runInBase (RIO env () -> IO ()) -> RIO env () -> IO ()
forall a b. (a -> b) -> a -> b
$
                TestOpts
-> [StackUnqualCompName]
-> ActionContext
-> ExecuteEnv
-> Task
-> InstalledMap
-> RIO env ()
forall env.
HasEnvConfig env =>
TestOpts
-> [StackUnqualCompName]
-> ActionContext
-> ExecuteEnv
-> Task
-> InstalledMap
-> RIO env ()
singleTest TestOpts
topts (Set StackUnqualCompName -> [StackUnqualCompName]
forall a. Set a -> [a]
Set.toList Set StackUnqualCompName
tests) ActionContext
ac ExecuteEnv
ee Task
task InstalledMap
installedMap
              -- Always allow tests tasks to run concurrently with other tasks,

              -- particularly build tasks. Note that 'mtestLock' can optionally

              -- make it so that only one test is run at a time.

            , concurrency :: Concurrency
concurrency = Concurrency
ConcurrencyAllowed
            }
      ) ([Action] -> [Action]) -> [Action] -> [Action]
forall a b. (a -> b) -> a -> b
$
      ( if Set StackUnqualCompName -> Bool
forall a. Set a -> Bool
Set.null Set StackUnqualCompName
benches Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
runBenchmarks
          then [Action] -> [Action]
forall a. a -> a
id
          else (:) Action
            { actionId :: ActionId
actionId = PackageIdentifier -> ActionType -> ActionId
ActionId PackageIdentifier
pkgId ActionType
ATRunBenchmarks
            , actionDeps :: Set ActionId
actionDeps = Set ActionId
finalDeps
            , action :: ActionContext -> IO ()
action = \ActionContext
ac -> RIO env () -> IO ()
runInBase (RIO env () -> IO ()) -> RIO env () -> IO ()
forall a b. (a -> b) -> a -> b
$
                BenchmarkOpts
-> [StackUnqualCompName]
-> ActionContext
-> ExecuteEnv
-> Task
-> InstalledMap
-> RIO env ()
forall env.
HasEnvConfig env =>
BenchmarkOpts
-> [StackUnqualCompName]
-> ActionContext
-> ExecuteEnv
-> Task
-> InstalledMap
-> RIO env ()
singleBench
                  BenchmarkOpts
beopts
                  (Set StackUnqualCompName -> [StackUnqualCompName]
forall a. Set a -> [a]
Set.toList Set StackUnqualCompName
benches)
                  ActionContext
ac
                  ExecuteEnv
ee
                  Task
task
                  InstalledMap
installedMap
              -- Never run benchmarks concurrently with any other task, see

              -- #3663

            , concurrency :: Concurrency
concurrency = Concurrency
ConcurrencyDisallowed
            }
      )
      []
     where
      pkgId :: PackageIdentifier
pkgId = Task -> PackageIdentifier
taskProvides Task
task
      comps :: Set NamedComponent
comps = Task -> Set NamedComponent
taskComponents Task
task
      tests :: Set StackUnqualCompName
tests = Set NamedComponent -> Set StackUnqualCompName
testComponents Set NamedComponent
comps
      benches :: Set StackUnqualCompName
benches = Set NamedComponent -> Set StackUnqualCompName
benchComponents Set NamedComponent
comps
      finalDeps :: Set ActionId
finalDeps =
        if Task
task.allInOne
          then Set ActionId -> Set ActionId
addBuild Set ActionId
forall a. Monoid a => a
mempty
          else ActionId -> Set ActionId
forall a. a -> Set a
Set.singleton (PackageIdentifier -> ActionType -> ActionId
ActionId PackageIdentifier
pkgId ActionType
ATBuildFinal)
      addBuild :: Set ActionId -> Set ActionId
addBuild =
        case Maybe Task
mbuild of
          Maybe Task
Nothing -> Set ActionId -> Set ActionId
forall a. a -> a
id
          Just Task
_ -> ActionId -> Set ActionId -> Set ActionId
forall a. Ord a => a -> Set a -> Set a
Set.insert (ActionId -> Set ActionId -> Set ActionId)
-> ActionId -> Set ActionId -> Set ActionId
forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> ActionType -> ActionId
ActionId PackageIdentifier
pkgId ActionType
ATBuild
  withLock :: Maybe (MVar ()) -> m b -> m b
withLock Maybe (MVar ())
Nothing m b
f = m b
f
  withLock (Just MVar ()
lock) m b
f = MVar () -> (() -> m b) -> m b
forall (m :: * -> *) a b.
MonadUnliftIO m =>
MVar a -> (a -> m b) -> m b
withMVar MVar ()
lock ((() -> m b) -> m b) -> (() -> m b) -> m b
forall a b. (a -> b) -> a -> b
$ \() -> m b
f
  bopts :: BuildOpts
bopts = ExecuteEnv
ee.buildOpts
  topts :: TestOpts
topts = BuildOpts
bopts.testOpts
  beopts :: BenchmarkOpts
beopts = BuildOpts
bopts.benchmarkOpts
  runTests :: Bool
runTests = TestOpts
topts.runTests
  runBenchmarks :: Bool
runBenchmarks = BenchmarkOpts
beopts.runBenchmarks

taskComponents :: Task -> Set NamedComponent
taskComponents :: Task -> Set NamedComponent
taskComponents Task
task =
  case Task
task.taskType of
    TTLocalMutable LocalPackage
lp -> LocalPackage
lp.components -- FIXME probably just want lpWanted

    TTRemotePackage{} -> Set NamedComponent
forall a. Set a
Set.empty