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

-- | 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 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           Distribution.Version ( mkVersion )
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 (..), Plan (..)
                   , Task (..), TaskConfigOpts (..), TaskType (..), taskLocation
                   , taskProvides
                   )
import           Stack.Types.Build.Exception ( BuildPrettyException (..) )
import           Stack.Types.BuildOpts ( BuildOpts (..), TestOpts (..)
                   )
import           Stack.Types.BuildOptsCLI ( BuildOptsCLI (..) )
import           Stack.Types.BuildOptsMonoid ( ProgressBarFormat (..) )
import           Stack.Types.Compiler ( ActualCompiler (..) )
import           Stack.Types.CompilerPaths ( HasCompiler (..), getGhcPkgExe )
import           Stack.Types.Config
                   ( Config (..), HasConfig (..), buildOptsL )
import           Stack.Types.ConfigureOpts
                   ( BaseConfigOpts (..) )
import           Stack.Types.DumpPackage ( DumpPackage (..) )
import           Stack.Types.EnvConfig
                   ( HasEnvConfig (..), actualCompilerVersionL
                   , 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.Platform ( HasPlatform (..) )
import           Stack.Types.Runner ( HasRunner, terminalL )
import           Stack.Types.SourceMap ( Target )
import qualified System.Directory as D
import           System.Environment ( getExecutablePath )
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 :: (HasRunner env, HasTerm env) => Plan -> RIO env ()
printPlan :: forall env. (HasRunner env, HasTerm 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

  let hasTests :: Task -> Bool
hasTests = Bool -> Bool
not (Bool -> Bool) -> (Task -> Bool) -> Task -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Text -> Bool
forall a. Set a -> Bool
Set.null (Set Text -> Bool) -> (Task -> Set Text) -> Task -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set NamedComponent -> Set Text
testComponents (Set NamedComponent -> Set Text)
-> (Task -> Set NamedComponent) -> Task -> Set Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Task -> Set NamedComponent
taskComponents
      hasBenches :: Task -> Bool
hasBenches = Bool -> Bool
not (Bool -> Bool) -> (Task -> Bool) -> Task -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Text -> Bool
forall a. Set a -> Bool
Set.null (Set Text -> Bool) -> (Task -> Set Text) -> Task -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set NamedComponent -> Set Text
benchComponents (Set NamedComponent -> Set Text)
-> (Task -> Set NamedComponent) -> Task -> Set Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Task -> Set NamedComponent
taskComponents
      tests :: [Task]
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 :: [Task]
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

  Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Task] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Task]
tests) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ 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 test:"
      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]
tests)
      StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line

  Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Task] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Task]
benches) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ 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 benchmark:"
      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]
benches)
      StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line

  case Map Text InstallLocation -> [(Text, InstallLocation)]
forall k a. Map k a -> [(k, a)]
Map.toList Plan
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
    [(Text, InstallLocation)]
xs -> do
      let executableMsg :: (Text, InstallLocation) -> StyleDoc
