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

-- | Perform a build

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

  , ExecuteEnv
  , withExecuteEnv
  , withSingleContext
  , ExcludeTHLoading (..)
  , KeepOutputOpen (..)
  ) where

import           Control.Concurrent.Execute
                   ( Action (..), ActionContext (..), ActionId (..)
                   , ActionType (..)
                   , Concurrency (..), runActions
                   )
import           Control.Concurrent.STM ( check )
import           Crypto.Hash ( SHA256 (..), hashWith )
import           Data.Attoparsec.Text ( char, choice, digit, parseOnly )
import qualified Data.Attoparsec.Text as P ( string )
import qualified Data.ByteArray as Mem ( convert )
import qualified Data.ByteString as S
import qualified Data.ByteString.Builder ( toLazyByteString )
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Base64.URL as B64URL
import           Data.Char ( isSpace )
import           Conduit
                   ( ConduitT, awaitForever, runConduitRes, sinkHandle
                   , withSinkFile, withSourceFile, yield
                   )
import qualified Data.Conduit.Binary as CB
import qualified Data.Conduit.Filesystem as CF
import qualified Data.Conduit.List as CL
import           Data.Conduit.Process.Typed ( createSource )
import qualified Data.Conduit.Text as CT
import qualified Data.List as L
import           Data.List.NonEmpty ( nonEmpty )
import qualified Data.List.NonEmpty as NonEmpty ( toList )
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.Text.Encoding ( decodeUtf8 )
import           Data.Tuple ( swap )
import           Data.Time
                   ( ZonedTime, getZonedTime, formatTime, defaultTimeLocale )
import qualified Data.ByteString.Char8 as S8
import qualified Distribution.PackageDescription as C
import           Distribution.Pretty ( prettyShow )
import qualified Distribution.Simple.Build.Macros as C
import           Distribution.System ( OS (Windows), Platform (Platform) )
import qualified Distribution.Text as C
import           Distribution.Types.MungedPackageName
                   ( encodeCompatPackageName )
import           Distribution.Types.PackageName ( mkPackageName )
import           Distribution.Types.UnqualComponentName
                   ( mkUnqualComponentName )
import           Distribution.Verbosity ( showForCabal )
import           Distribution.Version ( mkVersion )
import           Pantry.Internal.Companion ( Companion, withCompanion )
import           Path
                   ( PathException, (</>), addExtension, filename
                   , isProperPrefixOf, parent, parseRelDir, parseRelFile
                   , stripProperPrefix
                   )
import           Path.CheckInstall ( warnInstallSearchPathIssues )
import           Path.Extra
                   ( forgivingResolveFile, rejectMissingFile
                   , toFilePathNoTrailingSep
                   )
import           Path.IO
                   ( copyFile, doesDirExist, doesFileExist, ensureDir
                   , ignoringAbsence, removeDirRecur, removeFile, renameDir
                   , renameFile
                   )
import           RIO.Process
                   ( HasProcessContext, byteStringInput, doesExecutableExist
                   , eceExitCode, findExecutable, getStderr, getStdout, inherit
                   , modifyEnvVars, proc, readProcess_, runProcess_, setStderr
                   , setStdin, setStdout, showProcessArgDebug, useHandleOpen
                   , waitExitCode, withModifyEnvVars, withProcessWait
                   , withWorkingDir
                   )
import           Stack.Build.Cache
                   ( TestStatus (..), deleteCaches, getTestStatus
                   , markExeInstalled, markExeNotInstalled, readPrecompiledCache
                   , setTestStatus, tryGetCabalMod, tryGetConfigCache
                   , tryGetPackageProjectRoot, tryGetSetupConfigMod
                   , writeBuildCache, writeCabalMod, writeConfigCache
                   , writeFlagCache, writePrecompiledCache
                   , writePackageProjectRoot, writeSetupConfigMod
                   )
import           Stack.Build.Haddock
                   ( generateDepsHaddockIndex, generateLocalHaddockIndex
                   , generateSnapHaddockIndex, openHaddocksInBrowser
                   )
import           Stack.Build.Installed (  )
import           Stack.Build.Source ( addUnlistedToBuildCache )
import           Stack.Build.Target (  )
import           Stack.Config ( checkOwnership )
import           Stack.Constants
                   ( bindirSuffix, cabalPackageName, compilerOptionsCabalFlag
                   , osIsWindows, relDirBuild, relDirDist, relDirSetup
                   , relDirSetupExeCache, relDirSetupExeSrc, relFileBuildLock
                   , relFileConfigure, relFileSetupHs, relFileSetupLhs
                   , relFileSetupLower, relFileSetupMacrosH, setupGhciShimCode
                   , stackProgName, testGhcEnvRelFile
                   )
import           Stack.Constants.Config
                   ( distDirFromDir, distRelativeDir, hpcDirFromDir
                   , hpcRelativeDir, setupConfigFromDir
                   )
import           Stack.Coverage
                   ( deleteHpcReports, generateHpcMarkupIndex, generateHpcReport
                   , generateHpcUnifiedReport, updateTixFile
                   )
import           Stack.DefaultColorWhen ( defaultColorWhen )
import           Stack.GhcPkg ( ghcPkgPathEnvVar, unregisterGhcPkgIds )
import           Stack.Package ( buildLogPath )
import           Stack.PackageDump ( conduitDumpPackage, ghcPkgDescribe )
import           Stack.Prelude
import           Stack.Types.ApplyGhcOptions ( ApplyGhcOptions (..) )
import           Stack.Types.Build
                   ( ConfigCache (..), Plan (..), PrecompiledCache (..)
                   , Task (..), TaskConfigOpts (..), TaskType (..)
                   , configCacheComponents, taskIsTarget, taskLocation
                   )
import           Stack.Types.Build.Exception
                   ( BuildException (..), BuildPrettyException (..) )
import           Stack.Types.BuildConfig
                   ( BuildConfig (..), HasBuildConfig (..), projectRootL )
import           Stack.Types.BuildOpts
                   ( BenchmarkOpts (..), BuildOpts (..), BuildOptsCLI (..)
                   , CabalVerbosity (..), HaddockOpts (..), TestOpts (..)
                   )
import           Stack.Types.Compiler
                   ( ActualCompiler (..), WhichCompiler (..)
                   , compilerVersionString, getGhcVersion, whichCompilerL
                   )
import           Stack.Types.CompilerPaths
                   ( CompilerPaths (..), GhcPkgExe (..), HasCompiler (..)
                   , cabalVersionL, cpWhich, getCompilerPath, getGhcPkgExe
                   )
import           Stack.Types.Config
                   ( Config (..), HasConfig (..), buildOptsL, stackRootL )
import           Stack.Types.ConfigureOpts
                   ( BaseConfigOpts (..), ConfigureOpts (..) )
import           Stack.Types.DumpLogs ( DumpLogs (..) )
import           Stack.Types.DumpPackage ( DumpPackage (..) )
import           Stack.Types.EnvConfig
                   ( HasEnvConfig (..), actualCompilerVersionL
                   , appropriateGhcColorFlag, bindirCompilerTools
                   , installationRootDeps, installationRootLocal
                   , packageDatabaseLocal, platformGhcRelDir
                   , shouldForceGhcColorFlag
                   )
import           Stack.Types.EnvSettings ( EnvSettings (..) )
import           Stack.Types.GhcPkgId ( GhcPkgId, ghcPkgIdString, unGhcPkgId )
import           Stack.Types.GlobalOpts ( GlobalOpts (..) )
import           Stack.Types.IsMutable ( IsMutable (..) )
import           Stack.Types.NamedComponent
                   ( NamedComponent, benchComponents, exeComponents, isCBench
                   , isCTest, renderComponent, testComponents
                   )
import           Stack.Types.Package
                   ( InstallLocation (..), Installed (..), InstalledMap
                   , LocalPackage (..), Package (..), PackageLibraries (..)
                   , installedPackageIdentifier, packageIdent, packageIdentifier
                   , runMemoizedWith
                   )
import           Stack.Types.PackageFile ( PackageWarning (..) )
import           Stack.Types.Platform ( HasPlatform (..) )
import           Stack.Types.Curator ( Curator (..) )
import           Stack.Types.Runner ( HasRunner, globalOptsL, terminalL )
import           Stack.Types.SourceMap ( Target )
import           Stack.Types.Version ( withinRange )
import qualified System.Directory as D
import           System.Environment ( getExecutablePath, lookupEnv )
import           System.FileLock
                   ( SharedExclusive (Exclusive), withFileLock, withTryFileLock
                   )
import qualified System.FilePath as FP
import           System.IO.Error ( isDoesNotExistError )
import           System.PosixCompat.Files
                   ( createLink, getFileStatus, modificationTime )
import           System.Random ( randomIO )

-- | Has an executable been built or not?

data ExecutableBuildStatus
  = ExecutableBuilt
  | ExecutableNotBuilt
  deriving (ExecutableBuildStatus -> ExecutableBuildStatus -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ExecutableBuildStatus -> ExecutableBuildStatus -> Bool
$c/= :: ExecutableBuildStatus -> ExecutableBuildStatus -> Bool
== :: ExecutableBuildStatus -> ExecutableBuildStatus -> Bool
$c== :: ExecutableBuildStatus -> ExecutableBuildStatus -> Bool
Eq, Eq ExecutableBuildStatus
ExecutableBuildStatus -> ExecutableBuildStatus -> Bool
ExecutableBuildStatus -> ExecutableBuildStatus -> Ordering
ExecutableBuildStatus
-> ExecutableBuildStatus -> ExecutableBuildStatus
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ExecutableBuildStatus
-> ExecutableBuildStatus -> ExecutableBuildStatus
$cmin :: ExecutableBuildStatus
-> ExecutableBuildStatus -> ExecutableBuildStatus
max :: ExecutableBuildStatus
-> ExecutableBuildStatus -> ExecutableBuildStatus
$cmax :: ExecutableBuildStatus
-> ExecutableBuildStatus -> ExecutableBuildStatus
>= :: ExecutableBuildStatus -> ExecutableBuildStatus -> Bool
$c>= :: ExecutableBuildStatus -> ExecutableBuildStatus -> Bool
> :: ExecutableBuildStatus -> ExecutableBuildStatus -> Bool
$c> :: ExecutableBuildStatus -> ExecutableBuildStatus -> Bool
<= :: ExecutableBuildStatus -> ExecutableBuildStatus -> Bool
$c<= :: ExecutableBuildStatus -> ExecutableBuildStatus -> Bool
< :: ExecutableBuildStatus -> ExecutableBuildStatus -> Bool
$c< :: ExecutableBuildStatus -> ExecutableBuildStatus -> Bool
compare :: ExecutableBuildStatus -> ExecutableBuildStatus -> Ordering
$ccompare :: ExecutableBuildStatus -> ExecutableBuildStatus -> Ordering
Ord, Int -> ExecutableBuildStatus -> ShowS
[ExecutableBuildStatus] -> ShowS
ExecutableBuildStatus -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ExecutableBuildStatus] -> ShowS
$cshowList :: [ExecutableBuildStatus] -> ShowS
show :: ExecutableBuildStatus -> String
$cshow :: ExecutableBuildStatus -> String
showsPrec :: Int -> ExecutableBuildStatus -> ShowS
$cshowsPrec :: Int -> ExecutableBuildStatus -> ShowS
Show)

-- | 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
  | forall a. Set a -> Bool
Set.null Set PackageLocationImmutable
pkgLocs = forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
 ?callStack::CallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Nothing to fetch"
  | Bool
otherwise = do
      forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
 ?callStack::CallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$
           Utf8Builder
"Prefetching: "
        forall a. Semigroup a => a -> a -> a
<> forall a. Monoid a => [a] -> a
mconcat (forall a. a -> [a] -> [a]
L.intersperse Utf8Builder
", " (forall a. Display a => a -> Utf8Builder
display forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Set a -> [a]
Set.toList Set PackageLocationImmutable
pkgLocs))
      forall env (f :: * -> *).
(HasPantryConfig env, HasLogFunc env, HasProcessContext env,
 Foldable f) =>
f PackageLocationImmutable -> RIO env ()
fetchPackages Set PackageLocationImmutable
pkgLocs
 where
  pkgLocs :: Set PackageLocationImmutable
pkgLocs = forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Task -> Set PackageLocationImmutable
toPkgLoc forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [a]
Map.elems forall a b. (a -> b) -> a -> b
$ Plan -> Map PackageName Task
planTasks Plan
plan

  toPkgLoc :: Task -> Set PackageLocationImmutable
toPkgLoc Task
task =
    case Task -> TaskType
taskType Task
task of
      TTLocalMutable{} -> forall a. Set a
Set.empty
      TTRemotePackage IsMutable
_ Package
_ PackageLocationImmutable
pkgloc -> 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 forall k a. Map k a -> [a]
Map.elems forall a b. (a -> b) -> a -> b
$ Plan -> Map GhcPkgId (PackageIdentifier, Text)
planUnregisterLocal Plan
plan of
    [] -> forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
 MonadIO m) =>
StyleDoc -> m ()
prettyInfo forall a b. (a -> b) -> a -> b
$
               String -> StyleDoc
flow String
"No packages would be unregistered."
            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 forall a b. (a -> b) -> a -> b
$
              forall a. IsString a => String -> a
fromString (PackageIdentifier -> String
packageIdentifierString PackageIdentifier
ident)
            forall a. a -> [a] -> [a]
: [ StyleDoc -> StyleDoc
parens forall a b. (a -> b) -> a -> b
$ String -> StyleDoc
flow (Text -> String
T.unpack Text
reason) | Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Text -> Bool
T.null Text
reason ]
      forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
 MonadIO m) =>
StyleDoc -> m ()
prettyInfo forall a b. (a -> b) -> a -> b
$
           String -> StyleDoc
flow String
"Would unregister locally:"
        forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
        forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
bulletedList (forall a b. (a -> b) -> [a] -> [b]
map (PackageIdentifier, Text) -> StyleDoc
unregisterMsg [(PackageIdentifier, Text)]
xs)
        forall a. Semigroup a => a -> a -> a
<> StyleDoc
line

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

  let hasTests :: Task -> Bool
hasTests = Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> Bool
Set.null forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set NamedComponent -> Set Text
testComponents forall b c a. (b -> c) -> (a -> b) -> a -> c
. Task -> Set NamedComponent
taskComponents
      hasBenches :: Task -> Bool
hasBenches = Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> Bool
Set.null forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set NamedComponent -> Set Text
benchComponents forall b c a. (b -> c) -> (a -> b) -> a -> c
. Task -> Set NamedComponent
taskComponents
      tests :: [Task]
tests = forall k a. Map k a -> [a]
Map.elems forall a b. (a -> b) -> a -> b
$ forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter Task -> Bool
hasTests forall a b. (a -> b) -> a -> b
$ Plan -> Map PackageName Task
planFinals Plan
plan
      benches :: [Task]
benches = forall k a. Map k a -> [a]
Map.elems forall a b. (a -> b) -> a -> b
$ forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter Task -> Bool
hasBenches forall a b. (a -> b) -> a -> b
$ Plan -> Map PackageName Task
planFinals Plan
plan

  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Task]
tests) forall a b. (a -> b) -> a -> b
$ do
    forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
 MonadIO m) =>
StyleDoc -> m ()
prettyInfo forall a b. (a -> b) -> a -> b
$
         String -> StyleDoc
flow String
"Would test:"
      forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
      forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
bulletedList (forall a b. (a -> b) -> [a] -> [b]
map Task -> StyleDoc
displayTask [Task]
tests)
      forall a. Semigroup a => a -> a -> a
<> StyleDoc
line

  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Task]
benches) forall a b. (a -> b) -> a -> b
$ do
    forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
 MonadIO m) =>
StyleDoc -> m ()
prettyInfo forall a b. (a -> b) -> a -> b
$
         String -> StyleDoc
flow String
"Would benchmark:"
      forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
      forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
bulletedList (forall a b. (a -> b) -> [a] -> [b]
map Task -> StyleDoc
displayTask [Task]
benches)
      forall a. Semigroup a => a -> a -> a
<> StyleDoc
line

  case forall k a. Map k a -> [(k, a)]
Map.toList forall a b. (a -> b) -> a -> b
$ Plan -> Map Text InstallLocation
planInstallExes Plan
plan of
    [] -> forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
 MonadIO m) =>
StyleDoc -> m ()
prettyInfo forall a b. (a -> b) -> a -> b
$
               String -> StyleDoc
flow String
"No executables to be installed."
            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 forall a b. (a -> b) -> a -> b
$
              forall a. IsString a => String -> a
fromString (Text -> String
T.unpack Text
name)
            forall a. a -> [a] -> [a]
: StyleDoc
"from"
            forall a. a -> [a] -> [a]
: ( case InstallLocation
loc of
                  InstallLocation
Snap -> StyleDoc
"snapshot" :: StyleDoc
                  InstallLocation
Local -> StyleDoc
"local" :: StyleDoc
              )
            forall a. a -> [a] -> [a]
: [StyleDoc
"database."]
      forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
 MonadIO m) =>
StyleDoc -> m ()
prettyInfo forall a b. (a -> b) -> a -> b
$
           String -> StyleDoc
flow String
"Would install executables:"
        forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
        forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
bulletedList (forall a b. (a -> b) -> [a] -> [b]
map (Text, InstallLocation) -> StyleDoc
executableMsg [(Text, InstallLocation)]
xs)
        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 forall a b. (a -> b) -> a -> b
$
     [ forall a. IsString a => String -> a
fromString (PackageIdentifier -> String
packageIdentifierString (Task -> PackageIdentifier
taskProvides Task
task)) forall a. Semigroup a => a -> a -> a
<> StyleDoc
":"
     ,    StyleDoc
"database="
       forall a. Semigroup a => a -> a -> a
<> ( case Task -> InstallLocation
taskLocation Task
task of
              InstallLocation
Snap -> StyleDoc
"snapshot" :: StyleDoc
              InstallLocation
Local -> StyleDoc
"local" :: StyleDoc
          )
       forall a. Semigroup a => a -> a -> a
<> StyleDoc
","
     ,    StyleDoc
"source="
       forall a. Semigroup a => a -> a -> a
<> ( case Task -> TaskType
taskType Task
task of
              TTLocalMutable LocalPackage
lp -> forall a. Pretty a => a -> StyleDoc
pretty forall a b. (a -> b) -> a -> b
$ forall b t. Path b t -> Path b Dir
parent forall a b. (a -> b) -> a -> b
$ LocalPackage -> Path Abs File
lpCabalFile LocalPackage
lp
              TTRemotePackage IsMutable
_ Package
_ PackageLocationImmutable
pl -> forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack forall a b. (a -> b) -> a -> b
$ forall a. Display a => a -> Text
textDisplay PackageLocationImmutable
pl
          )
       forall a. Semigroup a => a -> a -> a
<> if forall a. Set a -> Bool
Set.null Set PackageIdentifier
missing
            then forall a. Monoid a => a
mempty
            else StyleDoc
","
     ]
  forall a. Semigroup a => a -> a -> a
<> [ [StyleDoc] -> StyleDoc
fillSep forall a b. (a -> b) -> a -> b
$
           StyleDoc
"after:"
         forall a. a -> [a] -> [a]
: forall a. Pretty a => Maybe Style -> Bool -> [a] -> [StyleDoc]
mkNarrativeList forall a. Maybe a
Nothing Bool
False
             (forall a b. (a -> b) -> [a] -> [b]
map (forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageIdentifier -> String
packageIdentifierString) (forall a. Set a -> [a]
Set.toList Set PackageIdentifier
missing) :: [StyleDoc])
     | Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall a. Set a -> Bool
Set.null Set PackageIdentifier
missing
     ]
 where
  missing :: Set PackageIdentifier
missing = TaskConfigOpts -> Set PackageIdentifier
tcoMissing forall a b. (a -> b) -> a -> b
$ Task -> TaskConfigOpts
taskConfigOpts Task
task

data ExecuteEnv = ExecuteEnv
  { ExecuteEnv -> MVar ()
eeConfigureLock  :: !(MVar ())
  , ExecuteEnv -> MVar ()
eeInstallLock    :: !(MVar ())
  , ExecuteEnv -> BuildOpts
eeBuildOpts      :: !BuildOpts
  , ExecuteEnv -> BuildOptsCLI
eeBuildOptsCLI   :: !BuildOptsCLI
  , ExecuteEnv -> BaseConfigOpts
eeBaseConfigOpts :: !BaseConfigOpts
  , ExecuteEnv -> TVar (Map PackageIdentifier Installed)
eeGhcPkgIds      :: !(TVar (Map PackageIdentifier Installed))
  , ExecuteEnv -> Path Abs Dir
eeTempDir        :: !(Path Abs Dir)
  , ExecuteEnv -> Path Abs File
eeSetupHs        :: !(Path Abs File)
    -- ^ Temporary Setup.hs for simple builds

  , ExecuteEnv -> Path Abs File
eeSetupShimHs    :: !(Path Abs File)
    -- ^ Temporary SetupShim.hs, to provide access to initial-build-steps

  , ExecuteEnv -> Maybe (Path Abs File)
eeSetupExe       :: !(Maybe (Path Abs File))
    -- ^ Compiled version of eeSetupHs

  , ExecuteEnv -> Version
eeCabalPkgVer    :: !Version
  , ExecuteEnv -> Int
eeTotalWanted    :: !Int
  , ExecuteEnv -> [LocalPackage]
eeLocals         :: ![LocalPackage]
  , ExecuteEnv -> Path Abs Dir
eeGlobalDB       :: !(Path Abs Dir)
  , ExecuteEnv -> Map GhcPkgId DumpPackage
eeGlobalDumpPkgs :: !(Map GhcPkgId DumpPackage)
  , ExecuteEnv -> TVar (Map GhcPkgId DumpPackage)
eeSnapshotDumpPkgs :: !(TVar (Map GhcPkgId DumpPackage))
  , ExecuteEnv -> TVar (Map GhcPkgId DumpPackage)
eeLocalDumpPkgs  :: !(TVar (Map GhcPkgId DumpPackage))
  , ExecuteEnv -> TChan (Path Abs Dir, Path Abs File)
eeLogFiles       :: !(TChan (Path Abs Dir, Path Abs File))
  , ExecuteEnv -> IORef (Set PackageName)
eeCustomBuilt    :: !(IORef (Set PackageName))
    -- ^ Stores which packages with custom-setup have already had their

    -- Setup.hs built.

  , ExecuteEnv -> Maybe Int
eeLargestPackageName :: !(Maybe Int)
    -- ^ For nicer interleaved output: track the largest package name size

  , ExecuteEnv -> Text
eePathEnvVar :: !Text
    -- ^ Value of the PATH environment variable

  }

buildSetupArgs :: [String]
buildSetupArgs :: [String]
buildSetupArgs =
  [ String
"-rtsopts"
  , String
"-threaded"
  , String
"-clear-package-db"
  , String
"-global-package-db"
  , String
"-hide-all-packages"
  , String
"-package"
  , String
"base"
  , String
"-main-is"
  , String
"StackSetupShim.mainOverride"
  ]

simpleSetupCode :: Builder
simpleSetupCode :: Builder
simpleSetupCode = Builder
"import Distribution.Simple\nmain = defaultMain"

simpleSetupHash :: String
simpleSetupHash :: String
simpleSetupHash =
    Text -> String
T.unpack
  forall a b. (a -> b) -> a -> b
$ ByteString -> Text
decodeUtf8
  forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
S.take Int
8
  forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
B64URL.encode
  forall a b. (a -> b) -> a -> b
$ forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
Mem.convert
  forall a b. (a -> b) -> a -> b
$ forall ba alg.
(ByteArrayAccess ba, HashAlgorithm alg) =>
alg -> ba -> Digest alg
hashWith SHA256
SHA256
  forall a b. (a -> b) -> a -> b
$ LByteString -> ByteString
toStrictBytes
  forall a b. (a -> b) -> a -> b
$ Builder -> LByteString
Data.ByteString.Builder.toLazyByteString
  forall a b. (a -> b) -> a -> b
$  Text -> Builder
encodeUtf8Builder (String -> Text
T.pack ([String] -> String
unwords [String]
buildSetupArgs))
  forall a. Semigroup a => a -> a -> a
<> Builder
setupGhciShimCode
  forall a. Semigroup a => a -> a -> a
<> Builder
simpleSetupCode

-- | Get a compiled Setup exe

getSetupExe :: HasEnvConfig env
            => Path Abs File -- ^ Setup.hs input file

            -> Path Abs File -- ^ SetupShim.hs input file

            -> Path Abs Dir -- ^ temporary directory

            -> RIO env (Maybe (Path Abs File))
getSetupExe :: forall env.
HasEnvConfig env =>
Path Abs File
-> Path Abs File -> Path Abs Dir -> RIO env (Maybe (Path Abs File))
getSetupExe Path Abs File
setupHs Path Abs File
setupShimHs Path Abs Dir
tmpdir = do
  WhichCompiler
wc <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasSourceMap env => SimpleGetter env ActualCompiler
actualCompilerVersionLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall r. Getting r ActualCompiler WhichCompiler
whichCompilerL
  Path Rel Dir
platformDir <- forall env (m :: * -> *).
(HasEnvConfig env, MonadReader env m, MonadThrow m) =>
m (Path Rel Dir)
platformGhcRelDir
  Config
config <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasConfig env => Lens' env Config
configL
  String
cabalVersionString <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasCompiler env => SimpleGetter env Version
cabalVersionLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to Version -> String
versionString
  String
actualCompilerVersionString <-
    forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasSourceMap env => SimpleGetter env ActualCompiler
actualCompilerVersionLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to ActualCompiler -> String
compilerVersionString
  Platform
platform <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasPlatform env => Lens' env Platform
platformL
  let baseNameS :: String
baseNameS = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"Cabal-simple_"
        , String
simpleSetupHash
        , String
"_"
        , String
cabalVersionString
        , String
"_"
        , String
actualCompilerVersionString
        ]
      exeNameS :: String
exeNameS = String
baseNameS forall a. [a] -> [a] -> [a]
++
        case Platform
platform of
          Platform Arch
_ OS
Windows -> String
".exe"
          Platform
_ -> String
""
      outputNameS :: String
outputNameS =
        case WhichCompiler
wc of
            WhichCompiler
Ghc -> String
exeNameS
      setupDir :: Path Abs Dir
setupDir =
        forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall s. HasConfig s => Lens' s (Path Abs Dir)
stackRootL Config
config forall b t. Path b Dir -> Path Rel t -> Path b t
</>
        Path Rel Dir
relDirSetupExeCache forall b t. Path b Dir -> Path Rel t -> Path b t
</>
        Path Rel Dir
platformDir

  Path Abs File
exePath <- (Path Abs Dir
setupDir </>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile String
exeNameS

  Bool
exists <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO Bool
D.doesFileExist forall a b. (a -> b) -> a -> b
$ forall b t. Path b t -> String
toFilePath Path Abs File
exePath

  if Bool
exists
    then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Path Abs File
exePath
    else do
      Path Abs File
tmpExePath <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Path Abs Dir
setupDir </>) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile forall a b. (a -> b) -> a -> b
$ String
"tmp-" forall a. [a] -> [a] -> [a]
++ String
exeNameS
      Path Abs File
tmpOutputPath <-
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Path Abs Dir
setupDir </>) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile forall a b. (a -> b) -> a -> b
$ String
"tmp-" forall a. [a] -> [a] -> [a]
++ String
outputNameS
      forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir Path Abs Dir
setupDir
      let args :: [String]
args = [String]
buildSetupArgs forall a. [a] -> [a] -> [a]
++
            [ String
"-package"
            , String
"Cabal-" forall a. [a] -> [a] -> [a]
++ String
cabalVersionString
            , forall b t. Path b t -> String
toFilePath Path Abs File
setupHs
            , forall b t. Path b t -> String
toFilePath Path Abs File
setupShimHs
            , String
"-o"
            , forall b t. Path b t -> String
toFilePath Path Abs File
tmpOutputPath
            ]
      Path Abs File
compilerPath <- forall env. HasCompiler env => RIO env (Path Abs File)
getCompilerPath
      forall env (m :: * -> *) a.
(HasProcessContext env, MonadReader env m, MonadIO m) =>
String -> m a -> m a
withWorkingDir (forall b t. Path b t -> String
toFilePath Path Abs Dir
tmpdir) forall a b. (a -> b) -> a -> b
$
        forall env (m :: * -> *) a.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
 MonadIO m, ?callStack::CallStack) =>
String -> [String] -> (ProcessConfig () () () -> m a) -> m a
proc (forall b t. Path b t -> String
toFilePath Path Abs File
compilerPath) [String]
args (\ProcessConfig () () ()
pc0 -> do
          let pc :: ProcessConfig () () ()
pc = forall stdout stdin stdout0 stderr.
StreamSpec 'STOutput stdout
-> ProcessConfig stdin stdout0 stderr
-> ProcessConfig stdin stdout stderr
setStdout (forall (anyStreamType :: StreamType).
Handle -> StreamSpec anyStreamType ()
useHandleOpen Handle
stderr) ProcessConfig () () ()
pc0
          forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
ProcessConfig stdin stdout stderr -> m ()
runProcess_ ProcessConfig () () ()
pc)
            forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \ExitCodeException
ece ->
              forall e (m :: * -> *) a.
(Exception e, MonadThrow m, Pretty e) =>
e -> m a
prettyThrowM forall a b. (a -> b) -> a -> b
$ ExitCode
-> Maybe PackageIdentifier
-> Path Abs File
-> [String]
-> Maybe (Path Abs File)
-> [Text]
-> BuildPrettyException
SetupHsBuildFailure
                (ExitCodeException -> ExitCode
eceExitCode ExitCodeException
ece) forall a. Maybe a
Nothing Path Abs File
compilerPath [String]
args forall a. Maybe a
Nothing []
      forall (m :: * -> *) b0 b1.
MonadIO m =>
Path b0 File -> Path b1 File -> m ()
renameFile Path Abs File
tmpExePath Path Abs File
exePath
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Path Abs File
exePath

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

withExecuteEnv ::
     forall env a. HasEnvConfig env
  => BuildOpts
  -> BuildOptsCLI
  -> BaseConfigOpts
  -> [LocalPackage]
  -> [DumpPackage] -- ^ global packages

  -> [DumpPackage] -- ^ snapshot packages

  -> [DumpPackage] -- ^ local packages

  -> Maybe Int -- ^ largest package name, for nicer interleaved output

  -> (ExecuteEnv -> RIO env a)
  -> RIO env a
withExecuteEnv :: 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 ExecuteEnv -> RIO env a
inner =
  String -> (Path Abs Dir -> RIO env a) -> RIO env a
createTempDirFunction String
stackProgName forall a b. (a -> b) -> a -> b
$ \Path Abs Dir
tmpdir -> do
    MVar ()
configLock <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => a -> m (MVar a)
newMVar ()
    MVar ()
installLock <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => a -> m (MVar a)
newMVar ()
    TVar (Map PackageIdentifier Installed)
idMap <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO forall k a. Map k a
Map.empty
    Config
config <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasConfig env => Lens' env Config
configL

    IORef (Set PackageName)
customBuiltRef <- forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef forall a. Set a
Set.empty

    -- Create files for simple setup and setup shim, if necessary

    let setupSrcDir :: Path Abs Dir
setupSrcDir =
            forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall s. HasConfig s => Lens' s (Path Abs Dir)
stackRootL Config
config forall b t. Path b Dir -> Path Rel t -> Path b t
</>
            Path Rel Dir
relDirSetupExeSrc
    forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir Path Abs Dir
setupSrcDir
    Path Rel File
setupFileName <- forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile (String
"setup-" forall a. [a] -> [a] -> [a]
++ String
simpleSetupHash forall a. [a] -> [a] -> [a]
++ String
".hs")
    let setupHs :: Path Abs File
setupHs = Path Abs Dir
setupSrcDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
setupFileName
    Bool
setupHsExists <- forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
setupHs
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
setupHsExists forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) absrel.
MonadIO m =>
Path absrel File -> Builder -> m ()
writeBinaryFileAtomic Path Abs File
setupHs Builder
simpleSetupCode
    Path Rel File
setupShimFileName <-
      forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile (String
"setup-shim-" forall a. [a] -> [a] -> [a]
++ String
simpleSetupHash forall a. [a] -> [a] -> [a]
++ String
".hs")
    let setupShimHs :: Path Abs File
setupShimHs = Path Abs Dir
setupSrcDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
setupShimFileName
    Bool
setupShimHsExists <- forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
setupShimHs
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
setupShimHsExists forall a b. (a -> b) -> a -> b
$
      forall (m :: * -> *) absrel.
MonadIO m =>
Path absrel File -> Builder -> m ()
writeBinaryFileAtomic Path Abs File
setupShimHs Builder
setupGhciShimCode
    Maybe (Path Abs File)
setupExe <- forall env.
HasEnvConfig env =>
Path Abs File
-> Path Abs File -> Path Abs Dir -> RIO env (Maybe (Path Abs File))
getSetupExe Path Abs File
setupHs Path Abs File
setupShimHs Path Abs Dir
tmpdir

    Version