executableMsg (Text
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 (Text -> [Char]
T.unpack Text
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 (((Text, InstallLocation) -> StyleDoc)
-> [(Text, InstallLocation)] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map (Text, InstallLocation) -> StyleDoc
executableMsg [(Text, 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] -- ^ local packages

            -> 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"
    BuildOpts
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
    BuildOpts
-> BuildOptsCLI
-> BaseConfigOpts
-> [LocalPackage]
-> [DumpPackage]
-> [DumpPackage]
-> [DumpPackage]
-> Maybe Int
-> (ExecuteEnv -> RIO env ())
-> RIO env ()
forall env a.
HasEnvConfig env =>
BuildOpts
-> BuildOptsCLI
-> BaseConfigOpts
-> [LocalPackage]
-> [DumpPackage]
-> [DumpPackage]
-> [DumpPackage]
-> Maybe Int
-> (ExecuteEnv -> RIO env a)
-> RIO env a
withExecuteEnv
      BuildOpts
bopts
      BuildOptsCLI
boptsCli
      BaseConfigOpts
baseConfigOpts
      [LocalPackage]
locals
      [DumpPackage]
globalPackages
      [DumpPackage]
snapshotPackages
      [DumpPackage]
localPackages
      Maybe Int
mlargestPackageName
      (InstalledMap
-> Map PackageName Target -> Plan -> ExecuteEnv -> RIO env ()
forall env.
HasEnvConfig env =>
InstalledMap
-> Map PackageName Target -> Plan -> ExecuteEnv -> RIO env ()
executePlan' InstalledMap
installedMap Map PackageName Target
targets Plan
plan)

    Map Text InstallLocation -> RIO env ()
forall env.
HasEnvConfig env =>
Map Text InstallLocation -> RIO env ()
copyExecutables Plan
plan.installExes

    Config
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
    ProcessContext
menv' <- IO ProcessContext -> RIO env ProcessContext
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ProcessContext -> RIO env ProcessContext)
-> IO ProcessContext -> RIO env ProcessContext
forall a b. (a -> b) -> a -> b
$ Config
config.processContextSettings EnvSettings
               { $sel:includeLocals:EnvSettings :: Bool
includeLocals = Bool
True
               , $sel:includeGhcPackagePath:EnvSettings :: Bool
includeGhcPackagePath = Bool
True
               , $sel:stackExe:EnvSettings :: Bool
stackExe = Bool
True
               , $sel:localeUtf8:EnvSettings :: Bool
localeUtf8 = Bool
False
               , $sel:keepGhcRts:EnvSettings :: Bool
keepGhcRts = Bool
False
               }
    ProcessContext -> RIO env () -> RIO env ()
forall env a.
HasProcessContext env =>
ProcessContext -> RIO env a -> RIO env a
withProcessContext ProcessContext
menv' (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
      [([Char], [[Char]])]
-> (([Char], [[Char]]) -> RIO env ()) -> RIO env ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ BuildOptsCLI
boptsCli.exec ((([Char], [[Char]]) -> RIO env ()) -> RIO env ())
-> (([Char], [[Char]]) -> RIO env ()) -> RIO env ()
forall a b. (a -> b) -> a -> b
$ \([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 Text InstallLocation
    -> RIO env ()
copyExecutables :: forall env.
HasEnvConfig env =>
Map Text InstallLocation -> RIO env ()
copyExecutables Map Text InstallLocation
exes | Map Text InstallLocation -> Bool
forall k a. Map k a -> Bool
Map.null Map Text InstallLocation
exes = () -> RIO env ()
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
copyExecutables Map Text InstallLocation
exes = do
  Path Abs Dir
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
  Path Abs Dir
localBin <- (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)
installationRootLocal
  Bool
compilerSpecific <- (.installCompilerTool) (BuildOpts -> Bool) -> RIO env BuildOpts -> RIO env Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
  Path Abs Dir
destDir <- if Bool
compilerSpecific
               then RIO env (Path Abs Dir)
forall env (m :: * -> *).
(HasEnvConfig env, MonadReader env m, MonadThrow m) =>
m (Path Abs Dir)
bindirCompilerTools
               else Getting (Path Abs Dir) env (Path Abs Dir) -> RIO env (Path Abs Dir)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting (Path Abs Dir) env (Path Abs Dir)
 -> RIO env (Path Abs Dir))
-> Getting (Path Abs Dir) env (Path Abs Dir)
-> RIO env (Path Abs Dir)
forall a b. (a -> b) -> a -> b
$ (Config -> Const (Path Abs Dir) Config)
-> env -> Const (Path Abs Dir) env
forall env. HasConfig env => Lens' env Config
Lens' env Config
configL ((Config -> Const (Path Abs Dir) Config)
 -> env -> Const (Path Abs Dir) env)
-> ((Path Abs Dir -> Const (Path Abs Dir) (Path Abs Dir))
    -> Config -> Const (Path Abs Dir) Config)
-> Getting (Path Abs Dir) env (Path Abs Dir)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Config -> Path Abs Dir) -> SimpleGetter Config (Path Abs Dir)
forall s a. (s -> a) -> SimpleGetter s a
to (.localBin)
  Path Abs Dir -> RIO env ()
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir Path Abs Dir
destDir

  [Char]
destDir' <- IO [Char] -> RIO env [Char]
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Char] -> RIO env [Char])
-> (Path Abs Dir -> IO [Char]) -> Path Abs Dir -> RIO env [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> IO [Char]
D.canonicalizePath ([Char] -> IO [Char])
-> (Path Abs Dir -> [Char]) -> Path Abs Dir -> IO [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs Dir -> [Char]
forall b t. Path b t -> [Char]
toFilePath (Path Abs Dir -> RIO env [Char]) -> Path Abs Dir -> RIO env [Char]
forall a b. (a -> b) -> a -> b
$ Path Abs Dir
destDir

  Platform
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
  let ext :: [Char]
ext =
        case Platform
platform of
          Platform Arch
_ OS
Windows -> [Char]
".exe"
          Platform
_ -> [Char]
""

  [Char]
currExe <- IO [Char] -> RIO env [Char]
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [Char]
getExecutablePath -- needed for windows, see below


  [Text]
installed <- [(Text, InstallLocation)]
-> ((Text, InstallLocation) -> RIO env (Maybe Text))
-> RIO env [Text]
forall (m :: * -> *) a b.
Monad m =>
[a] -> (a -> m (Maybe b)) -> m [b]
forMaybeM (Map Text InstallLocation -> [(Text, InstallLocation)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Text InstallLocation
exes) (((Text, InstallLocation) -> RIO env (Maybe Text))
 -> RIO env [Text])
-> ((Text, InstallLocation) -> RIO env (Maybe Text))
-> RIO env [Text]
forall a b. (a -> b) -> a -> b
$ \(Text
name, InstallLocation
loc) -> do
    let bindir :: Path Abs Dir
bindir =
            case InstallLocation
loc of
                InstallLocation
Snap -> Path Abs Dir
snapBin
                InstallLocation
Local -> Path Abs Dir
localBin
    Maybe (Path Abs File)
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 (Text -> [Char]
T.unpack Text
name [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 Maybe (Path Abs File)
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] -> StyleDoc) -> [Char] -> StyleDoc
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
name)
          , [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 Text -> RIO env (Maybe Text)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Text
forall a. Maybe a
Nothing
      Just Path Abs File
file -> do
        let destFile :: [Char]
destFile = [Char]
destDir' [Char] -> [Char] -> [Char]
FP.</> Text -> [Char]
T.unpack Text
name [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 Text -> RIO env (Maybe Text)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text -> RIO env (Maybe Text))
-> Maybe Text -> RIO env (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just (Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack [Char]
ext)

  Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
installed) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ 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
$
         [StyleDoc] -> StyleDoc
fillSep
           [ [Char] -> StyleDoc
flow [Char]
"Copied executables to"
           , Path Abs Dir -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Abs Dir
destDir StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
":"
           ]
      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
           ((Text -> StyleDoc) -> [Text] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> StyleDoc
forall a. IsString a => [Char] -> a
fromString ([Char] -> StyleDoc) -> (Text -> [Char]) -> Text -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack (Text -> [Char]) -> (Text -> Text) -> Text -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
forall a. Display a => a -> Text
textDisplay) [Text]
installed :: [StyleDoc])
  Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
compilerSpecific (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ [Char] -> [Text] -> RIO env ()
forall env. HasConfig env => [Char] -> [Text] -> RIO env ()
warnInstallSearchPathIssues [Char]
destDir' [Text]
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
  let !buildOpts :: BuildOpts
buildOpts = ExecuteEnv
ee.buildOpts
  let !testOpts :: TestOpts
testOpts = BuildOpts
buildOpts.testOpts
  Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when TestOpts
testOpts.coverage RIO env ()
forall env. HasEnvConfig env => RIO env ()
deleteHpcReports
  ActualCompiler
cv <- Getting ActualCompiler env ActualCompiler -> RIO env ActualCompiler
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting ActualCompiler env ActualCompiler
forall env. HasSourceMap env => SimpleGetter env ActualCompiler
SimpleGetter env ActualCompiler
actualCompilerVersionL
  case [(GhcPkgId, (PackageIdentifier, Text))]
-> Maybe (NonEmpty (GhcPkgId, (PackageIdentifier, Text)))
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty ([(GhcPkgId, (PackageIdentifier, Text))]
 -> Maybe (NonEmpty (GhcPkgId, (PackageIdentifier, Text))))
-> [(GhcPkgId, (PackageIdentifier, Text))]
-> Maybe (NonEmpty (GhcPkgId, (PackageIdentifier, Text)))
forall a b. (a -> b) -> a -> b
$ Map GhcPkgId (PackageIdentifier, Text)
-> [(GhcPkgId, (PackageIdentifier, Text))]
forall k a. Map k a -> [(k, a)]
Map.toList Plan
plan.unregisterLocal of
    Maybe (NonEmpty (GhcPkgId, (PackageIdentifier, Text)))
Nothing -> () -> RIO env ()
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Just NonEmpty (GhcPkgId, (PackageIdentifier, Text))
ids -> do
      Path Abs Dir
localDB <- RIO env (Path Abs Dir)
forall env. HasEnvConfig env => RIO env (Path Abs Dir)
packageDatabaseLocal
      ActualCompiler
-> Path Abs Dir
-> NonEmpty (GhcPkgId, (PackageIdentifier, Text))
-> RIO env ()
forall env.
(HasCompiler env, HasPlatform env, HasProcessContext env,
 HasTerm env) =>
ActualCompiler
-> Path Abs Dir
-> NonEmpty (GhcPkgId, (PackageIdentifier, Text))
-> RIO env ()
unregisterPackages ActualCompiler
cv Path Abs Dir
localDB NonEmpty (GhcPkgId, (PackageIdentifier, Text))
ids

  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
$ STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar (Map GhcPkgId DumpPackage)
-> (Map GhcPkgId DumpPackage -> Map GhcPkgId DumpPackage) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' ExecuteEnv
ee.localDumpPkgs ((Map GhcPkgId DumpPackage -> Map GhcPkgId DumpPackage) -> STM ())
-> (Map GhcPkgId DumpPackage -> Map GhcPkgId DumpPackage) -> STM ()
forall a b. (a -> b) -> a -> b
$ \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

  RIO env () -> IO ()
run <- RIO env (RIO env () -> IO ())
forall (m :: * -> *) a. MonadUnliftIO m => m (m a -> IO a)
askRunInIO

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

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

  Bool
concurrentTests <- Getting Bool env Bool -> RIO env Bool
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting Bool env Bool -> RIO env Bool)
-> Getting Bool env Bool -> RIO env Bool
forall a b. (a -> b) -> a -> b
$ (Config -> Const Bool Config) -> env -> Const Bool env
forall env. HasConfig env => Lens' env Config
Lens' env Config
configL ((Config -> Const Bool Config) -> env -> Const Bool env)
-> ((Bool -> Const Bool Bool) -> Config -> Const Bool Config)
-> Getting Bool env Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Config -> Bool) -> SimpleGetter Config Bool
forall s a. (s -> a) -> SimpleGetter s a
to (.concurrentTests)
  Maybe (MVar ())
mtestLock <- if Bool
concurrentTests
                 then Maybe (MVar ()) -> RIO env (Maybe (MVar ()))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (MVar ())
forall a. Maybe a
Nothing
                 else MVar () -> Maybe (MVar ())
forall a. a -> Maybe a
Just (MVar () -> Maybe (MVar ()))
-> RIO env (MVar ()) -> RIO env (Maybe (MVar ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (MVar ()) -> RIO env (MVar ())
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (() -> IO (MVar ())
forall (m :: * -> *) a. MonadIO m => a -> m (MVar a)
newMVar ())

  let actions :: [Action]
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
  Int
threads <- Getting Int env Int -> RIO env Int
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting Int env Int -> RIO env Int)
-> Getting Int env Int -> RIO env Int
forall a b. (a -> b) -> a -> b
$ (Config -> Const Int Config) -> env -> Const Int env
forall env. HasConfig env => Lens' env Config
Lens' env Config
configL ((Config -> Const Int Config) -> env -> Const Int env)
-> ((Int -> Const Int Int) -> Config -> Const Int Config)
-> Getting Int env Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Config -> Int) -> SimpleGetter Config Int
forall s a. (s -> a) -> SimpleGetter s a
to (.jobs)
  let keepGoing :: Bool
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
  Bool
terminal <- Getting Bool env Bool -> RIO env Bool
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Bool env Bool
forall env. HasRunner env => Lens' env Bool
Lens' env Bool
terminalL
  Int
terminalWidth <- Getting Int env Int -> RIO env Int
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Int env Int
forall env. HasTerm env => Lens' env Int
Lens' env Int
termWidthL
  [SomeException]
errs <- IO [SomeException] -> RIO env [SomeException]
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [SomeException] -> RIO env [SomeException])
-> IO [SomeException] -> RIO env [SomeException]
forall a b. (a -> b) -> a -> b
$ Int
-> Bool
-> [Action]
-> (TVar Int -> TVar (Set ActionId) -> IO ())
-> IO [SomeException]
runActions Int
threads Bool
keepGoing [Action]
actions ((TVar Int -> TVar (Set ActionId) -> IO ()) -> IO [SomeException])
-> (TVar Int -> TVar (Set ActionId) -> IO ()) -> IO [SomeException]
forall a b. (a -> b) -> a -> b
$
    \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
                Set ActionId
inProgress <- TVar (Set ActionId) -> IO (Set ActionId)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar (Set ActionId)
actionsVar
                let packageNames :: [PackageName]
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 :: [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 :: ProgressBarFormat
progressFormat = BuildOpts
buildOpts.progressBar
                    progressLine :: Int -> Int -> Utf8Builder
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 -> Text -> Text
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
"…"
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
terminal Bool -> Bool -> Bool
&& ProgressBarFormat
progressFormat ProgressBarFormat -> ProgressBarFormat -> Bool
forall a. Eq a => a -> a -> Bool
/= ProgressBarFormat
NoBar) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                  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 ()
logSticky (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display (Text -> Utf8Builder) -> Text -> Utf8Builder
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
ellipsize Int
terminalWidth (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$
                    Utf8Builder -> Text
utf8BuilderToText (Utf8Builder -> Text) -> Utf8Builder -> Text
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Utf8Builder
progressLine Int
prev Int
total
                Int
done <- STM Int -> IO Int
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM Int -> IO Int) -> STM Int -> IO Int
forall a b. (a -> b) -> a -> b
$ do
                  Int
done <- TVar Int -> STM Int
forall a. TVar a -> STM a
readTVar TVar Int
doneVar
                  Bool -> STM ()
check (Bool -> STM ()) -> Bool -> STM ()
forall a b. (a -> b) -> a -> b
$ Int
done Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
prev
                  Int -> STM Int
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
done
                Int -> IO ()
loop Int
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
  Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when TestOpts
testOpts.coverage (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
    RIO env ()
forall env. HasEnvConfig env => RIO env ()
generateHpcUnifiedReport
    RIO env ()
forall env. HasEnvConfig env => RIO env ()
generateHpcMarkupIndex
  Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([SomeException] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SomeException]
errs) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
    BuildPrettyException -> RIO env ()
forall e (m :: * -> *) a.
(Exception e, MonadThrow m, Pretty e) =>
e -> m a
prettyThrowM (BuildPrettyException -> RIO env ())
-> BuildPrettyException -> RIO env ()
forall a b. (a -> b) -> a -> b
$ [SomeException] -> BuildPrettyException
ExecutionFailure [SomeException]
errs
  Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when BuildOpts
buildOpts.buildHaddocks (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
    if BuildOpts
buildOpts.haddockForHackage
      then
        [LocalPackage] -> RIO env ()
forall env.
(HasEnvConfig env, HasTerm env) =>
[LocalPackage] -> RIO env ()
generateLocalHaddockForHackageArchives ExecuteEnv
ee.locals
      else do
        Map GhcPkgId DumpPackage
snapshotDumpPkgs <- IO (Map GhcPkgId DumpPackage) -> RIO env (Map GhcPkgId DumpPackage)
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (TVar (Map GhcPkgId DumpPackage) -> IO (Map GhcPkgId DumpPackage)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO ExecuteEnv
ee.snapshotDumpPkgs)
        Map GhcPkgId DumpPackage
localDumpPkgs <- IO (Map GhcPkgId DumpPackage) -> RIO env (Map GhcPkgId DumpPackage)
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (TVar (Map GhcPkgId DumpPackage) -> IO (Map GhcPkgId DumpPackage)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO ExecuteEnv
ee.localDumpPkgs)
        BaseConfigOpts
-> Map GhcPkgId DumpPackage -> [LocalPackage] -> RIO env ()
forall env.
(HasCompiler env, HasProcessContext env, HasTerm env) =>
BaseConfigOpts
-> Map GhcPkgId DumpPackage -> [LocalPackage] -> RIO env ()
generateLocalHaddockIndex ExecuteEnv
ee.baseConfigOpts Map GhcPkgId DumpPackage
localDumpPkgs ExecuteEnv
ee.locals
        BaseConfigOpts
-> Map GhcPkgId DumpPackage
-> Map GhcPkgId DumpPackage
-> Map GhcPkgId DumpPackage
-> [LocalPackage]
-> RIO env ()
forall env.
(HasCompiler env, HasProcessContext env, HasTerm env) =>
BaseConfigOpts
-> Map GhcPkgId DumpPackage
-> Map GhcPkgId DumpPackage
-> Map GhcPkgId DumpPackage
-> [LocalPackage]
-> RIO env ()
generateDepsHaddockIndex
          ExecuteEnv
ee.baseConfigOpts
          ExecuteEnv
ee.globalDumpPkgs
          Map GhcPkgId DumpPackage
snapshotDumpPkgs
          Map GhcPkgId DumpPackage
localDumpPkgs
          ExecuteEnv
ee.locals
        BaseConfigOpts
-> Map GhcPkgId DumpPackage
-> Map GhcPkgId DumpPackage
-> RIO env ()
forall env.
(HasCompiler env, HasProcessContext env, HasTerm env) =>
BaseConfigOpts
-> Map GhcPkgId DumpPackage
-> Map GhcPkgId DumpPackage
-> RIO env ()
generateSnapHaddockIndex
          ExecuteEnv
ee.baseConfigOpts
          ExecuteEnv
ee.globalDumpPkgs
          Map GhcPkgId DumpPackage
snapshotDumpPkgs
        Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when BuildOpts
buildOpts.openHaddocks (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
          let planPkgs, localPkgs, installedPkgs, availablePkgs
                :: Map PackageName (PackageIdentifier, InstallLocation)
              planPkgs :: 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 :: Map PackageName (PackageIdentifier, InstallLocation)
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 :: Map PackageName (PackageIdentifier, InstallLocation)
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)
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]
          BaseConfigOpts
-> Map PackageName (PackageIdentifier, InstallLocation)
-> Set PackageName
-> RIO env ()
forall env.
HasTerm env =>
BaseConfigOpts
-> Map PackageName (PackageIdentifier, InstallLocation)
-> Set PackageName
-> RIO env ()
openHaddocksInBrowser
            ExecuteEnv
ee.baseConfigOpts
            Map PackageName (PackageIdentifier, InstallLocation)
availablePkgs
            (Map PackageName Target -> Set PackageName
forall k a. Map k a -> Set k
Map.keysSet Map PackageName Target
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)
  => ActualCompiler
  -> Path Abs Dir
  -> NonEmpty (GhcPkgId, (PackageIdentifier, Text))
  -> RIO env ()
unregisterPackages :: forall env.
(HasCompiler env, HasPlatform env, HasProcessContext env,
 HasTerm env) =>
ActualCompiler
-> Path Abs Dir
-> NonEmpty (GhcPkgId, (PackageIdentifier, Text))
-> RIO env ()
unregisterPackages ActualCompiler
cv 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 ]
          )
  let unregisterSinglePkg :: (PackageIdentifier
 -> GhcPkgId -> Either PackageIdentifier GhcPkgId)
-> (GhcPkgId, (PackageIdentifier, Text)) -> RIO env ()
unregisterSinglePkg PackageIdentifier -> GhcPkgId -> Either PackageIdentifier GhcPkgId
select (GhcPkgId
gid, (PackageIdentifier
ident, Text
reason)) = do
        PackageIdentifier -> Text -> RIO env ()
forall {env} {m :: * -> *}.
(HasTerm env, MonadReader env m, MonadIO m) =>
PackageIdentifier -> Text -> m ()
logReason PackageIdentifier
ident Text
reason
        GhcPkgExe
pkg <- RIO env GhcPkgExe
forall env. HasCompiler env => RIO env GhcPkgExe
getGhcPkgExe
        Bool
-> GhcPkgExe
-> Path Abs Dir
-> NonEmpty (Either PackageIdentifier GhcPkgId)
-> RIO env ()
forall env.
(HasCompiler env, HasProcessContext env, HasTerm env) =>
Bool
-> GhcPkgExe
-> Path Abs Dir
-> NonEmpty (Either PackageIdentifier GhcPkgId)
-> RIO env ()
unregisterGhcPkgIds Bool
True GhcPkgExe
pkg Path Abs Dir
localDB (NonEmpty (Either PackageIdentifier GhcPkgId) -> RIO env ())
-> NonEmpty (Either PackageIdentifier GhcPkgId) -> RIO env ()
forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> GhcPkgId -> Either PackageIdentifier GhcPkgId
select PackageIdentifier
ident GhcPkgId
gid Either PackageIdentifier GhcPkgId
-> [Either PackageIdentifier GhcPkgId]
-> NonEmpty (Either PackageIdentifier GhcPkgId)
forall a. a -> [a] -> NonEmpty a
:| []
  case ActualCompiler