cabalPkgVer <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasCompiler env => SimpleGetter env Version
cabalVersionL
    Path Abs Dir
globalDB <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasCompiler env => SimpleGetter env CompilerPaths
compilerPathsLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to CompilerPaths -> Path Abs Dir
cpGlobalDB
    TVar (Map GhcPkgId DumpPackage)
snapshotPackagesTVar <-
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO ([DumpPackage] -> Map GhcPkgId DumpPackage
toDumpPackagesByGhcPkgId [DumpPackage]
snapshotPackages)
    TVar (Map GhcPkgId DumpPackage)
localPackagesTVar <-
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO ([DumpPackage] -> Map GhcPkgId DumpPackage
toDumpPackagesByGhcPkgId [DumpPackage]
localPackages)
    TChan (Path Abs Dir, Path Abs File)
logFilesTChan <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall a. STM (TChan a)
newTChan
    let totalWanted :: Int
totalWanted = forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter LocalPackage -> Bool
lpWanted [LocalPackage]
locals
    Text
pathEnvVar <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty String -> Text
T.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
"PATH"
    ExecuteEnv -> RIO env a
inner ExecuteEnv
      { eeBuildOpts :: BuildOpts
eeBuildOpts = BuildOpts
bopts
      , eeBuildOptsCLI :: BuildOptsCLI
eeBuildOptsCLI = BuildOptsCLI
boptsCli
        -- Uncertain as to why we cannot run configures in parallel. This

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

        -- https://github.com/commercialhaskell/stack/issues/84. Ideally

        -- we'd be able to remove this.

      , eeConfigureLock :: MVar ()
eeConfigureLock = MVar ()
configLock
      , eeInstallLock :: MVar ()
eeInstallLock = MVar ()
installLock
      , eeBaseConfigOpts :: BaseConfigOpts
eeBaseConfigOpts = BaseConfigOpts
baseConfigOpts
      , eeGhcPkgIds :: TVar (Map PackageIdentifier Installed)
eeGhcPkgIds = TVar (Map PackageIdentifier Installed)
idMap
      , eeTempDir :: Path Abs Dir
eeTempDir = Path Abs Dir
tmpdir
      , eeSetupHs :: Path Abs File
eeSetupHs = Path Abs File
setupHs
      , eeSetupShimHs :: Path Abs File
eeSetupShimHs = Path Abs File
setupShimHs
      , eeSetupExe :: Maybe (Path Abs File)
eeSetupExe = Maybe (Path Abs File)
setupExe
      , eeCabalPkgVer :: Version
eeCabalPkgVer = Version
cabalPkgVer
      , eeTotalWanted :: Int
eeTotalWanted = Int
totalWanted
      , eeLocals :: [LocalPackage]
eeLocals = [LocalPackage]
locals
      , eeGlobalDB :: Path Abs Dir
eeGlobalDB = Path Abs Dir
globalDB
      , eeGlobalDumpPkgs :: Map GhcPkgId DumpPackage
eeGlobalDumpPkgs = [DumpPackage] -> Map GhcPkgId DumpPackage
toDumpPackagesByGhcPkgId [DumpPackage]
globalPackages
      , eeSnapshotDumpPkgs :: TVar (Map GhcPkgId DumpPackage)
eeSnapshotDumpPkgs = TVar (Map GhcPkgId DumpPackage)
snapshotPackagesTVar
      , eeLocalDumpPkgs :: TVar (Map GhcPkgId DumpPackage)
eeLocalDumpPkgs = TVar (Map GhcPkgId DumpPackage)
localPackagesTVar
      , eeLogFiles :: TChan (Path Abs Dir, Path Abs File)
eeLogFiles = TChan (Path Abs Dir, Path Abs File)
logFilesTChan
      , eeCustomBuilt :: IORef (Set PackageName)
eeCustomBuilt = IORef (Set PackageName)
customBuiltRef
      , eeLargestPackageName :: Maybe Int
eeLargestPackageName = Maybe Int
mlargestPackageName
      , eePathEnvVar :: Text
eePathEnvVar = Text
pathEnvVar
      } forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
`finally` TChan (Path Abs Dir, Path Abs File) -> Int -> RIO env ()
dumpLogs TChan (Path Abs Dir, Path Abs File)
logFilesTChan Int
totalWanted
 where
  toDumpPackagesByGhcPkgId :: [DumpPackage] -> Map GhcPkgId DumpPackage
toDumpPackagesByGhcPkgId = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (\DumpPackage
dp -> (DumpPackage -> GhcPkgId
dpGhcPkgId DumpPackage
dp, DumpPackage
dp))

  createTempDirFunction :: String -> (Path Abs Dir -> RIO env a) -> RIO env a
createTempDirFunction
    | BuildOpts -> Bool
boptsKeepTmpFiles BuildOpts
bopts = forall (m :: * -> *) a.
MonadUnliftIO m =>
String -> (Path Abs Dir -> m a) -> m a
withKeepSystemTempDir
    | Bool
otherwise = forall (m :: * -> *) a.
MonadUnliftIO m =>
String -> (Path Abs Dir -> m a) -> m a
withSystemTempDir

  dumpLogs :: TChan (Path Abs Dir, Path Abs File) -> Int -> RIO env ()
  dumpLogs :: TChan (Path Abs Dir, Path Abs File) -> Int -> RIO env ()
dumpLogs TChan (Path Abs Dir, Path Abs File)
chan Int
totalWanted = do
    [(Path Abs Dir, Path Abs File)]
allLogs <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically STM [(Path Abs Dir, Path Abs File)]
drainChan
    case [(Path Abs Dir, Path Abs File)]
allLogs of
      -- No log files generated, nothing to dump

      [] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      (Path Abs Dir, Path Abs File)
firstLog:[(Path Abs Dir, Path Abs File)]
_ -> do
        DumpLogs
toDump <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasConfig env => Lens' env Config
configLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to Config -> DumpLogs
configDumpLogs
        case DumpLogs
toDump of
          DumpLogs
DumpAllLogs -> forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> (Path Abs Dir, Path Abs File) -> RIO env ()
dumpLog String
"") [(Path Abs Dir, Path Abs File)]
allLogs
          DumpLogs
DumpWarningLogs -> forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Path Abs Dir, Path Abs File) -> RIO env ()
dumpLogIfWarning [(Path Abs Dir, Path Abs File)]
allLogs
          DumpLogs
DumpNoLogs
              | Int
totalWanted forall a. Ord a => a -> a -> Bool
> Int
1 ->
                  forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
 MonadIO m) =>
[StyleDoc] -> m ()
prettyInfoL
                    [ String -> StyleDoc
flow String
"Build output has been captured to log files, use"
                    , Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"--dump-logs"
                    , String -> StyleDoc
flow String
"to see it on the console."
                    ]
              | Bool
otherwise -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
 MonadIO m) =>
[StyleDoc] -> m ()
prettyInfoL
          [ String -> StyleDoc
flow String
"Log files have been written to:"
          , forall a. Pretty a => a -> StyleDoc
pretty (forall b t. Path b t -> Path b Dir
parent (forall a b. (a, b) -> b
snd (Path Abs Dir, Path Abs File)
firstLog))
          ]

    -- We only strip the colors /after/ we've dumped logs, so that we get pretty

    -- colors in our dump output on the terminal.

    Bool
colors <- forall env. (HasEnvConfig env, HasRunner env) => RIO env Bool
shouldForceGhcColorFlag
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
colors forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Path Abs File -> IO ()
stripColors forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(Path Abs Dir, Path Abs File)]
allLogs
   where
    drainChan :: STM [(Path Abs Dir, Path Abs File)]
    drainChan :: STM [(Path Abs Dir, Path Abs File)]
drainChan = do
      Maybe (Path Abs Dir, Path Abs File)
mx <- forall a. TChan a -> STM (Maybe a)
tryReadTChan TChan (Path Abs Dir, Path Abs File)
chan
      case Maybe (Path Abs Dir, Path Abs File)
mx of
        Maybe (Path Abs Dir, Path Abs File)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure []
        Just (Path Abs Dir, Path Abs File)
x -> do
          [(Path Abs Dir, Path Abs File)]
xs <- STM [(Path Abs Dir, Path Abs File)]
drainChan
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ (Path Abs Dir, Path Abs File)
xforall a. a -> [a] -> [a]
:[(Path Abs Dir, Path Abs File)]
xs

  dumpLogIfWarning :: (Path Abs Dir, Path Abs File) -> RIO env ()
  dumpLogIfWarning :: (Path Abs Dir, Path Abs File) -> RIO env ()
dumpLogIfWarning (Path Abs Dir
pkgDir, Path Abs File
filepath) = do
    [Text]
firstWarning <- forall (m :: * -> *) (n :: * -> *) i a.
(MonadUnliftIO m, MonadIO n) =>
String -> (ConduitM i ByteString n () -> m a) -> m a
withSourceFile (forall b t. Path b t -> String
toFilePath Path Abs File
filepath) forall a b. (a -> b) -> a -> b
$ \ConduitM () ByteString (RIO env) ()
src ->
         forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit
       forall a b. (a -> b) -> a -> b
$ ConduitM () ByteString (RIO env) ()
src
      forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *). Monad m => ConduitT ByteString Text m ()
CT.decodeUtf8Lenient
      forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *). Monad m => ConduitT Text Text m ()
CT.lines
      forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) a b. Monad m => (a -> b) -> ConduitT a b m ()
CL.map Text -> Text
stripCR
      forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) a. Monad m => (a -> Bool) -> ConduitT a a m ()
CL.filter Text -> Bool
isWarning
      forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) a o. Monad m => Int -> ConduitT a o m [a]
CL.take Int
1
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
firstWarning) forall a b. (a -> b) -> a -> b
$ String -> (Path Abs Dir, Path Abs File) -> RIO env ()
dumpLog String
" due to warnings" (Path Abs Dir
pkgDir, Path Abs File
filepath)

  isWarning :: Text -> Bool
  isWarning :: Text -> Bool
isWarning Text
t = Text
": Warning:" Text -> Text -> Bool
`T.isSuffixOf` Text
t -- prior to GHC 8

             Bool -> Bool -> Bool
|| Text
": warning:" Text -> Text -> Bool
`T.isInfixOf` Text
t -- GHC 8 is slightly different

             Bool -> Bool -> Bool
|| Text
"mwarning:" Text -> Text -> Bool
`T.isInfixOf` Text
t -- colorized output


  dumpLog :: String -> (Path Abs Dir, Path Abs File) -> RIO env ()
  dumpLog :: String -> (Path Abs Dir, Path Abs File) -> RIO env ()
dumpLog String
msgSuffix (Path Abs Dir
pkgDir, Path Abs File
filepath) = do
    forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
 MonadIO m) =>
StyleDoc -> m ()
prettyNote forall a b. (a -> b) -> a -> b
$
         [StyleDoc] -> StyleDoc
fillSep
           ( ( [StyleDoc] -> StyleDoc
fillSep
                 ( String -> StyleDoc
flow String
"Dumping log file"
                 forall a. a -> [a] -> [a]
: [ String -> StyleDoc
flow String
msgSuffix | forall (t :: * -> *) a. Foldable t => t a -> Bool
L.null String
msgSuffix ]
                 )
             forall a. Semigroup a => a -> a -> a
<> StyleDoc
":"
             )
           forall a. a -> [a] -> [a]
: [ forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
filepath forall a. Semigroup a => a -> a -> a
<> StyleDoc
"." ]
           )
      forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    ActualCompiler
compilerVer <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasSourceMap env => SimpleGetter env ActualCompiler
actualCompilerVersionL
    forall (m :: * -> *) (n :: * -> *) i a.
(MonadUnliftIO m, MonadIO n) =>
String -> (ConduitM i ByteString n () -> m a) -> m a
withSourceFile (forall b t. Path b t -> String
toFilePath Path Abs File
filepath) forall a b. (a -> b) -> a -> b
$ \ConduitM () ByteString (RIO env) ()
src ->
         forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit
       forall a b. (a -> b) -> a -> b
$ ConduitM () ByteString (RIO env) ()
src
      forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *). Monad m => ConduitT ByteString Text m ()
CT.decodeUtf8Lenient
      forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *).
(MonadIO m, MonadUnliftIO m) =>
ExcludeTHLoading
-> ConvertPathsToAbsolute
-> Path Abs Dir
-> ActualCompiler
-> ConduitM Text Text m ()
mungeBuildOutput ExcludeTHLoading
ExcludeTHLoading ConvertPathsToAbsolute
ConvertPathsToAbsolute Path Abs Dir
pkgDir ActualCompiler
compilerVer
      forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) a o.
Monad m =>
(a -> m ()) -> ConduitT a o m ()
CL.mapM_ (forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
 ?callStack::CallStack) =>
Utf8Builder -> m ()
logInfo forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Display a => a -> Utf8Builder
display)
    forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
 MonadIO m) =>
StyleDoc -> m ()
prettyNote forall a b. (a -> b) -> a -> b
$
         [StyleDoc] -> StyleDoc
fillSep
           [ String -> StyleDoc
flow String
"End of log file:"
           , forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
filepath forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
           ]
      forall a. Semigroup a => a -> a -> a
<> StyleDoc
line

  stripColors :: Path Abs File -> IO ()
  stripColors :: Path Abs File -> IO ()
stripColors Path Abs File
fp = do
    let colorfp :: String
colorfp = forall b t. Path b t -> String
toFilePath Path Abs File
fp forall a. [a] -> [a] -> [a]
++ String
"-color"
    forall (m :: * -> *) (n :: * -> *) i a.
(MonadUnliftIO m, MonadIO n) =>
String -> (ConduitM i ByteString n () -> m a) -> m a
withSourceFile (forall b t. Path b t -> String
toFilePath Path Abs File
fp) forall a b. (a -> b) -> a -> b
$ \ConduitM () ByteString IO ()
src ->
      forall (m :: * -> *) (n :: * -> *) o a.
(MonadUnliftIO m, MonadIO n) =>
String -> (ConduitM ByteString o n () -> m a) -> m a
withSinkFile String
colorfp forall a b. (a -> b) -> a -> b
$ \ConduitM ByteString Void IO ()
sink ->
      forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit forall a b. (a -> b) -> a -> b
$ ConduitM () ByteString IO ()
src forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitM ByteString Void IO ()
sink
    forall (m :: * -> *) (n :: * -> *) i a.
(MonadUnliftIO m, MonadIO n) =>
String -> (ConduitM i ByteString n () -> m a) -> m a
withSourceFile String
colorfp forall a b. (a -> b) -> a -> b
$ \ConduitM () ByteString IO ()
src ->
      forall (m :: * -> *) (n :: * -> *) o a.
(MonadUnliftIO m, MonadIO n) =>
String -> (ConduitM ByteString o n () -> m a) -> m a
withSinkFile (forall b t. Path b t -> String
toFilePath Path Abs File
fp) forall a b. (a -> b) -> a -> b
$ \ConduitM ByteString Void IO ()
sink ->
      forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit forall a b. (a -> b) -> a -> b
$ ConduitM () ByteString IO ()
src forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT ByteString ByteString IO ()
noColors forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitM ByteString Void IO ()
sink

   where
    noColors :: ConduitT ByteString ByteString IO ()
noColors = do
      forall (m :: * -> *).
Monad m =>
(Word8 -> Bool) -> ConduitT ByteString ByteString m ()
CB.takeWhile (forall a. Eq a => a -> a -> Bool
/= Word8
27) -- ESC

      Maybe Word8
mnext <- forall (m :: * -> *) o.
Monad m =>
ConduitT ByteString o m (Maybe Word8)
CB.head
      case Maybe Word8
mnext of
        Maybe Word8
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Just Word8
x -> forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Word8
x forall a. Eq a => a -> a -> Bool
== Word8
27) forall a b. (a -> b) -> a -> b
$ do
          -- Color sequences always end with an m

          forall (m :: * -> *) o.
Monad m =>
(Word8 -> Bool) -> ConduitT ByteString o m ()
CB.dropWhile (forall a. Eq a => a -> a -> Bool
/= Word8
109) -- m

          forall (m :: * -> *) o.
Monad m =>
Int -> ConduitT ByteString o m ()
CB.drop Int
1 -- drop the m itself

          ConduitT ByteString ByteString IO ()
noColors

-- | 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
  forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
 ?callStack::CallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Executing the build plan"
  BuildOpts
bopts <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall s. HasConfig s => Lens' s BuildOpts
buildOptsL
  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
    (forall env.
HasEnvConfig env =>
InstalledMap
-> Map PackageName Target -> Plan -> ExecuteEnv -> RIO env ()
executePlan' InstalledMap
installedMap Map PackageName Target
targets Plan
plan)

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

  Config
config <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasConfig env => Lens' env Config
configL
  ProcessContext
menv' <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Config -> EnvSettings -> IO ProcessContext
configProcessContextSettings Config
config EnvSettings
             { esIncludeLocals :: Bool
esIncludeLocals = Bool
True
             , esIncludeGhcPackagePath :: Bool
esIncludeGhcPackagePath = Bool
True
             , esStackExe :: Bool
esStackExe = Bool
True
             , esLocaleUtf8 :: Bool
esLocaleUtf8 = Bool
False
             , esKeepGhcRts :: Bool
esKeepGhcRts = Bool
False
             }
  forall env a.
HasProcessContext env =>
ProcessContext -> RIO env a -> RIO env a
withProcessContext ProcessContext
menv' forall a b. (a -> b) -> a -> b
$
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (BuildOptsCLI -> [(String, [String])]
boptsCLIExec BuildOptsCLI
boptsCli) forall a b. (a -> b) -> a -> b
$ \(String
cmd, [String]
args) ->
    forall env (m :: * -> *) a.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
 MonadIO m, ?callStack::CallStack) =>
String -> [String] -> (ProcessConfig () () () -> m a) -> m a
proc String
cmd [String]
args forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
ProcessConfig stdin stdout stderr -> m ()
runProcess_
 where
  mlargestPackageName :: Maybe Int
mlargestPackageName =
    forall a. Set a -> Maybe a
Set.lookupMax forall a b. (a -> b) -> a -> b
$
    forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (forall (t :: * -> *) a. Foldable t => t a -> Int
length forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> String
packageNameString) forall a b. (a -> b) -> a -> b
$
    forall k a. Map k a -> Set k
Map.keysSet (Plan -> Map PackageName Task
planTasks Plan
plan) forall a. Semigroup a => a -> a -> a
<> forall k a. Map k a -> Set k
Map.keysSet (Plan -> Map PackageName Task
planFinals Plan
plan)

copyExecutables ::
       HasEnvConfig env
    => Map Text InstallLocation
    -> RIO env ()
copyExecutables :: forall env.
HasEnvConfig env =>
Map Text InstallLocation -> RIO env ()
copyExecutables Map Text InstallLocation
exes | forall k a. Map k a -> Bool
Map.null Map Text InstallLocation
exes = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
copyExecutables Map Text InstallLocation
exes = do
  Path Abs Dir
snapBin <- (forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
bindirSuffix) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall env. HasEnvConfig env => RIO env (Path Abs Dir)
installationRootDeps
  Path Abs Dir
localBin <- (forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
bindirSuffix) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall env. HasEnvConfig env => RIO env (Path Abs Dir)
installationRootLocal
  Bool
compilerSpecific <- BuildOpts -> Bool
boptsInstallCompilerTool forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall s. HasConfig s => Lens' s BuildOpts
buildOptsL
  Path Abs Dir
destDir <- if Bool
compilerSpecific
               then forall env (m :: * -> *).
(HasEnvConfig env, MonadReader env m, MonadThrow m) =>
m (Path Abs Dir)
bindirCompilerTools
               else forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasConfig env => Lens' env Config
configLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to Config -> Path Abs Dir
configLocalBin
  forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir Path Abs Dir
destDir

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

  Platform
platform <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasPlatform env => Lens' env Platform
platformL
  let ext :: String
ext =
        case Platform
platform of
          Platform Arch
_ OS
Windows -> String
".exe"
          Platform
_ -> String
""

  String
currExe <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO String
getExecutablePath -- needed for windows, see below


  [Text]
installed <- forall (m :: * -> *) a b.
Monad m =>
[a] -> (a -> m (Maybe b)) -> m [b]
forMaybeM (forall k a. Map k a -> [(k, a)]
Map.toList Map Text InstallLocation
exes) 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 <- forall (m :: * -> *).
MonadIO m =>
Path Abs Dir -> String -> m (Maybe (Path Abs File))
forgivingResolveFile Path Abs Dir
bindir (Text -> String
T.unpack Text
name forall a. [a] -> [a] -> [a]
++ String
ext)
      forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 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
        forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
 MonadIO m) =>
[StyleDoc] -> m ()
prettyWarnL
          [ String -> StyleDoc
flow String
"Couldn't find executable"
          , Style -> StyleDoc -> StyleDoc
style Style
Current (forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
name)
          , String -> StyleDoc
flow String
"in directory"
          , forall a. Pretty a => a -> StyleDoc
pretty Path Abs Dir
bindir forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
          ]
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
      Just Path Abs File
file -> do
        let destFile :: String
destFile = String
destDir' String -> ShowS
FP.</> Text -> String
T.unpack Text
name forall a. [a] -> [a] -> [a]
++ String
ext
        forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
 MonadIO m) =>
[StyleDoc] -> m ()
prettyInfoL
          [ String -> StyleDoc
flow String
"Copying from"
          , forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
file
          , StyleDoc
"to"
          , Style -> StyleDoc -> StyleDoc
style Style
File (forall a. IsString a => String -> a
fromString String
destFile) forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
          ]

        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ case Platform
platform of
          Platform Arch
_ OS
Windows | String -> String -> Bool
FP.equalFilePath String
destFile String
currExe ->
              String -> String -> IO ()
windowsRenameCopy (forall b t. Path b t -> String
toFilePath Path Abs File
file) String
destFile
          Platform
_ -> String -> String -> IO ()
D.copyFile (forall b t. Path b t -> String
toFilePath Path Abs File
file) String
destFile
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (Text
name forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
ext)

  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
installed) forall a b. (a -> b) -> a -> b
$ do
    forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
 MonadIO m) =>
StyleDoc -> m ()
prettyInfo forall a b. (a -> b) -> a -> b
$
         [StyleDoc] -> StyleDoc
fillSep
           [ String -> StyleDoc
flow String
"Copied executables to"
           , forall a. Pretty a => a -> StyleDoc
pretty Path Abs Dir
destDir forall a. Semigroup a => a -> a -> a
<> StyleDoc
":"
           ]
      forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
      forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
bulletedList
           (forall a b. (a -> b) -> [a] -> [b]
map (forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Display a => a -> Text
textDisplay) [Text]
installed :: [StyleDoc])
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
compilerSpecific forall a b. (a -> b) -> a -> b
$ forall env. HasConfig env => String -> [Text] -> RIO env ()
warnInstallSearchPathIssues String
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 :: String -> String -> IO ()
windowsRenameCopy String
src String
dest = do
  String -> String -> IO ()
D.copyFile String
src String
new
  String -> String -> IO ()
D.renameFile String
dest String
old
  String -> String -> IO ()
D.renameFile String
new String
dest
 where
  new :: String
new = String
dest forall a. [a] -> [a] -> [a]
++ String
".new"
  old :: String
old = String
dest forall a. [a] -> [a] -> [a]
++ String
".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 ee :: ExecuteEnv
ee@ExecuteEnv {Int
[LocalPackage]
Maybe Int
Maybe (Path Abs File)
Map GhcPkgId DumpPackage
MVar ()
Version
Text
TVar (Map PackageIdentifier Installed)
TVar (Map GhcPkgId DumpPackage)
IORef (Set PackageName)
Path Abs File
Path Abs Dir
TChan (Path Abs Dir, Path Abs File)
BuildOptsCLI
BuildOpts
BaseConfigOpts
eePathEnvVar :: Text
eeLargestPackageName :: Maybe Int
eeCustomBuilt :: IORef (Set PackageName)
eeLogFiles :: TChan (Path Abs Dir, Path Abs File)
eeLocalDumpPkgs :: TVar (Map GhcPkgId DumpPackage)
eeSnapshotDumpPkgs :: TVar (Map GhcPkgId DumpPackage)
eeGlobalDumpPkgs :: Map GhcPkgId DumpPackage
eeGlobalDB :: Path Abs Dir
eeLocals :: [LocalPackage]
eeTotalWanted :: Int
eeCabalPkgVer :: Version
eeSetupExe :: Maybe (Path Abs File)
eeSetupShimHs :: Path Abs File
eeSetupHs :: Path Abs File
eeTempDir :: Path Abs Dir
eeGhcPkgIds :: TVar (Map PackageIdentifier Installed)
eeBaseConfigOpts :: BaseConfigOpts
eeBuildOptsCLI :: BuildOptsCLI
eeBuildOpts :: BuildOpts
eeInstallLock :: MVar ()
eeConfigureLock :: MVar ()
eePathEnvVar :: ExecuteEnv -> Text
eeLargestPackageName :: ExecuteEnv -> Maybe Int
eeCustomBuilt :: ExecuteEnv -> IORef (Set PackageName)
eeLogFiles :: ExecuteEnv -> TChan (Path Abs Dir, Path Abs File)
eeLocalDumpPkgs :: ExecuteEnv -> TVar (Map GhcPkgId DumpPackage)
eeSnapshotDumpPkgs :: ExecuteEnv -> TVar (Map GhcPkgId DumpPackage)
eeGlobalDumpPkgs :: ExecuteEnv -> Map GhcPkgId DumpPackage
eeGlobalDB :: ExecuteEnv -> Path Abs Dir
eeLocals :: ExecuteEnv -> [LocalPackage]
eeTotalWanted :: ExecuteEnv -> Int
eeCabalPkgVer :: ExecuteEnv -> Version
eeSetupExe :: ExecuteEnv -> Maybe (Path Abs File)
eeSetupShimHs :: ExecuteEnv -> Path Abs File
eeSetupHs :: ExecuteEnv -> Path Abs File
eeTempDir :: ExecuteEnv -> Path Abs Dir
eeGhcPkgIds :: ExecuteEnv -> TVar (Map PackageIdentifier Installed)
eeBaseConfigOpts :: ExecuteEnv -> BaseConfigOpts
eeBuildOptsCLI :: ExecuteEnv -> BuildOptsCLI
eeBuildOpts :: ExecuteEnv -> BuildOpts
eeInstallLock :: ExecuteEnv -> MVar ()
eeConfigureLock :: ExecuteEnv -> MVar ()
..} = do
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TestOpts -> Bool
toCoverage forall a b. (a -> b) -> a -> b
$ BuildOpts -> TestOpts
boptsTestOpts BuildOpts
eeBuildOpts) forall env. HasEnvConfig env => RIO env ()
deleteHpcReports
  ActualCompiler
cv <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasSourceMap env => SimpleGetter env ActualCompiler
actualCompilerVersionL
  case forall a. [a] -> Maybe (NonEmpty a)
nonEmpty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
Map.toList forall a b. (a -> b) -> a -> b
$ Plan -> Map GhcPkgId (PackageIdentifier, Text)
planUnregisterLocal Plan
plan of
    Maybe (NonEmpty (GhcPkgId, (PackageIdentifier, Text)))
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Just NonEmpty (GhcPkgId, (PackageIdentifier, Text))
ids -> do
      Path Abs Dir
localDB <- forall env. HasEnvConfig env => RIO env (Path Abs Dir)
packageDatabaseLocal
      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

  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar (Map GhcPkgId DumpPackage)
eeLocalDumpPkgs forall a b. (a -> b) -> a -> b
$ \Map GhcPkgId DumpPackage
initMap ->
    forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall k a. Ord k => k -> Map k a -> Map k a
Map.delete) Map GhcPkgId DumpPackage
initMap forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [k]
Map.keys (Plan -> Map GhcPkgId (PackageIdentifier, Text)
planUnregisterLocal Plan
plan)

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

  let actions :: [Action]
actions = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (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) forall a b. (a -> b) -> a -> b
$
        forall k a. Map k a -> [a]
Map.elems forall a b. (a -> b) -> a -> b
$ 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
          (forall (f :: * -> *) k x y.
Applicative f =>
(k -> x -> y) -> WhenMissing f k x y
Map.mapMissing (\PackageName
_ Task
b -> (forall a. a -> Maybe a
Just Task
b, forall a. Maybe a
Nothing)))
          (forall (f :: * -> *) k x y.
Applicative f =>
(k -> x -> y) -> WhenMissing f k x y
Map.mapMissing (\PackageName
_ Task
f -> (forall a. Maybe a
Nothing, forall a. a -> Maybe a
Just Task
f)))
          (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 -> (forall a. a -> Maybe a
Just Task
b, forall a. a -> Maybe a
Just Task
f)))
          (Plan -> Map PackageName Task
planTasks Plan
plan)
          (Plan -> Map PackageName Task
planFinals Plan
plan)
  Int
threads <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasConfig env => Lens' env Config
configLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to Config -> Int
configJobs
  let keepGoing :: Bool
keepGoing =
        forall a. a -> Maybe a -> a
fromMaybe (Bool -> Bool
not (forall k a. Map k a -> Bool
Map.null (Plan -> Map PackageName Task
planFinals Plan
plan))) (BuildOpts -> Maybe Bool
boptsKeepGoing BuildOpts
eeBuildOpts)
  Bool
terminal <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasRunner env => Lens' env Bool
terminalL
  [SomeException]
errs <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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 forall a b. (a -> b) -> a -> b
$
    \TVar Int
doneVar TVar (Set ActionId)
actionsVar -> do
      let total :: Int
total = forall (t :: * -> *) a. Foldable t => t a -> Int
length [Action]
actions
          loop :: Int -> IO ()
loop Int
prev
            | Int
prev forall a. Eq a => a -> a -> Bool
== Int
total =
                RIO env () -> IO ()
run forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) env.
(MonadIO m, ?callStack::CallStack, MonadReader env m,
 HasLogFunc env) =>
Utf8Builder -> m ()
logStickyDone
                  ( Utf8Builder
"Completed " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Int
total forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" action(s).")
            | Bool
otherwise = do
                Set ActionId
inProgress <- forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar (Set ActionId)
actionsVar
                let packageNames :: [PackageName]
packageNames = forall a b. (a -> b) -> [a] -> [b]
map
                      (\(ActionId PackageIdentifier
pkgID ActionType
_) -> PackageIdentifier -> PackageName
pkgName PackageIdentifier
pkgID)
                      (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Set ActionId
inProgress)
                    nowBuilding :: [PackageName] -> Utf8Builder
                    nowBuilding :: [PackageName] -> Utf8Builder
nowBuilding []    = Utf8Builder
""
                    nowBuilding [PackageName]
names = forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$
                        Utf8Builder
": "
                      forall a. a -> [a] -> [a]
: forall a. a -> [a] -> [a]
L.intersperse Utf8Builder
", "
                          (forall a b. (a -> b) -> [a] -> [b]
map (forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> String
packageNameString) [PackageName]
names)
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
terminal forall a b. (a -> b) -> a -> b
$ RIO env () -> IO ()
run forall a b. (a -> b) -> a -> b
$
                  forall (m :: * -> *) env.
(MonadIO m, ?callStack::CallStack, MonadReader env m,
 HasLogFunc env) =>
Utf8Builder -> m ()
logSticky forall a b. (a -> b) -> a -> b
$
                    Utf8Builder
"Progress " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Int
prev forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"/" forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Int
total forall a. Semigroup a => a -> a -> a
<>
                        [PackageName] -> Utf8Builder
nowBuilding [PackageName]
packageNames
                Int
done <- forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$ do
                  Int
done <- forall a. TVar a -> STM a
readTVar TVar Int
doneVar
                  Bool -> STM ()
check forall a b. (a -> b) -> a -> b
$ Int
done forall a. Eq a => a -> a -> Bool
/= Int
prev
                  forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
done
                Int -> IO ()
loop Int
done
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
total forall a. Ord a => a -> a -> Bool
> Int
1) forall a b. (a -> b) -> a -> b
$ Int -> IO ()
loop Int
0
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TestOpts -> Bool
toCoverage forall a b. (a -> b) -> a -> b
$ BuildOpts -> TestOpts
boptsTestOpts BuildOpts
eeBuildOpts) forall a b. (a -> b) -> a -> b
$ do
    forall env. HasEnvConfig env => RIO env ()
generateHpcUnifiedReport
    forall env. HasEnvConfig env => RIO env ()
generateHpcMarkupIndex
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SomeException]
errs) forall a b. (a -> b) -> a -> b
$
    forall e (m :: * -> *) a.
(Exception e, MonadThrow m, Pretty e) =>
e -> m a
prettyThrowM forall a b. (a -> b) -> a -> b
$ [SomeException] -> BuildPrettyException
ExecutionFailure [SomeException]
errs
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (BuildOpts -> Bool
boptsHaddock BuildOpts
eeBuildOpts) forall a b. (a -> b) -> a -> b
$ do
    Map GhcPkgId DumpPackage
snapshotDumpPkgs <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar (Map GhcPkgId DumpPackage)
eeSnapshotDumpPkgs)
    Map GhcPkgId DumpPackage