cv of
    -- GHC versions >= 8.2.1 support batch unregistering of packages. See

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

    ACGhc Version
v | Version
v Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
>= [Int] -> Version
mkVersion [Int
8, Int
2, Int
1] -> do
      Platform
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 :: Int
batchSize = case Platform
platform of
            Platform Arch
_ OS
Windows -> Int
100
            Platform
_ -> Int
500
      let chunksOfNE :: Int -> NonEmpty a -> [NonEmpty a]
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
      [NonEmpty (GhcPkgId, (PackageIdentifier, Text))]
-> (NonEmpty (GhcPkgId, (PackageIdentifier, Text)) -> RIO env ())
-> RIO env ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (Int
-> NonEmpty (GhcPkgId, (PackageIdentifier, Text))
-> [NonEmpty (GhcPkgId, (PackageIdentifier, Text))]
forall {a}. Int -> NonEmpty a -> [NonEmpty a]
chunksOfNE Int
batchSize NonEmpty (GhcPkgId, (PackageIdentifier, Text))
ids) ((NonEmpty (GhcPkgId, (PackageIdentifier, Text)) -> RIO env ())
 -> RIO env ())
-> (NonEmpty (GhcPkgId, (PackageIdentifier, Text)) -> RIO env ())
-> RIO env ()
forall a b. (a -> b) -> a -> b
$ \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
        GhcPkgExe
pkg <- RIO env GhcPkgExe
forall env. HasCompiler env => RIO env GhcPkgExe
getGhcPkgExe
        Bool
-> GhcPkgExe
-> Path Abs Dir
-> NonEmpty (Either PackageIdentifier GhcPkgId)
-> RIO env ()
forall env.
(HasCompiler env, HasProcessContext env, HasTerm env) =>
Bool
-> GhcPkgExe
-> Path Abs Dir
-> NonEmpty (Either PackageIdentifier GhcPkgId)
-> RIO env ()
unregisterGhcPkgIds Bool
True GhcPkgExe
pkg Path Abs Dir
localDB (NonEmpty (Either PackageIdentifier GhcPkgId) -> RIO env ())
-> NonEmpty (Either PackageIdentifier GhcPkgId) -> RIO env ()
forall a b. (a -> b) -> a -> b
$ ((GhcPkgId, (PackageIdentifier, Text))
 -> Either PackageIdentifier GhcPkgId)
-> NonEmpty (GhcPkgId, (PackageIdentifier, Text))
-> NonEmpty (Either PackageIdentifier GhcPkgId)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (GhcPkgId -> Either PackageIdentifier GhcPkgId
forall a b. b -> Either a b
Right (GhcPkgId -> Either PackageIdentifier GhcPkgId)
-> ((GhcPkgId, (PackageIdentifier, Text)) -> GhcPkgId)
-> (GhcPkgId, (PackageIdentifier, Text))
-> Either PackageIdentifier GhcPkgId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GhcPkgId, (PackageIdentifier, Text)) -> GhcPkgId
forall a b. (a, b) -> a
fst) NonEmpty (GhcPkgId, (PackageIdentifier, Text))
batch

    -- GHC versions >= 7.9 support unregistering of packages via their GhcPkgId.

    ACGhc Version