localDumpPkgs <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar (Map GhcPkgId DumpPackage)
eeLocalDumpPkgs)
    forall env.
(HasCompiler env, HasProcessContext env, HasTerm env) =>
BaseConfigOpts
-> Map GhcPkgId DumpPackage -> [LocalPackage] -> RIO env ()
generateLocalHaddockIndex BaseConfigOpts
eeBaseConfigOpts Map GhcPkgId DumpPackage
localDumpPkgs [LocalPackage]
eeLocals
    forall env.
(HasCompiler env, HasProcessContext env, HasTerm env) =>
BaseConfigOpts
-> Map GhcPkgId DumpPackage
-> Map GhcPkgId DumpPackage
-> Map GhcPkgId DumpPackage
-> [LocalPackage]
-> RIO env ()
generateDepsHaddockIndex
      BaseConfigOpts
eeBaseConfigOpts
      Map GhcPkgId DumpPackage
eeGlobalDumpPkgs
      Map GhcPkgId DumpPackage
snapshotDumpPkgs
      Map GhcPkgId DumpPackage
localDumpPkgs
      [LocalPackage]
eeLocals
    forall env.
(HasCompiler env, HasProcessContext env, HasTerm env) =>
BaseConfigOpts
-> Map GhcPkgId DumpPackage
-> Map GhcPkgId DumpPackage
-> RIO env ()
generateSnapHaddockIndex BaseConfigOpts
eeBaseConfigOpts Map GhcPkgId DumpPackage
eeGlobalDumpPkgs Map GhcPkgId DumpPackage
snapshotDumpPkgs
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (BuildOpts -> Bool
boptsOpenHaddocks BuildOpts
eeBuildOpts) forall a b. (a -> b) -> a -> b
$ do
      let planPkgs, localPkgs, installedPkgs, availablePkgs
            :: Map PackageName (PackageIdentifier, InstallLocation)
          planPkgs :: Map PackageName (PackageIdentifier, InstallLocation)
planPkgs = forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (Task -> PackageIdentifier
taskProvides forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Task -> InstallLocation
taskLocation) (Plan -> Map PackageName Task
planTasks Plan
plan)
          localPkgs :: Map PackageName (PackageIdentifier, InstallLocation)
localPkgs =
            forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
              [ (Package -> PackageName
packageName Package
p, (Package -> PackageIdentifier
packageIdentifier Package
p, InstallLocation
Local))
              | Package
p <- forall a b. (a -> b) -> [a] -> [b]
map LocalPackage -> Package
lpPackage [LocalPackage]
eeLocals
              ]
          installedPkgs :: Map PackageName (PackageIdentifier, InstallLocation)
installedPkgs =
            forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (forall a b. (a, b) -> (b, a)
swap 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 = 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]
      forall env.
HasTerm env =>
BaseConfigOpts
-> Map PackageName (PackageIdentifier, InstallLocation)
-> Set PackageName
-> RIO env ()
openHaddocksInBrowser BaseConfigOpts
eeBaseConfigOpts Map PackageName (PackageIdentifier, InstallLocation)
availablePkgs (forall k a. Map k a -> Set k
Map.keysSet Map PackageName Target
targets)
 where
  installedMap' :: InstalledMap
installedMap' = forall k a b. Ord k => Map k a -> Map k b -> Map k a
Map.difference InstalledMap
installedMap0
                forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
                forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\(PackageIdentifier
ident, Text
_) -> (PackageIdentifier -> PackageName
pkgName PackageIdentifier
ident, ()))
                forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [a]
Map.elems
                forall a b. (a -> b) -> a -> b
$ Plan -> Map GhcPkgId (PackageIdentifier, Text)
planUnregisterLocal Plan
plan

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 =
        forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
 MonadIO m) =>
[StyleDoc] -> m ()
prettyInfoL
          (  [ forall a. IsString a => String -> a
fromString (PackageIdentifier -> String
packageIdentifierString PackageIdentifier
ident) forall a. Semigroup a => a -> a -> a
<> StyleDoc
":"
             , StyleDoc
"unregistering"
             ]
          forall a. Semigroup a => a -> a -> a
<> [ StyleDoc -> StyleDoc
parens (String -> StyleDoc
flow forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
reason) | Bool -> Bool
not 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
        forall {env} {m :: * -> *}.
(HasTerm env, MonadReader env m, MonadIO m) =>
PackageIdentifier -> Text -> m ()
logReason PackageIdentifier
ident Text
reason
        GhcPkgExe
pkg <- forall env. HasCompiler env => RIO env GhcPkgExe
getGhcPkgExe
        forall env.
(HasProcessContext env, HasTerm env) =>
GhcPkgExe
-> Path Abs Dir
-> NonEmpty (Either PackageIdentifier GhcPkgId)
-> RIO env ()
unregisterGhcPkgIds GhcPkgExe
pkg Path Abs Dir
localDB forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> GhcPkgId -> Either PackageIdentifier GhcPkgId
select PackageIdentifier
ident GhcPkgId
gid 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 forall a. Ord a => a -> a -> Bool
>= [Int] -> Version
mkVersion [Int
8, Int
2, Int
1] -> do
      Platform
platform <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasPlatform env => 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 = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall a. [a] -> Maybe (NonEmpty a)
nonEmpty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Int -> [e] -> [[e]]
chunksOf Int
size forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NonEmpty a -> [a]
NonEmpty.toList
      forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (forall {a}. Int -> NonEmpty a -> [NonEmpty a]
chunksOfNE Int
batchSize NonEmpty (GhcPkgId, (PackageIdentifier, Text))
ids) forall a b. (a -> b) -> a -> b
$ \NonEmpty (GhcPkgId, (PackageIdentifier, Text))
batch -> do
        forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ NonEmpty (GhcPkgId, (PackageIdentifier, Text))
batch forall a b. (a -> b) -> a -> b
$ \(GhcPkgId
_, (PackageIdentifier
ident, Text
reason)) -> forall {env} {m :: * -> *}.
(HasTerm env, MonadReader env m, MonadIO m) =>
PackageIdentifier -> Text -> m ()
logReason PackageIdentifier
ident Text
reason
        GhcPkgExe
pkg <- forall env. HasCompiler env => RIO env GhcPkgExe
getGhcPkgExe
        forall env.
(HasProcessContext env, HasTerm env) =>
GhcPkgExe
-> Path Abs Dir
-> NonEmpty (Either PackageIdentifier GhcPkgId)
-> RIO env ()
unregisterGhcPkgIds GhcPkgExe
pkg Path Abs Dir
localDB forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall a. Ord a => a -> a -> Bool
>= [Int] -> Version
mkVersion [Int
7, Int
9] ->
      forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ NonEmpty (GhcPkgId, (PackageIdentifier, Text))
ids forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PackageIdentifier
 -> GhcPkgId -> Either PackageIdentifier GhcPkgId)
-> (GhcPkgId, (PackageIdentifier, Text)) -> RIO env ()
unregisterSinglePkg forall a b. (a -> b) -> a -> b
$ \PackageIdentifier
_ident GhcPkgId
gid -> forall a b. b -> Either a b
Right GhcPkgId
gid

    ActualCompiler
_ -> forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ NonEmpty (GhcPkgId, (PackageIdentifier, Text))
ids forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PackageIdentifier
 -> GhcPkgId -> Either PackageIdentifier GhcPkgId)
-> (GhcPkgId, (PackageIdentifier, Text)) -> RIO env ()
unregisterSinglePkg forall a b. (a -> b) -> a -> b
$ \PackageIdentifier
ident GhcPkgId
_gid -> 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 forall a. [a] -> [a] -> [a]
++ [Action]
afinal
 where
  abuild :: [Action]
abuild = case Maybe Task
mbuild of
    Maybe Task
Nothing -> []
    Just task :: Task
task@Task {Bool
PackageIdentifier
Map PackageIdentifier GhcPkgId
TaskType
TaskConfigOpts
CachePkgSrc
taskBuildTypeConfig :: Task -> Bool
taskAnyMissing :: Task -> Bool
taskCachePkgSrc :: Task -> CachePkgSrc
taskAllInOne :: Task -> Bool
taskPresent :: Task -> Map PackageIdentifier GhcPkgId
taskBuildHaddock :: Task -> Bool
taskBuildTypeConfig :: Bool
taskAnyMissing :: Bool
taskCachePkgSrc :: CachePkgSrc
taskAllInOne :: Bool
taskPresent :: Map PackageIdentifier GhcPkgId
taskBuildHaddock :: Bool
taskConfigOpts :: TaskConfigOpts
taskType :: TaskType
taskProvides :: PackageIdentifier
taskConfigOpts :: Task -> TaskConfigOpts
taskProvides :: Task -> PackageIdentifier
taskType :: Task -> TaskType
..} ->
      [ Action
          { actionId :: ActionId
actionId = PackageIdentifier -> ActionType -> ActionId
ActionId PackageIdentifier
taskProvides ActionType
ATBuild
          , actionDeps :: Set ActionId
actionDeps =
              forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (PackageIdentifier -> ActionType -> ActionId
`ActionId` ActionType
ATBuild) (TaskConfigOpts -> Set PackageIdentifier
tcoMissing TaskConfigOpts
taskConfigOpts)
          , actionDo :: ActionContext -> IO ()
actionDo =
              \ActionContext
ac -> RIO env () -> IO ()
runInBase forall a b. (a -> b) -> a -> b
$ forall env.
(HasEnvConfig env, HasRunner env) =>
ActionContext
-> ExecuteEnv -> Task -> InstalledMap -> Bool -> RIO env ()
singleBuild ActionContext
ac ExecuteEnv
ee Task
task InstalledMap
installedMap Bool
False
          , actionConcurrency :: Concurrency
actionConcurrency = Concurrency
ConcurrencyAllowed
          }
      ]
  afinal :: [Action]
afinal = case Maybe Task
mfinal of
    Maybe Task
Nothing -> []
    Just task :: Task
task@Task {Bool
PackageIdentifier
Map PackageIdentifier GhcPkgId
TaskType
TaskConfigOpts
CachePkgSrc
taskBuildTypeConfig :: Bool
taskAnyMissing :: Bool
taskCachePkgSrc :: CachePkgSrc
taskAllInOne :: Bool
taskPresent :: Map PackageIdentifier GhcPkgId
taskBuildHaddock :: Bool
taskConfigOpts :: TaskConfigOpts
taskType :: TaskType
taskProvides :: PackageIdentifier
taskBuildTypeConfig :: Task -> Bool
taskAnyMissing :: Task -> Bool
taskCachePkgSrc :: Task -> CachePkgSrc
taskAllInOne :: Task -> Bool
taskPresent :: Task -> Map PackageIdentifier GhcPkgId
taskBuildHaddock :: Task -> Bool
taskConfigOpts :: Task -> TaskConfigOpts
taskProvides :: Task -> PackageIdentifier
taskType :: Task -> TaskType
..} ->
      (if Bool
taskAllInOne then forall a. a -> a
id else (:)
          Action
              { actionId :: ActionId
actionId = PackageIdentifier -> ActionType -> ActionId
ActionId PackageIdentifier
taskProvides ActionType
ATBuildFinal
              , actionDeps :: Set ActionId
actionDeps = Set ActionId -> Set ActionId
addBuild
                  (forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (PackageIdentifier -> ActionType -> ActionId
`ActionId` ActionType
ATBuild) (TaskConfigOpts -> Set PackageIdentifier
tcoMissing TaskConfigOpts
taskConfigOpts))
              , actionDo :: ActionContext -> IO ()
actionDo =
                  \ActionContext
ac -> RIO env () -> IO ()
runInBase forall a b. (a -> b) -> a -> b
$ forall env.
(HasEnvConfig env, HasRunner env) =>
ActionContext
-> ExecuteEnv -> Task -> InstalledMap -> Bool -> RIO env ()
singleBuild ActionContext
ac ExecuteEnv
ee Task
task InstalledMap
installedMap Bool
True
              , actionConcurrency :: Concurrency
actionConcurrency = Concurrency
ConcurrencyAllowed
              }) forall a b. (a -> b) -> a -> b
$
      -- These are the "final" actions - running tests and benchmarks.

      (if forall a. Set a -> Bool
Set.null Set Text
tests then forall a. a -> a
id else (:)
          Action
              { actionId :: ActionId
actionId = PackageIdentifier -> ActionType -> ActionId
ActionId PackageIdentifier
taskProvides ActionType
ATRunTests
              , actionDeps :: Set ActionId
actionDeps = Set ActionId
finalDeps
              , actionDo :: ActionContext -> IO ()
actionDo = \ActionContext
ac -> forall {m :: * -> *} {b}.
MonadUnliftIO m =>
Maybe (MVar ()) -> m b -> m b
withLock Maybe (MVar ())
mtestLock forall a b. (a -> b) -> a -> b
$ RIO env () -> IO ()
runInBase forall a b. (a -> b) -> a -> b
$
                  forall env.
HasEnvConfig env =>
TestOpts
-> [Text]
-> ActionContext
-> ExecuteEnv
-> Task
-> InstalledMap
-> RIO env ()
singleTest TestOpts
topts (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.

              , actionConcurrency :: Concurrency
actionConcurrency = Concurrency
ConcurrencyAllowed
              }) forall a b. (a -> b) -> a -> b
$
      (if forall a. Set a -> Bool
Set.null Set Text
benches then forall a. a -> a
id else (:)
          Action
              { actionId :: ActionId
actionId = PackageIdentifier -> ActionType -> ActionId
ActionId PackageIdentifier
taskProvides ActionType
ATRunBenchmarks
              , actionDeps :: Set ActionId
actionDeps = Set ActionId
finalDeps
              , actionDo :: ActionContext -> IO ()
actionDo = \ActionContext
ac -> RIO env () -> IO ()
runInBase forall a b. (a -> b) -> a -> b
$
                  forall env.
HasEnvConfig env =>
BenchmarkOpts
-> [Text]
-> ActionContext
-> ExecuteEnv
-> Task
-> InstalledMap
-> RIO env ()
singleBench
                    BenchmarkOpts
beopts
                    (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

              , actionConcurrency :: Concurrency
actionConcurrency = Concurrency
ConcurrencyDisallowed
              })
      []
     where
      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 Bool
taskAllInOne
          then Set ActionId -> Set ActionId
addBuild forall a. Monoid a => a
mempty
          else forall a. a -> Set a
Set.singleton (PackageIdentifier -> ActionType -> ActionId
ActionId PackageIdentifier
taskProvides ActionType
ATBuildFinal)
      addBuild :: Set ActionId -> Set ActionId
addBuild =
        case Maybe Task
mbuild of
          Maybe Task
Nothing -> forall a. a -> a
id
          Just Task
_ -> forall a. Ord a => a -> Set a -> Set a
Set.insert forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> ActionType -> ActionId
ActionId PackageIdentifier
taskProvides 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 = forall (m :: * -> *) a b.
MonadUnliftIO m =>
MVar a -> (a -> m b) -> m b
withMVar MVar ()
lock forall a b. (a -> b) -> a -> b
$ \() -> m b
f
  bopts :: BuildOpts
bopts = ExecuteEnv -> BuildOpts
eeBuildOpts ExecuteEnv
ee
  topts :: TestOpts
topts = BuildOpts -> TestOpts
boptsTestOpts BuildOpts
bopts
  beopts :: BenchmarkOpts
beopts = BuildOpts -> BenchmarkOpts
boptsBenchmarkOpts BuildOpts
bopts

-- | Generate the ConfigCache

getConfigCache ::
     HasEnvConfig env
  => ExecuteEnv
  -> Task
  -> InstalledMap
  -> Bool
  -> Bool
  -> RIO env (Map PackageIdentifier GhcPkgId, ConfigCache)
getConfigCache :: forall env.
HasEnvConfig env =>
ExecuteEnv
-> Task
-> InstalledMap
-> Bool
-> Bool
-> RIO env (Map PackageIdentifier GhcPkgId, ConfigCache)
getConfigCache ExecuteEnv {Int
[LocalPackage]
Maybe Int
Maybe (Path Abs File)
Map GhcPkgId DumpPackage
MVar ()
Version
Text
TVar (Map PackageIdentifier Installed)
TVar (Map GhcPkgId DumpPackage)
IORef (Set PackageName)
Path Abs File
Path Abs Dir
TChan (Path Abs Dir, Path Abs File)
BuildOptsCLI
BuildOpts
BaseConfigOpts
eePathEnvVar :: Text
eeLargestPackageName :: Maybe Int
eeCustomBuilt :: IORef (Set PackageName)
eeLogFiles :: TChan (Path Abs Dir, Path Abs File)
eeLocalDumpPkgs :: TVar (Map GhcPkgId DumpPackage)
eeSnapshotDumpPkgs :: TVar (Map GhcPkgId DumpPackage)
eeGlobalDumpPkgs :: Map GhcPkgId DumpPackage
eeGlobalDB :: Path Abs Dir
eeLocals :: [LocalPackage]
eeTotalWanted :: Int
eeCabalPkgVer :: Version
eeSetupExe :: Maybe (Path Abs File)
eeSetupShimHs :: Path Abs File
eeSetupHs :: Path Abs File
eeTempDir :: Path Abs Dir
eeGhcPkgIds :: TVar (Map PackageIdentifier Installed)
eeBaseConfigOpts :: BaseConfigOpts
eeBuildOptsCLI :: BuildOptsCLI
eeBuildOpts :: BuildOpts
eeInstallLock :: MVar ()
eeConfigureLock :: MVar ()
eePathEnvVar :: ExecuteEnv -> Text
eeLargestPackageName :: ExecuteEnv -> Maybe Int
eeCustomBuilt :: ExecuteEnv -> IORef (Set PackageName)
eeLogFiles :: ExecuteEnv -> TChan (Path Abs Dir, Path Abs File)
eeLocalDumpPkgs :: ExecuteEnv -> TVar (Map GhcPkgId DumpPackage)
eeSnapshotDumpPkgs :: ExecuteEnv -> TVar (Map GhcPkgId DumpPackage)
eeGlobalDumpPkgs :: ExecuteEnv -> Map GhcPkgId DumpPackage
eeGlobalDB :: ExecuteEnv -> Path Abs Dir
eeLocals :: ExecuteEnv -> [LocalPackage]
eeTotalWanted :: ExecuteEnv -> Int
eeCabalPkgVer :: ExecuteEnv -> Version
eeSetupExe :: ExecuteEnv -> Maybe (Path Abs File)
eeSetupShimHs :: ExecuteEnv -> Path Abs File
eeSetupHs :: ExecuteEnv -> Path Abs File
eeTempDir :: ExecuteEnv -> Path Abs Dir
eeGhcPkgIds :: ExecuteEnv -> TVar (Map PackageIdentifier Installed)
eeBaseConfigOpts :: ExecuteEnv -> BaseConfigOpts
eeBuildOptsCLI :: ExecuteEnv -> BuildOptsCLI
eeBuildOpts :: ExecuteEnv -> BuildOpts
eeInstallLock :: ExecuteEnv -> MVar ()
eeConfigureLock :: ExecuteEnv -> MVar ()
..} task :: Task
task@Task {Bool
PackageIdentifier
Map PackageIdentifier GhcPkgId
TaskType
TaskConfigOpts
CachePkgSrc
taskBuildTypeConfig :: Bool
taskAnyMissing :: Bool
taskCachePkgSrc :: CachePkgSrc
taskAllInOne :: Bool
taskPresent :: Map PackageIdentifier GhcPkgId
taskBuildHaddock :: Bool
taskConfigOpts :: TaskConfigOpts
taskType :: TaskType
taskProvides :: PackageIdentifier
taskBuildTypeConfig :: Task -> Bool
taskAnyMissing :: Task -> Bool
taskCachePkgSrc :: Task -> CachePkgSrc
taskAllInOne :: Task -> Bool
taskPresent :: Task -> Map PackageIdentifier GhcPkgId
taskBuildHaddock :: Task -> Bool
taskConfigOpts :: Task -> TaskConfigOpts
taskProvides :: Task -> PackageIdentifier
taskType :: Task -> TaskType
..} InstalledMap
installedMap Bool
enableTest Bool
enableBench = do
  let extra :: [Text]
extra =
        -- We enable tests if the test suite dependencies are already

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

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

        -- 'stack test'. See:

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

        case TaskType
taskType of
          TTLocalMutable LocalPackage
_ ->
            -- FIXME: make this work with exact-configuration.

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

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

            [ Text
"--enable-tests" | Bool
enableTest] forall a. [a] -> [a] -> [a]
++
            [ Text
"--enable-benchmarks" | Bool
enableBench]
          TTRemotePackage{} -> []
  Map PackageIdentifier Installed
idMap <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar (Map PackageIdentifier Installed)
eeGhcPkgIds
  let getMissing :: PackageIdentifier -> Maybe (PackageIdentifier, GhcPkgId)
getMissing PackageIdentifier
ident =
        case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageIdentifier
ident Map PackageIdentifier Installed
idMap of
          Maybe Installed
Nothing
              -- Expect to instead find it in installedMap if it's

              -- an initialBuildSteps target.

              | BuildOptsCLI -> Bool
boptsCLIInitialBuildSteps BuildOptsCLI
eeBuildOptsCLI Bool -> Bool -> Bool
&& Task -> Bool
taskIsTarget Task
task,
                Just (InstallLocation
_, Installed
installed) <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (PackageIdentifier -> PackageName
pkgName PackageIdentifier
ident) InstalledMap
installedMap
                  -> PackageIdentifier
-> Installed -> Maybe (PackageIdentifier, GhcPkgId)
installedToGhcPkgId PackageIdentifier
ident Installed
installed
          Just Installed
installed -> PackageIdentifier
-> Installed -> Maybe (PackageIdentifier, GhcPkgId)
installedToGhcPkgId PackageIdentifier
ident Installed
installed
          Maybe Installed
_ -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> BuildException
PackageIdMissingBug PackageIdentifier
ident
      installedToGhcPkgId :: PackageIdentifier
-> Installed -> Maybe (PackageIdentifier, GhcPkgId)
installedToGhcPkgId PackageIdentifier
ident (Library PackageIdentifier
ident' GhcPkgId
x Maybe (Either License License)
_) =
        forall a. (?callStack::CallStack) => Bool -> a -> a
assert (PackageIdentifier
ident forall a. Eq a => a -> a -> Bool
== PackageIdentifier
ident') forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (PackageIdentifier
ident, GhcPkgId
x)
      installedToGhcPkgId PackageIdentifier
_ (Executable PackageIdentifier
_) = forall a. Maybe a
Nothing
      missing' :: Map PackageIdentifier GhcPkgId
missing' = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe PackageIdentifier -> Maybe (PackageIdentifier, GhcPkgId)
getMissing forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
Set.toList Set PackageIdentifier
missing
      TaskConfigOpts Set PackageIdentifier
missing Map PackageIdentifier GhcPkgId -> ConfigureOpts
mkOpts = TaskConfigOpts
taskConfigOpts
      opts :: ConfigureOpts
opts = Map PackageIdentifier GhcPkgId -> ConfigureOpts
mkOpts Map PackageIdentifier GhcPkgId
missing'
      allDeps :: Set GhcPkgId
allDeps = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [a]
Map.elems Map PackageIdentifier GhcPkgId
missing' forall a. [a] -> [a] -> [a]
++ forall k a. Map k a -> [a]
Map.elems Map PackageIdentifier GhcPkgId
taskPresent
      cache :: ConfigCache
cache = ConfigCache
        { configCacheOpts :: ConfigureOpts
configCacheOpts = ConfigureOpts
opts
            { coNoDirs :: [String]
coNoDirs = ConfigureOpts -> [String]
coNoDirs ConfigureOpts
opts forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map Text -> String
T.unpack [Text]
extra
            }
        , configCacheDeps :: Set GhcPkgId
configCacheDeps = Set GhcPkgId
allDeps
        , configCacheComponents :: Set ByteString
configCacheComponents =
            case TaskType
taskType of
              TTLocalMutable LocalPackage
lp ->
                forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (Text -> ByteString
encodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamedComponent -> Text
renderComponent) forall a b. (a -> b) -> a -> b
$ LocalPackage -> Set NamedComponent
lpComponents LocalPackage
lp
              TTRemotePackage{} -> forall a. Set a
Set.empty
        , configCacheHaddock :: Bool
configCacheHaddock = Bool
taskBuildHaddock
        , configCachePkgSrc :: CachePkgSrc
configCachePkgSrc = CachePkgSrc
taskCachePkgSrc
        , configCachePathEnvVar :: Text
configCachePathEnvVar = Text
eePathEnvVar
        }
      allDepsMap :: Map PackageIdentifier GhcPkgId
allDepsMap = forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map PackageIdentifier GhcPkgId
missing' Map PackageIdentifier GhcPkgId
taskPresent
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map PackageIdentifier GhcPkgId
allDepsMap, ConfigCache
cache)

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

ensureConfig :: HasEnvConfig env
             => ConfigCache -- ^ newConfigCache

             -> Path Abs Dir -- ^ package directory

             -> ExecuteEnv
             -> RIO env () -- ^ announce

             -> (ExcludeTHLoading -> [String] -> RIO env ()) -- ^ cabal

             -> Path Abs File -- ^ Cabal file

             -> Task
             -> RIO env Bool
ensureConfig :: forall env.
HasEnvConfig env =>
ConfigCache
-> Path Abs Dir
-> ExecuteEnv
-> RIO env ()
-> (ExcludeTHLoading -> [String] -> RIO env ())
-> Path Abs File
-> Task
-> RIO env Bool
ensureConfig ConfigCache
newConfigCache Path Abs Dir
pkgDir ExecuteEnv {Int
[LocalPackage]
Maybe Int
Maybe (Path Abs File)
Map GhcPkgId DumpPackage
MVar ()
Version
Text
TVar (Map PackageIdentifier Installed)
TVar (Map GhcPkgId DumpPackage)
IORef (Set PackageName)
Path Abs File
Path Abs Dir
TChan (Path Abs Dir, Path Abs File)
BuildOptsCLI
BuildOpts
BaseConfigOpts
eePathEnvVar :: Text
eeLargestPackageName :: Maybe Int
eeCustomBuilt :: IORef (Set PackageName)
eeLogFiles :: TChan (Path Abs Dir, Path Abs File)
eeLocalDumpPkgs :: TVar (Map GhcPkgId DumpPackage)
eeSnapshotDumpPkgs :: TVar (Map GhcPkgId DumpPackage)
eeGlobalDumpPkgs :: Map GhcPkgId DumpPackage
eeGlobalDB :: Path Abs Dir
eeLocals :: [LocalPackage]
eeTotalWanted :: Int
eeCabalPkgVer :: Version
eeSetupExe :: Maybe (Path Abs File)
eeSetupShimHs :: Path Abs File
eeSetupHs :: Path Abs File
eeTempDir :: Path Abs Dir
eeGhcPkgIds :: TVar (Map PackageIdentifier Installed)
eeBaseConfigOpts :: BaseConfigOpts
eeBuildOptsCLI :: BuildOptsCLI
eeBuildOpts :: BuildOpts
eeInstallLock :: MVar ()
eeConfigureLock :: MVar ()
eePathEnvVar :: ExecuteEnv -> Text
eeLargestPackageName :: ExecuteEnv -> Maybe Int
eeCustomBuilt :: ExecuteEnv -> IORef (Set PackageName)
eeLogFiles :: ExecuteEnv -> TChan (Path Abs Dir, Path Abs File)
eeLocalDumpPkgs :: ExecuteEnv -> TVar (Map GhcPkgId DumpPackage)
eeSnapshotDumpPkgs :: ExecuteEnv -> TVar (Map GhcPkgId DumpPackage)
eeGlobalDumpPkgs :: ExecuteEnv -> Map GhcPkgId DumpPackage
eeGlobalDB :: ExecuteEnv -> Path Abs Dir
eeLocals :: ExecuteEnv -> [LocalPackage]
eeTotalWanted :: ExecuteEnv -> Int
eeCabalPkgVer :: ExecuteEnv -> Version
eeSetupExe :: ExecuteEnv -> Maybe (Path Abs File)
eeSetupShimHs :: ExecuteEnv -> Path Abs File
eeSetupHs :: ExecuteEnv -> Path Abs File
eeTempDir :: ExecuteEnv -> Path Abs Dir
eeGhcPkgIds :: ExecuteEnv -> TVar (Map PackageIdentifier Installed)
eeBaseConfigOpts :: ExecuteEnv -> BaseConfigOpts
eeBuildOptsCLI :: ExecuteEnv -> BuildOptsCLI
eeBuildOpts :: ExecuteEnv -> BuildOpts
eeInstallLock :: ExecuteEnv -> MVar ()
eeConfigureLock :: ExecuteEnv -> MVar ()
..} RIO env ()
announce ExcludeTHLoading -> [String] -> RIO env ()
cabal Path Abs File
cabalfp Task
task = do
  CTime
newCabalMod <-
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FileStatus -> CTime
modificationTime forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO FileStatus
getFileStatus (forall b t. Path b t -> String
toFilePath Path Abs File
cabalfp)
  Path Abs File
setupConfigfp <- forall (m :: * -> *) env.
(MonadThrow m, MonadReader env m, HasEnvConfig env) =>
Path Abs Dir -> m (Path Abs File)
setupConfigFromDir Path Abs Dir
pkgDir
  let getNewSetupConfigMod :: RIO env (Maybe CTime)
getNewSetupConfigMod =
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileStatus -> CTime
modificationTime) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        forall (m :: * -> *) e b a.
(MonadUnliftIO m, Exception e) =>
(e -> Maybe b) -> m a -> m (Either b a)
tryJust
          (forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOError -> Bool
isDoesNotExistError)
          (String -> IO FileStatus
getFileStatus (forall b t. Path b t -> String
toFilePath Path Abs File
setupConfigfp))
  Maybe CTime
newSetupConfigMod <- RIO env (Maybe CTime)
getNewSetupConfigMod
  ByteString
newProjectRoot <- String -> ByteString
S8.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b t. Path b t -> String
toFilePath forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env r. HasBuildConfig env => Getting r env (Path Abs Dir)
projectRootL
  -- See https://github.com/commercialhaskell/stack/issues/3554

  Bool
taskAnyMissingHack <-
    forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasSourceMap env => SimpleGetter env ActualCompiler
actualCompilerVersionLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to ActualCompiler -> Version
getGhcVersionforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to (forall a. Ord a => a -> a -> Bool
< [Int] -> Version
mkVersion [Int
8, Int
4])
  Bool
needConfig <-
    if   BuildOpts -> Bool
boptsReconfigure BuildOpts
eeBuildOpts
      Bool -> Bool -> Bool
|| (Task -> Bool
taskAnyMissing Task
task Bool -> Bool -> Bool
&& Bool
taskAnyMissingHack)
      then forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
      else do
        -- We can ignore the components portion of the config

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

        -- plan that we need to plan to build additional

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

        -- package configuration.

        let ignoreComponents :: ConfigCache -> ConfigCache
ignoreComponents ConfigCache
cc = ConfigCache
cc { configCacheComponents :: Set ByteString
configCacheComponents = forall a. Set a
Set.empty }
        -- Determine the old and new configuration in the local directory, to

        -- determine if we need to reconfigure.

        Maybe ConfigCache
mOldConfigCache <- forall env.
HasEnvConfig env =>
Path Abs Dir -> RIO env (Maybe ConfigCache)
tryGetConfigCache Path Abs Dir
pkgDir

        Maybe CTime
mOldCabalMod <- forall env.
HasEnvConfig env =>
Path Abs Dir -> RIO env (Maybe CTime)
tryGetCabalMod Path Abs Dir
pkgDir

        -- Cabal's setup-config is created per OS/Cabal version, multiple

        -- projects using the same package could get a conflict because of this

        Maybe CTime
mOldSetupConfigMod <- forall env.
HasEnvConfig env =>
Path Abs Dir -> RIO env (Maybe CTime)
tryGetSetupConfigMod Path Abs Dir
pkgDir
        Maybe ByteString
mOldProjectRoot <- forall env.
HasEnvConfig env =>
Path Abs Dir -> RIO env (Maybe ByteString)
tryGetPackageProjectRoot Path Abs Dir
pkgDir

        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
                forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ConfigCache -> ConfigCache
ignoreComponents Maybe ConfigCache
mOldConfigCache
             forall a. Eq a => a -> a -> Bool
/= forall a. a -> Maybe a
Just (ConfigCache -> ConfigCache
ignoreComponents ConfigCache
newConfigCache)
          Bool -> Bool -> Bool
|| Maybe CTime
mOldCabalMod forall a. Eq a => a -> a -> Bool
/= forall a. a -> Maybe a
Just CTime
newCabalMod
          Bool -> Bool -> Bool
|| Maybe CTime
mOldSetupConfigMod forall a. Eq a => a -> a -> Bool
/= Maybe CTime
newSetupConfigMod
          Bool -> Bool -> Bool
|| Maybe ByteString
mOldProjectRoot forall a. Eq a => a -> a -> Bool
/= forall a. a -> Maybe a
Just ByteString
newProjectRoot
  let ConfigureOpts [String]