v | Version
v Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
>= [Int] -> Version
mkVersion [Int
7, Int
9] ->
      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))
ids (((GhcPkgId, (PackageIdentifier, Text)) -> RIO env ())
 -> RIO env ())
-> ((PackageIdentifier
     -> GhcPkgId -> Either PackageIdentifier GhcPkgId)
    -> (GhcPkgId, (PackageIdentifier, Text)) -> RIO env ())
-> (PackageIdentifier
    -> GhcPkgId -> Either PackageIdentifier GhcPkgId)
-> RIO env ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PackageIdentifier
 -> GhcPkgId -> Either PackageIdentifier GhcPkgId)
-> (GhcPkgId, (PackageIdentifier, Text)) -> RIO env ()
unregisterSinglePkg ((PackageIdentifier
  -> GhcPkgId -> Either PackageIdentifier GhcPkgId)
 -> RIO env ())
-> (PackageIdentifier
    -> GhcPkgId -> Either PackageIdentifier GhcPkgId)
-> RIO env ()
forall a b. (a -> b) -> a -> b
$ \PackageIdentifier
_ident GhcPkgId
gid -> GhcPkgId -> Either PackageIdentifier GhcPkgId
forall a b. b -> Either a b
Right GhcPkgId
gid

    ActualCompiler