dirs [String]
nodirs = ConfigCache -> ConfigureOpts
configCacheOpts ConfigCache
newConfigCache

  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Task -> Bool
taskBuildTypeConfig Task
task) RIO env ()
ensureConfigureScript

  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
needConfig forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b.
MonadUnliftIO m =>
MVar a -> (a -> m b) -> m b
withMVar MVar ()
eeConfigureLock forall a b. (a -> b) -> a -> b
$ \()
_ -> do
    forall env. HasEnvConfig env => Path Abs Dir -> RIO env ()
deleteCaches Path Abs Dir
pkgDir
    RIO env ()
announce
    CompilerPaths
cp <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasCompiler env => SimpleGetter env CompilerPaths
compilerPathsL
    let (GhcPkgExe Path Abs File
pkgPath) = CompilerPaths -> GhcPkgExe
cpPkg CompilerPaths
cp
    let programNames :: [(String, String)]
programNames =
          case forall env (m :: * -> *).
(MonadReader env m, HasCompiler env) =>
m WhichCompiler
cpWhich CompilerPaths
cp of
            WhichCompiler
Ghc ->
              [ (String
"ghc", forall b t. Path b t -> String
toFilePath (CompilerPaths -> Path Abs File
cpCompiler CompilerPaths
cp))
              , (String
"ghc-pkg", forall b t. Path b t -> String
toFilePath Path Abs File
pkgPath)
              ]
    [[String]]
exes <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(String, String)]
programNames forall a b. (a -> b) -> a -> b
$ \(String
name, String
file) -> do
      Either ProcessException String
mpath <- forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasProcessContext env) =>
String -> m (Either ProcessException String)
findExecutable String
file
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case Either ProcessException String
mpath of
          Left ProcessException
_ -> []
          Right String
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"--with-", String
name, String
"=", String
x]
    -- Configure cabal with arguments determined by

    -- Stack.Types.Build.configureOpts

    ExcludeTHLoading -> [String] -> RIO env ()
cabal ExcludeTHLoading
KeepTHLoading forall a b. (a -> b) -> a -> b
$ String
"configure" forall a. a -> [a] -> [a]
: forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[String]]
exes
      , [String]
dirs
      , [String]
nodirs
      ]
    -- Only write the cache for local packages.  Remote packages are built in a

    -- temporary directory so the cache would never be used anyway.

    case Task -> TaskType
taskType Task
task of
      TTLocalMutable{} -> forall env.
HasEnvConfig env =>
Path Abs Dir -> ConfigCache -> RIO env ()
writeConfigCache Path Abs Dir
pkgDir ConfigCache
newConfigCache
      TTRemotePackage{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    forall env. HasEnvConfig env => Path Abs Dir -> CTime -> RIO env ()
writeCabalMod Path Abs Dir
pkgDir CTime
newCabalMod
    -- This file gets updated one more time by the configure step, so get the

    -- most recent value. We could instead change our logic above to check if

    -- our config mod file is newer than the file above, but this seems

    -- reasonable too.

    RIO env (Maybe CTime)
getNewSetupConfigMod forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall env.
HasEnvConfig env =>
Path Abs Dir -> Maybe CTime -> RIO env ()
writeSetupConfigMod Path Abs Dir
pkgDir
    forall env.
HasEnvConfig env =>
Path Abs Dir -> ByteString -> RIO env ()
writePackageProjectRoot Path Abs Dir
pkgDir ByteString
newProjectRoot

  forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
needConfig
 where
  -- When build-type is Configure, we need to have a configure script in the

  -- local directory. If it doesn't exist, build it with autoreconf -i. See:

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

  ensureConfigureScript :: RIO env ()
ensureConfigureScript = do
    let fp :: Path Abs File
fp = Path Abs Dir
pkgDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFileConfigure
    Bool
exists <- forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
fp
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exists forall a b. (a -> b) -> a -> b
$ do
      forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
 MonadIO m) =>
[StyleDoc] -> m ()
prettyInfoL
        [ String -> StyleDoc
flow String
"Trying to generate configure with autoreconf in"
        , forall a. Pretty a => a -> StyleDoc
pretty Path Abs Dir
pkgDir forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
        ]
      let autoreconf :: RIO env ()
autoreconf = if Bool
osIsWindows
                         then forall env.
(HasProcessContext env, HasLogFunc env, ?callStack::CallStack) =>
String -> [String] -> RIO env ()
readProcessNull String
"sh" [String
"autoreconf", String
"-i"]
                         else forall env.
(HasProcessContext env, HasLogFunc env, ?callStack::CallStack) =>
String -> [String] -> RIO env ()
readProcessNull String
"autoreconf" [String
"-i"]
          -- On Windows 10, an upstream issue with the `sh autoreconf -i`

          -- command means that command clears, but does not then restore, the

          -- ENABLE_VIRTUAL_TERMINAL_PROCESSING flag for native terminals. The

          -- following hack re-enables the lost ANSI-capability.

          fixupOnWindows :: RIO env ()
fixupOnWindows = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
osIsWindows (forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ColorWhen
defaultColorWhen)
      forall env (m :: * -> *) a.
(HasProcessContext env, MonadReader env m, MonadIO m) =>
String -> m a -> m a
withWorkingDir (forall b t. Path b t -> String
toFilePath Path Abs Dir
pkgDir) forall a b. (a -> b) -> a -> b
$ RIO env ()
autoreconf forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`catchAny` \SomeException
ex -> do
        RIO env ()
fixupOnWindows
        forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
 MonadIO m) =>
StyleDoc -> m ()
prettyWarn forall a b. (a -> b) -> a -> b
$
             [StyleDoc] -> StyleDoc
fillSep
               [ String -> StyleDoc
flow String
"Stack failed to run"
               , Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"autoreconf" forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
               ]
          forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
          forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
flow String
"Stack encountered the following error:"
          forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
          forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
string (forall e. Exception e => e -> String
displayException SomeException
ex)
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
osIsWindows forall a b. (a -> b) -> a -> b
$ do
          forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
 MonadIO m) =>
StyleDoc -> m ()
prettyInfo forall a b. (a -> b) -> a -> b
$
               [StyleDoc] -> StyleDoc
fillSep
                 [ String -> StyleDoc
flow String
"Check that executable"
                 , Style -> StyleDoc -> StyleDoc
style Style
File StyleDoc
"perl"
                 , String -> StyleDoc
flow String
"is on the path in Stack's MSYS2"
                 , Style -> StyleDoc -> StyleDoc
style Style
Dir StyleDoc
"\\usr\\bin"
                 , String -> StyleDoc
flow String
"folder, and working, and that script file"
                 , Style -> StyleDoc -> StyleDoc
style Style
File StyleDoc
"autoreconf"
                 , String -> StyleDoc
flow String
"is on the path in that location. To check that"
                 , Style -> StyleDoc -> StyleDoc
style Style
File StyleDoc
"perl"
                 , StyleDoc
"or"
                 , Style -> StyleDoc -> StyleDoc
style Style
File StyleDoc
"autoreconf"
                 , String -> StyleDoc
flow String
"are on the path in the required location, run commands:"
                 ]
            forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
            forall a. Semigroup a => a -> a -> a
<> Int -> StyleDoc -> StyleDoc
indent Int
4 (Style -> StyleDoc -> StyleDoc
style Style
Shell forall a b. (a -> b) -> a -> b
$ String -> StyleDoc
flow String
"stack exec where -- perl")
            forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
            forall a. Semigroup a => a -> a -> a
<> Int -> StyleDoc -> StyleDoc
indent Int
4 (Style -> StyleDoc -> StyleDoc
style Style
Shell forall a b. (a -> b) -> a -> b
$ String -> StyleDoc
flow String
"stack exec where -- autoreconf")
            forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
            forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
                 [ StyleDoc
"If"
                 , Style -> StyleDoc -> StyleDoc
style Style
File StyleDoc
"perl"
                 , StyleDoc
"or"
                 , Style -> StyleDoc -> StyleDoc
style Style
File StyleDoc
"autoreconf"
                 , String -> StyleDoc
flow String
"is not on the path in the required location, add them \
                        \with command (note that the relevant package name is"
                 , Style -> StyleDoc -> StyleDoc
style Style
File StyleDoc
"autoconf"
                 , StyleDoc
"not"
                 , Style -> StyleDoc -> StyleDoc
style Style
File StyleDoc
"autoreconf" forall a. Semigroup a => a -> a -> a
<> StyleDoc
"):"
                 ]
            forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
            forall a. Semigroup a => a -> a -> a
<> Int -> StyleDoc -> StyleDoc
indent Int
4
                 (Style -> StyleDoc -> StyleDoc
style Style
Shell forall a b. (a -> b) -> a -> b
$ String -> StyleDoc
flow String
"stack exec pacman -- --sync --refresh autoconf")
            forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
            forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
                 [ String -> StyleDoc
flow String
"Some versions of"
                 , Style -> StyleDoc -> StyleDoc
style Style
File StyleDoc
"perl"
                 , String -> StyleDoc
flow String
"from MSYS2 are broken. See"
                 , Style -> StyleDoc -> StyleDoc
style Style
Url StyleDoc
"https://github.com/msys2/MSYS2-packages/issues/1611"
                 , StyleDoc
"and"
                 , Style -> StyleDoc -> StyleDoc
style Style
Url StyleDoc
"https://github.com/commercialhaskell/stack/pull/4781" forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
                 , StyleDoc
"To test if"
                 , Style -> StyleDoc -> StyleDoc
style Style
File StyleDoc
"perl"
                 , String -> StyleDoc
flow String
"in the required location is working, try command:"
                 ]
            forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
            forall a. Semigroup a => a -> a -> a
<> Int -> StyleDoc -> StyleDoc
indent Int
4 (Style -> StyleDoc -> StyleDoc
style Style
Shell forall a b. (a -> b) -> a -> b
$ String -> StyleDoc
flow String
"stack exec perl -- --version")
            forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
      RIO env ()
fixupOnWindows

-- | Make a padded prefix for log messages

packageNamePrefix :: ExecuteEnv -> PackageName -> String
packageNamePrefix :: ExecuteEnv -> PackageName -> String
packageNamePrefix ExecuteEnv
ee PackageName
name' =
  let name :: String
name = PackageName -> String
packageNameString PackageName
name'
      paddedName :: String
paddedName =
        case ExecuteEnv -> Maybe Int
eeLargestPackageName ExecuteEnv
ee of
          Maybe Int
Nothing -> String
name
          Just Int
len ->
            forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Int
len forall a. Ord a => a -> a -> Bool
>= forall (t :: * -> *) a. Foldable t => t a -> Int
length String
name) forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
take Int
len forall a b. (a -> b) -> a -> b
$ String
name forall a. [a] -> [a] -> [a]
++ forall a. a -> [a]
L.repeat Char
' '
  in  String
paddedName forall a. Semigroup a => a -> a -> a
<> String
"> "

announceTask ::
     HasLogFunc env
  => ExecuteEnv
  -> Task
  -> Utf8Builder
  -> RIO env ()
announceTask :: forall env.
HasLogFunc env =>
ExecuteEnv -> Task -> Utf8Builder -> RIO env ()
announceTask ExecuteEnv
ee Task
task Utf8Builder
action = forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
 ?callStack::CallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$
  forall a. IsString a => String -> a
fromString (ExecuteEnv -> PackageName -> String
packageNamePrefix ExecuteEnv
ee (PackageIdentifier -> PackageName
pkgName (Task -> PackageIdentifier
taskProvides Task
task))) forall a. Semigroup a => a -> a -> a
<> Utf8Builder
action

prettyAnnounceTask ::
     HasTerm env
  => ExecuteEnv
  -> Task
  -> StyleDoc
  -> RIO env ()
prettyAnnounceTask :: forall env.
HasTerm env =>
ExecuteEnv -> Task -> StyleDoc -> RIO env ()
prettyAnnounceTask ExecuteEnv
ee Task
task StyleDoc
action = forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
 MonadIO m) =>
StyleDoc -> m ()
prettyInfo forall a b. (a -> b) -> a -> b
$
  forall a. IsString a => String -> a
fromString (ExecuteEnv -> PackageName -> String
packageNamePrefix ExecuteEnv
ee (PackageIdentifier -> PackageName
pkgName (Task -> PackageIdentifier
taskProvides Task
task))) forall a. Semigroup a => a -> a -> a
<> StyleDoc
action

-- | Ensure we're the only action using the directory.  See

-- <https://github.com/commercialhaskell/stack/issues/2730>

withLockedDistDir ::
     forall env a. HasEnvConfig env
  => (StyleDoc -> RIO env ()) -- ^ A pretty announce function

  -> Path Abs Dir -- ^ root directory for package

  -> RIO env a
  -> RIO env a
withLockedDistDir :: forall env a.
HasEnvConfig env =>
(StyleDoc -> RIO env ()) -> Path Abs Dir -> RIO env a -> RIO env a
withLockedDistDir StyleDoc -> RIO env ()
announce Path Abs Dir
root RIO env a
inner = do
  Path Rel Dir
distDir <- forall (m :: * -> *) env.
(MonadThrow m, MonadReader env m, HasEnvConfig env) =>
m (Path Rel Dir)
distRelativeDir
  let lockFP :: Path Abs File
lockFP = Path Abs Dir
root forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
distDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFileBuildLock
  forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir forall a b. (a -> b) -> a -> b
$ forall b t. Path b t -> Path b Dir
parent Path Abs File
lockFP

  Maybe a
mres <-
    forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO forall a b. (a -> b) -> a -> b
$ \forall a. RIO env a -> IO a
run ->
    forall a.
String -> SharedExclusive -> (FileLock -> IO a) -> IO (Maybe a)
withTryFileLock (forall b t. Path b t -> String
toFilePath Path Abs File
lockFP) SharedExclusive
Exclusive forall a b. (a -> b) -> a -> b
$ \FileLock
_lock ->
    forall a. RIO env a -> IO a
run RIO env a
inner

  case Maybe a
mres of
    Just a
res -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
res
    Maybe a
Nothing -> do
      let complainer :: Companion (RIO env)
          complainer :: Companion (RIO env)
complainer Delay
delay = do
            Delay
delay Int
5000000 -- 5 seconds

            StyleDoc -> RIO env ()
announce forall a b. (a -> b) -> a -> b
$ [StyleDoc] -> StyleDoc
fillSep
              [ String -> StyleDoc
flow String
"blocking for directory lock on"
              , forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
lockFP
              ]
            forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ do
              Delay
delay Int
30000000 -- 30 seconds

              StyleDoc -> RIO env ()
announce forall a b. (a -> b) -> a -> b
$ [StyleDoc] -> StyleDoc
fillSep
                [ String -> StyleDoc
flow String
"still blocking for directory lock on"
                , forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
lockFP forall a. Semigroup a => a -> a -> a
<> StyleDoc
";"
                , String -> StyleDoc
flow String
"maybe another Stack process is running?"
                ]
      forall (m :: * -> *) a.
MonadUnliftIO m =>
Companion m -> (StopCompanion m -> m a) -> m a
withCompanion Companion (RIO env)
complainer forall a b. (a -> b) -> a -> b
$
        \RIO env ()
stopComplaining ->
          forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO forall a b. (a -> b) -> a -> b
$ \forall a. RIO env a -> IO a
run ->
            forall a. String -> SharedExclusive -> (FileLock -> IO a) -> IO a
withFileLock (forall b t. Path b t -> String
toFilePath Path Abs File
lockFP) SharedExclusive
Exclusive forall a b. (a -> b) -> a -> b
$ \FileLock
_ ->
              forall a. RIO env a -> IO a
run forall a b. (a -> b) -> a -> b
$ RIO env ()
stopComplaining forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> RIO env a
inner

-- | How we deal with output from GHC, either dumping to a log file or the

-- console (with some prefix).

data OutputType
  = OTLogFile !(Path Abs File) !Handle
  | OTConsole !(Maybe Utf8Builder)

-- | This sets up a context for executing build steps which need to run

-- Cabal (via a compiled Setup.hs).  In particular it does the following:

--

-- * Ensures the package exists in the file system, downloading if necessary.

--

-- * Opens a log file if the built output shouldn't go to stderr.

--

-- * Ensures that either a simple Setup.hs is built, or the package's

--   custom setup is built.

--

-- * Provides the user a function with which run the Cabal process.

withSingleContext ::
     forall env a. HasEnvConfig env
  => ActionContext
  -> ExecuteEnv
  -> Task
  -> Map PackageIdentifier GhcPkgId
     -- ^ All dependencies' package ids to provide to Setup.hs.

  -> Maybe String
  -> (  Package        -- Package info

     -> Path Abs File  -- Cabal file path

     -> Path Abs Dir   -- Package root directory file path

        -- Note that the `Path Abs Dir` argument is redundant with the

        -- `Path Abs File` argument, but we provide both to avoid recalculating

        -- `parent` of the `File`.

     -> (KeepOutputOpen -> ExcludeTHLoading -> [String] -> RIO env ())
        -- Function to run Cabal with args

     -> (Utf8Builder -> RIO env ())
        -- An plain 'announce' function, for different build phases

     -> OutputType
     -> RIO env a)
  -> RIO env a
withSingleContext :: forall env a.
HasEnvConfig env =>
ActionContext
-> ExecuteEnv
-> Task
-> Map PackageIdentifier GhcPkgId
-> Maybe String
-> (Package
    -> Path Abs File
    -> Path Abs Dir
    -> (KeepOutputOpen -> ExcludeTHLoading -> [String] -> RIO env ())
    -> (Utf8Builder -> RIO env ())
    -> OutputType
    -> RIO env a)
-> RIO env a
withSingleContext ActionContext {[Action]
Set ActionId
Concurrency
acConcurrency :: ActionContext -> Concurrency
acDownstream :: ActionContext -> [Action]
acRemaining :: ActionContext -> Set ActionId
acConcurrency :: Concurrency
acDownstream :: [Action]
acRemaining :: Set ActionId
..} ee :: ExecuteEnv
ee@ExecuteEnv {Int
[LocalPackage]
Maybe Int
Maybe (Path Abs File)
Map GhcPkgId DumpPackage
MVar ()
Version
Text
TVar (Map PackageIdentifier Installed)
TVar (Map GhcPkgId DumpPackage)
IORef (Set PackageName)
Path Abs File
Path Abs Dir
TChan (Path Abs Dir, Path Abs File)
BuildOptsCLI
BuildOpts
BaseConfigOpts
eePathEnvVar :: Text
eeLargestPackageName :: Maybe Int
eeCustomBuilt :: IORef (Set PackageName)
eeLogFiles :: TChan (Path Abs Dir, Path Abs File)
eeLocalDumpPkgs :: TVar (Map GhcPkgId DumpPackage)
eeSnapshotDumpPkgs :: TVar (Map GhcPkgId DumpPackage)
eeGlobalDumpPkgs :: Map GhcPkgId DumpPackage
eeGlobalDB :: Path Abs Dir
eeLocals :: [LocalPackage]
eeTotalWanted :: Int
eeCabalPkgVer :: Version
eeSetupExe :: Maybe (Path Abs File)
eeSetupShimHs :: Path Abs File
eeSetupHs :: Path Abs File
eeTempDir :: Path Abs Dir
eeGhcPkgIds :: TVar (Map PackageIdentifier Installed)
eeBaseConfigOpts :: BaseConfigOpts
eeBuildOptsCLI :: BuildOptsCLI
eeBuildOpts :: BuildOpts
eeInstallLock :: MVar ()
eeConfigureLock :: MVar ()
eePathEnvVar :: ExecuteEnv -> Text
eeLargestPackageName :: ExecuteEnv -> Maybe Int
eeCustomBuilt :: ExecuteEnv -> IORef (Set PackageName)
eeLogFiles :: ExecuteEnv -> TChan (Path Abs Dir, Path Abs File)
eeLocalDumpPkgs :: ExecuteEnv -> TVar (Map GhcPkgId DumpPackage)
eeSnapshotDumpPkgs :: ExecuteEnv -> TVar (Map GhcPkgId DumpPackage)
eeGlobalDumpPkgs :: ExecuteEnv -> Map GhcPkgId DumpPackage
eeGlobalDB :: ExecuteEnv -> Path Abs Dir
eeLocals :: ExecuteEnv -> [LocalPackage]
eeTotalWanted :: ExecuteEnv -> Int
eeCabalPkgVer :: ExecuteEnv -> Version
eeSetupExe :: ExecuteEnv -> Maybe (Path Abs File)
eeSetupShimHs :: ExecuteEnv -> Path Abs File
eeSetupHs :: ExecuteEnv -> Path Abs File
eeTempDir :: ExecuteEnv -> Path Abs Dir
eeGhcPkgIds :: ExecuteEnv -> TVar (Map PackageIdentifier Installed)
eeBaseConfigOpts :: ExecuteEnv -> BaseConfigOpts
eeBuildOptsCLI :: ExecuteEnv -> BuildOptsCLI
eeBuildOpts :: ExecuteEnv -> BuildOpts
eeInstallLock :: ExecuteEnv -> MVar ()
eeConfigureLock :: ExecuteEnv -> MVar ()
..} task :: Task
task@Task {Bool
PackageIdentifier
Map PackageIdentifier GhcPkgId
TaskType
TaskConfigOpts
CachePkgSrc
taskBuildTypeConfig :: Bool
taskAnyMissing :: Bool
taskCachePkgSrc :: CachePkgSrc
taskAllInOne :: Bool
taskPresent :: Map PackageIdentifier GhcPkgId
taskBuildHaddock :: Bool
taskConfigOpts :: TaskConfigOpts
taskType :: TaskType
taskProvides :: PackageIdentifier
taskBuildTypeConfig :: Task -> Bool
taskAnyMissing :: Task -> Bool
taskCachePkgSrc :: Task -> CachePkgSrc
taskAllInOne :: Task -> Bool
taskPresent :: Task -> Map PackageIdentifier GhcPkgId
taskBuildHaddock :: Task -> Bool
taskConfigOpts :: Task -> TaskConfigOpts
taskProvides :: Task -> PackageIdentifier
taskType :: Task -> TaskType
..} Map PackageIdentifier GhcPkgId
allDeps Maybe String
msuffix Package
-> Path Abs File
-> Path Abs Dir
-> (KeepOutputOpen -> ExcludeTHLoading -> [String] -> RIO env ())
-> (Utf8Builder -> RIO env ())
-> OutputType
-> RIO env a
inner0 =
  (Package -> Path Abs File -> Path Abs Dir -> RIO env a)
-> RIO env a
withPackage forall a b. (a -> b) -> a -> b
$ \Package
package Path Abs File
cabalfp Path Abs Dir
pkgDir ->
  Path Abs Dir -> Package -> (OutputType -> RIO env a) -> RIO env a
withOutputType Path Abs Dir
pkgDir Package
package forall a b. (a -> b) -> a -> b
$ \OutputType
outputType ->
  Package
-> Path Abs Dir
-> OutputType
-> ((KeepOutputOpen -> ExcludeTHLoading -> [String] -> RIO env ())
    -> RIO env a)
-> RIO env a
withCabal Package
package Path Abs Dir
pkgDir OutputType
outputType forall a b. (a -> b) -> a -> b
$ \KeepOutputOpen -> ExcludeTHLoading -> [String] -> RIO env ()
cabal ->
  Package
-> Path Abs File
-> Path Abs Dir
-> (KeepOutputOpen -> ExcludeTHLoading -> [String] -> RIO env ())
-> (Utf8Builder -> RIO env ())
-> OutputType
-> RIO env a
inner0 Package
package Path Abs File
cabalfp Path Abs Dir
pkgDir KeepOutputOpen -> ExcludeTHLoading -> [String] -> RIO env ()
cabal Utf8Builder -> RIO env ()
announce OutputType
outputType
 where
  announce :: Utf8Builder -> RIO env ()
announce = forall env.
HasLogFunc env =>
ExecuteEnv -> Task -> Utf8Builder -> RIO env ()
announceTask ExecuteEnv
ee Task
task
  prettyAnnounce :: StyleDoc -> RIO env ()
prettyAnnounce = forall env.
HasTerm env =>
ExecuteEnv -> Task -> StyleDoc -> RIO env ()
prettyAnnounceTask ExecuteEnv
ee Task
task

  wanted :: Bool
wanted =
    case TaskType
taskType of
      TTLocalMutable LocalPackage
lp -> LocalPackage -> Bool
lpWanted LocalPackage
lp
      TTRemotePackage{} -> Bool
False

  -- Output to the console if this is the last task, and the user asked to build

  -- it specifically. When the action is a 'ConcurrencyDisallowed' action

  -- (benchmarks), then we can also be sure to have exclusive access to the

  -- console, so output is also sent to the console in this case.

  --

  -- See the discussion on #426 for thoughts on sending output to the console

  --from concurrent tasks.

  console :: Bool
console =
       (  Bool
wanted
       Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all
            (\(ActionId PackageIdentifier
ident ActionType
_) -> PackageIdentifier
ident forall a. Eq a => a -> a -> Bool
== PackageIdentifier
taskProvides)
            (forall a. Set a -> [a]
Set.toList Set ActionId
acRemaining)
       Bool -> Bool -> Bool
&& Int
eeTotalWanted forall a. Eq a => a -> a -> Bool
== Int
1
       )
    Bool -> Bool -> Bool
|| Concurrency
acConcurrency forall a. Eq a => a -> a -> Bool
== Concurrency
ConcurrencyDisallowed

  withPackage :: (Package -> Path Abs File -> Path Abs Dir -> RIO env a)
-> RIO env a
withPackage Package -> Path Abs File -> Path Abs Dir -> RIO env a
inner =
    case TaskType
taskType of
      TTLocalMutable LocalPackage
lp -> do
        let root :: Path Abs Dir
root = forall b t. Path b t -> Path b Dir
parent forall a b. (a -> b) -> a -> b
$ LocalPackage -> Path Abs File
lpCabalFile LocalPackage
lp
        forall env a.
HasEnvConfig env =>
(StyleDoc -> RIO env ()) -> Path Abs Dir -> RIO env a -> RIO env a
withLockedDistDir StyleDoc -> RIO env ()
prettyAnnounce Path Abs Dir
root forall a b. (a -> b) -> a -> b
$
          Package -> Path Abs File -> Path Abs Dir -> RIO env a
inner (LocalPackage -> Package
lpPackage LocalPackage
lp) (LocalPackage -> Path Abs File
lpCabalFile LocalPackage
lp) Path Abs Dir
root
      TTRemotePackage IsMutable
_ Package
package PackageLocationImmutable
pkgloc -> do
          Path Rel Dir
suffix <- forall (m :: * -> *). MonadThrow m => String -> m (Path Rel Dir)
parseRelDir forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> String
packageIdentifierString forall a b. (a -> b) -> a -> b
$ Package -> PackageIdentifier
packageIdent Package
package
          let dir :: Path Abs Dir
dir = Path Abs Dir
eeTempDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
suffix
          forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Path Abs Dir -> PackageLocationImmutable -> RIO env ()
unpackPackageLocation Path Abs Dir
dir PackageLocationImmutable
pkgloc

          -- See: https://github.com/commercialhaskell/stack/issues/157

          Path Rel Dir
distDir <- forall (m :: * -> *) env.
(MonadThrow m, MonadReader env m, HasEnvConfig env) =>
m (Path Rel Dir)
distRelativeDir
          let oldDist :: Path Abs Dir
oldDist = Path Abs Dir
dir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirDist
              newDist :: Path Abs Dir
newDist = Path Abs Dir
dir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
distDir
          Bool
exists <- forall (m :: * -> *) b. MonadIO m => Path b Dir -> m Bool
doesDirExist Path Abs Dir
oldDist
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
exists forall a b. (a -> b) -> a -> b
$ do
            -- Previously used takeDirectory, but that got confused

            -- by trailing slashes, see:

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

            --

            -- Instead, use Path which is a bit more resilient

            forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir forall a b. (a -> b) -> a -> b
$ forall b t. Path b t -> Path b Dir
parent Path Abs Dir
newDist
            forall (m :: * -> *) b0 b1.
MonadIO m =>
Path b0 Dir -> Path b1 Dir -> m ()
renameDir Path Abs Dir
oldDist Path Abs Dir
newDist

          let name :: PackageName
name = PackageIdentifier -> PackageName
pkgName PackageIdentifier
taskProvides
          Path Rel File
cabalfpRel <- forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile forall a b. (a -> b) -> a -> b
$ PackageName -> String
packageNameString PackageName
name forall a. [a] -> [a] -> [a]
++ String
".cabal"
          let cabalfp :: Path Abs File
cabalfp = Path Abs Dir
dir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
cabalfpRel
          Package -> Path Abs File -> Path Abs Dir -> RIO env a
inner Package
package Path Abs File
cabalfp Path Abs Dir
dir

  withOutputType :: Path Abs Dir -> Package -> (OutputType -> RIO env a) -> RIO env a
withOutputType Path Abs Dir
pkgDir Package
package OutputType -> RIO env a
inner
    -- Not in interleaved mode. When building a single wanted package, dump

    -- to the console with no prefix.

    | Bool
console = OutputType -> RIO env a
inner forall a b. (a -> b) -> a -> b
$ Maybe Utf8Builder -> OutputType
OTConsole forall a. Maybe a
Nothing

    -- If the user requested interleaved output, dump to the console with a

    -- prefix.

    | BuildOpts -> Bool
boptsInterleavedOutput BuildOpts
eeBuildOpts = OutputType -> RIO env a
inner forall a b. (a -> b) -> a -> b
$
        Maybe Utf8Builder -> OutputType
OTConsole forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. IsString a => String -> a
fromString (ExecuteEnv -> PackageName -> String
packageNamePrefix ExecuteEnv
ee forall a b. (a -> b) -> a -> b
$ Package -> PackageName
packageName Package
package)

    -- Neither condition applies, dump to a file.

    | Bool
otherwise = do
        Path Abs File
logPath <- forall env (m :: * -> *).
(MonadReader env m, HasBuildConfig env, MonadThrow m) =>
Package -> Maybe String -> m (Path Abs File)
buildLogPath Package
package Maybe String
msuffix
        forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir (forall b t. Path b t -> Path b Dir
parent Path Abs File
logPath)
        let fp :: String
fp = forall b t. Path b t -> String
toFilePath Path Abs File
logPath

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

        case TaskType
taskType of
          TTLocalMutable LocalPackage
lp | LocalPackage -> Bool
lpWanted LocalPackage
lp ->
              forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TChan a -> a -> STM ()
writeTChan TChan (Path Abs Dir, Path Abs File)
eeLogFiles (Path Abs Dir
pkgDir, Path Abs File
logPath)
          TaskType
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

        forall (m :: * -> *) a.
MonadUnliftIO m =>
String -> IOMode -> (Handle -> m a) -> m a
withBinaryFile String
fp IOMode
WriteMode forall a b. (a -> b) -> a -> b
$ \Handle
h -> OutputType -> RIO env a
inner forall a b. (a -> b) -> a -> b
$ Path Abs File -> Handle -> OutputType
OTLogFile Path Abs File
logPath Handle
h

  withCabal ::
       Package
    -> Path Abs Dir
    -> OutputType
    -> (  (KeepOutputOpen -> ExcludeTHLoading -> [String] -> RIO env ())
       -> RIO env a
       )
    -> RIO env a
  withCabal :: Package
-> Path Abs Dir
-> OutputType
-> ((KeepOutputOpen -> ExcludeTHLoading -> [String] -> RIO env ())
    -> RIO env a)
-> RIO env a
withCabal Package
package Path Abs Dir
pkgDir OutputType
outputType (KeepOutputOpen -> ExcludeTHLoading -> [String] -> RIO env ())
-> RIO env a
inner = do
    Config
config <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasConfig env => Lens' env Config
configL
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Config -> Bool
configAllowDifferentUser Config
config) forall a b. (a -> b) -> a -> b
$
      forall (m :: * -> *). MonadIO m => Path Abs Dir -> m ()
checkOwnership (Path Abs Dir
pkgDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Config -> Path Rel Dir
configWorkDir Config
config)
    let envSettings :: EnvSettings
envSettings = EnvSettings
          { esIncludeLocals :: Bool
esIncludeLocals = Task -> InstallLocation
taskLocation Task
task forall a. Eq a => a -> a -> Bool
== InstallLocation
Local
          , esIncludeGhcPackagePath :: Bool
esIncludeGhcPackagePath = Bool
False
          , esStackExe :: Bool
esStackExe = Bool
False
          , esLocaleUtf8 :: Bool
esLocaleUtf8 = Bool
True
          , esKeepGhcRts :: Bool
esKeepGhcRts = Bool
False
          }
    ProcessContext
menv <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Config -> EnvSettings -> IO ProcessContext
configProcessContextSettings Config
config EnvSettings
envSettings
    Path Rel Dir
distRelativeDir' <- forall (m :: * -> *) env.
(MonadThrow m, MonadReader env m, HasEnvConfig env) =>
m (Path Rel Dir)
distRelativeDir
    Either (Path Abs File) (Path Abs File)
esetupexehs <-
      -- Avoid broken Setup.hs files causing problems for simple build

      -- types, see:

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

      case (Package -> BuildType
packageBuildType Package
package, Maybe (Path Abs File)
eeSetupExe) of
        (BuildType
C.Simple, Just Path Abs File
setupExe) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left Path Abs File
setupExe
        (BuildType, Maybe (Path Abs File))
_ -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Path Abs Dir -> IO (Path Abs File)
getSetupHs Path Abs Dir
pkgDir
    (KeepOutputOpen -> ExcludeTHLoading -> [String] -> RIO env ())
-> RIO env a
inner forall a b. (a -> b) -> a -> b
$ \KeepOutputOpen
keepOutputOpen ExcludeTHLoading
stripTHLoading [String]
args -> do
      let cabalPackageArg :: [String]
cabalPackageArg
            -- Omit cabal package dependency when building

            -- Cabal. See

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

            | Package -> PackageName
packageName Package
package forall a. Eq a => a -> a -> Bool
== String -> PackageName
mkPackageName String
"Cabal" = []
            | Bool
otherwise =
                [String
"-package=" forall a. [a] -> [a] -> [a]
++ PackageIdentifier -> String
packageIdentifierString
                                    (PackageName -> Version -> PackageIdentifier
PackageIdentifier PackageName
cabalPackageName
                                                      Version
eeCabalPkgVer)]
          packageDBArgs :: [String]
packageDBArgs =
            ( String
"-clear-package-db"
            forall a. a -> [a] -> [a]
: String
"-global-package-db"
            forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map
                ((String
"-package-db=" ++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall loc. Path loc Dir -> String
toFilePathNoTrailingSep)
                (BaseConfigOpts -> [Path Abs Dir]
bcoExtraDBs BaseConfigOpts
eeBaseConfigOpts)
            ) forall a. [a] -> [a] -> [a]
++
            ( (  String
"-package-db="
              forall a. [a] -> [a] -> [a]
++ forall loc. Path loc Dir -> String
toFilePathNoTrailingSep (BaseConfigOpts -> Path Abs Dir
bcoSnapDB BaseConfigOpts
eeBaseConfigOpts)
              )
            forall a. a -> [a] -> [a]
: (  String
"-package-db="
              forall a. [a] -> [a] -> [a]
++ forall loc. Path loc Dir -> String
toFilePathNoTrailingSep (BaseConfigOpts -> Path Abs Dir
bcoLocalDB BaseConfigOpts
eeBaseConfigOpts)
              )
            forall a. a -> [a] -> [a]
: [String
"-hide-all-packages"]
            )

          warnCustomNoDeps :: RIO env ()
          warnCustomNoDeps :: RIO env ()
warnCustomNoDeps =
            case (TaskType
taskType, Package -> BuildType
packageBuildType Package
package) of
              (TTLocalMutable LocalPackage
lp, BuildType
C.Custom) | LocalPackage -> Bool
lpWanted LocalPackage
lp ->
                forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
 MonadIO m) =>
[StyleDoc] -> m ()
prettyWarnL
                  [ String -> StyleDoc
flow String
"Package"
                  , forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ PackageName -> String
packageNameString forall a b. (a -> b) -> a -> b
$ Package -> PackageName
packageName Package
package
                  , String -> StyleDoc
flow String
"uses a custom Cabal build, but does not use a \
                         \custom-setup stanza"
                  ]
              (TaskType, BuildType)
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

          getPackageArgs :: Path Abs Dir -> RIO env [String]
          getPackageArgs :: Path Abs Dir -> RIO env [String]
getPackageArgs Path Abs Dir
setupDir =
            case Package -> Maybe (Map PackageName VersionRange)
packageSetupDeps Package
package of
              -- The package is using the Cabal custom-setup

              -- configuration introduced in Cabal 1.24. In

              -- this case, the package is providing an

              -- explicit list of dependencies, and we

              -- should simply use all of them.

              Just Map PackageName VersionRange
customSetupDeps -> do
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall k a. Ord k => k -> Map k a -> Bool
Map.member (String -> PackageName
mkPackageName String
"Cabal") Map PackageName VersionRange
customSetupDeps) forall a b. (a -> b) -> a -> b
$
                  forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
 MonadIO m) =>
[StyleDoc] -> m ()
prettyWarnL
                    [ forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ PackageName -> String
packageNameString forall a b. (a -> b) -> a -> b
$ Package -> PackageName
packageName Package
package
                    , String -> StyleDoc
flow String
"has a setup-depends field, but it does not mention \
                           \a Cabal dependency. This is likely to cause build \
                           \errors."
                    ]
                [(String, Maybe PackageIdentifier)]
matchedDeps <-
                  forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (forall k a. Map k a -> [(k, a)]
Map.toList Map PackageName VersionRange
customSetupDeps) forall a b. (a -> b) -> a -> b
$ \(PackageName
name, VersionRange
range) -> do
                    let matches :: PackageIdentifier -> Bool
matches (PackageIdentifier PackageName
name' Version
version) =
                          PackageName
name forall a. Eq a => a -> a -> Bool
== PackageName
name' Bool -> Bool -> Bool
&&
                          Version
version Version -> VersionRange -> Bool
`withinRange` VersionRange
range
                    case forall a. (a -> Bool) -> [a] -> [a]
filter (PackageIdentifier -> Bool
matches forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) (forall k a. Map k a -> [(k, a)]
Map.toList Map PackageIdentifier GhcPkgId
allDeps) of
                      (PackageIdentifier, GhcPkgId)
x:[(PackageIdentifier, GhcPkgId)]
xs -> do
                        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(PackageIdentifier, GhcPkgId)]
xs) forall a b. (a -> b) -> a -> b
$
                          forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
 MonadIO m) =>
[StyleDoc] -> m ()
prettyWarnL
                            [ String -> StyleDoc
flow String
"Found multiple installed packages for \
                                   \custom-setup dep:"
                            , Style -> StyleDoc -> StyleDoc
style Style
Current (forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ PackageName -> String
packageNameString PackageName
name) forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
                            ]
                        forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
"-package-id=" forall a. [a] -> [a] -> [a]
++ GhcPkgId -> String
ghcPkgIdString (forall a b. (a, b) -> b
snd (PackageIdentifier, GhcPkgId)
x), forall a. a -> Maybe a
Just (forall a b. (a, b) -> a
fst (PackageIdentifier, GhcPkgId)
x))
                      [] -> do
                        forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
 MonadIO m) =>
[StyleDoc] -> m ()
prettyWarnL
                          [ String -> StyleDoc
flow String
"Could not find custom-setup dep:"
                          , Style -> StyleDoc -> StyleDoc
style Style
Current (forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ PackageName -> String
packageNameString PackageName
name) forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
                          ]
                        forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
"-package=" forall a. [a] -> [a] -> [a]
++ PackageName -> String
packageNameString PackageName
name, forall a. Maybe a
Nothing)
                let depsArgs :: [String]
depsArgs = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(String, Maybe PackageIdentifier)]
matchedDeps
                -- Generate setup_macros.h and provide it to ghc

                let macroDeps :: [PackageIdentifier]
macroDeps = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall a b. (a, b) -> b
snd [(String, Maybe PackageIdentifier)]
matchedDeps
                    cppMacrosFile :: Path Abs File
cppMacrosFile = Path Abs Dir
setupDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFileSetupMacrosH
                    cppArgs :: [String]
cppArgs =
                      [String
"-optP-include", String
"-optP" forall a. [a] -> [a] -> [a]
++ forall b t. Path b t -> String
toFilePath Path Abs File
cppMacrosFile]
                forall (m :: * -> *) absrel.
MonadIO m =>
Path absrel File -> Builder -> m ()
writeBinaryFileAtomic
                  Path Abs File
cppMacrosFile
                  ( Text -> Builder
encodeUtf8Builder
                      ( String -> Text
T.pack
                          ( Version -> [PackageIdentifier] -> String
C.generatePackageVersionMacros
                              (Package -> Version
packageVersion Package
package)
                              [PackageIdentifier]
macroDeps
                          )
                      )
                  )
                forall (f :: * -> *) a. Applicative f => a -> f a
pure ([String]
packageDBArgs forall a. [a] -> [a] -> [a]
++ [String]
depsArgs forall a. [a] -> [a] -> [a]
++ [String]
cppArgs)

              -- This branch is usually taken for builds, and is always taken

              -- for `stack sdist`.

              --

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

              -- package database for Cabal. There are two possible objections:

              --

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

              -- packages available could cause the build to succeed or fail.

              --

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

              -- include the local database when building local packages.

              --

              -- Currently, this branch is only taken via `stack sdist` or when

              -- explicitly requested in the stack.yaml file.

              Maybe (Map PackageName VersionRange)
Nothing -> do
                RIO env ()
warnCustomNoDeps
                forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
                     [String]
cabalPackageArg
                      -- NOTE: This is different from packageDBArgs above in

                      -- that it does not include the local database and does

                      -- not pass in the -hide-all-packages argument

                  forall a. [a] -> [a] -> [a]
++ ( String
"-clear-package-db"
                     forall a. a -> [a] -> [a]
: String
"-global-package-db"
                     forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map
                         ((String
"-package-db=" ++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall loc. Path loc Dir -> String
toFilePathNoTrailingSep)
                         (BaseConfigOpts -> [Path Abs Dir]
bcoExtraDBs BaseConfigOpts
eeBaseConfigOpts)
                     forall a. [a] -> [a] -> [a]
++ [    String
"-package-db="
                          forall a. [a] -> [a] -> [a]
++ forall loc. Path loc Dir -> String
toFilePathNoTrailingSep (BaseConfigOpts -> Path Abs Dir
bcoSnapDB BaseConfigOpts
eeBaseConfigOpts)
                        ]
                     )

          setupArgs :: [String]
setupArgs =
            (String
"--builddir=" forall a. [a] -> [a] -> [a]
++ forall loc. Path loc Dir -> String
toFilePathNoTrailingSep Path Rel Dir
distRelativeDir') forall a. a -> [a] -> [a]
: [String]
args

          runExe :: Path Abs File -> [String] -> RIO env ()
          runExe :: Path Abs File -> [String] -> RIO env ()
runExe Path Abs File
exeName [String]
fullArgs = do
            ActualCompiler
compilerVer <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasSourceMap env => SimpleGetter env ActualCompiler
actualCompilerVersionL
            ActualCompiler -> RIO env ()
runAndOutput ActualCompiler
compilerVer forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \ExitCodeException
ece -> do
              (Maybe (Path Abs File)
mlogFile, [Text]
bss) <-
                case OutputType
outputType of
                  OTConsole Maybe Utf8Builder
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Maybe a
Nothing, [])
                  OTLogFile Path Abs File
logFile Handle
h ->
                    if KeepOutputOpen
keepOutputOpen forall a. Eq a => a -> a -> Bool
== KeepOutputOpen
KeepOpen
                    then
                      forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Maybe a
Nothing, []) -- expected failure build continues further

                    else do
                      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadIO m => Handle -> m ()
hClose Handle
h
                      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> Maybe a
Just Path Abs File
logFile,) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (n :: * -> *) i a.
(MonadUnliftIO m, MonadIO n) =>
String -> (ConduitM i ByteString n () -> m a) -> m a
withSourceFile (forall b t. Path b t -> String
toFilePath Path Abs File
logFile) forall a b. (a -> b) -> a -> b
$
                        \ConduitM () ByteString (RIO env) ()
src ->
                             forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit
                           forall a b. (a -> b) -> a -> b
$ ConduitM () ByteString (RIO env) ()
src
                          forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *). Monad m => ConduitT ByteString Text m ()
CT.decodeUtf8Lenient
                          forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *).
(MonadIO m, MonadUnliftIO m) =>
ExcludeTHLoading
-> ConvertPathsToAbsolute
-> Path Abs Dir
-> ActualCompiler
-> ConduitM Text Text m ()
mungeBuildOutput
                               ExcludeTHLoading
stripTHLoading ConvertPathsToAbsolute
makeAbsolute Path Abs Dir
pkgDir ActualCompiler
compilerVer
                          forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) a o. Monad m => ConduitT a o m [a]
CL.consume
              forall e (m :: * -> *) a.
(Exception e, MonadThrow m, Pretty e) =>
e -> m a
prettyThrowM forall a b. (a -> b) -> a -> b
$ ExitCode
-> PackageIdentifier
-> Path Abs File
-> [String]
-> Maybe (Path Abs File)
-> [Text]
-> BuildPrettyException
CabalExitedUnsuccessfully
                (ExitCodeException -> ExitCode
eceExitCode ExitCodeException
ece) PackageIdentifier
taskProvides Path Abs File
exeName [String]
fullArgs Maybe (Path Abs File)
mlogFile [Text]
bss
           where
            runAndOutput :: ActualCompiler -> RIO env ()
            runAndOutput :: ActualCompiler -> RIO env ()
runAndOutput ActualCompiler
compilerVer = forall env (m :: * -> *) a.
(HasProcessContext env, MonadReader env m, MonadIO m) =>
String -> m a -> m a
withWorkingDir (forall b t. Path b t -> String
toFilePath Path Abs Dir
pkgDir) forall a b. (a -> b) -> a -> b
$
              forall env a.
HasProcessContext env =>
ProcessContext -> RIO env a -> RIO env a
withProcessContext ProcessContext
menv forall a b. (a -> b) -> a -> b
$ case OutputType
outputType of
                OTLogFile Path Abs File
_ Handle
h -> do
                  let prefixWithTimestamps :: PrefixWithTimestamps
prefixWithTimestamps =
                        if Config -> Bool
configPrefixTimestamps Config
config
                          then PrefixWithTimestamps
PrefixWithTimestamps
                          else PrefixWithTimestamps
WithoutTimestamps
                  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall e o env.
(HasProcessContext env, HasLogFunc env, ?callStack::CallStack) =>
String
-> [String]
-> ConduitM ByteString Void (RIO env) e
-> ConduitM ByteString Void (RIO env) o
-> RIO env (e, o)
sinkProcessStderrStdout (forall b t. Path b t -> String
toFilePath Path Abs File
exeName) [String]
fullArgs
                    (forall (m :: * -> *).
MonadIO m =>
PrefixWithTimestamps -> Handle -> ConduitT ByteString Void m ()
sinkWithTimestamps PrefixWithTimestamps
prefixWithTimestamps Handle
h)
                    (forall (m :: * -> *).
MonadIO m =>
PrefixWithTimestamps -> Handle -> ConduitT ByteString Void m ()
sinkWithTimestamps PrefixWithTimestamps
prefixWithTimestamps Handle
h)
                OTConsole Maybe Utf8Builder
mprefix ->
                  let prefix :: Utf8Builder
prefix = forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold Maybe Utf8Builder
mprefix
                  in  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall e o env.
(HasProcessContext env, HasLogFunc env, ?callStack::CallStack) =>
String
-> [String]
-> ConduitM ByteString Void (RIO env) e
-> ConduitM ByteString Void (RIO env) o
-> RIO env (e, o)
sinkProcessStderrStdout
                        (forall b t. Path b t -> String
toFilePath Path Abs File
exeName)
                        [String]
fullArgs
                        ((?callStack::CallStack) =>
ExcludeTHLoading
-> LogLevel
-> ActualCompiler
-> Utf8Builder
-> ConduitM ByteString Void (RIO env) ()
outputSink ExcludeTHLoading
KeepTHLoading LogLevel
LevelWarn ActualCompiler
compilerVer Utf8Builder
prefix)
                        ((?callStack::CallStack) =>
ExcludeTHLoading
-> LogLevel
-> ActualCompiler
-> Utf8Builder
-> ConduitM ByteString Void (RIO env) ()
outputSink ExcludeTHLoading
stripTHLoading LogLevel
LevelInfo ActualCompiler
compilerVer Utf8Builder
prefix)
            outputSink ::
                 HasCallStack
              => ExcludeTHLoading
              -> LogLevel
              -> ActualCompiler
              -> Utf8Builder
              -> ConduitM S.ByteString Void (RIO env) ()
            outputSink :: (?callStack::CallStack) =>
ExcludeTHLoading
-> LogLevel
-> ActualCompiler
-> Utf8Builder
-> ConduitM ByteString Void (RIO env) ()
outputSink ExcludeTHLoading
excludeTH LogLevel
level ActualCompiler
compilerVer Utf8Builder
prefix =
              forall (m :: * -> *). Monad m => ConduitT ByteString Text m ()
CT.decodeUtf8Lenient
              forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *).
(MonadIO m, MonadUnliftIO m) =>
ExcludeTHLoading
-> ConvertPathsToAbsolute
-> Path Abs Dir
-> ActualCompiler
-> ConduitM Text Text m ()
mungeBuildOutput ExcludeTHLoading
excludeTH ConvertPathsToAbsolute
makeAbsolute Path Abs Dir
pkgDir ActualCompiler
compilerVer
              forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) a o.
Monad m =>
(a -> m ()) -> ConduitT a o m ()
CL.mapM_ (forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
 ?callStack::CallStack) =>
Text -> LogLevel -> Utf8Builder -> m ()
logGeneric Text
"" LogLevel
level forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Utf8Builder
prefix <>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Display a => a -> Utf8Builder
display)
            -- If users want control, we should add a config option for this

            makeAbsolute :: ConvertPathsToAbsolute
            makeAbsolute :: ConvertPathsToAbsolute
makeAbsolute = case ExcludeTHLoading
stripTHLoading of
              ExcludeTHLoading
ExcludeTHLoading -> ConvertPathsToAbsolute
ConvertPathsToAbsolute
              ExcludeTHLoading
KeepTHLoading    -> ConvertPathsToAbsolute
KeepPathsAsIs

      Path Abs File
exeName <- case Either (Path Abs File) (Path Abs File)
esetupexehs of
        Left Path Abs File
setupExe -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Path Abs File
setupExe
        Right Path Abs File
setuphs -> do
          Path Abs Dir
distDir <- forall (m :: * -> *) env.
(MonadThrow m, MonadReader env m, HasEnvConfig env) =>
Path Abs Dir -> m (Path Abs Dir)
distDirFromDir Path Abs Dir
pkgDir
          let setupDir :: Path Abs Dir
setupDir = Path Abs Dir
distDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirSetup
              outputFile :: Path Abs File
outputFile = Path Abs Dir
setupDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFileSetupLower
          Set PackageName
customBuilt <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef (Set PackageName)
eeCustomBuilt
          if forall a. Ord a => a -> Set a -> Bool
Set.member (Package -> PackageName
packageName Package
package) Set PackageName
customBuilt
            then forall (f :: * -> *) a. Applicative f => a -> f a
pure Path Abs File
outputFile
            else do
              forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir Path Abs Dir
setupDir
              Path Abs File
compilerPath <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasCompiler env => SimpleGetter env CompilerPaths
compilerPathsLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to CompilerPaths -> Path Abs File
cpCompiler
              [String]
packageArgs <- Path Abs Dir -> RIO env [String]
getPackageArgs Path Abs Dir
setupDir
              Path Abs File -> [String] -> RIO env ()
runExe Path Abs File
compilerPath forall a b. (a -> b) -> a -> b
$
                [ String
"--make"
                , String
"-odir", forall loc. Path loc Dir -> String
toFilePathNoTrailingSep Path Abs Dir
setupDir
                , String
"-hidir", forall loc. Path loc Dir -> String
toFilePathNoTrailingSep Path Abs Dir
setupDir
                , String
"-i", String
"-i."
                ] forall a. [a] -> [a] -> [a]
++ [String]
packageArgs forall a. [a] -> [a] -> [a]
++
                [ forall b t. Path b t -> String
toFilePath Path Abs File
setuphs
                , forall b t. Path b t -> String
toFilePath Path Abs File
eeSetupShimHs
                , String
"-main-is"
                , String
"StackSetupShim.mainOverride"
                , String
"-o", forall b t. Path b t -> String
toFilePath Path Abs File
outputFile
                , String
"-threaded"
                ] forall a. [a] -> [a] -> [a]
++

                -- Apply GHC options

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

                forall a b. (a -> b) -> [a] -> [b]
map
                  Text -> String
T.unpack
                  ( forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault
                      []
                      ApplyGhcOptions
AGOEverything
                      (Config -> Map ApplyGhcOptions [Text]
configGhcOptionsByCat Config
config)
                  forall a. [a] -> [a] -> [a]
++ case Config -> ApplyGhcOptions
configApplyGhcOptions Config
config of
                       ApplyGhcOptions
AGOEverything -> BuildOptsCLI -> [Text]
boptsCLIGhcOptions BuildOptsCLI
eeBuildOptsCLI
                       ApplyGhcOptions
AGOTargets -> []
                       ApplyGhcOptions
AGOLocals -> []
                  )

              forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b.
MonadIO m =>
IORef a -> (a -> (a, b)) -> m b
atomicModifyIORef' IORef (Set PackageName)
eeCustomBuilt forall a b. (a -> b) -> a -> b
$
                \Set PackageName
oldCustomBuilt ->
                  (forall a. Ord a => a -> Set a -> Set a
Set.insert (Package -> PackageName
packageName Package
package) Set PackageName
oldCustomBuilt, ())
              forall (f :: * -> *) a. Applicative f => a -> f a
pure Path Abs File
outputFile
      let cabalVerboseArg :: String
cabalVerboseArg =
            let CabalVerbosity Verbosity
cv = BuildOpts -> CabalVerbosity
boptsCabalVerbose BuildOpts
eeBuildOpts
            in  String
"--verbose=" forall a. Semigroup a => a -> a -> a
<> Verbosity -> String
showForCabal Verbosity
cv
      Path Abs File -> [String] -> RIO env ()
runExe Path Abs File
exeName forall a b. (a -> b) -> a -> b
$ String
cabalVerboseArgforall a. a -> [a] -> [a]
:[String]
setupArgs

-- Implements running a package's build, used to implement 'ATBuild' and

-- 'ATBuildFinal' tasks.  In particular this does the following:

--

-- * Checks if the package exists in the precompiled cache, and if so,

--   add it to the database instead of performing the build.

--

-- * Runs the configure step if needed ('ensureConfig')

--

-- * Runs the build step

--

-- * Generates haddocks

--

-- * Registers the library and copies the built executables into the

--   local install directory. Note that this is literally invoking Cabal

--   with @copy@, and not the copying done by @stack install@ - that is

--   handled by 'copyExecutables'.

singleBuild :: forall env. (HasEnvConfig env, HasRunner env)
            => ActionContext
            -> ExecuteEnv
            -> Task
            -> InstalledMap
            -> Bool             -- ^ Is this a final build?

            -> RIO env ()
singleBuild :: forall env.
(HasEnvConfig env, HasRunner env) =>
ActionContext
-> ExecuteEnv -> Task -> InstalledMap -> Bool -> RIO env ()
singleBuild ac :: ActionContext
ac@ActionContext {[Action]
Set ActionId
Concurrency
acConcurrency :: Concurrency
acDownstream :: [Action]
acRemaining :: Set ActionId
acConcurrency :: ActionContext -> Concurrency
acDownstream :: ActionContext -> [Action]
acRemaining :: ActionContext -> Set ActionId
..} ee :: ExecuteEnv
ee@ExecuteEnv {Int
[LocalPackage]
Maybe Int
Maybe (Path Abs File)
Map GhcPkgId DumpPackage
MVar ()
Version
Text
TVar (Map PackageIdentifier Installed)
TVar (Map GhcPkgId DumpPackage)
IORef (Set PackageName)
Path Abs File
Path Abs Dir
TChan (Path Abs Dir, Path Abs File)
BuildOptsCLI
BuildOpts
BaseConfigOpts
eePathEnvVar :: Text
eeLargestPackageName :: Maybe Int
eeCustomBuilt :: IORef (Set PackageName)
eeLogFiles :: TChan (Path Abs Dir, Path Abs File)
eeLocalDumpPkgs :: TVar (Map GhcPkgId DumpPackage)
eeSnapshotDumpPkgs :: TVar (Map GhcPkgId DumpPackage)
eeGlobalDumpPkgs :: Map GhcPkgId DumpPackage
eeGlobalDB :: Path Abs Dir
eeLocals :: [LocalPackage]
eeTotalWanted :: Int
eeCabalPkgVer :: Version
eeSetupExe :: Maybe (Path Abs File)
eeSetupShimHs :: Path Abs File
eeSetupHs :: Path Abs File
eeTempDir :: Path Abs Dir
eeGhcPkgIds :: TVar (Map PackageIdentifier Installed)
eeBaseConfigOpts :: BaseConfigOpts
eeBuildOptsCLI :: BuildOptsCLI
eeBuildOpts :: BuildOpts
eeInstallLock :: MVar ()
eeConfigureLock :: MVar ()
eePathEnvVar :: ExecuteEnv -> Text
eeLargestPackageName :: ExecuteEnv -> Maybe Int
eeCustomBuilt :: ExecuteEnv -> IORef (Set PackageName)
eeLogFiles :: ExecuteEnv -> TChan (Path Abs Dir, Path Abs File)
eeLocalDumpPkgs :: ExecuteEnv -> TVar (Map GhcPkgId DumpPackage)
eeSnapshotDumpPkgs :: ExecuteEnv -> TVar (Map GhcPkgId DumpPackage)
eeGlobalDumpPkgs :: ExecuteEnv -> Map GhcPkgId DumpPackage
eeGlobalDB :: ExecuteEnv -> Path Abs Dir
eeLocals :: ExecuteEnv -> [LocalPackage]
eeTotalWanted :: ExecuteEnv -> Int
eeCabalPkgVer :: ExecuteEnv -> Version
eeSetupExe :: ExecuteEnv -> Maybe (Path Abs File)
eeSetupShimHs :: ExecuteEnv -> Path Abs File
eeSetupHs :: ExecuteEnv -> Path Abs File
eeTempDir :: ExecuteEnv -> Path Abs Dir
eeGhcPkgIds :: ExecuteEnv -> TVar (Map PackageIdentifier Installed)
eeBaseConfigOpts :: ExecuteEnv -> BaseConfigOpts
eeBuildOptsCLI :: ExecuteEnv -> BuildOptsCLI
eeBuildOpts :: ExecuteEnv -> BuildOpts
eeInstallLock :: ExecuteEnv -> MVar ()
eeConfigureLock :: ExecuteEnv -> MVar ()
..} task :: Task
task@Task {Bool
PackageIdentifier
Map PackageIdentifier GhcPkgId
TaskType
TaskConfigOpts
CachePkgSrc
taskBuildTypeConfig :: Bool
taskAnyMissing :: Bool
taskCachePkgSrc :: CachePkgSrc
taskAllInOne :: Bool
taskPresent :: Map PackageIdentifier GhcPkgId
taskBuildHaddock :: Bool
taskConfigOpts :: TaskConfigOpts
taskType :: TaskType
taskProvides :: PackageIdentifier
taskBuildTypeConfig :: Task -> Bool
taskAnyMissing :: Task -> Bool
taskCachePkgSrc :: Task -> CachePkgSrc
taskAllInOne :: Task -> Bool
taskPresent :: Task -> Map PackageIdentifier GhcPkgId
taskBuildHaddock :: Task -> Bool
taskConfigOpts :: Task -> TaskConfigOpts
taskProvides :: Task -> PackageIdentifier
taskType :: Task -> TaskType
..} InstalledMap
installedMap Bool
isFinalBuild = do
  (Map PackageIdentifier GhcPkgId
allDepsMap, ConfigCache
cache) <-
    forall env.
HasEnvConfig env =>
ExecuteEnv
-> Task
-> InstalledMap
-> Bool
-> Bool
-> RIO env (Map PackageIdentifier GhcPkgId, ConfigCache)
getConfigCache ExecuteEnv
ee Task
task InstalledMap
installedMap Bool
enableTests Bool
enableBenchmarks
  Maybe (PrecompiledCache Abs)
mprecompiled <- ConfigCache -> RIO env (Maybe (PrecompiledCache Abs))
getPrecompiled ConfigCache
cache
  Maybe Installed
minstalled <-
    case Maybe (PrecompiledCache Abs)
mprecompiled of
      Just PrecompiledCache Abs
precompiled -> PrecompiledCache Abs -> RIO env (Maybe Installed)
copyPreCompiled PrecompiledCache Abs
precompiled
      Maybe (PrecompiledCache Abs)
Nothing -> do
        Maybe Curator
mcurator <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasBuildConfig env => Lens' env BuildConfig
buildConfigLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to BuildConfig -> Maybe Curator
bcCurator
        ConfigCache
-> Maybe Curator
-> Map PackageIdentifier GhcPkgId
-> RIO env (Maybe Installed)
realConfigAndBuild ConfigCache
cache Maybe Curator
mcurator Map PackageIdentifier GhcPkgId
allDepsMap
  case Maybe Installed
minstalled of
    Maybe Installed
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Just Installed
installed -> do
      forall env.
HasEnvConfig env =>
Installed -> ConfigCache -> RIO env ()
writeFlagCache Installed
installed ConfigCache
cache
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$
        forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (Map PackageIdentifier Installed)
eeGhcPkgIds forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert PackageIdentifier
taskProvides Installed
installed
 where
  PackageIdentifier PackageName
pname Version
pversion = PackageIdentifier
taskProvides
  doHaddock :: Maybe Curator -> Package -> Bool
doHaddock Maybe Curator
mcurator Package
package =
       Bool
taskBuildHaddock
    Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
isFinalBuild
       -- Works around haddock failing on bytestring-builder since it has no

       -- modules when bytestring is new enough.

    Bool -> Bool -> Bool
&& Package -> Bool
packageHasExposedModules Package
package
       -- Special help for the curator tool to avoid haddocks that are known

       -- to fail

    Bool -> Bool -> Bool
&& forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (forall a. Ord a => a -> Set a -> Bool
Set.notMember PackageName
pname forall b c a. (b -> c) -> (a -> b) -> a -> c
. Curator -> Set PackageName
curatorSkipHaddock) Maybe Curator
mcurator
  expectHaddockFailure :: Maybe Curator -> Bool
expectHaddockFailure =
      forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (forall a. Ord a => a -> Set a -> Bool
Set.member PackageName
pname forall b c a. (b -> c) -> (a -> b) -> a -> c
. Curator -> Set PackageName
curatorExpectHaddockFailure)
  fulfillHaddockExpectations :: Maybe Curator -> (KeepOutputOpen -> RIO env ()) -> RIO env ()
fulfillHaddockExpectations Maybe Curator
mcurator KeepOutputOpen -> RIO env ()
action
    | Maybe Curator -> Bool
expectHaddockFailure Maybe Curator
mcurator = do
        Either SomeException ()
eres <- forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny forall a b. (a -> b) -> a -> b
$ KeepOutputOpen -> RIO env ()
action KeepOutputOpen
KeepOpen
        case Either SomeException ()
eres of
          Right () -> forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
 MonadIO m) =>
[StyleDoc] -> m ()
prettyWarnL
            [ Style -> StyleDoc -> StyleDoc
style Style
Current (forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ PackageName -> String
packageNameString PackageName
pname) forall a. Semigroup a => a -> a -> a
<> StyleDoc
":"
            , String -> StyleDoc
flow String
"unexpected Haddock success."
            ]
          Left SomeException
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  fulfillHaddockExpectations Maybe Curator
_ KeepOutputOpen -> RIO env ()
action = KeepOutputOpen -> RIO env ()
action KeepOutputOpen
CloseOnException

  buildingFinals :: Bool
buildingFinals = Bool
isFinalBuild Bool -> Bool -> Bool
|| Bool
taskAllInOne
  enableTests :: Bool
enableTests = Bool
buildingFinals Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any NamedComponent -> Bool
isCTest (Task -> Set NamedComponent
taskComponents Task
task)
  enableBenchmarks :: Bool
enableBenchmarks = Bool
buildingFinals Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any NamedComponent -> Bool
isCBench (Task -> Set NamedComponent
taskComponents Task
task)

  annSuffix :: Map Text ExecutableBuildStatus -> Text
annSuffix Map Text ExecutableBuildStatus
executableBuildStatuses =
    if Text
result forall a. Eq a => a -> a -> Bool
== Text
"" then Text
"" else Text
" (" forall a. Semigroup a => a -> a -> a
<> Text
result forall a. Semigroup a => a -> a -> a
<> Text
")"
   where
    result :: Text
result = Text -> [Text] -> Text
T.intercalate Text
" + " forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ [Text
"lib" | Bool
taskAllInOne Bool -> Bool -> Bool
&& Bool
hasLib]
      , [Text
"internal-lib" | Bool
taskAllInOne Bool -> Bool -> Bool
&& Bool
hasSubLib]
      , [Text
"exe" | Bool
taskAllInOne Bool -> Bool -> Bool
&& Bool
hasExe]
      , [Text
"test" | Bool
enableTests]
      , [Text
"bench" | Bool
enableBenchmarks]
      ]
    (Bool
hasLib, Bool
hasSubLib, Bool
hasExe) = case TaskType
taskType of
      TTLocalMutable LocalPackage
lp ->
        let package :: Package
package = LocalPackage -> Package
lpPackage LocalPackage
lp
            hasLibrary :: Bool
hasLibrary =
              case Package -> PackageLibraries