_ -> 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))
ids (((GhcPkgId, (PackageIdentifier, Text)) -> RIO env ())
 -> RIO env ())
-> ((PackageIdentifier
     -> GhcPkgId -> Either PackageIdentifier GhcPkgId)
    -> (GhcPkgId, (PackageIdentifier, Text)) -> RIO env ())
-> (PackageIdentifier
    -> GhcPkgId -> Either PackageIdentifier GhcPkgId)
-> RIO env ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PackageIdentifier
 -> GhcPkgId -> Either PackageIdentifier GhcPkgId)
-> (GhcPkgId, (PackageIdentifier, Text)) -> RIO env ()
unregisterSinglePkg ((PackageIdentifier
  -> GhcPkgId -> Either PackageIdentifier GhcPkgId)
 -> RIO env ())
-> (PackageIdentifier
    -> GhcPkgId -> Either PackageIdentifier GhcPkgId)
-> RIO env ()
forall a b. (a -> b) -> a -> b
$ \PackageIdentifier
ident GhcPkgId
_gid -> PackageIdentifier -> Either PackageIdentifier GhcPkgId
forall a b. a -> Either a b
Left PackageIdentifier
ident

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
          { $sel:actionId:Action :: ActionId
actionId = PackageIdentifier -> ActionType -> ActionId
ActionId (Task -> PackageIdentifier
taskProvides Task
task) ActionType
ATBuild
          , $sel:actionDeps:Action :: 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
          , $sel:action: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
          , $sel:concurrency:Action :: 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
            { $sel:actionId:Action :: ActionId
actionId = PackageIdentifier -> ActionType -> ActionId
ActionId PackageIdentifier
pkgId ActionType
ATBuildFinal
            , $sel:actionDeps:Action :: 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)
            , $sel:action: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
            , $sel:concurrency:Action :: Concurrency
concurrency = Concurrency
ConcurrencyAllowed
            }
      ) ([Action] -> [Action]) -> [Action] -> [Action]
forall a b. (a -> b) -> a -> b
$
      -- These are the "final" actions - running tests and benchmarks.

      ( if Set Text -> Bool
forall a. Set a -> Bool
Set.null Set Text
tests
          then [Action] -> [Action]
forall a. a -> a
id
          else (:) Action
            { $sel:actionId:Action :: ActionId
actionId = PackageIdentifier -> ActionType -> ActionId
ActionId PackageIdentifier
pkgId ActionType
ATRunTests
            , $sel:actionDeps:Action :: Set ActionId
actionDeps = Set ActionId
finalDeps
            , $sel:action: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
-> [Text]
-> ActionContext
-> ExecuteEnv
-> Task
-> InstalledMap
-> RIO env ()
forall env.
HasEnvConfig env =>
TestOpts
-> [Text]
-> ActionContext
-> ExecuteEnv
-> Task
-> InstalledMap
-> RIO env ()
singleTest TestOpts
topts (Set Text -> [Text]
forall a. Set a -> [a]
Set.toList Set Text
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.

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

              -- #3663

            , $sel:concurrency:Action :: 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 Text
tests = Set NamedComponent -> Set Text
testComponents Set NamedComponent
comps
      benches :: Set Text
benches = Set NamedComponent -> Set Text
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

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