packageLibraries Package
package of
                PackageLibraries
NoLibraries -> Bool
False
                HasLibraries Set Text
_ -> Bool
True
            hasSubLibrary :: Bool
hasSubLibrary = Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> Bool
Set.null forall a b. (a -> b) -> a -> b
$ Package -> Set Text
packageInternalLibraries Package
package
            hasExecutables :: Bool
hasExecutables =
              Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> Bool
Set.null forall a b. (a -> b) -> a -> b
$ Map Text ExecutableBuildStatus -> LocalPackage -> Set Text
exesToBuild Map Text ExecutableBuildStatus
executableBuildStatuses LocalPackage
lp
        in  (Bool
hasLibrary, Bool
hasSubLibrary, Bool
hasExecutables)
      -- This isn't true, but we don't want to have this info for upstream deps.

      TaskType
_ -> (Bool
False, Bool
False, Bool
False)

  getPrecompiled :: ConfigCache -> RIO env (Maybe (PrecompiledCache Abs))
getPrecompiled ConfigCache
cache =
    case TaskType
taskType of
      TTRemotePackage IsMutable
Immutable Package
_ PackageLocationImmutable
loc -> do
        Maybe (PrecompiledCache Abs)
mpc <- forall env.
HasEnvConfig env =>
PackageLocationImmutable
-> ConfigureOpts
-> Bool
-> Set GhcPkgId
-> RIO env (Maybe (PrecompiledCache Abs))
readPrecompiledCache
                 PackageLocationImmutable
loc
                 (ConfigCache -> ConfigureOpts
configCacheOpts ConfigCache
cache)
                 (ConfigCache -> Bool
configCacheHaddock ConfigCache
cache)
                 (ConfigCache -> Set GhcPkgId
configCacheDeps ConfigCache
cache)
        case Maybe (PrecompiledCache Abs)
mpc of
          Maybe (PrecompiledCache Abs)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
          -- Only pay attention to precompiled caches that refer to packages

          -- within the snapshot.

          Just PrecompiledCache Abs
pc
            | forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False
                (BaseConfigOpts -> Path Abs Dir
bcoSnapInstallRoot BaseConfigOpts
eeBaseConfigOpts `isProperPrefixOf`)
                (forall base. PrecompiledCache base -> Maybe (Path base File)
pcLibrary PrecompiledCache Abs
pc) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
          -- If old precompiled cache files are left around but snapshots are

          -- deleted, it is possible for the precompiled file to refer to the

          -- very library we're building, and if flags are changed it may try to

          -- copy the library to itself. This check prevents that from

          -- happening.

          Just PrecompiledCache Abs
pc -> do
            let allM :: (t -> f Bool) -> [t] -> f Bool
allM t -> f Bool
_ [] = forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
                allM t -> f Bool
f (t
x:[t]
xs) = do
                  Bool
b <- t -> f Bool
f t
x
                  if Bool
b then (t -> f Bool) -> [t] -> f Bool
allM t -> f Bool
f [t]
xs else forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
            Bool
b <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
                   forall {f :: * -> *} {t}. Monad f => (t -> f Bool) -> [t] -> f Bool
allM forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (:) (forall base. PrecompiledCache base -> Maybe (Path base File)
pcLibrary PrecompiledCache Abs
pc) forall a b. (a -> b) -> a -> b
$ forall base. PrecompiledCache base -> [Path base File]
pcExes PrecompiledCache Abs
pc
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ if Bool
b then forall a. a -> Maybe a
Just PrecompiledCache Abs
pc else forall a. Maybe a
Nothing
      TaskType
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing

  copyPreCompiled :: PrecompiledCache Abs -> RIO env (Maybe Installed)
copyPreCompiled (PrecompiledCache Maybe (Path Abs File)
mlib [Path Abs File]
sublibs [Path Abs File]
exes) = do
    WhichCompiler
wc <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasSourceMap env => SimpleGetter env ActualCompiler
actualCompilerVersionLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall r. Getting r ActualCompiler WhichCompiler
whichCompilerL
    forall env.
HasLogFunc env =>
ExecuteEnv -> Task -> Utf8Builder -> RIO env ()
announceTask ExecuteEnv
ee Task
task Utf8Builder
"using precompiled package"

    -- We need to copy .conf files for the main library and all sublibraries

    -- which exist in the cache, from their old snapshot to the new one.

    -- However, we must unregister any such library in the new snapshot, in case

    -- it was built with different flags.

    let
      subLibNames :: [Text]
subLibNames = forall a. Set a -> [a]
Set.toList forall a b. (a -> b) -> a -> b
$ case TaskType
taskType of
        TTLocalMutable LocalPackage
lp -> Package -> Set Text
packageInternalLibraries forall a b. (a -> b) -> a -> b
$ LocalPackage -> Package
lpPackage LocalPackage
lp
        TTRemotePackage IsMutable
_ Package
p PackageLocationImmutable
_ -> Package -> Set Text
packageInternalLibraries Package
p
      toMungedPackageId :: Text -> MungedPackageId
      toMungedPackageId :: Text -> MungedPackageId
toMungedPackageId Text
sublib =
        let sublibName :: LibraryName
sublibName = UnqualComponentName -> LibraryName
LSubLibName forall a b. (a -> b) -> a -> b
$ String -> UnqualComponentName
mkUnqualComponentName forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
sublib
        in  MungedPackageName -> Version -> MungedPackageId
MungedPackageId (PackageName -> LibraryName -> MungedPackageName
MungedPackageName PackageName
pname LibraryName
sublibName) Version
pversion
      allToUnregister :: [String]
allToUnregister = forall a. Maybe a -> [a] -> [a]
mcons
        (forall a. Pretty a => a -> String
prettyShow PackageIdentifier
taskProvides forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Maybe (Path Abs File)
mlib)
        (forall a b. (a -> b) -> [a] -> [b]
map (forall a. Pretty a => a -> String
prettyShow forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> MungedPackageId
toMungedPackageId) [Text]
subLibNames)
      allToRegister :: [Path Abs File]
allToRegister = forall a. Maybe a -> [a] -> [a]
mcons Maybe (Path Abs File)
mlib [Path Abs File]
sublibs

    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Path Abs File]
allToRegister) forall a b. (a -> b) -> a -> b
$
      forall (m :: * -> *) a b.
MonadUnliftIO m =>
MVar a -> (a -> m b) -> m b
withMVar MVar ()
eeInstallLock forall a b. (a -> b) -> a -> b
$ \() -> do
        -- We want to ignore the global and user databases.

        -- Unfortunately, ghc-pkg doesn't take such arguments on the

        -- command line. Instead, we'll set GHC_PACKAGE_PATH. See:

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


        let modifyEnv :: Map Text Text -> Map Text Text
modifyEnv = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert
              (WhichCompiler -> Text
ghcPkgPathEnvVar WhichCompiler
wc)
              (String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall loc. Path loc Dir -> String
toFilePathNoTrailingSep forall a b. (a -> b) -> a -> b
$ BaseConfigOpts -> Path Abs Dir
bcoSnapDB BaseConfigOpts
eeBaseConfigOpts)

        forall env (m :: * -> *) a.
(HasProcessContext env, MonadReader env m, MonadIO m) =>
(Map Text Text -> Map Text Text) -> m a -> m a
withModifyEnvVars Map Text Text -> Map Text Text
modifyEnv forall a b. (a -> b) -> a -> b
$ do
          GhcPkgExe Path Abs File
ghcPkgExe <- forall env. HasCompiler env => RIO env GhcPkgExe
getGhcPkgExe

          -- first unregister everything that needs to be unregistered

          forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [String]
allToUnregister forall a b. (a -> b) -> a -> b
$ \String
packageName -> forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
catchAny
            ( forall env.
(HasProcessContext env, HasLogFunc env, ?callStack::CallStack) =>
String -> [String] -> RIO env ()
readProcessNull
                (forall b t. Path b t -> String
toFilePath Path Abs File
ghcPkgExe)
                [ String
"unregister", String
"--force", String
packageName]
            )
            (forall a b. a -> b -> a
const (forall (f :: * -> *) a. Applicative f => a -> f a
pure ()))

          -- now, register the cached conf files

          forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Path Abs File]
allToRegister forall a b. (a -> b) -> a -> b
$ \Path Abs File
libpath ->
            forall env (m :: * -> *) a.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
 MonadIO m, ?callStack::CallStack) =>
String -> [String] -> (ProcessConfig () () () -> m a) -> m a
proc
              (forall b t. Path b t -> String
toFilePath Path Abs File
ghcPkgExe)
              [ String
"register", String
"--force", forall b t. Path b t -> String
toFilePath Path Abs File
libpath]
              forall (m :: * -> *) stdin stdoutIgnored stderrIgnored.
MonadIO m =>
ProcessConfig stdin stdoutIgnored stderrIgnored
-> m (LByteString, LByteString)
readProcess_

    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Path Abs File]
exes forall a b. (a -> b) -> a -> b
$ \Path Abs File
exe -> do
      forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir Path Abs Dir
bindir
      let dst :: Path Abs File
dst = Path Abs Dir
bindir forall b t. Path b Dir -> Path Rel t -> Path b t
</> forall b. Path b File -> Path Rel File
filename Path Abs File
exe
      String -> String -> IO ()
createLink (forall b t. Path b t -> String
toFilePath Path Abs File
exe) (forall b t. Path b t -> String
toFilePath Path Abs File
dst) forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (IOError -> m a) -> m a
`catchIO` \IOError
_ -> forall (m :: * -> *) b0 b1.
MonadIO m =>
Path b0 File -> Path b1 File -> m ()
copyFile Path Abs File
exe Path Abs File
dst
    case (Maybe (Path Abs File)
mlib, [Path Abs File]
exes) of
      (Maybe (Path Abs File)
Nothing, Path Abs File
_:[Path Abs File]
_) -> forall env.
HasEnvConfig env =>
InstallLocation -> PackageIdentifier -> RIO env ()
markExeInstalled (Task -> InstallLocation
taskLocation Task
task) PackageIdentifier
taskProvides
      (Maybe (Path Abs File), [Path Abs File])
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

    -- Find the package in the database

    let pkgDbs :: [Path Abs Dir]
pkgDbs = [BaseConfigOpts -> Path Abs Dir
bcoSnapDB BaseConfigOpts
eeBaseConfigOpts]

    case Maybe (Path Abs File)
mlib of
      Maybe (Path Abs File)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> Installed
Executable PackageIdentifier
taskProvides
      Just Path Abs File
_ -> do
        Maybe GhcPkgId
mpkgid <- [Path Abs Dir]
-> TVar (Map GhcPkgId DumpPackage)
-> PackageName
-> RIO env (Maybe GhcPkgId)
loadInstalledPkg [Path Abs Dir]
pkgDbs TVar (Map GhcPkgId DumpPackage)
eeSnapshotDumpPkgs PackageName
pname

        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
          case Maybe GhcPkgId
mpkgid of
            Maybe GhcPkgId
Nothing -> forall a. (?callStack::CallStack) => Bool -> a -> a
assert Bool
False forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> Installed
Executable PackageIdentifier
taskProvides
            Just GhcPkgId
pkgid -> PackageIdentifier
-> GhcPkgId -> Maybe (Either License License) -> Installed
Library PackageIdentifier
taskProvides GhcPkgId
pkgid forall a. Maybe a
Nothing
   where
    bindir :: Path Abs Dir
bindir = BaseConfigOpts -> Path Abs Dir
bcoSnapInstallRoot BaseConfigOpts
eeBaseConfigOpts forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
bindirSuffix

  realConfigAndBuild :: ConfigCache
-> Maybe Curator
-> Map PackageIdentifier GhcPkgId
-> RIO env (Maybe Installed)
realConfigAndBuild ConfigCache
cache Maybe Curator
mcurator Map PackageIdentifier GhcPkgId
allDepsMap =
    forall env a.
HasEnvConfig env =>
ActionContext
-> ExecuteEnv
-> Task
-> Map PackageIdentifier GhcPkgId
-> Maybe String
-> (Package
    -> Path Abs File
    -> Path Abs Dir
    -> (KeepOutputOpen -> ExcludeTHLoading -> [String] -> RIO env ())
    -> (Utf8Builder -> RIO env ())
    -> OutputType
    -> RIO env a)
-> RIO env a
withSingleContext ActionContext
ac ExecuteEnv
ee Task
task Map PackageIdentifier GhcPkgId
allDepsMap forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$
      \Package
package Path Abs File
cabalfp Path Abs Dir
pkgDir KeepOutputOpen -> ExcludeTHLoading -> [String] -> RIO env ()
cabal0 Utf8Builder -> RIO env ()
announce OutputType
_outputType -> do
        let cabal :: ExcludeTHLoading -> [String] -> RIO env ()
cabal = KeepOutputOpen -> ExcludeTHLoading -> [String] -> RIO env ()
cabal0 KeepOutputOpen
CloseOnException
        Map Text ExecutableBuildStatus
executableBuildStatuses <- forall env.
HasEnvConfig env =>
Package -> Path Abs Dir -> RIO env (Map Text ExecutableBuildStatus)
getExecutableBuildStatuses Package
package Path Abs Dir
pkgDir
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (  Bool -> Bool
not (forall k. Map k ExecutableBuildStatus -> Bool
cabalIsSatisfied Map Text ExecutableBuildStatus
executableBuildStatuses)
             Bool -> Bool -> Bool
&& Task -> Bool
taskIsTarget Task
task
             ) forall a b. (a -> b) -> a -> b
$
          forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
 MonadIO m) =>
[StyleDoc] -> m ()
prettyInfoL
            [ String -> StyleDoc
flow String
"Building all executables for"
            , Style -> StyleDoc -> StyleDoc
style Style
Current (forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ PackageName -> String
packageNameString forall a b. (a -> b) -> a -> b
$ Package -> PackageName
packageName Package
package)
            , String -> StyleDoc
flow String
"once. After a successful build of all of them, only \
                   \specified executables will be rebuilt."
            ]
        Bool
_neededConfig <-
          forall env.
HasEnvConfig env =>
ConfigCache
-> Path Abs Dir
-> ExecuteEnv
-> RIO env ()
-> (ExcludeTHLoading -> [String] -> RIO env ())
-> Path Abs File
-> Task
-> RIO env Bool
ensureConfig
            ConfigCache
cache
            Path Abs Dir
pkgDir
            ExecuteEnv
ee
            ( Utf8Builder -> RIO env ()
announce
                (  Utf8Builder
"configure"
                forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display (Map Text ExecutableBuildStatus -> Text
annSuffix Map Text ExecutableBuildStatus
executableBuildStatuses)
                )
            )
            ExcludeTHLoading -> [String] -> RIO env ()
cabal
            Path Abs File
cabalfp
            Task
task
        let installedMapHasThisPkg :: Bool
            installedMapHasThisPkg :: Bool
installedMapHasThisPkg =
              case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Package -> PackageName
packageName Package
package) InstalledMap
installedMap of
                Just (InstallLocation
_, Library PackageIdentifier
ident GhcPkgId
_ Maybe (Either License License)
_) -> PackageIdentifier
ident forall a. Eq a => a -> a -> Bool
== PackageIdentifier
taskProvides
                Just (InstallLocation
_, Executable PackageIdentifier
_) -> Bool
True
                Maybe (InstallLocation, Installed)
_ -> Bool
False

        case ( BuildOptsCLI -> Bool
boptsCLIOnlyConfigure BuildOptsCLI
eeBuildOptsCLI
             , BuildOptsCLI -> Bool
boptsCLIInitialBuildSteps BuildOptsCLI
eeBuildOptsCLI Bool -> Bool -> Bool
&& Task -> Bool
taskIsTarget Task
task) of
          -- A full build is done if there are downstream actions,

          -- because their configure step will require that this

          -- package is built. See

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

          (Bool
True, Bool
_) | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Action]
acDownstream -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
          (Bool
_, Bool
True) | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Action]
acDownstream Bool -> Bool -> Bool
|| Bool
installedMapHasThisPkg -> do
            Map Text ExecutableBuildStatus
-> (ExcludeTHLoading -> [String] -> RIO env ())
-> (Utf8Builder -> RIO env ())
-> RIO env ()
initialBuildSteps Map Text ExecutableBuildStatus
executableBuildStatuses ExcludeTHLoading -> [String] -> RIO env ()
cabal Utf8Builder -> RIO env ()
announce
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
          (Bool, Bool)
_ -> forall env b.
(?callStack::CallStack, HasTerm env) =>
PackageName
-> Maybe Curator -> Bool -> Bool -> b -> RIO env b -> RIO env b
fulfillCuratorBuildExpectations
                 PackageName
pname
                 Maybe Curator
mcurator
                 Bool
enableTests
                 Bool
enableBenchmarks
                 forall a. Maybe a
Nothing
                 (forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                    ConfigCache
-> Package
-> Path Abs Dir
-> (KeepOutputOpen -> ExcludeTHLoading -> [String] -> RIO env ())
-> (Utf8Builder -> RIO env ())
-> Map Text ExecutableBuildStatus
-> RIO env Installed
realBuild ConfigCache
cache Package
package Path Abs Dir
pkgDir KeepOutputOpen -> ExcludeTHLoading -> [String] -> RIO env ()
cabal0 Utf8Builder -> RIO env ()
announce Map Text ExecutableBuildStatus
executableBuildStatuses)

  initialBuildSteps :: Map Text ExecutableBuildStatus
-> (ExcludeTHLoading -> [String] -> RIO env ())
-> (Utf8Builder -> RIO env ())
-> RIO env ()
initialBuildSteps Map Text ExecutableBuildStatus
executableBuildStatuses ExcludeTHLoading -> [String] -> RIO env ()
cabal Utf8Builder -> RIO env ()
announce = do
    Utf8Builder -> RIO env ()
announce
      (  Utf8Builder
"initial-build-steps"
      forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display (Map Text ExecutableBuildStatus -> Text
annSuffix Map Text ExecutableBuildStatus
executableBuildStatuses)
      )
    ExcludeTHLoading -> [String] -> RIO env ()
cabal ExcludeTHLoading
KeepTHLoading [String
"repl", String
"stack-initial-build-steps"]

  realBuild ::
       ConfigCache
    -> Package
    -> Path Abs Dir
    -> (KeepOutputOpen -> ExcludeTHLoading -> [String] -> RIO env ())
    -> (Utf8Builder -> RIO env ())
       -- ^ A plain 'announce' function

    -> Map Text ExecutableBuildStatus
    -> RIO env Installed
  realBuild :: ConfigCache
-> Package
-> Path Abs Dir
-> (KeepOutputOpen -> ExcludeTHLoading -> [String] -> RIO env ())
-> (Utf8Builder -> RIO env ())
-> Map Text ExecutableBuildStatus
-> RIO env Installed
realBuild ConfigCache
cache Package
package Path Abs Dir
pkgDir KeepOutputOpen -> ExcludeTHLoading -> [String] -> RIO env ()
cabal0 Utf8Builder -> RIO env ()
announce Map Text ExecutableBuildStatus
executableBuildStatuses = do
    let cabal :: ExcludeTHLoading -> [String] -> RIO env ()
cabal = KeepOutputOpen -> ExcludeTHLoading -> [String] -> RIO env ()
cabal0 KeepOutputOpen
CloseOnException
    WhichCompiler
wc <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasSourceMap env => SimpleGetter env ActualCompiler
actualCompilerVersionLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall r. Getting r ActualCompiler WhichCompiler
whichCompilerL

    forall env.
HasEnvConfig env =>
InstallLocation -> PackageIdentifier -> RIO env ()
markExeNotInstalled (Task -> InstallLocation
taskLocation Task
task) PackageIdentifier
taskProvides
    case TaskType
taskType of
      TTLocalMutable LocalPackage
lp -> do
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
enableTests forall a b. (a -> b) -> a -> b
$ forall env.
HasEnvConfig env =>
Path Abs Dir -> TestStatus -> RIO env ()
setTestStatus Path Abs Dir
pkgDir TestStatus
TSUnknown
        Map NamedComponent (Map String FileCacheInfo)
caches <- forall env (m :: * -> *) a.
(HasEnvConfig env, MonadReader env m, MonadIO m) =>
MemoizedWith EnvConfig a -> m a
runMemoizedWith forall a b. (a -> b) -> a -> b
$ LocalPackage
-> MemoizedWith
     EnvConfig (Map NamedComponent (Map String FileCacheInfo))
lpNewBuildCaches LocalPackage
lp
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_
          (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (forall env.
HasEnvConfig env =>
Path Abs Dir
-> NamedComponent -> Map String FileCacheInfo -> RIO env ()
writeBuildCache Path Abs Dir
pkgDir))
          (forall k a. Map k a -> [(k, a)]
Map.toList Map NamedComponent (Map String FileCacheInfo)
caches)
      TTRemotePackage{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

    -- FIXME: only output these if they're in the build plan.


    let postBuildCheck :: Bool -> RIO env ()
postBuildCheck Bool
_succeeded = do
          Maybe (Path Abs File, [PackageWarning])
mlocalWarnings <- case TaskType
taskType of
            TTLocalMutable LocalPackage
lp -> do
                [PackageWarning]
warnings <- forall env.
HasEnvConfig env =>
TaskType -> Path Abs Dir -> RIO env [PackageWarning]
checkForUnlistedFiles TaskType
taskType Path Abs Dir
pkgDir
                -- TODO: Perhaps only emit these warnings for non extra-dep?

                forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just (LocalPackage -> Path Abs File
lpCabalFile LocalPackage
lp, [PackageWarning]
warnings))
            TaskType
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
          -- NOTE: once

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

          -- is resolved, we will want to partition the warnings

          -- based on variety, and output in different lists.

          let showModuleWarning :: PackageWarning -> StyleDoc
showModuleWarning (UnlistedModulesWarning NamedComponent
comp [ModuleName]
modules) =
                StyleDoc
"- In" StyleDoc -> StyleDoc -> StyleDoc
<+>
                forall a. IsString a => String -> a
fromString (Text -> String
T.unpack (NamedComponent -> Text
renderComponent NamedComponent
comp)) forall a. Semigroup a => a -> a -> a
<>
                StyleDoc
":" forall a. Semigroup a => a -> a -> a
<> StyleDoc
line forall a. Semigroup a => a -> a -> a
<>
                Int -> StyleDoc -> StyleDoc
indent Int
4 ( forall a. Monoid a => [a] -> a
mconcat
                         forall a b. (a -> b) -> a -> b
$ forall a. a -> [a] -> [a]
L.intersperse StyleDoc
line
                         forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map
                             (Style -> StyleDoc -> StyleDoc
style Style
Good forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Pretty a => a -> String
C.display)
                             [ModuleName]
modules
                         )
          forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (Path Abs File, [PackageWarning])
mlocalWarnings forall a b. (a -> b) -> a -> b
$ \(Path Abs File
cabalfp, [PackageWarning]
warnings) ->
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PackageWarning]
warnings) forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
 MonadIO m) =>
StyleDoc -> m ()
prettyWarn forall a b. (a -> b) -> a -> b
$
                 String -> StyleDoc
flow String
"The following modules should be added to \
                      \exposed-modules or other-modules in" StyleDoc -> StyleDoc -> StyleDoc
<+>
                      forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
cabalfp
              forall a. Semigroup a => a -> a -> a
<> StyleDoc
":"
              forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
              forall a. Semigroup a => a -> a -> a
<> Int -> StyleDoc -> StyleDoc
indent Int
4 ( forall a. Monoid a => [a] -> a
mconcat
                          forall a b. (a -> b) -> a -> b
$ forall a. a -> [a] -> [a]
L.intersperse StyleDoc
line
                          forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map PackageWarning -> StyleDoc
showModuleWarning [PackageWarning]
warnings
                          )
              forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
              forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
flow String
"Missing modules in the Cabal file are likely to cause \
                      \undefined reference errors from the linker, along with \
                      \other problems."

    () <- Utf8Builder -> RIO env ()
announce
      (  Utf8Builder
"build"
      forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display (Map Text ExecutableBuildStatus -> Text
annSuffix Map Text ExecutableBuildStatus
executableBuildStatuses)
      )
    Config
config <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasConfig env => Lens' env Config
configL
    [String]
extraOpts <- forall env.
(HasEnvConfig env, HasRunner env) =>
WhichCompiler -> BuildOpts -> RIO env [String]
extraBuildOptions WhichCompiler
wc BuildOpts
eeBuildOpts
    let stripTHLoading :: ExcludeTHLoading
stripTHLoading
          | Config -> Bool
configHideTHLoading Config
config = ExcludeTHLoading
ExcludeTHLoading
          | Bool
otherwise                  = ExcludeTHLoading
KeepTHLoading
    ExcludeTHLoading -> [String] -> RIO env ()
cabal ExcludeTHLoading
stripTHLoading ((String
"build" :) forall a b. (a -> b) -> a -> b
$ (forall a. [a] -> [a] -> [a]
++ [String]
extraOpts) forall a b. (a -> b) -> a -> b
$
        case (TaskType
taskType, Bool
taskAllInOne, Bool
isFinalBuild) of
            (TaskType
_, Bool
True, Bool
True) -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM BuildException
AllInOneBuildBug
            (TTLocalMutable LocalPackage
lp, Bool
False, Bool
False) ->
              Map Text ExecutableBuildStatus -> LocalPackage -> [String]
primaryComponentOptions Map Text ExecutableBuildStatus
executableBuildStatuses LocalPackage
lp
            (TTLocalMutable LocalPackage
lp, Bool
False, Bool
True) -> LocalPackage -> [String]
finalComponentOptions LocalPackage
lp
            (TTLocalMutable LocalPackage
lp, Bool
True, Bool
False) ->
                 Map Text ExecutableBuildStatus -> LocalPackage -> [String]
primaryComponentOptions Map Text ExecutableBuildStatus
executableBuildStatuses LocalPackage
lp
              forall a. [a] -> [a] -> [a]
++ LocalPackage -> [String]
finalComponentOptions LocalPackage
lp
            (TTRemotePackage{}, Bool
_, Bool
_) -> [])
      forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \BuildPrettyException
ex -> case BuildPrettyException
ex of
        CabalExitedUnsuccessfully{} ->
          Bool -> RIO env ()
postBuildCheck Bool
False forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall e (m :: * -> *) a.
(Exception e, MonadThrow m, Pretty e) =>
e -> m a
prettyThrowM BuildPrettyException
ex
        BuildPrettyException
_ -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM BuildPrettyException
ex
    Bool -> RIO env ()
postBuildCheck Bool
True

    Maybe Curator
mcurator <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasBuildConfig env => Lens' env BuildConfig
buildConfigLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to BuildConfig -> Maybe Curator
bcCurator
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Curator -> Package -> Bool
doHaddock Maybe Curator
mcurator Package
package) forall a b. (a -> b) -> a -> b
$ do
      Utf8Builder -> RIO env ()
announce Utf8Builder
"haddock"
      [String]
sourceFlag <- if Bool -> Bool
not (BuildOpts -> Bool
boptsHaddockHyperlinkSource BuildOpts
eeBuildOpts)
        then forall (f :: * -> *) a. Applicative f => a -> f a
pure []
        else do
          -- See #2429 for why the temp dir is used

          ExitCode
ec
            <- forall env (m :: * -> *) a.
(HasProcessContext env, MonadReader env m, MonadIO m) =>
String -> m a -> m a
withWorkingDir (forall b t. Path b t -> String
toFilePath Path Abs Dir
eeTempDir)
             forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *) a.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
 MonadIO m, ?callStack::CallStack) =>
String -> [String] -> (ProcessConfig () () () -> m a) -> m a
proc String
"haddock" [String
"--hyperlinked-source"]
             forall a b. (a -> b) -> a -> b
$ \ProcessConfig () () ()
pc -> forall (m :: * -> *) stdin stdout stderr a.
MonadUnliftIO m =>
ProcessConfig stdin stdout stderr
-> (Process stdin stdout stderr -> m a) -> m a
withProcessWait
               (forall stdout stdin stdout0 stderr.
StreamSpec 'STOutput stdout
-> ProcessConfig stdin stdout0 stderr
-> ProcessConfig stdin stdout stderr
setStdout forall (m :: * -> *) i.
MonadIO m =>
StreamSpec 'STOutput (ConduitM i ByteString m ())
createSource forall a b. (a -> b) -> a -> b
$ forall stderr stdin stdout stderr0.
StreamSpec 'STOutput stderr
-> ProcessConfig stdin stdout stderr0
-> ProcessConfig stdin stdout stderr
setStderr forall (m :: * -> *) i.
MonadIO m =>
StreamSpec 'STOutput (ConduitM i ByteString m ())
createSource ProcessConfig () () ()
pc) forall a b. (a -> b) -> a -> b
$ \Process
  ()
  (ConduitM () ByteString (RIO env) ())
  (ConduitM () ByteString (RIO env) ())
p ->
                 forall (m :: * -> *) a. Concurrently m a -> m a
runConcurrently
                   forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. m a -> Concurrently m a
Concurrently (forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit forall a b. (a -> b) -> a -> b
$ forall stdin stdout stderr. Process stdin stdout stderr -> stdout
getStdout Process
  ()
  (ConduitM () ByteString (RIO env) ())
  (ConduitM () ByteString (RIO env) ())
p forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) i o. Monad m => ConduitT i o m ()
CL.sinkNull)
                  forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) a. m a -> Concurrently m a
Concurrently (forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit forall a b. (a -> b) -> a -> b
$ forall stdin stdout stderr. Process stdin stdout stderr -> stderr
getStderr Process
  ()
  (ConduitM () ByteString (RIO env) ())
  (ConduitM () ByteString (RIO env) ())
p forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) i o. Monad m => ConduitT i o m ()
CL.sinkNull)
                  forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) a. m a -> Concurrently m a
Concurrently (forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
Process stdin stdout stderr -> m ExitCode
waitExitCode Process
  ()
  (ConduitM () ByteString (RIO env) ())
  (ConduitM () ByteString (RIO env) ())
p)
          case ExitCode
ec of
            -- Fancy crosslinked source

            ExitCode
ExitSuccess -> forall (f :: * -> *) a. Applicative f => a -> f a
pure [String
"--haddock-option=--hyperlinked-source"]
            -- Older hscolour colouring

            ExitFailure Int
_ -> do
              Bool
hscolourExists <- forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasProcessContext env) =>
String -> m Bool
doesExecutableExist String
"HsColour"
              forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
hscolourExists forall a b. (a -> b) -> a -> b
$
                forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
 MonadIO m) =>
[StyleDoc] -> m ()
prettyWarnL
                  [ String -> StyleDoc
flow String
"Warning: Haddock is not generating hyperlinked \
                         \sources because 'HsColour' not found on PATH (use"
                  , Style -> StyleDoc -> StyleDoc
style Style
Shell (String -> StyleDoc
flow String
"stack install hscolour")
                  , String -> StyleDoc
flow String
"to install)."
                  ]
              forall (f :: * -> *) a. Applicative f => a -> f a
pure [String
"--hyperlink-source" | Bool
hscolourExists]

      -- For GHC 8.4 and later, provide the --quickjump option.

      ActualCompiler
actualCompiler <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasSourceMap env => SimpleGetter env ActualCompiler
actualCompilerVersionL
      let quickjump :: [String]
quickjump =
            case ActualCompiler
actualCompiler of
              ACGhc Version
ghcVer
                | Version
ghcVer forall a. Ord a => a -> a -> Bool
>= [Int] -> Version
mkVersion [Int
8, Int
4] -> [String
"--haddock-option=--quickjump"]
              ActualCompiler
_ -> []

      Maybe Curator -> (KeepOutputOpen -> RIO env ()) -> RIO env ()
fulfillHaddockExpectations Maybe Curator
mcurator forall a b. (a -> b) -> a -> b
$ \KeepOutputOpen
keep ->
        KeepOutputOpen -> ExcludeTHLoading -> [String] -> RIO env ()
cabal0 KeepOutputOpen
keep ExcludeTHLoading
KeepTHLoading forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
          [ [ String
"haddock"
            , String
"--html"
            , String
"--hoogle"
            , String
"--html-location=../$pkg-$version/"
            ]
          , [String]
sourceFlag
          , [String
"--internal" | BuildOpts -> Bool
boptsHaddockInternal BuildOpts
eeBuildOpts]
          , [ String
"--haddock-option=" forall a. Semigroup a => a -> a -> a
<> String
opt
            | String
opt <- HaddockOpts -> [String]
hoAdditionalArgs (BuildOpts -> HaddockOpts
boptsHaddockOpts BuildOpts
eeBuildOpts) ]
          , [String]
quickjump
          ]

    let hasLibrary :: Bool
hasLibrary =
          case Package -> PackageLibraries
packageLibraries Package
package of
            PackageLibraries
NoLibraries -> Bool
False
            HasLibraries Set Text
_ -> Bool
True
        packageHasComponentSet :: (Package -> Set Text) -> Bool
packageHasComponentSet Package -> Set Text
f = Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall a. Set a -> Bool
Set.null forall a b. (a -> b) -> a -> b
$ Package -> Set Text
f Package
package
        hasInternalLibrary :: Bool
hasInternalLibrary = (Package -> Set Text) -> Bool
packageHasComponentSet Package -> Set Text
packageInternalLibraries
        hasExecutables :: Bool
hasExecutables = (Package -> Set Text) -> Bool
packageHasComponentSet Package -> Set Text
packageExes
        shouldCopy :: Bool
shouldCopy =
             Bool -> Bool
not Bool
isFinalBuild
          Bool -> Bool -> Bool
&& (Bool
hasLibrary Bool -> Bool -> Bool
|| Bool
hasInternalLibrary Bool -> Bool -> Bool
|| Bool
hasExecutables)
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
shouldCopy forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b.
MonadUnliftIO m =>
MVar a -> (a -> m b) -> m b
withMVar MVar ()
eeInstallLock forall a b. (a -> b) -> a -> b
$ \() -> do
      Utf8Builder -> RIO env ()
announce Utf8Builder
"copy/register"
      Either BuildPrettyException ()
eres <- forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try forall a b. (a -> b) -> a -> b
$ ExcludeTHLoading -> [String] -> RIO env ()
cabal ExcludeTHLoading
KeepTHLoading [String
"copy"]
      case Either BuildPrettyException ()
eres of
        Left err :: BuildPrettyException
err@CabalExitedUnsuccessfully{} ->
          forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ Bool -> String -> BuildException
CabalCopyFailed
                     (Package -> BuildType
packageBuildType Package
package forall a. Eq a => a -> a -> Bool
== BuildType
C.Simple)
                     (forall e. Exception e => e -> String
displayException BuildPrettyException
err)
        Either BuildPrettyException ()
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
hasLibrary forall a b. (a -> b) -> a -> b
$ ExcludeTHLoading -> [String] -> RIO env ()
cabal ExcludeTHLoading
KeepTHLoading [String
"register"]

    -- copy ddump-* files

    case Text -> String
T.unpack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BuildOpts -> Maybe Text
boptsDdumpDir BuildOpts
eeBuildOpts of
      Just String
ddumpPath | Bool
buildingFinals Bool -> Bool -> Bool
&& Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
ddumpPath) -> do
        Path Rel Dir
distDir <- forall (m :: * -> *) env.
(MonadThrow m, MonadReader env m, HasEnvConfig env) =>
m (Path Rel Dir)
distRelativeDir
        Path Rel Dir
ddumpDir <- forall (m :: * -> *). MonadThrow m => String -> m (Path Rel Dir)
parseRelDir String
ddumpPath

        forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
 ?callStack::CallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ forall a. IsString a => String -> a
fromString (String
"ddump-dir: " forall a. Semigroup a => a -> a -> a
<> forall b t. Path b t -> String
toFilePath Path Rel Dir
ddumpDir)
        forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
 ?callStack::CallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ forall a. IsString a => String -> a
fromString (String
"dist-dir: " forall a. Semigroup a => a -> a -> a
<> forall b t. Path b t -> String
toFilePath Path Rel Dir
distDir)

        forall (m :: * -> *) r.
MonadUnliftIO m =>
ConduitT () Void (ResourceT m) r -> m r
runConduitRes
          forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) i.
MonadResource m =>
Bool -> String -> ConduitT i String m ()
CF.sourceDirectoryDeep Bool
False (forall b t. Path b t -> String
toFilePath Path Rel Dir
distDir)
         forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) a. Monad m => (a -> Bool) -> ConduitT a a m ()
CL.filter (forall a. Eq a => [a] -> [a] -> Bool
L.isInfixOf String
".dump-")
         forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) a o.
Monad m =>
(a -> m ()) -> ConduitT a o m ()
CL.mapM_ (\String
src -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
              Path Rel Dir
parentDir <- forall b t. Path b t -> Path b Dir
parent forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadThrow m => String -> m (Path Rel Dir)
parseRelDir String
src
              Path Rel Dir
destBaseDir <-
                (Path Rel Dir
ddumpDir </>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) b t.
MonadThrow m =>
Path b Dir -> Path b t -> m (Path Rel t)
stripProperPrefix Path Rel Dir
distDir Path Rel Dir
parentDir
              -- exclude .stack-work dir

              forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (String
".stack-work" forall a. Eq a => [a] -> [a] -> Bool
`L.isInfixOf` forall b t. Path b t -> String
toFilePath Path Rel Dir
destBaseDir) forall a b. (a -> b) -> a -> b
$ do
                forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir Path Rel Dir
destBaseDir
                Path Rel File
src' <- forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile String
src
                forall (m :: * -> *) b0 b1.
MonadIO m =>
Path b0 File -> Path b1 File -> m ()
copyFile Path Rel File
src' (Path Rel Dir
destBaseDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> forall b. Path b File -> Path Rel File
filename Path Rel File
src'))
      Maybe String
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

    let (Path Abs Dir
installedPkgDb, TVar (Map GhcPkgId DumpPackage)
installedDumpPkgsTVar) =
          case Task -> InstallLocation
taskLocation Task
task of
            InstallLocation
Snap ->
              ( BaseConfigOpts -> Path Abs Dir
bcoSnapDB BaseConfigOpts
eeBaseConfigOpts
              , TVar (Map GhcPkgId DumpPackage)
eeSnapshotDumpPkgs )
            InstallLocation
Local ->
              ( BaseConfigOpts -> Path Abs Dir
bcoLocalDB BaseConfigOpts
eeBaseConfigOpts
              , TVar (Map GhcPkgId DumpPackage)
eeLocalDumpPkgs )
    let ident :: PackageIdentifier
ident = PackageName -> Version -> PackageIdentifier
PackageIdentifier (Package -> PackageName
packageName Package
package) (Package -> Version
packageVersion Package
package)
    -- only pure the sublibs to cache them if we also cache the main lib (that

    -- is, if it exists)

    (Installed
mpkgid, [GhcPkgId]
sublibsPkgIds) <- case Package -> PackageLibraries
packageLibraries Package
package of
      HasLibraries Set Text
_ -> do
        [GhcPkgId]
sublibsPkgIds <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$
          forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (forall a. Set a -> [a]
Set.toList forall a b. (a -> b) -> a -> b
$ Package -> Set Text
packageInternalLibraries Package
package) forall a b. (a -> b) -> a -> b
$ \Text
sublib -> do
            let sublibName :: MungedPackageName
sublibName = PackageName -> LibraryName -> MungedPackageName
MungedPackageName
                  (Package -> PackageName
packageName Package
package)
                  (UnqualComponentName -> LibraryName
LSubLibName forall a b. (a -> b) -> a -> b
$ String -> UnqualComponentName
mkUnqualComponentName forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
sublib)
            [Path Abs Dir]
-> TVar (Map GhcPkgId DumpPackage)
-> PackageName
-> RIO env (Maybe GhcPkgId)
loadInstalledPkg
              [Path Abs Dir
installedPkgDb]
              TVar (Map GhcPkgId DumpPackage)
installedDumpPkgsTVar
              (MungedPackageName -> PackageName
encodeCompatPackageName MungedPackageName
sublibName)

        Maybe GhcPkgId
mpkgid <- [Path Abs Dir]
-> TVar (Map GhcPkgId DumpPackage)
-> PackageName
-> RIO env (Maybe GhcPkgId)
loadInstalledPkg
                    [Path Abs Dir
installedPkgDb]
                    TVar (Map GhcPkgId DumpPackage)
installedDumpPkgsTVar
                    (Package -> PackageName
packageName Package
package)
        case Maybe GhcPkgId
mpkgid of
          Maybe GhcPkgId
Nothing -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ PackageName -> BuildException
Couldn'tFindPkgId forall a b. (a -> b) -> a -> b
$ Package -> PackageName
packageName Package
package
          Just GhcPkgId
pkgid -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (PackageIdentifier
-> GhcPkgId -> Maybe (Either License License) -> Installed
Library PackageIdentifier
ident GhcPkgId
pkgid forall a. Maybe a
Nothing, [GhcPkgId]
sublibsPkgIds)
      PackageLibraries
NoLibraries -> do
        forall env.
HasEnvConfig env =>
InstallLocation -> PackageIdentifier -> RIO env ()
markExeInstalled (Task -> InstallLocation
taskLocation Task
task) PackageIdentifier
taskProvides -- TODO unify somehow

                                                          -- with writeFlagCache?

        forall (f :: * -> *) a. Applicative f => a -> f a
pure (PackageIdentifier -> Installed
Executable PackageIdentifier
ident, []) -- don't pure sublibs in this case


    case TaskType
taskType of
      TTRemotePackage IsMutable
Immutable Package
_ PackageLocationImmutable
loc ->
        forall env.
HasEnvConfig env =>
BaseConfigOpts
-> PackageLocationImmutable
-> ConfigureOpts
-> Bool
-> Set GhcPkgId
-> Installed
-> [GhcPkgId]
-> Set Text
-> RIO env ()
writePrecompiledCache
          BaseConfigOpts
eeBaseConfigOpts
          PackageLocationImmutable
loc
          (ConfigCache -> ConfigureOpts
configCacheOpts ConfigCache
cache)
          (ConfigCache -> Bool
configCacheHaddock ConfigCache
cache)
          (ConfigCache -> Set GhcPkgId
configCacheDeps ConfigCache
cache)
          Installed
mpkgid [GhcPkgId]
sublibsPkgIds (Package -> Set Text
packageExes Package
package)
      TaskType
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

    case TaskType
taskType of
      -- For packages from a package index, pkgDir is in the tmp directory. We

      -- eagerly delete it if no other tasks require it, to reduce space usage

      -- in tmp (#3018).

      TTRemotePackage{} -> do
        let remaining :: [ActionId]
remaining =
              forall a. (a -> Bool) -> [a] -> [a]
filter
                (\(ActionId PackageIdentifier
x ActionType
_) -> PackageIdentifier
x forall a. Eq a => a -> a -> Bool
== PackageIdentifier
taskProvides)
                (forall a. Set a -> [a]
Set.toList Set ActionId
acRemaining)
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ActionId]
remaining) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
removeDirRecur Path Abs Dir
pkgDir
      TTLocalMutable{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

    forall (f :: * -> *) a. Applicative f => a -> f a
pure Installed
mpkgid

  loadInstalledPkg ::
       [Path Abs Dir]
    -> TVar (Map GhcPkgId DumpPackage)
    -> PackageName
    -> RIO env (Maybe GhcPkgId)
  loadInstalledPkg :: [Path Abs Dir]
-> TVar (Map GhcPkgId DumpPackage)
-> PackageName
-> RIO env (Maybe GhcPkgId)
loadInstalledPkg [Path Abs Dir]
pkgDbs TVar (Map GhcPkgId DumpPackage)
tvar PackageName
name = do
    GhcPkgExe
pkgexe <- forall env. HasCompiler env => RIO env GhcPkgExe
getGhcPkgExe
    [DumpPackage]
dps <- forall env a.
(HasCompiler env, HasProcessContext env, HasTerm env) =>
GhcPkgExe
-> PackageName
-> [Path Abs Dir]
-> ConduitM Text Void (RIO env) a
-> RIO env a
ghcPkgDescribe GhcPkgExe
pkgexe PackageName
name [Path Abs Dir]
pkgDbs forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadThrow m =>
ConduitM Text DumpPackage m ()
conduitDumpPackage forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) a o. Monad m => ConduitT a o m [a]
CL.consume
    case [DumpPackage]
dps of
      [] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
      [DumpPackage
dp] -> do
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar (Map GhcPkgId DumpPackage)
tvar (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (DumpPackage -> GhcPkgId
dpGhcPkgId DumpPackage
dp) DumpPackage
dp)
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (DumpPackage -> GhcPkgId
dpGhcPkgId DumpPackage
dp)
      [DumpPackage]
_ -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ PackageName -> [DumpPackage] -> BuildException
MultipleResultsBug PackageName
name [DumpPackage]
dps

-- | Get the build status of all the package executables. Do so by

-- testing whether their expected output file exists, e.g.

--

-- .stack-work/dist/x86_64-osx/Cabal-1.22.4.0/build/alpha/alpha

-- .stack-work/dist/x86_64-osx/Cabal-1.22.4.0/build/alpha/alpha.exe

-- .stack-work/dist/x86_64-osx/Cabal-1.22.4.0/build/alpha/alpha.jsexe/ (NOTE: a dir)

getExecutableBuildStatuses ::
     HasEnvConfig env
  => Package
  -> Path Abs Dir
  -> RIO env (Map Text ExecutableBuildStatus)
getExecutableBuildStatuses :: forall env.
HasEnvConfig env =>
Package -> Path Abs Dir -> RIO env (Map Text ExecutableBuildStatus)
getExecutableBuildStatuses Package
package Path Abs Dir
pkgDir = do
  Path Abs Dir
distDir <- forall (m :: * -> *) env.
(MonadThrow m, MonadReader env m, HasEnvConfig env) =>
Path Abs Dir -> m (Path Abs Dir)
distDirFromDir Path Abs Dir
pkgDir
  Platform
platform <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasPlatform env => Lens' env Platform
platformL
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
    forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall env b.
HasLogFunc env =>
Platform
-> Path b Dir -> Text -> RIO env (Text, ExecutableBuildStatus)
checkExeStatus Platform
platform Path Abs Dir
distDir) (forall a. Set a -> [a]
Set.toList (Package -> Set Text
packageExes Package
package)))

-- | Check whether the given executable is defined in the given dist directory.

checkExeStatus ::
     HasLogFunc env
  => Platform
  -> Path b Dir
  -> Text
  -> RIO env (Text, ExecutableBuildStatus)
checkExeStatus :: forall env b.
HasLogFunc env =>
Platform
-> Path b Dir -> Text -> RIO env (Text, ExecutableBuildStatus)
checkExeStatus Platform
platform Path b Dir
distDir Text
name = do
  Path Rel Dir
exename <- forall (m :: * -> *). MonadThrow m => String -> m (Path Rel Dir)
parseRelDir (Text -> String
T.unpack Text
name)
  Bool
exists <- Path b Dir -> RIO env Bool
checkPath (Path b Dir
distDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirBuild forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
exename)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ( Text
name
    , if Bool
exists
        then ExecutableBuildStatus
ExecutableBuilt
        else ExecutableBuildStatus
ExecutableNotBuilt)
 where
  checkPath :: Path b Dir -> RIO env Bool
checkPath Path b Dir
base =
    case Platform
platform of
      Platform Arch
_ OS
Windows -> do
        Path Rel File
fileandext <- forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile (String
file forall a. [a] -> [a] -> [a]
++ String
".exe")
        forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist (Path b Dir
base forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
fileandext)
      Platform
_ -> do
        Path Rel File
fileandext <- forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile String
file
        forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist (Path b Dir
base forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
fileandext)
   where
    file :: String
file = Text -> String
T.unpack Text
name

-- | Check if any unlisted files have been found, and add them to the build cache.

checkForUnlistedFiles ::
     HasEnvConfig env
  => TaskType
  -> Path Abs Dir
  -> RIO env [PackageWarning]
checkForUnlistedFiles :: forall env.
HasEnvConfig env =>
TaskType -> Path Abs Dir -> RIO env [PackageWarning]
checkForUnlistedFiles (TTLocalMutable LocalPackage
lp) Path Abs Dir
pkgDir = do
  Map NamedComponent (Map String FileCacheInfo)
caches <- forall env (m :: * -> *) a.
(HasEnvConfig env, MonadReader env m, MonadIO m) =>
MemoizedWith EnvConfig a -> m a
runMemoizedWith forall a b. (a -> b) -> a -> b
$ LocalPackage
-> MemoizedWith
     EnvConfig (Map NamedComponent (Map String FileCacheInfo))
lpNewBuildCaches LocalPackage
lp
  (Map NamedComponent [Map String FileCacheInfo]
addBuildCache,[PackageWarning]
warnings) <-
    forall env a.
HasEnvConfig env =>
Package
-> Path Abs File
-> Set NamedComponent
-> Map NamedComponent (Map String a)
-> RIO
     env
     (Map NamedComponent [Map String FileCacheInfo], [PackageWarning])
addUnlistedToBuildCache
      (LocalPackage -> Package
lpPackage LocalPackage
lp)
      (LocalPackage -> Path Abs File
lpCabalFile LocalPackage
lp)
      (LocalPackage -> Set NamedComponent
lpComponents LocalPackage
lp)
      Map NamedComponent (Map String FileCacheInfo)
caches
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall k a. Map k a -> [(k, a)]
Map.toList Map NamedComponent [Map String FileCacheInfo]
addBuildCache) forall a b. (a -> b) -> a -> b
$ \(NamedComponent
component, [Map String FileCacheInfo]
newToCache) -> do
    let cache :: Map String FileCacheInfo
cache = forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault forall k a. Map k a
Map.empty NamedComponent
component Map NamedComponent (Map String FileCacheInfo)
caches
    forall env.
HasEnvConfig env =>
Path Abs Dir
-> NamedComponent -> Map String FileCacheInfo -> RIO env ()
writeBuildCache Path Abs Dir
pkgDir NamedComponent
component forall a b. (a -> b) -> a -> b
$
      forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions (Map String FileCacheInfo
cache forall a. a -> [a] -> [a]
: [Map String FileCacheInfo]
newToCache)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure [PackageWarning]
warnings
checkForUnlistedFiles TTRemotePackage{} Path Abs Dir
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure []

-- | Implements running a package's tests. Also handles producing

-- coverage reports if coverage is enabled.

singleTest :: HasEnvConfig env
           => TestOpts
           -> [Text]
           -> ActionContext
           -> ExecuteEnv
           -> Task
           -> InstalledMap
           -> RIO env ()
singleTest :: forall env.
HasEnvConfig env =>
TestOpts
-> [Text]
-> ActionContext
-> ExecuteEnv
-> Task
-> InstalledMap
-> RIO env ()
singleTest TestOpts
topts [Text]
testsToRun ActionContext
ac ExecuteEnv
ee Task
task InstalledMap
installedMap = do
  -- FIXME: Since this doesn't use cabal, we should be able to avoid using a

  -- full blown 'withSingleContext'.

  (Map PackageIdentifier GhcPkgId
allDepsMap, ConfigCache
_cache) <- forall env.
HasEnvConfig env =>
ExecuteEnv
-> Task
-> InstalledMap
-> Bool
-> Bool
-> RIO env (Map PackageIdentifier GhcPkgId, ConfigCache)
getConfigCache ExecuteEnv
ee Task
task InstalledMap
installedMap Bool
True Bool
False
  Maybe Curator
mcurator <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasBuildConfig env => Lens' env BuildConfig
buildConfigLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to BuildConfig -> Maybe Curator
bcCurator
  let pname :: PackageName
pname = PackageIdentifier -> PackageName
pkgName forall a b. (a -> b) -> a -> b
$ Task -> PackageIdentifier
taskProvides Task
task
      expectFailure :: Bool
expectFailure = PackageName -> Maybe Curator -> Bool
expectTestFailure PackageName
pname Maybe Curator
mcurator
  forall env a.
HasEnvConfig env =>
ActionContext
-> ExecuteEnv
-> Task
-> Map PackageIdentifier GhcPkgId
-> Maybe String
-> (Package
    -> Path Abs File
    -> Path Abs Dir
    -> (KeepOutputOpen -> ExcludeTHLoading -> [String] -> RIO env ())
    -> (Utf8Builder -> RIO env ())
    -> OutputType
    -> RIO env a)
-> RIO env a
withSingleContext ActionContext
ac ExecuteEnv
ee Task
task Map PackageIdentifier GhcPkgId
allDepsMap (forall a. a -> Maybe a
Just String
"test") forall a b. (a -> b) -> a -> b
$
    \Package
package Path Abs File
_cabalfp Path Abs Dir
pkgDir KeepOutputOpen -> ExcludeTHLoading -> [String] -> RIO env ()
_cabal Utf8Builder -> RIO env ()
announce OutputType
outputType -> do
      Config
config <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasConfig env => Lens' env Config
configL
      let needHpc :: Bool
needHpc = TestOpts -> Bool
toCoverage TestOpts
topts

      Bool
toRun <-
        if TestOpts -> Bool
toDisableRun TestOpts
topts
          then do
            Utf8Builder -> RIO env ()
announce Utf8Builder
"Test running disabled by --no-run-tests flag."
            forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
          else if TestOpts -> Bool
toRerunTests TestOpts
topts
            then forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
            else do
              TestStatus
status <- forall env. HasEnvConfig env => Path Abs Dir -> RIO env TestStatus
getTestStatus Path Abs Dir
pkgDir
              case TestStatus
status of
                TestStatus
TSSuccess -> do
                  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
testsToRun) forall a b. (a -> b) -> a -> b
$
                    Utf8Builder -> RIO env ()
announce Utf8Builder
"skipping already passed test"
                  forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
                TestStatus
TSFailure
                  | Bool
expectFailure -> do
                      Utf8Builder -> RIO env ()
announce Utf8Builder
"skipping already failed test that's expected to fail"
                      forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
                  | Bool
otherwise -> do
                      Utf8Builder -> RIO env ()
announce Utf8Builder
"rerunning previously failed test"
                      forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
                TestStatus
TSUnknown -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True

      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
toRun forall a b. (a -> b) -> a -> b
$ do
        Path Abs Dir
buildDir <- forall (m :: * -> *) env.
(MonadThrow m, MonadReader env m, HasEnvConfig env) =>
Path Abs Dir -> m (Path Abs Dir)
distDirFromDir Path Abs Dir
pkgDir
        Path Abs Dir
hpcDir <- forall (m :: * -> *) env.
(MonadThrow m, MonadReader env m, HasEnvConfig env) =>
Path Abs Dir -> m (Path Abs Dir)
hpcDirFromDir Path Abs Dir
pkgDir
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
needHpc (forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir Path Abs Dir
hpcDir)

        let suitesToRun :: [(Text, TestSuiteInterface)]
suitesToRun
              = [ (Text, TestSuiteInterface)
testSuitePair
                | (Text, TestSuiteInterface)
testSuitePair <- forall k a. Map k a -> [(k, a)]
Map.toList forall a b. (a -> b) -> a -> b
$ Package -> Map Text TestSuiteInterface
packageTests Package
package
                , let testName :: Text
testName = forall a b. (a, b) -> a
fst (Text, TestSuiteInterface)
testSuitePair
                , Text
testName forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
testsToRun
                ]

        Map Text (Maybe ExitCode)
errs <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Text, TestSuiteInterface)]
suitesToRun forall a b. (a -> b) -> a -> b
$ \(Text
testName, TestSuiteInterface
suiteInterface) -> do
          let stestName :: String
stestName = Text -> String
T.unpack Text
testName
          (String
testName', Bool
isTestTypeLib) <-
            case TestSuiteInterface
suiteInterface of
              C.TestSuiteLibV09{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
stestName forall a. [a] -> [a] -> [a]
++ String
"Stub", Bool
True)
              C.TestSuiteExeV10{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
stestName, Bool
False)
              TestSuiteInterface
interface -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (TestSuiteInterface -> BuildException
TestSuiteTypeUnsupported TestSuiteInterface
interface)

          let exeName :: String
exeName = String
testName' forall a. [a] -> [a] -> [a]
++
                case Config -> Platform
configPlatform Config
config of
                  Platform Arch
_ OS
Windows -> String
".exe"
                  Platform
_ -> String
""
          Path Abs File
tixPath <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Path Abs Dir
pkgDir </>) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile forall a b. (a -> b) -> a -> b
$ String
exeName forall a. [a] -> [a] -> [a]
++ String
".tix"
          Path Abs File
exePath <-
            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Path Abs Dir
buildDir </>) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile forall a b. (a -> b) -> a -> b
$
              String
"build/" forall a. [a] -> [a] -> [a]
++ String
testName' forall a. [a] -> [a] -> [a]
++ String
"/" forall a. [a] -> [a] -> [a]
++ String
exeName
          Bool
exists <- forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
exePath
          -- in Stack.Package.packageFromPackageDescription we filter out

          -- package itself of any dependencies so any tests requiring loading

          -- of their own package library will fail so to prevent this we return

          -- it back here but unfortunately unconditionally

          Maybe Installed
installed <- case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
pname InstalledMap
installedMap of
            Just (InstallLocation
_, Installed
installed) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Installed
installed
            Maybe (InstallLocation, Installed)
Nothing -> do
              Map PackageIdentifier Installed
idMap <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO (ExecuteEnv -> TVar (Map PackageIdentifier Installed)
eeGhcPkgIds ExecuteEnv
ee)
              forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Task -> PackageIdentifier
taskProvides Task
task) Map PackageIdentifier Installed
idMap
          let pkgGhcIdList :: [GhcPkgId]
pkgGhcIdList = case Maybe Installed
installed of
                               Just (Library PackageIdentifier
_ GhcPkgId
ghcPkgId Maybe (Either License License)
_) -> [GhcPkgId
ghcPkgId]
                               Maybe Installed
_ -> []
          -- doctest relies on template-haskell in QuickCheck-based tests

          GhcPkgId
thGhcId <-
            case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find ((forall a. Eq a => a -> a -> Bool
== PackageName
"template-haskell") forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageIdentifier -> PackageName
pkgName forall b c a. (b -> c) -> (a -> b) -> a -> c
. DumpPackage -> PackageIdentifier
dpPackageIdentforall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd)
                   (forall k a. Map k a -> [(k, a)]
Map.toList forall a b. (a -> b) -> a -> b
$ ExecuteEnv -> Map GhcPkgId DumpPackage
eeGlobalDumpPkgs ExecuteEnv
ee) of
              Just (GhcPkgId
ghcId, DumpPackage
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure GhcPkgId
ghcId
              Maybe (GhcPkgId, DumpPackage)
Nothing -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO BuildException
TemplateHaskellNotFoundBug
          -- env variable GHC_ENVIRONMENT is set for doctest so module names for

          -- packages with proper dependencies should no longer get ambiguous

          -- see e.g. https://github.com/doctest/issues/119

          -- also we set HASKELL_DIST_DIR to a package dist directory so

          -- doctest will be able to load modules autogenerated by Cabal

          let setEnv :: String -> ProcessContext -> IO ProcessContext
setEnv String
f ProcessContext
pc = forall (m :: * -> *).
MonadIO m =>
ProcessContext
-> (Map Text Text -> Map Text Text) -> m ProcessContext
modifyEnvVars ProcessContext
pc forall a b. (a -> b) -> a -> b
$ \Map Text Text
envVars ->
                forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
"HASKELL_DIST_DIR" (String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall b t. Path b t -> String
toFilePath Path Abs Dir
buildDir) forall a b. (a -> b) -> a -> b
$
                forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
"GHC_ENVIRONMENT" (String -> Text
T.pack String
f) Map Text Text
envVars
              fp' :: Path Abs File
fp' = ExecuteEnv -> Path Abs Dir
eeTempDir ExecuteEnv
ee forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
testGhcEnvRelFile
          -- Add a random suffix to avoid conflicts between parallel jobs

          -- See https://github.com/commercialhaskell/stack/issues/5024

          Int
randomInt <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a (m :: * -> *). (Random a, MonadIO m) => m a
randomIO :: IO Int)
          let randomSuffix :: String
randomSuffix = String
"." forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (forall a. Num a => a -> a
abs Int
randomInt)
          String
fp <- forall b t. Path b t -> String
toFilePath forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) b.
MonadThrow m =>
String -> Path b File -> m (Path b File)
addExtension String
randomSuffix Path Abs File
fp'
          let snapDBPath :: String
snapDBPath =
                forall loc. Path loc Dir -> String
toFilePathNoTrailingSep (BaseConfigOpts -> Path Abs Dir
bcoSnapDB forall a b. (a -> b) -> a -> b
$ ExecuteEnv -> BaseConfigOpts
eeBaseConfigOpts ExecuteEnv
ee)
              localDBPath :: String
localDBPath =
                forall loc. Path loc Dir -> String
toFilePathNoTrailingSep (BaseConfigOpts -> Path Abs Dir
bcoLocalDB forall a b. (a -> b) -> a -> b
$ ExecuteEnv -> BaseConfigOpts
eeBaseConfigOpts ExecuteEnv
ee)
              ghcEnv :: Utf8Builder
ghcEnv =
                   Utf8Builder
"clear-package-db\n"
                forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"global-package-db\n"
                forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"package-db "
                forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => String -> a
fromString String
snapDBPath
                forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"\n"
                forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"package-db "
                forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => String -> a
fromString String
localDBPath
                forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"\n"
                forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
                     ( \GhcPkgId
ghcId ->
                            Utf8Builder
"package-id "
                         forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display (GhcPkgId -> Text
unGhcPkgId GhcPkgId
ghcId)
                         forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"\n"
                     )
                     ([GhcPkgId]
pkgGhcIdList forall a. [a] -> [a] -> [a]
++ GhcPkgId
thGhcIdforall a. a -> [a] -> [a]
:forall k a. Map k a -> [a]
Map.elems Map PackageIdentifier GhcPkgId
allDepsMap)
          forall (m :: * -> *). MonadIO m => String -> Utf8Builder -> m ()
writeFileUtf8Builder String
fp Utf8Builder
ghcEnv
          ProcessContext
menv <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
            String -> ProcessContext -> IO ProcessContext
setEnv String
fp forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Config -> EnvSettings -> IO ProcessContext
configProcessContextSettings Config
config EnvSettings
              { esIncludeLocals :: Bool
esIncludeLocals = Task -> InstallLocation
taskLocation Task
task forall a. Eq a => a -> a -> Bool
== InstallLocation
Local
              , esIncludeGhcPackagePath :: Bool
esIncludeGhcPackagePath = Bool
True
              , esStackExe :: Bool
esStackExe = Bool
True
              , esLocaleUtf8 :: Bool
esLocaleUtf8 = Bool
False
              , esKeepGhcRts :: Bool
esKeepGhcRts = Bool
False
              }
          let emptyResult :: Map Text (Maybe ExitCode)
emptyResult = forall k a. k -> a -> Map k a
Map.singleton Text
testName forall a. Maybe a
Nothing
          forall env a.
HasProcessContext env =>
ProcessContext -> RIO env a -> RIO env a
withProcessContext ProcessContext
menv forall a b. (a -> b) -> a -> b
$ if Bool
exists
            then do
                -- We clear out the .tix files before doing a run.

                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
needHpc forall a b. (a -> b) -> a -> b
$ do
                  Bool
tixexists <- forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
tixPath
                  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
tixexists forall a b. (a -> b) -> a -> b
$
                    forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
 MonadIO m) =>
[StyleDoc] -> m ()
prettyWarnL
                      [ String -> StyleDoc
flow String
"Removing HPC file"
                      , forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
tixPath forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
                      ]
                  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. (MonadIO m, MonadCatch m) => m a -> m ()
ignoringAbsence (forall (m :: * -> *) b. MonadIO m => Path b File -> m ()
removeFile Path Abs File
tixPath)

                let args :: [String]
args = TestOpts -> [String]
toAdditionalArgs TestOpts
topts
                    argsDisplay :: Text
argsDisplay = case [String]
args of
                      [] -> Text
""
                      [String]
_ ->    Text
", args: "
                           forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
" " (forall a b. (a -> b) -> [a] -> [b]
map String -> Text
showProcessArgDebug [String]
args)
                Utf8Builder -> RIO env ()
announce forall a b. (a -> b) -> a -> b
$
                     Utf8Builder
"test (suite: "
                  forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Text
testName
                  forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Text
argsDisplay
                  forall a. Semigroup a => a -> a -> a
<> Utf8Builder
")"

                -- Clear "Progress: ..." message before

                -- redirecting output.

                case OutputType
outputType of
                  OTConsole Maybe Utf8Builder
_ -> do
                    forall (m :: * -> *) env.
(MonadIO m, ?callStack::CallStack, MonadReader env m,
 HasLogFunc env) =>
Utf8Builder -> m ()
logStickyDone Utf8Builder
""
                    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadIO m => Handle -> m ()
hFlush Handle
stdout
                    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadIO m => Handle -> m ()
hFlush Handle
stderr
                  OTLogFile Path Abs File
_ Handle
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

                let output :: StreamSpec 'STOutput (Maybe (RIO env ()))
output = case OutputType
outputType of
                      OTConsole Maybe Utf8Builder
Nothing -> forall a. Maybe a
Nothing forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (anyStreamType :: StreamType). StreamSpec anyStreamType ()
inherit
                      OTConsole (Just Utf8Builder
prefix) -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
                        ( \ConduitT () ByteString (RIO env) ()
src -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
                               forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit forall a b. (a -> b) -> a -> b
$ ConduitT () ByteString (RIO env) ()
src
                            forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *). Monad m => ConduitT ByteString Text m ()
CT.decodeUtf8Lenient
                            forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *). Monad m => ConduitT Text Text m ()
CT.lines
                            forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) a b. Monad m => (a -> b) -> ConduitT a b m ()
CL.map Text -> Text
stripCR
                            forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) a o.
Monad m =>
(a -> m ()) -> ConduitT a o m ()
CL.mapM_ (\Text
t -> forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
 ?callStack::CallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Utf8Builder
prefix forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Text
t)
                        )
                        forall (m :: * -> *) i.
MonadIO m =>
StreamSpec 'STOutput (ConduitM i ByteString m ())
createSource
                      OTLogFile Path Abs File
_ Handle
h -> forall a. Maybe a
Nothing forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (anyStreamType :: StreamType).
Handle -> StreamSpec anyStreamType ()
useHandleOpen Handle
h
                    optionalTimeout :: RIO env ExitCode -> RIO env (Maybe ExitCode)
optionalTimeout RIO env ExitCode
action
                      | Just Int
maxSecs <- TestOpts -> Maybe Int
toMaximumTimeSeconds TestOpts
topts, Int
maxSecs forall a. Ord a => a -> a -> Bool
> Int
0 =
                          forall (m :: * -> *) a.
MonadUnliftIO m =>
Int -> m a -> m (Maybe a)
timeout (Int
maxSecs forall a. Num a => a -> a -> a
* Int
1000000) RIO env ExitCode
action
                      | Bool
otherwise = forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RIO env ExitCode
action

                Maybe ExitCode
mec <- forall env (m :: * -> *) a.
(HasProcessContext env, MonadReader env m, MonadIO m) =>
String -> m a -> m a
withWorkingDir (forall b t. Path b t -> String
toFilePath Path Abs Dir
pkgDir) forall a b. (a -> b) -> a -> b
$
                  RIO env ExitCode -> RIO env (Maybe ExitCode)
optionalTimeout forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *) a.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
 MonadIO m, ?callStack::CallStack) =>
String -> [String] -> (ProcessConfig () () () -> m a) -> m a
proc (forall b t. Path b t -> String
toFilePath Path Abs File
exePath) [String]
args forall a b. (a -> b) -> a -> b
$ \ProcessConfig () () ()
pc0 -> do
                    ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))
-> ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))
changeStdin <-
                      if Bool
isTestTypeLib
                        then do
                          Path Abs File
logPath <- forall env (m :: * -> *).
(MonadReader env m, HasBuildConfig env, MonadThrow m) =>
Package -> Maybe String -> m (Path Abs File)
buildLogPath Package
package (forall a. a -> Maybe a
Just String
stestName)
                          forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir (forall b t. Path b t -> Path b Dir
parent Path Abs File
logPath)
                          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
                              forall stdin stdin0 stdout stderr.
StreamSpec 'STInput stdin
-> ProcessConfig stdin0 stdout stderr
-> ProcessConfig stdin stdout stderr
setStdin
                            forall a b. (a -> b) -> a -> b
$ LByteString -> StreamSpec 'STInput ()
byteStringInput
                            forall a b. (a -> b) -> a -> b
$ ByteString -> LByteString
BL.fromStrict
                            forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 forall a b. (a -> b) -> a -> b
$ forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$
                            forall a. Show a => a -> String
show ( Path Abs File
logPath
                                 , String -> UnqualComponentName
mkUnqualComponentName (Text -> String
T.unpack Text
testName)
                                 )
                        else do
                          Bool
isTerminal <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasRunner env => Lens' env GlobalOpts
globalOptsLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to GlobalOpts -> Bool
globalTerminal
                          if TestOpts -> Bool
toAllowStdin TestOpts
topts Bool -> Bool -> Bool
&& Bool
isTerminal
                            then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. a -> a
id
                            else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall stdin stdin0 stdout stderr.
StreamSpec 'STInput stdin
-> ProcessConfig stdin0 stdout stderr
-> ProcessConfig stdin stdout stderr
setStdin forall a b. (a -> b) -> a -> b
$ LByteString -> StreamSpec 'STInput ()
byteStringInput forall a. Monoid a => a
mempty
                    let pc :: ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))
pc = ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))
-> ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))
changeStdin
                           forall a b. (a -> b) -> a -> b
$ forall stdout stdin stdout0 stderr.
StreamSpec 'STOutput stdout
-> ProcessConfig stdin stdout0 stderr
-> ProcessConfig stdin stdout stderr
setStdout StreamSpec 'STOutput (Maybe (RIO env ()))
output
                           forall a b. (a -> b) -> a -> b
$ forall stderr stdin stdout stderr0.
StreamSpec 'STOutput stderr
-> ProcessConfig stdin stdout stderr0
-> ProcessConfig stdin stdout stderr
setStderr StreamSpec 'STOutput (Maybe (RIO env ()))
output
                             ProcessConfig () () ()
pc0
                    forall (m :: * -> *) stdin stdout stderr a.
MonadUnliftIO m =>
ProcessConfig stdin stdout stderr
-> (Process stdin stdout stderr -> m a) -> m a
withProcessWait ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))
pc forall a b. (a -> b) -> a -> b
$ \Process () (Maybe (RIO env ())) (Maybe (RIO env ()))
p -> do
                      case (forall stdin stdout stderr. Process stdin stdout stderr -> stdout
getStdout Process () (Maybe (RIO env ())) (Maybe (RIO env ()))
p, forall stdin stdout stderr. Process stdin stdout stderr -> stderr
getStderr Process () (Maybe (RIO env ())) (Maybe (RIO env ()))
p) of
                        (Maybe (RIO env ())
Nothing, Maybe (RIO env ())
Nothing) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                        (Just RIO env ()
x, Just RIO env ()
y) -> forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m ()
concurrently_ RIO env ()
x RIO env ()
y
                        (Maybe (RIO env ())
x, Maybe (RIO env ())
y) -> forall a. (?callStack::CallStack) => Bool -> a -> a
assert Bool
False forall a b. (a -> b) -> a -> b
$
                          forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m ()
concurrently_
                            (forall a. a -> Maybe a -> a
fromMaybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) Maybe (RIO env ())
x)
                            (forall a. a -> Maybe a -> a
fromMaybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) Maybe (RIO env ())
y)
                      forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
Process stdin stdout stderr -> m ExitCode
waitExitCode Process () (Maybe (RIO env ())) (Maybe (RIO env ()))
p
                -- Add a trailing newline, incase the test

                -- output didn't finish with a newline.

                case OutputType
outputType of
                  OTConsole Maybe Utf8Builder
Nothing -> forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
 MonadIO m) =>
StyleDoc -> m ()
prettyInfo StyleDoc
blankLine
                  OutputType
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                -- Move the .tix file out of the package

                -- directory into the hpc work dir, for

                -- tidiness.

                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
needHpc forall a b. (a -> b) -> a -> b
$
                  forall env.
HasEnvConfig env =>
PackageName -> Path Abs File -> String -> RIO env ()
updateTixFile (Package -> PackageName
packageName Package
package) Path Abs File
tixPath String
testName'
                let announceResult :: Utf8Builder -> RIO env ()
announceResult Utf8Builder
result =
                      Utf8Builder -> RIO env ()
announce forall a b. (a -> b) -> a -> b
$
                           Utf8Builder
"Test suite "
                        forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Text
testName
                        forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" "
                        forall a. Semigroup a => a -> a -> a
<> Utf8Builder
result
                case Maybe ExitCode
mec of
                  Just ExitCode
ExitSuccess -> do
                    Utf8Builder -> RIO env ()
announceResult Utf8Builder
"passed"
                    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall k a. Map k a
Map.empty
                  Maybe ExitCode
Nothing -> do
                    Utf8Builder -> RIO env ()
announceResult Utf8Builder
"timed out"
                    if Bool
expectFailure
                    then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall k a. Map k a
Map.empty
                    else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall k a. k -> a -> Map k a
Map.singleton Text
testName forall a. Maybe a
Nothing
                  Just ExitCode
ec -> do
                    Utf8Builder -> RIO env ()
announceResult Utf8Builder
"failed"
                    if Bool
expectFailure
                    then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall k a. Map k a
Map.empty
                    else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall k a. k -> a -> Map k a
Map.singleton Text
testName (forall a. a -> Maybe a
Just ExitCode
ec)
              else do
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
expectFailure forall a b. (a -> b) -> a -> b
$
                  forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
 ?callStack::CallStack) =>
Utf8Builder -> m ()
logError forall a b. (a -> b) -> a -> b
$
                    forall a. Show a => a -> Utf8Builder
displayShow forall a b. (a -> b) -> a -> b
$ Bool -> String -> String -> String -> BuildException
TestSuiteExeMissing
                      (Package -> BuildType
packageBuildType Package
package forall a. Eq a => a -> a -> Bool
== BuildType
C.Simple)
                      String
exeName
                      (PackageName -> String
packageNameString (Package -> PackageName
packageName Package
package))
                      (Text -> String
T.unpack Text
testName)
                forall (f :: * -> *) a. Applicative f => a -> f a
pure Map Text (Maybe ExitCode)
emptyResult

        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
needHpc forall a b. (a -> b) -> a -> b
$ do
          let testsToRun' :: [Text]
testsToRun' = forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
f [Text]
testsToRun
              f :: Text -> Text
f Text
tName =
                  case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
tName (Package -> Map Text TestSuiteInterface
packageTests Package
package) of
                    Just C.TestSuiteLibV09{} -> Text
tName forall a. Semigroup a => a -> a -> a
<> Text
"Stub"
                    Maybe TestSuiteInterface
_ -> Text
tName
          forall env.
HasEnvConfig env =>
Path Abs Dir -> Package -> [Text] -> RIO env ()
generateHpcReport Path Abs Dir
pkgDir Package
package [Text]
testsToRun'

        ByteString
bs <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
          case OutputType
outputType of
            OTConsole Maybe Utf8Builder
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
""
            OTLogFile Path Abs File
logFile Handle
h -> do
              forall (m :: * -> *). MonadIO m => Handle -> m ()
hClose Handle
h
              String -> IO ByteString
S.readFile forall a b. (a -> b) -> a -> b
$ forall b t. Path b t -> String
toFilePath Path Abs File
logFile

        let succeeded :: Bool
succeeded = forall k a. Map k a -> Bool
Map.null Map Text (Maybe ExitCode)
errs
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
succeeded Bool -> Bool -> Bool
|| Bool
expectFailure) forall a b. (a -> b) -> a -> b
$
          forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ PackageIdentifier
-> Map Text (Maybe ExitCode)
-> Maybe (Path Abs File)
-> ByteString
-> BuildException
TestSuiteFailure
            (Task -> PackageIdentifier
taskProvides Task
task)
            Map Text (Maybe ExitCode)
errs
            (case OutputType
outputType of
               OTLogFile Path Abs File
fp Handle
_ -> forall a. a -> Maybe a
Just Path Abs File
fp
               OTConsole Maybe Utf8Builder
_ -> forall a. Maybe a
Nothing)
            ByteString
bs

        forall env.
HasEnvConfig env =>
Path Abs Dir -> TestStatus -> RIO env ()
setTestStatus Path Abs Dir
pkgDir forall a b. (a -> b) -> a -> b
$ if Bool
succeeded then TestStatus
TSSuccess else TestStatus
TSFailure

-- | Implements running a package's benchmarks.

singleBench :: HasEnvConfig env
            => BenchmarkOpts
            -> [Text]
            -> ActionContext
            -> ExecuteEnv
            -> Task
            -> InstalledMap
            -> RIO env ()
singleBench :: forall env.
HasEnvConfig env =>
BenchmarkOpts
-> [Text]
-> ActionContext
-> ExecuteEnv
-> Task
-> InstalledMap
-> RIO env ()
singleBench BenchmarkOpts
beopts [Text]
benchesToRun ActionContext
ac ExecuteEnv
ee Task
task InstalledMap
installedMap = do
  (Map PackageIdentifier GhcPkgId
allDepsMap, ConfigCache
_cache) <- forall env.
HasEnvConfig env =>
ExecuteEnv
-> Task
-> InstalledMap
-> Bool
-> Bool
-> RIO env (Map PackageIdentifier GhcPkgId, ConfigCache)
getConfigCache ExecuteEnv
ee Task
task InstalledMap
installedMap Bool
False Bool
True
  forall env a.
HasEnvConfig env =>
ActionContext
-> ExecuteEnv
-> Task
-> Map PackageIdentifier GhcPkgId
-> Maybe String
-> (Package
    -> Path Abs File
    -> Path Abs Dir
    -> (KeepOutputOpen -> ExcludeTHLoading -> [String] -> RIO env ())
    -> (Utf8Builder -> RIO env ())
    -> OutputType
    -> RIO env a)
-> RIO env a
withSingleContext ActionContext
ac ExecuteEnv
ee Task
task Map PackageIdentifier GhcPkgId
allDepsMap (forall a. a -> Maybe a
Just String
"bench") forall a b. (a -> b) -> a -> b
$
    \Package
_package Path Abs File
_cabalfp Path Abs Dir
_pkgDir KeepOutputOpen -> ExcludeTHLoading -> [String] -> RIO env ()
cabal Utf8Builder -> RIO env ()
announce OutputType
_outputType -> do
      let args :: [String]
args = forall a b. (a -> b) -> [a] -> [b]
map Text -> String
T.unpack [Text]
benchesToRun forall a. Semigroup a => a -> a -> a
<> forall b a. b -> (a -> b) -> Maybe a -> b
maybe []
                       ((forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"--benchmark-options=" <>))
                       (BenchmarkOpts -> Maybe String
beoAdditionalArgs BenchmarkOpts
beopts)

      Bool
toRun <-
        if BenchmarkOpts -> Bool
beoDisableRun BenchmarkOpts
beopts
          then do
            Utf8Builder -> RIO env ()
announce Utf8Builder
"Benchmark running disabled by --no-run-benchmarks flag."
            forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
          else forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True

      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
toRun forall a b. (a -> b) -> a -> b
$ do
        Utf8Builder -> RIO env ()
announce Utf8Builder
"benchmarks"
        KeepOutputOpen -> ExcludeTHLoading -> [String] -> RIO env ()
cabal KeepOutputOpen
CloseOnException ExcludeTHLoading
KeepTHLoading (String
"bench" forall a. a -> [a] -> [a]
: [String]
args)

data ExcludeTHLoading
  = ExcludeTHLoading
  | KeepTHLoading

data ConvertPathsToAbsolute
  = ConvertPathsToAbsolute
  | KeepPathsAsIs

-- | special marker for expected failures in curator builds, using those we need

-- to keep log handle open as build continues further even after a failure

data KeepOutputOpen
  = KeepOpen
  | CloseOnException
  deriving KeepOutputOpen -> KeepOutputOpen -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: KeepOutputOpen -> KeepOutputOpen -> Bool
$c/= :: KeepOutputOpen -> KeepOutputOpen -> Bool
== :: KeepOutputOpen -> KeepOutputOpen -> Bool
$c== :: KeepOutputOpen -> KeepOutputOpen -> Bool
Eq

-- | Strip Template Haskell "Loading package" lines and making paths absolute.

mungeBuildOutput ::
     forall m. (MonadIO m, MonadUnliftIO m)
  => ExcludeTHLoading       -- ^ exclude TH loading?

  -> ConvertPathsToAbsolute -- ^ convert paths to absolute?

  -> Path Abs Dir           -- ^ package's root directory

  -> ActualCompiler         -- ^ compiler we're building with

  -> ConduitM Text Text m ()
mungeBuildOutput :: forall (m :: * -> *).
(MonadIO m, MonadUnliftIO m) =>
ExcludeTHLoading
-> ConvertPathsToAbsolute
-> Path Abs Dir
-> ActualCompiler
-> ConduitM Text Text m ()
mungeBuildOutput ExcludeTHLoading
excludeTHLoading ConvertPathsToAbsolute
makeAbsolute Path Abs Dir
pkgDir ActualCompiler
compilerVer = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$
  forall (m :: * -> *). Monad m => ConduitT Text Text m ()
CT.lines
  forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) a b. Monad m => (a -> b) -> ConduitT a b m ()
CL.map Text -> Text
stripCR
  forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) a. Monad m => (a -> Bool) -> ConduitT a a m ()
CL.filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
isTHLoading)
  forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT Text Text m ()
filterLinkerWarnings
  forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT Text Text m ()
toAbsolute
 where
  -- | Is this line a Template Haskell "Loading package" line

  -- ByteString

  isTHLoading :: Text -> Bool
  isTHLoading :: Text -> Bool
isTHLoading = case ExcludeTHLoading
excludeTHLoading of
    ExcludeTHLoading
KeepTHLoading    -> forall a b. a -> b -> a
const Bool
False
    ExcludeTHLoading
ExcludeTHLoading -> \Text
bs ->
      Text
"Loading package " Text -> Text -> Bool
`T.isPrefixOf` Text
bs Bool -> Bool -> Bool
&&
      (Text
"done." Text -> Text -> Bool
`T.isSuffixOf` Text
bs Bool -> Bool -> Bool
|| Text
"done.\r" Text -> Text -> Bool
`T.isSuffixOf` Text
bs)

  filterLinkerWarnings :: ConduitM Text Text m ()
  filterLinkerWarnings :: ConduitT Text Text m ()
filterLinkerWarnings
    -- Check for ghc 7.8 since it's the only one prone to producing

    -- linker warnings on Windows x64

    | ActualCompiler -> Version
getGhcVersion ActualCompiler
compilerVer forall a. Ord a => a -> a -> Bool
>= [Int] -> Version
mkVersion [Int
7, Int
8] = ConduitT Text Text m ()
doNothing
    | Bool
otherwise = forall (m :: * -> *) a. Monad m => (a -> Bool) -> ConduitT a a m ()
CL.filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
isLinkerWarning)

  isLinkerWarning :: Text -> Bool
  isLinkerWarning :: Text -> Bool
isLinkerWarning Text
str =
       (  Text
"ghc.exe: warning:" Text -> Text -> Bool
`T.isPrefixOf` Text
str
       Bool -> Bool -> Bool
|| Text
"ghc.EXE: warning:" Text -> Text -> Bool
`T.isPrefixOf` Text
str
       )
    Bool -> Bool -> Bool
&& Text
"is linked instead of __imp_" Text -> Text -> Bool
`T.isInfixOf` Text
str

  -- | Convert GHC error lines with file paths to have absolute file paths

  toAbsolute :: ConduitM Text Text m ()
  toAbsolute :: ConduitT Text Text m ()
toAbsolute = case ConvertPathsToAbsolute
makeAbsolute of
    ConvertPathsToAbsolute
KeepPathsAsIs          -> ConduitT Text Text m ()
doNothing
    ConvertPathsToAbsolute
ConvertPathsToAbsolute -> forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ConduitT a b m ()
CL.mapM Text -> m Text
toAbsolutePath

  toAbsolutePath :: Text -> m Text
  toAbsolutePath :: Text -> m Text
toAbsolutePath Text
bs = do
    let (Text
x, Text
y) = (Char -> Bool) -> Text -> (Text, Text)
T.break (forall a. Eq a => a -> a -> Bool
== Char
':') Text
bs
    Maybe Text
mabs <-
      if Text -> Bool
isValidSuffix Text
y
        then
          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((Char -> Bool) -> Text -> Text
T.takeWhile Char -> Bool
isSpace Text
x <>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b t. Path b t -> String
toFilePath)) forall a b. (a -> b) -> a -> b
$
            forall (m :: * -> *).
MonadIO m =>
Path Abs Dir -> String -> m (Maybe (Path Abs File))
forgivingResolveFile Path Abs Dir
pkgDir (Text -> String
T.unpack forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> Text
T.dropWhile Char -> Bool
isSpace Text
x) forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch`
              \(PathException
_ :: PathException) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
        else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
    case Maybe Text
mabs of
      Maybe Text
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
bs
      Just Text
fp -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text
fp Text -> Text -> Text
`T.append` Text
y

  doNothing :: ConduitM Text Text m ()
  doNothing :: ConduitT Text Text m ()
doNothing = forall (m :: * -> *) i o r.
Monad m =>
(i -> ConduitT i o m r) -> ConduitT i o m ()
awaitForever forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield

  -- | Match the error location format at the end of lines

  isValidSuffix :: Text -> Bool
isValidSuffix = forall a b. Either a b -> Bool
isRight forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Parser a -> Text -> Either String a
parseOnly Parser Text ()
lineCol
  lineCol :: Parser Text ()
lineCol = Char -> Parser Text Char
char Char
':'
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Alternative f => [f a] -> f a
choice
         [ Parser Text String
num forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Parser Text Char
char Char
':' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser Text String
num forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Char -> Parser Text Char
char Char
'-' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser Text String
num) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
         , Char -> Parser Text Char
char Char
'(' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser Text String
num forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Parser Text Char
char Char
',' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser Text String
num forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Text -> Parser Text Text
P.string Text
")-(" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser Text String
num forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
           Char -> Parser Text Char
char Char
',' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser Text String
num forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Parser Text Char
char Char
')' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
         ]
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Parser Text Char
char Char
':'
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
   where
    num :: Parser Text String
num = forall (f :: * -> *) a. Alternative f => f a -> f [a]
some Parser Text Char
digit

-- | Whether to prefix log lines with timestamps.

data PrefixWithTimestamps
  = PrefixWithTimestamps
  | WithoutTimestamps

-- | Write stream of lines to handle, but adding timestamps.

sinkWithTimestamps ::
     MonadIO m
  => PrefixWithTimestamps
  -> Handle
  -> ConduitT ByteString Void m ()
sinkWithTimestamps :: forall (m :: * -> *).
MonadIO m =>
PrefixWithTimestamps -> Handle -> ConduitT ByteString Void m ()
sinkWithTimestamps PrefixWithTimestamps
prefixWithTimestamps Handle
h =
  case PrefixWithTimestamps
prefixWithTimestamps of
    PrefixWithTimestamps
PrefixWithTimestamps ->
      forall (m :: * -> *).
Monad m =>
ConduitT ByteString ByteString m ()
CB.lines forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ConduitT a b m ()
CL.mapM forall {m :: * -> *}. MonadIO m => ByteString -> m ByteString
addTimestamp forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) a b. Monad m => (a -> b) -> ConduitT a b m ()
CL.map (forall a. Semigroup a => a -> a -> a
<> ByteString
"\n") forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) o.
MonadIO m =>
Handle -> ConduitT ByteString o m ()
sinkHandle Handle
h
    PrefixWithTimestamps
WithoutTimestamps -> forall (m :: * -> *) o.
MonadIO m =>
Handle -> ConduitT ByteString o m ()
sinkHandle Handle
h
 where
  addTimestamp :: ByteString -> m ByteString
addTimestamp ByteString
theLine = do
    ZonedTime
now <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ZonedTime
getZonedTime
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (ZonedTime -> ByteString
formatZonedTimeForLog ZonedTime
now forall a. Semigroup a => a -> a -> a
<> ByteString
" " forall a. Semigroup a => a -> a -> a
<> ByteString
theLine)

-- | Format a time in ISO8601 format. We choose ZonedTime over UTCTime

-- because a user expects to see logs in their local time, and would

-- be confused to see UTC time. Stack's debug logs also use the local

-- time zone.

formatZonedTimeForLog :: ZonedTime -> ByteString
formatZonedTimeForLog :: ZonedTime -> ByteString
formatZonedTimeForLog =
  String -> ByteString
S8.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%Y-%m-%dT%H:%M:%S%6Q"

-- | Find the Setup.hs or Setup.lhs in the given directory. If none exists,

-- throw an exception.

getSetupHs :: Path Abs Dir -- ^ project directory

           -> IO (Path Abs File)
getSetupHs :: Path Abs Dir -> IO (Path Abs File)
getSetupHs Path Abs Dir
dir = do
  Bool
exists1 <- forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
fp1
  if Bool
exists1
    then forall (f :: * -> *) a. Applicative f => a -> f a
pure Path Abs File
fp1
    else do
      Bool
exists2 <- forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
fp2
      if Bool
exists2
        then forall (f :: * -> *) a. Applicative f => a -> f a
pure Path Abs File
fp2
        else forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ Path Abs Dir -> BuildException
NoSetupHsFound Path Abs Dir
dir
 where
  fp1 :: Path Abs File
fp1 = Path Abs Dir
dir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFileSetupHs
  fp2 :: Path Abs File
fp2 = Path Abs Dir
dir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFileSetupLhs

-- Do not pass `-hpcdir` as GHC option if the coverage is not enabled.

-- This helps running stack-compiled programs with dynamic interpreters like

-- `hint`. Cfr: https://github.com/commercialhaskell/stack/issues/997

extraBuildOptions :: (HasEnvConfig env, HasRunner env)
                  => WhichCompiler -> BuildOpts -> RIO env [String]
extraBuildOptions :: forall env.
(HasEnvConfig env, HasRunner env) =>
WhichCompiler -> BuildOpts -> RIO env [String]
extraBuildOptions WhichCompiler
wc BuildOpts
bopts = do
  Maybe String
colorOpt <- forall env.
(HasEnvConfig env, HasRunner env) =>
RIO env (Maybe String)
appropriateGhcColorFlag
  let optsFlag :: String
optsFlag = WhichCompiler -> String
compilerOptionsCabalFlag WhichCompiler
wc
      baseOpts :: String
baseOpts = forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (String
" " ++) Maybe String
colorOpt
  if TestOpts -> Bool
toCoverage (BuildOpts -> TestOpts
boptsTestOpts BuildOpts
bopts)
    then do
      String
hpcIndexDir <- forall loc. Path loc Dir -> String
toFilePathNoTrailingSep forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) env.
(MonadThrow m, MonadReader env m, HasEnvConfig env) =>
m (Path Rel Dir)
hpcRelativeDir
      forall (f :: * -> *) a. Applicative f => a -> f a
pure [String
optsFlag, String
"-hpcdir " forall a. [a] -> [a] -> [a]
++ String
hpcIndexDir forall a. [a] -> [a] -> [a]
++ String
baseOpts]
    else
      forall (f :: * -> *) a. Applicative f => a -> f a
pure [String
optsFlag, String
baseOpts]

-- Library, internal and foreign libraries and executable build components.

primaryComponentOptions ::
     Map Text ExecutableBuildStatus
  -> LocalPackage
  -> [String]
primaryComponentOptions :: Map Text ExecutableBuildStatus -> LocalPackage -> [String]
primaryComponentOptions Map Text ExecutableBuildStatus
executableBuildStatuses LocalPackage
lp =
    -- TODO: get this information from target parsing instead,

    -- which will allow users to turn off library building if

    -- desired

    (case Package -> PackageLibraries
packageLibraries Package
package of
      PackageLibraries
NoLibraries -> []
      HasLibraries Set Text
names ->
          forall a b. (a -> b) -> [a] -> [b]
map Text -> String
T.unpack
        forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text
T.append Text
"lib:" (String -> Text
T.pack (PackageName -> String
packageNameString (Package -> PackageName
packageName Package
package)))
        forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (Text -> Text -> Text
T.append Text
"flib:") (forall a. Set a -> [a]
Set.toList Set Text
names)) forall a. [a] -> [a] -> [a]
++
    forall a b. (a -> b) -> [a] -> [b]
map
      (Text -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text
T.append Text
"lib:")
      (forall a. Set a -> [a]
Set.toList forall a b. (a -> b) -> a -> b
$ Package -> Set Text
packageInternalLibraries Package
package) forall a. [a] -> [a] -> [a]
++
    forall a b. (a -> b) -> [a] -> [b]
map
      (Text -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text
T.append Text
"exe:")
      (forall a. Set a -> [a]
Set.toList forall a b. (a -> b) -> a -> b
$ Map Text ExecutableBuildStatus -> LocalPackage -> Set Text
exesToBuild Map Text ExecutableBuildStatus
executableBuildStatuses LocalPackage
lp)
 where
  package :: Package
package = LocalPackage -> Package
lpPackage LocalPackage
lp

-- | History of this function:

--

-- * Normally it would do either all executables or if the user specified

--   requested components, just build them. Afterwards, due to this Cabal bug

--   <https://github.com/haskell/cabal/issues/2780>, we had to make Stack build

--   all executables every time.

--

-- * In <https://github.com/commercialhaskell/stack/issues/3229> this was

--   flagged up as very undesirable behavior on a large project, hence the

--   behavior below that we build all executables once (modulo success), and

--   thereafter pay attention to user-wanted components.

--

exesToBuild :: Map Text ExecutableBuildStatus -> LocalPackage -> Set Text
exesToBuild :: Map Text ExecutableBuildStatus -> LocalPackage -> Set Text
exesToBuild Map Text ExecutableBuildStatus
executableBuildStatuses LocalPackage
lp =
  if forall k. Map k ExecutableBuildStatus -> Bool
cabalIsSatisfied Map Text ExecutableBuildStatus
executableBuildStatuses Bool -> Bool -> Bool
&& LocalPackage -> Bool
lpWanted LocalPackage
lp
    then Set NamedComponent -> Set Text
exeComponents (LocalPackage -> Set NamedComponent
lpComponents LocalPackage
lp)
    else Package -> Set Text
packageExes (LocalPackage -> Package
lpPackage LocalPackage
lp)

-- | Do the current executables satisfy Cabal's bugged out requirements?

cabalIsSatisfied :: Map k ExecutableBuildStatus -> Bool
cabalIsSatisfied :: forall k. Map k ExecutableBuildStatus -> Bool
cabalIsSatisfied = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall a. Eq a => a -> a -> Bool
== ExecutableBuildStatus
ExecutableBuilt) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [a]
Map.elems

-- Test-suite and benchmark build components.

finalComponentOptions :: LocalPackage -> [String]
finalComponentOptions :: LocalPackage -> [String]
finalComponentOptions LocalPackage
lp =
  forall a b. (a -> b) -> [a] -> [b]
map (Text -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamedComponent -> Text
renderComponent) forall a b. (a -> b) -> a -> b
$
  forall a. Set a -> [a]
Set.toList forall a b. (a -> b) -> a -> b
$
  forall a. (a -> Bool) -> Set a -> Set a
Set.filter (\NamedComponent
c -> NamedComponent -> Bool
isCTest NamedComponent
c Bool -> Bool -> Bool
|| NamedComponent -> Bool
isCBench NamedComponent
c) (LocalPackage -> Set NamedComponent
lpComponents LocalPackage
lp)

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

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

expectTestFailure :: PackageName -> Maybe Curator -> Bool
expectTestFailure :: PackageName -> Maybe Curator -> Bool
expectTestFailure PackageName
pname =
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (forall a. Ord a => a -> Set a -> Bool
Set.member PackageName
pname forall b c a. (b -> c) -> (a -> b) -> a -> c
. Curator -> Set PackageName
curatorExpectTestFailure)

expectBenchmarkFailure :: PackageName -> Maybe Curator -> Bool
expectBenchmarkFailure :: PackageName -> Maybe Curator -> Bool
expectBenchmarkFailure PackageName
pname =
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (forall a. Ord a => a -> Set a -> Bool
Set.member PackageName
pname forall b c a. (b -> c) -> (a -> b) -> a -> c
. Curator -> Set PackageName
curatorExpectBenchmarkFailure)

fulfillCuratorBuildExpectations ::
     (HasCallStack, HasTerm env)
  => PackageName
  -> Maybe Curator
  -> Bool
  -> Bool
  -> b
  -> RIO env b
  -> RIO env b
fulfillCuratorBuildExpectations :: forall env b.
(?callStack::CallStack, HasTerm env) =>
PackageName
-> Maybe Curator -> Bool -> Bool -> b -> RIO env b -> RIO env b
fulfillCuratorBuildExpectations PackageName
pname Maybe Curator
mcurator Bool
enableTests Bool
_ b
defValue RIO env b
action
  | Bool
enableTests Bool -> Bool -> Bool
&& PackageName -> Maybe Curator -> Bool
expectTestFailure PackageName
pname Maybe Curator
mcurator = do
      Either SomeException b
eres <- forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny RIO env b
action
      case Either SomeException b
eres of
        Right b
res -> do
          forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
 MonadIO m) =>
[StyleDoc] -> m ()
prettyWarnL
            [ Style -> StyleDoc -> StyleDoc
style Style
Current (forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ PackageName -> String
packageNameString PackageName
pname) forall a. Semigroup a => a -> a -> a
<> StyleDoc
":"
            , String -> StyleDoc
flow String
"unexpected test build success."
            ]
          forall (f :: * -> *) a. Applicative f => a -> f a
pure b
res
        Left SomeException
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure b
defValue
fulfillCuratorBuildExpectations PackageName
pname Maybe Curator
mcurator Bool
_ Bool
enableBench b
defValue RIO env b
action
  | Bool
enableBench Bool -> Bool -> Bool
&& PackageName -> Maybe Curator -> Bool
expectBenchmarkFailure PackageName
pname Maybe Curator
mcurator = do
      Either SomeException b
eres <- forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny RIO env b
action
      case Either SomeException b
eres of
        Right b
res -> do
          forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
 MonadIO m) =>
[StyleDoc] -> m ()
prettyWarnL
            [ Style -> StyleDoc -> StyleDoc
style Style
Current (forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ PackageName -> String
packageNameString PackageName
pname) forall a. Semigroup a => a -> a -> a
<> StyleDoc
":"
            , String -> StyleDoc
flow String
"unexpected benchmark build success."
            ]
          forall (f :: * -> *) a. Applicative f => a -> f a
pure b
res
        Left SomeException
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure b
defValue
fulfillCuratorBuildExpectations PackageName
_ Maybe Curator
_ Bool
_ Bool
_ b
_ RIO env b
action = RIO env b
action