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

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

Perform a build.
-}

module Stack.Build.ExecutePackage
  ( singleBuild
  , singleTest
  , singleBench
  ) where

import           Control.Concurrent.Execute
                   ( ActionContext (..), ActionId (..) )
import           Control.Monad.Extra ( whenJust )
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as BL
import           Conduit ( runConduitRes )
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 qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified Data.Text as T
import qualified Distribution.PackageDescription as C
import           Distribution.System ( OS (..), Platform (..) )
import qualified Distribution.Text as C
import           Distribution.Types.MungedPackageName
                   ( encodeCompatPackageName )
import           Path
                   ( (</>), addExtension, filename, isProperPrefixOf, parent
                   , parseRelDir, parseRelFile, stripProperPrefix
                   )
import           Path.Extra ( toFilePathNoTrailingSep )
import           Path.IO
                   ( copyFile, doesFileExist, ensureDir, ignoringAbsence
                   , removeDirRecur, removeFile
                   )
import           RIO.NonEmpty ( nonEmpty )
import           RIO.Process
                   ( HasProcessContext, byteStringInput, findExecutable
                   , getStderr, getStdout, inherit, modifyEnvVars, proc
                   , 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.ExecuteEnv
                   ( ExcludeTHLoading (..), ExecuteEnv (..), KeepOutputOpen (..)
                   , OutputType (..), withSingleContext
                   )
import           Stack.Build.Source ( addUnlistedToBuildCache )
import           Stack.Config.ConfigureScript ( ensureConfigureScript )
import           Stack.ConfigureOpts
                   ( configureOptsFromBase, renderConfigureOpts )
import           Stack.Constants
                   ( bindirSuffix, compilerOptionsCabalFlag, testGhcEnvRelFile )
import           Stack.Constants.Config
                   ( distDirFromDir, distRelativeDir, hpcDirFromDir
                   , hpcRelativeDir, setupConfigFromDir
                   )
import           Stack.Coverage ( generateHpcReport, updateTixFile )
import           Stack.GhcPkg ( ghcPkg, ghcPkgPathEnvVar, unregisterGhcPkgIds )
import           Stack.Package
                   ( buildLogPath, buildableExes, buildableSubLibs
                   , hasBuildableMainLibrary
                   )
import           Stack.PackageDump ( conduitDumpPackage, ghcPkgDescribe )
import           Stack.Prelude
import           Stack.Types.Build.Exception
                   ( BuildException (..), BuildPrettyException (..) )
import           Stack.Types.BuildConfig
                   ( BuildConfig (..), HasBuildConfig (..), configFileRootL )
import           Stack.Types.BuildOpts
                   ( BenchmarkOpts (..), BuildOpts (..), HaddockOpts (..)
                   , TestOpts (..)
                   )
import           Stack.Types.BuildOptsCLI ( BuildOptsCLI (..) )
import           Stack.Types.Cache
                   ( ConfigCache (..), PrecompiledCache (..) )
import qualified Stack.Types.Cache as ConfigCache ( ConfigCache (..) )
import           Stack.Types.CompCollection
                   ( collectionKeyValueList, collectionLookup
                   , foldComponentToAnotherCollection, getBuildableListText
                   )
import           Stack.Types.Compiler
                   ( WhichCompiler (..), whichCompiler, whichCompilerL )
import           Stack.Types.CompilerPaths
                   ( CompilerPaths (..), GhcPkgExe (..), HasCompiler (..)
                   , cpWhich, getGhcPkgExe
                   )
import qualified Stack.Types.Component as Component
import           Stack.Types.ComponentUtils
                   ( StackUnqualCompName, toCabalName, unqualCompToString
                   , unqualCompToText
                   )
import           Stack.Types.Config ( Config (..), HasConfig (..) )
import           Stack.Types.ConfigureOpts
                   ( BaseConfigOpts (..), ConfigureOpts (..) )
import           Stack.Types.Curator ( Curator (..) )
import           Stack.Types.DumpPackage ( DumpPackage (..) )
import           Stack.Types.EnvConfig
                   ( EnvConfig (..), HasEnvConfig (..), actualCompilerVersionL
                   , appropriateGhcColorFlag
                   )
import           Stack.Types.EnvSettings ( EnvSettings (..) )
import           Stack.Types.GhcPkgId ( GhcPkgId, ghcPkgIdToText )
import           Stack.Types.GlobalOpts ( GlobalOpts (..) )
import           Stack.Types.Installed
                   ( InstallLocation (..), Installed (..), InstalledMap
                   , InstalledLibraryInfo (..)
                   )
import           Stack.Types.IsMutable ( IsMutable (..) )
import           Stack.Types.NamedComponent
                   ( NamedComponent, exeComponents, isCBench, isCTest
                   , renderComponent
                   )
import           Stack.Types.Package
                   ( LocalPackage (..), Package (..), installedPackageToGhcPkgId
                   , runMemoizedWith, simpleInstalledLib
                   , toCabalMungedPackageName
                   )
import           Stack.Types.PackageFile ( PackageWarning (..) )
import           Stack.Types.Plan
                   ( Task (..), TaskConfigOpts (..), TaskType (..), taskIsTarget
                   , taskLocation, taskProvides, taskTargetIsMutable
                   , taskTypePackageIdentifier
                   )
import           Stack.Types.Runner ( HasRunner, globalOptsL )
import           Stack.Types.SourceMap ( SourceMap (..) )
import           System.IO.Error ( isDoesNotExistError )
import           System.PosixCompat.Files
                   ( createLink, getFileStatus, modificationTime )
import           System.Random ( randomIO )

-- | Generate the t'ConfigCache' value.

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
ee Task
task 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 Task
task.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] [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++
            [ Text
"--enable-benchmarks" | Bool
enableBench]
          TTRemotePackage{} -> []
  idMap <- IO (Map PackageIdentifier Installed)
-> RIO env (Map PackageIdentifier Installed)
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Map PackageIdentifier Installed)
 -> RIO env (Map PackageIdentifier Installed))
-> IO (Map PackageIdentifier Installed)
-> RIO env (Map PackageIdentifier Installed)
forall a b. (a -> b) -> a -> b
$ TVar (Map PackageIdentifier Installed)
-> IO (Map PackageIdentifier Installed)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO ExecuteEnv
ee.ghcPkgIds
  let getMissing PackageIdentifier
ident =
        case PackageIdentifier
-> Map PackageIdentifier Installed -> Maybe Installed
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.

              | ExecuteEnv
ee.buildOptsCLI.initialBuildSteps Bool -> Bool -> Bool
&& Task -> Bool
taskIsTarget Task
task
              , Just (InstallLocation
_, Installed
installed) <- PackageName -> InstalledMap -> Maybe (InstallLocation, Installed)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (PackageIdentifier -> PackageName
pkgName PackageIdentifier
ident) InstalledMap
installedMap
                  -> Map PackageIdentifier GhcPkgId
-> RIO env (Map PackageIdentifier GhcPkgId)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map PackageIdentifier GhcPkgId
 -> RIO env (Map PackageIdentifier GhcPkgId))
-> Map PackageIdentifier GhcPkgId
-> RIO env (Map PackageIdentifier GhcPkgId)
forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> Installed -> Map PackageIdentifier GhcPkgId
installedPackageToGhcPkgId PackageIdentifier
ident Installed
installed
          Just Installed
installed -> Map PackageIdentifier GhcPkgId
-> RIO env (Map PackageIdentifier GhcPkgId)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map PackageIdentifier GhcPkgId
 -> RIO env (Map PackageIdentifier GhcPkgId))
-> Map PackageIdentifier GhcPkgId
-> RIO env (Map PackageIdentifier GhcPkgId)
forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> Installed -> Map PackageIdentifier GhcPkgId
installedPackageToGhcPkgId PackageIdentifier
ident Installed
installed
          Maybe Installed
_ -> BuildException -> RIO env (Map PackageIdentifier GhcPkgId)
forall e a. (?callStack::CallStack, Exception e) => e -> RIO env a
forall (m :: * -> *) e a.
(MonadThrow m, ?callStack::CallStack, Exception e) =>
e -> m a
throwM (BuildException -> RIO env (Map PackageIdentifier GhcPkgId))
-> BuildException -> RIO env (Map PackageIdentifier GhcPkgId)
forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> BuildException
PackageIdMissingBug PackageIdentifier
ident
  let cOpts = Task
task.configOpts
  missingMapList <- traverse getMissing $ toList cOpts.missing
  let pcOpts = TaskConfigOpts
cOpts.pkgConfigOpts
      missing' = [Map PackageIdentifier GhcPkgId] -> Map PackageIdentifier GhcPkgId
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions [Map PackageIdentifier GhcPkgId]
missingMapList
      -- Historically the leftermost was missing' for union preference in case of

      -- collision for the return here. But unifying things with configureOpts

      -- where it was the opposite resulted in this. It doesn't seem to make any

      -- difference anyway.

      allDepsMap = Map PackageIdentifier GhcPkgId
-> Map PackageIdentifier GhcPkgId -> Map PackageIdentifier GhcPkgId
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map PackageIdentifier GhcPkgId
missing' Task
task.present
      configureOpts' = EnvConfig
-> BaseConfigOpts
-> Map PackageIdentifier GhcPkgId
-> Bool
-> IsMutable
-> PackageConfigureOpts
-> ConfigureOpts
configureOptsFromBase
        TaskConfigOpts
cOpts.envConfig
        TaskConfigOpts
cOpts.baseConfigOpts
        Map PackageIdentifier GhcPkgId
allDepsMap
        TaskConfigOpts
cOpts.isLocalNonExtraDep
        TaskConfigOpts
cOpts.isMutable
        PackageConfigureOpts
pcOpts
      configureOpts = ConfigureOpts
configureOpts'
        { nonPathRelated = configureOpts'.nonPathRelated ++ map T.unpack extra }
      deps = [GhcPkgId] -> Set GhcPkgId
forall a. Ord a => [a] -> Set a
Set.fromList ([GhcPkgId] -> Set GhcPkgId) -> [GhcPkgId] -> Set GhcPkgId
forall a b. (a -> b) -> a -> b
$ Map PackageIdentifier GhcPkgId -> [GhcPkgId]
forall k a. Map k a -> [a]
Map.elems Map PackageIdentifier GhcPkgId
missing' [GhcPkgId] -> [GhcPkgId] -> [GhcPkgId]
forall a. [a] -> [a] -> [a]
++ Map PackageIdentifier GhcPkgId -> [GhcPkgId]
forall k a. Map k a -> [a]
Map.elems Task
task.present
      components = case Task
task.taskType of
        TTLocalMutable LocalPackage
lp ->
          (NamedComponent -> ByteString)
-> Set NamedComponent -> Set ByteString
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (Text -> ByteString
encodeUtf8 (Text -> ByteString)
-> (NamedComponent -> Text) -> NamedComponent -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamedComponent -> Text
renderComponent) LocalPackage
lp.components
        TTRemotePackage{} -> Set ByteString
forall a. Set a
Set.empty
      cache = ConfigCache
        { ConfigureOpts
configureOpts :: ConfigureOpts
configureOpts :: ConfigureOpts
configureOpts
        , Set GhcPkgId
deps :: Set GhcPkgId
deps :: Set GhcPkgId
deps
        , Set ByteString
components :: Set ByteString
components :: Set ByteString
components
        , buildHaddocks :: Bool
buildHaddocks = Task
task.buildHaddocks
        , pkgSrc :: CachePkgSrc
pkgSrc = Task
task.cachePkgSrc
        , pathEnvVar :: Text
pathEnvVar = ExecuteEnv
ee.pathEnvVar
        }
  pure (allDepsMap, cache)

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

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

  -> Path Abs Dir
     -- ^ package directory

  -> BuildOpts
  -> 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
-> BuildOpts
-> RIO env ()
-> (ExcludeTHLoading -> [[Char]] -> RIO env ())
-> Path Abs File
-> Task
-> RIO env Bool
ensureConfig ConfigCache
newConfigCache Path Abs Dir
pkgDir BuildOpts
buildOpts RIO env ()
announce ExcludeTHLoading -> [[Char]] -> RIO env ()
cabal Path Abs File
cabalFP Task
task = do
  newCabalMod <-
    IO CTime -> RIO env CTime
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO CTime -> RIO env CTime) -> IO CTime -> RIO env CTime
forall a b. (a -> b) -> a -> b
$ FileStatus -> CTime
modificationTime (FileStatus -> CTime) -> IO FileStatus -> IO CTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO FileStatus
getFileStatus (Path Abs File -> [Char]
forall b t. Path b t -> [Char]
toFilePath Path Abs File
cabalFP)
  setupConfigfp <- setupConfigFromDir pkgDir
  let getNewSetupConfigMod =
        IO (Maybe CTime) -> RIO env (Maybe CTime)
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe CTime) -> RIO env (Maybe CTime))
-> IO (Maybe CTime) -> RIO env (Maybe CTime)
forall a b. (a -> b) -> a -> b
$ (() -> Maybe CTime)
-> (FileStatus -> Maybe CTime)
-> Either () FileStatus
-> Maybe CTime
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe CTime -> () -> Maybe CTime
forall a b. a -> b -> a
const Maybe CTime
forall a. Maybe a
Nothing) (CTime -> Maybe CTime
forall a. a -> Maybe a
Just (CTime -> Maybe CTime)
-> (FileStatus -> CTime) -> FileStatus -> Maybe CTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileStatus -> CTime
modificationTime) (Either () FileStatus -> Maybe CTime)
-> IO (Either () FileStatus) -> IO (Maybe CTime)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        (IOError -> Maybe ()) -> IO FileStatus -> IO (Either () FileStatus)
forall (m :: * -> *) e b a.
(MonadUnliftIO m, Exception e) =>
(e -> Maybe b) -> m a -> m (Either b a)
tryJust
          (Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> (IOError -> Bool) -> IOError -> Maybe ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOError -> Bool
isDoesNotExistError)
          ([Char] -> IO FileStatus
getFileStatus (Path Abs File -> [Char]
forall b t. Path b t -> [Char]
toFilePath Path Abs File
setupConfigfp))
  newSetupConfigMod <- getNewSetupConfigMod
  newConfigFileRoot <- S8.pack . toFilePath <$> view configFileRootL
  needConfig <-
    if buildOpts.reconfigure
          -- The reason 'taskAnyMissing' is necessary is a bug in Cabal. See:

          -- <https://github.com/haskell/cabal/issues/4728#issuecomment-337937673>.

          -- The problem is that Cabal may end up generating the same package ID

          -- for a dependency, even if the ABI has changed. As a result, without

          -- check, Stack would think that a reconfigure is unnecessary, when in

          -- fact we _do_ need to reconfigure. The details here suck. We really

          -- need proper hashes for package identifiers.

      then pure True
      else do
        -- We can ignore the components field of the Cabal configuration cache,

        -- because it is only used to inform 'construct plan' that we need to

        -- plan to build additional components. These components don't affect

        -- the Cabal configuration for the package.

        let ignoreComponents :: ConfigCache -> ConfigCache
            ignoreComponents ConfigCache
cc = ConfigCache
cc { ConfigCache.components = Set.empty }
        -- Determine the old and new Cabal configuration for the package

        -- directory, to determine if we need to reconfigure.

        mOldConfigCache <- tryGetConfigCache pkgDir

        mOldCabalMod <- tryGetCabalMod pkgDir

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

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

        mOldSetupConfigMod <- tryGetSetupConfigMod pkgDir
        mOldProjectRoot <- tryGetPackageProjectRoot pkgDir

        pure $
                fmap ignoreComponents mOldConfigCache
             /= Just (ignoreComponents newConfigCache)
          || mOldCabalMod /= Just newCabalMod
          || mOldSetupConfigMod /= newSetupConfigMod
          || mOldProjectRoot /= Just newConfigFileRoot

  when task.buildTypeConfig $
    -- 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 pkgDir

  when needConfig $ do
    deleteCaches pkgDir
    announce
    cp <- view compilerPathsL
    let (GhcPkgExe pkgPath) = cp.pkg
    let programNames =
          case CompilerPaths -> WhichCompiler
forall env (m :: * -> *).
(MonadReader env m, HasCompiler env) =>
m WhichCompiler
cpWhich CompilerPaths
cp of
            WhichCompiler
Ghc ->
              [ ([Char]
"ghc", Path Abs File -> [Char]
forall b t. Path b t -> [Char]
toFilePath CompilerPaths
cp.compiler)
              , ([Char]
"ghc-pkg", Path Abs File -> [Char]
forall b t. Path b t -> [Char]
toFilePath Path Abs File
pkgPath)
              ]
    exes <- forM programNames $ \([Char]
name, [Char]
file) ->
      [Char] -> RIO env (Either ProcessException [Char])
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasProcessContext env) =>
[Char] -> m (Either ProcessException [Char])
findExecutable [Char]
file RIO env (Either ProcessException [Char])
-> (Either ProcessException [Char] -> [[Char]]) -> RIO env [[Char]]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
        Left ProcessException
_ -> []
        Right [Char]
x -> [Char] -> [[Char]]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> [[Char]]) -> [Char] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Char]
"--with-", [Char]
name, [Char]
"=", [Char]
x]
    let allOpts =
             [[[Char]]] -> [[Char]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[[Char]]]
exes
          [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> ConfigureOpts -> [[Char]]
renderConfigureOpts ConfigCache
newConfigCache.configureOpts
    -- Configure cabal with arguments determined by

    -- Stack.Types.Build.configureOpts

    cabal KeepTHLoading $ "configure" : allOpts
    -- 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 of
      TTLocalMutable{} -> Path Abs Dir -> ConfigCache -> RIO env ()
forall env.
HasEnvConfig env =>
Path Abs Dir -> ConfigCache -> RIO env ()
writeConfigCache Path Abs Dir
pkgDir ConfigCache
newConfigCache
      TTRemotePackage{} -> () -> RIO env ()
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    writeCabalMod pkgDir 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.

    getNewSetupConfigMod >>= writeSetupConfigMod pkgDir
    writePackageProjectRoot pkgDir newConfigFileRoot
  pure needConfig

-- | Make a padded prefix for log messages

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

announceTask ::
     HasLogFunc env
  => ExecuteEnv
  -> TaskType
  -> Utf8Builder
  -> RIO env ()
announceTask :: forall env.
HasLogFunc env =>
ExecuteEnv -> TaskType -> Utf8Builder -> RIO env ()
announceTask ExecuteEnv
ee TaskType
taskType Utf8Builder
action = Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
 ?callStack::CallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$
     [Char] -> Utf8Builder
forall a. IsString a => [Char] -> a
fromString
       (ExecuteEnv -> PackageName -> [Char]
packageNamePrefix ExecuteEnv
ee (PackageIdentifier -> PackageName
pkgName (TaskType -> PackageIdentifier
taskTypePackageIdentifier TaskType
taskType)))
  Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
action

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

-- 'Control.Concurrent.Execute.ATBuild' and

-- 'Control.Concurrent.Execute.ATBuildFinal' tasks. The latter is a task for

-- building a package's benchmarks and test-suites.

--

-- 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

--   'Stack.Build.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
    ActionContext
ac
    ExecuteEnv
ee
    Task
task
    InstalledMap
installedMap
    Bool
isFinalBuild
  = do
    (allDepsMap, cache) <-
      ExecuteEnv
-> Task
-> InstalledMap
-> Bool
-> Bool
-> RIO env (Map PackageIdentifier GhcPkgId, ConfigCache)
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
    let bcoSnapInstallRoot = ExecuteEnv
ee.baseConfigOpts.snapInstallRoot
    mprecompiled <- getPrecompiled cache task.taskType bcoSnapInstallRoot
    minstalled <-
      case mprecompiled of
        Just PrecompiledCache Abs
precompiled -> ExecuteEnv
-> Task
-> PackageIdentifier
-> PrecompiledCache Abs
-> RIO env (Maybe Installed)
forall env b0.
(HasLogFunc env, HasCompiler env, HasTerm env,
 HasProcessContext env, HasEnvConfig env) =>
ExecuteEnv
-> Task
-> PackageIdentifier
-> PrecompiledCache b0
-> RIO env (Maybe Installed)
copyPreCompiled ExecuteEnv
ee Task
task PackageIdentifier
pkgId PrecompiledCache Abs
precompiled
        Maybe (PrecompiledCache Abs)
Nothing -> do
          curator <- Getting (Maybe Curator) env (Maybe Curator)
-> RIO env (Maybe Curator)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting (Maybe Curator) env (Maybe Curator)
 -> RIO env (Maybe Curator))
-> Getting (Maybe Curator) env (Maybe Curator)
-> RIO env (Maybe Curator)
forall a b. (a -> b) -> a -> b
$ (BuildConfig -> Const (Maybe Curator) BuildConfig)
-> env -> Const (Maybe Curator) env
forall env. HasBuildConfig env => Lens' env BuildConfig
Lens' env BuildConfig
buildConfigL ((BuildConfig -> Const (Maybe Curator) BuildConfig)
 -> env -> Const (Maybe Curator) env)
-> ((Maybe Curator -> Const (Maybe Curator) (Maybe Curator))
    -> BuildConfig -> Const (Maybe Curator) BuildConfig)
-> Getting (Maybe Curator) env (Maybe Curator)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BuildConfig -> Maybe Curator)
-> SimpleGetter BuildConfig (Maybe Curator)
forall s a. (s -> a) -> SimpleGetter s a
to (.curator)
          realConfigAndBuild
            ac
            ee
            task
            installedMap
            (enableTests, enableBenchmarks)
            (isFinalBuild, buildingFinals)
            cache
            curator
            allDepsMap
    whenJust minstalled $ \Installed
installed -> do
      Installed -> ConfigCache -> RIO env ()
forall env.
HasEnvConfig env =>
Installed -> ConfigCache -> RIO env ()
writeFlagCache Installed
installed ConfigCache
cache
      IO () -> RIO env ()
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO env ()) -> IO () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar (Map PackageIdentifier Installed)
-> (Map PackageIdentifier Installed
    -> Map PackageIdentifier Installed)
-> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar ExecuteEnv
ee.ghcPkgIds ((Map PackageIdentifier Installed
  -> Map PackageIdentifier Installed)
 -> STM ())
-> (Map PackageIdentifier Installed
    -> Map PackageIdentifier Installed)
-> STM ()
forall a b. (a -> b) -> a -> b
$ PackageIdentifier
-> Installed
-> Map PackageIdentifier Installed
-> Map PackageIdentifier Installed
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert PackageIdentifier
pkgId Installed
installed
 where
  pkgId :: PackageIdentifier
pkgId = Task -> PackageIdentifier
taskProvides Task
task
  buildingFinals :: Bool
buildingFinals = Bool
isFinalBuild Bool -> Bool -> Bool
|| Task
task.allInOne
  enableTests :: Bool
enableTests = Bool
buildingFinals Bool -> Bool -> Bool
&& (NamedComponent -> Bool) -> Set NamedComponent -> 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
&& (NamedComponent -> Bool) -> Set NamedComponent -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any NamedComponent -> Bool
isCBench (Task -> Set NamedComponent
taskComponents Task
task)

realConfigAndBuild ::
     forall env a. HasEnvConfig env
  => ActionContext
  -> ExecuteEnv
  -> Task
  -> Map PackageName (a, Installed)
  -> (Bool, Bool)
     -- ^ (enableTests, enableBenchmarks)

  -> (Bool, Bool)
     -- ^ (isFinalBuild, buildingFinals)

  -> ConfigCache
  -> Maybe Curator
  -> Map PackageIdentifier GhcPkgId
  -> RIO env (Maybe Installed)
realConfigAndBuild :: forall env a.
HasEnvConfig env =>
ActionContext
-> ExecuteEnv
-> Task
-> Map PackageName (a, Installed)
-> (Bool, Bool)
-> (Bool, Bool)
-> ConfigCache
-> Maybe Curator
-> Map PackageIdentifier GhcPkgId
-> RIO env (Maybe Installed)
realConfigAndBuild
    ActionContext
ac
    ExecuteEnv
ee
    Task
task
    Map PackageName (a, Installed)
installedMap
    (Bool
enableTests, Bool
enableBenchmarks)
    (Bool
isFinalBuild, Bool
buildingFinals)
    ConfigCache
cache
    Maybe Curator
mcurator0
    Map PackageIdentifier GhcPkgId
allDepsMap
  = ActionContext
-> ExecuteEnv
-> TaskType
-> Map PackageIdentifier GhcPkgId
-> Maybe [Char]
-> (Package
    -> Path Abs File
    -> Path Abs Dir
    -> (KeepOutputOpen -> ExcludeTHLoading -> [[Char]] -> RIO env ())
    -> (Utf8Builder -> RIO env ())
    -> OutputType
    -> RIO env (Maybe Installed))
-> RIO env (Maybe Installed)
forall env a.
HasEnvConfig env =>
ActionContext
-> ExecuteEnv
-> TaskType
-> Map PackageIdentifier GhcPkgId
-> Maybe [Char]
-> (Package
    -> Path Abs File
    -> Path Abs Dir
    -> (KeepOutputOpen -> ExcludeTHLoading -> [[Char]] -> RIO env ())
    -> (Utf8Builder -> RIO env ())
    -> OutputType
    -> RIO env a)
-> RIO env a
withSingleContext ActionContext
ac ExecuteEnv
ee Task
task.taskType Map PackageIdentifier GhcPkgId
allDepsMap Maybe [Char]
forall a. Maybe a
Nothing ((Package
  -> Path Abs File
  -> Path Abs Dir
  -> (KeepOutputOpen -> ExcludeTHLoading -> [[Char]] -> RIO env ())
  -> (Utf8Builder -> RIO env ())
  -> OutputType
  -> RIO env (Maybe Installed))
 -> RIO env (Maybe Installed))
-> (Package
    -> Path Abs File
    -> Path Abs Dir
    -> (KeepOutputOpen -> ExcludeTHLoading -> [[Char]] -> RIO env ())
    -> (Utf8Builder -> RIO env ())
    -> OutputType
    -> RIO env (Maybe Installed))
-> RIO env (Maybe Installed)
forall a b. (a -> b) -> a -> b
$
      \Package
package Path Abs File
cabalFP Path Abs Dir
pkgDir KeepOutputOpen -> ExcludeTHLoading -> [[Char]] -> RIO env ()
cabal0 Utf8Builder -> RIO env ()
announce OutputType
_outputType -> do
        let cabal :: ExcludeTHLoading -> [[Char]] -> RIO env ()
cabal = KeepOutputOpen -> ExcludeTHLoading -> [[Char]] -> RIO env ()
cabal0 KeepOutputOpen
CloseOnException
        _neededConfig <-
          ConfigCache
-> Path Abs Dir
-> BuildOpts
-> RIO env ()
-> (ExcludeTHLoading -> [[Char]] -> RIO env ())
-> Path Abs File
-> Task
-> RIO env Bool
forall env.
HasEnvConfig env =>
ConfigCache
-> Path Abs Dir
-> BuildOpts
-> RIO env ()
-> (ExcludeTHLoading -> [[Char]] -> RIO env ())
-> Path Abs File
-> Task
-> RIO env Bool
ensureConfig
            ConfigCache
cache
            Path Abs Dir
pkgDir
            ExecuteEnv
ee.buildOpts
            (Utf8Builder -> RIO env ()
announce (Utf8Builder
"configure" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Text
annSuffix))
            ExcludeTHLoading -> [[Char]] -> RIO env ()
cabal
            Path Abs File
cabalFP
            Task
task
        let installedMapHasThisPkg :: Bool
            installedMapHasThisPkg =
              case PackageName
-> Map PackageName (a, Installed) -> Maybe (a, Installed)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Package
package.name Map PackageName (a, Installed)
installedMap of
                Just (a
_, Library PackageIdentifier
ident InstalledLibraryInfo
_) -> PackageIdentifier
ident PackageIdentifier -> PackageIdentifier -> Bool
forall a. Eq a => a -> a -> Bool
== PackageIdentifier
pkgId
                Just (a
_, Executable PackageIdentifier
_) -> Bool
True
                Maybe (a, Installed)
_ -> Bool
False

        case ( ee.buildOptsCLI.onlyConfigure
             , ee.buildOptsCLI.initialBuildSteps && taskIsTarget 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
_) | [Action] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ActionContext
ac.downstream -> Maybe Installed -> RIO env (Maybe Installed)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Installed
forall a. Maybe a
Nothing
          (Bool
_, Bool
True) | [Action] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ActionContext
ac.downstream Bool -> Bool -> Bool
|| Bool
installedMapHasThisPkg -> do
            (ExcludeTHLoading -> [[Char]] -> RIO env ())
-> (Utf8Builder -> RIO env ()) -> RIO env ()
initialBuildSteps ExcludeTHLoading -> [[Char]] -> RIO env ()
cabal Utf8Builder -> RIO env ()
announce
            Maybe Installed -> RIO env (Maybe Installed)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Installed
forall a. Maybe a
Nothing
          (Bool, Bool)
_ -> PackageName
-> Maybe Curator
-> Bool
-> Bool
-> Maybe Installed
-> RIO env (Maybe Installed)
-> RIO env (Maybe Installed)
forall env b.
(?callStack::CallStack, HasTerm env) =>
PackageName
-> Maybe Curator -> Bool -> Bool -> b -> RIO env b -> RIO env b
fulfillCuratorBuildExpectations
                 PackageName
pname
                 Maybe Curator
mcurator0
                 Bool
enableTests
                 Bool
enableBenchmarks
                 Maybe Installed
forall a. Maybe a
Nothing
                 (Installed -> Maybe Installed
forall a. a -> Maybe a
Just (Installed -> Maybe Installed)
-> RIO env Installed -> RIO env (Maybe Installed)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Package
-> Path Abs Dir
-> (KeepOutputOpen -> ExcludeTHLoading -> [[Char]] -> RIO env ())
-> (Utf8Builder -> RIO env ())
-> RIO env Installed
realBuild Package
package Path Abs Dir
pkgDir KeepOutputOpen -> ExcludeTHLoading -> [[Char]] -> RIO env ()
cabal0 Utf8Builder -> RIO env ()
announce)
 where
  pkgId :: PackageIdentifier
pkgId = Task -> PackageIdentifier
taskProvides Task
task
  PackageIdentifier PackageName
pname Version
_ = PackageIdentifier
pkgId
  doHaddock :: Maybe Curator -> Bool
doHaddock Maybe Curator
curator =
       Task
task.buildHaddocks
    Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
isFinalBuild
       -- Special help for the curator tool to avoid haddocks that are known

       -- to fail

    Bool -> Bool -> Bool
&& Bool -> (Curator -> Bool) -> Maybe Curator -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (PackageName -> Set PackageName -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.notMember PackageName
pname (Set PackageName -> Bool)
-> (Curator -> Set PackageName) -> Curator -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.skipHaddock)) Maybe Curator
curator

  annSuffix :: Text
annSuffix = if Text
result Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"" then Text
"" else Text
" (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
result Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
   where
    result :: Text
result = Text -> [Text] -> Text
T.intercalate Text
" + " ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ [[Text]] -> [Text]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ [Text
"lib" | Task
task.allInOne Bool -> Bool -> Bool
&& Bool
hasLib]
      , [Text
"sub-lib" | Task
task.allInOne Bool -> Bool -> Bool
&& Bool
hasSubLib]
      , [Text
"exe" | Task
task.allInOne Bool -> Bool -> Bool
&& Bool
hasExe]
      , [Text
"test" | Bool
enableTests]
      , [Text
"bench" | Bool
enableBenchmarks]
      ]
    (Bool
hasLib, Bool
hasSubLib, Bool
hasExe) = case Task
task.taskType of
      TTLocalMutable LocalPackage
lp ->
        let package :: Package
package = LocalPackage
lp.package
            hasLibrary :: Bool
hasLibrary = Package -> Bool
hasBuildableMainLibrary Package
package
            hasSubLibraries :: Bool
hasSubLibraries = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ CompCollection StackLibrary -> Bool
forall a. CompCollection a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Package
package.subLibraries
            hasExecutables :: Bool
hasExecutables = Bool -> Bool
not (Bool -> Bool)
-> (Set StackUnqualCompName -> Bool)
-> Set StackUnqualCompName
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set StackUnqualCompName -> Bool
forall a. Set a -> Bool
Set.null (Set StackUnqualCompName -> Bool)
-> Set StackUnqualCompName -> Bool
forall a b. (a -> b) -> a -> b
$ LocalPackage -> Set StackUnqualCompName
exesToBuild LocalPackage
lp
        in  (Bool
hasLibrary, Bool
hasSubLibraries, 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)
  initialBuildSteps :: (ExcludeTHLoading -> [[Char]] -> RIO env ())
-> (Utf8Builder -> RIO env ()) -> RIO env ()
initialBuildSteps ExcludeTHLoading -> [[Char]] -> RIO env ()
cabal Utf8Builder -> RIO env ()
announce = do
    Utf8Builder -> RIO env ()
announce (Utf8Builder
"initial-build-steps" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Text
annSuffix)
    ExcludeTHLoading -> [[Char]] -> RIO env ()
cabal ExcludeTHLoading
KeepTHLoading [[Char]
"repl", [Char]
"stack-initial-build-steps"]

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

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

    markExeNotInstalled (taskLocation task) pkgId
    case task.taskType of
      TTLocalMutable LocalPackage
lp -> do
        Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
enableTests (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Path Abs Dir -> TestStatus -> RIO env ()
forall env.
HasEnvConfig env =>
Path Abs Dir -> TestStatus -> RIO env ()
setTestStatus Path Abs Dir
pkgDir TestStatus
TSUnknown
        caches <- MemoizedWith EnvConfig (Map NamedComponent FileCache)
-> RIO env (Map NamedComponent FileCache)
forall env (m :: * -> *) a.
(HasEnvConfig env, MonadReader env m, MonadIO m) =>
MemoizedWith EnvConfig a -> m a
runMemoizedWith LocalPackage
lp.newBuildCaches
        mapM_
          (uncurry (writeBuildCache pkgDir))
          (Map.toList caches)
      TTRemotePackage{} -> () -> RIO env ()
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

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

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

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

    actualCompiler <- view actualCompilerVersionL
    () <- announce
      (  "build"
      <> display annSuffix
      <> " with "
      <> display actualCompiler
      )
    config <- view configL
    extraOpts <- extraBuildOptions wc ee.buildOpts
    let stripTHLoading
          | Config
config.hideTHLoading = ExcludeTHLoading
ExcludeTHLoading
          | Bool
otherwise                  = ExcludeTHLoading
KeepTHLoading
    (buildOpts, copyOpts) <-
      case (task.taskType, task.allInOne, isFinalBuild) of
        (TaskType
_, Bool
True, Bool
True) -> BuildException -> RIO env ([[Char]], [[Char]])
forall e a. (?callStack::CallStack, Exception e) => e -> RIO env a
forall (m :: * -> *) e a.
(MonadThrow m, ?callStack::CallStack, Exception e) =>
e -> m a
throwM BuildException
AllInOneBuildBug
        (TTLocalMutable LocalPackage
lp, Bool
False, Bool
False) ->
          let componentOpts :: [[Char]]
componentOpts = LocalPackage -> [[Char]]
primaryComponentOptions LocalPackage
lp
          in  ([[Char]], [[Char]]) -> RIO env ([[Char]], [[Char]])
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([[Char]]
componentOpts, [[Char]]
componentOpts)
        (TTLocalMutable LocalPackage
lp, Bool
False, Bool
True) -> ([[Char]], [[Char]]) -> RIO env ([[Char]], [[Char]])
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LocalPackage -> [[Char]]
finalComponentOptions LocalPackage
lp, [])
        (TTLocalMutable LocalPackage
lp, Bool
True, Bool
False) ->
          let componentOpts :: [[Char]]
componentOpts = LocalPackage -> [[Char]]
primaryComponentOptions LocalPackage
lp
          in ([[Char]], [[Char]]) -> RIO env ([[Char]], [[Char]])
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([[Char]]
componentOpts [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> LocalPackage -> [[Char]]
finalComponentOptions LocalPackage
lp, [[Char]]
componentOpts)
        (TTRemotePackage{}, Bool
_, Bool
_) -> ([[Char]], [[Char]]) -> RIO env ([[Char]], [[Char]])
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], [])
    cabal stripTHLoading ("build" : buildOpts <> extraOpts)
      `catch` \BuildPrettyException
ex -> case BuildPrettyException
ex of
        CabalExitedUnsuccessfully{} ->
          Bool -> RIO env ()
postBuildCheck Bool
False RIO env () -> RIO env () -> RIO env ()
forall a b. RIO env a -> RIO env b -> RIO env b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> BuildPrettyException -> RIO env ()
forall e (m :: * -> *) a.
(Exception e, MonadThrow m, Pretty e) =>
e -> m a
prettyThrowM BuildPrettyException
ex
        BuildPrettyException
_ -> BuildPrettyException -> RIO env ()
forall e a. (?callStack::CallStack, Exception e) => e -> RIO env a
forall (m :: * -> *) e a.
(MonadThrow m, ?callStack::CallStack, Exception e) =>
e -> m a
throwM BuildPrettyException
ex
    postBuildCheck True

    mcurator <- view $ buildConfigL . to (.curator)
    when (doHaddock mcurator) $ do
      let isTaskTargetMutable = Task -> IsMutable
taskTargetIsMutable Task
task IsMutable -> IsMutable -> Bool
forall a. Eq a => a -> a -> Bool
== IsMutable
Mutable
          isHaddockForHackage =
            ExecuteEnv
ee.buildOpts.haddockForHackage Bool -> Bool -> Bool
&& Bool
isTaskTargetMutable
      announce $ if isHaddockForHackage
        then "haddock for Hackage"
        else "haddock"

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

      let quickjump = [[Char]
"--haddock-option=--quickjump"]

      fulfillHaddockExpectations pname mcurator $ \KeepOutputOpen
keep -> do
        let args :: [[Char]]
args = [[[Char]]] -> [[Char]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
              (  ( if Bool
isHaddockForHackage
                    then
                      [ [ [Char]
"--for-hackage" ] ]
                    else
                      [ [ [Char]
"--html"
                        , [Char]
"--hoogle"
                        , [Char]
"--html-location=../$pkg-$version/"
                        ]
                      , [ [Char]
"--haddock-option=--hyperlinked-source"
                        | ExecuteEnv
ee.buildOpts.haddockHyperlinkSource
                        ]
                      , [ [Char]
"--executables" | ExecuteEnv
ee.buildOpts.haddockExecutables ]
                      , [ [Char]
"--tests" | ExecuteEnv
ee.buildOpts.haddockTests ]
                      , [ [Char]
"--benchmarks" | ExecuteEnv
ee.buildOpts.haddockBenchmarks ]
                      , [ [Char]
"--internal" | ExecuteEnv
ee.buildOpts.haddockInternal  ]
                      , [[Char]]
quickjump
                      ]
                 )
              [[[Char]]] -> [[[Char]]] -> [[[Char]]]
forall a. Semigroup a => a -> a -> a
<> [ [ [Char]
"--haddock-option=" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
opt
                   | [Char]
opt <- ExecuteEnv
ee.buildOpts.haddockOpts.additionalArgs
                   ]
                 ]
              )

        KeepOutputOpen -> ExcludeTHLoading -> [[Char]] -> RIO env ()
cabal0 KeepOutputOpen
keep ExcludeTHLoading
KeepTHLoading ([[Char]] -> RIO env ()) -> [[Char]] -> RIO env ()
forall a b. (a -> b) -> a -> b
$ [Char]
"haddock" [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]]
args

    let hasLibrary = Package -> Bool
hasBuildableMainLibrary Package
package
        hasSubLibraries = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ CompCollection StackLibrary -> Bool
forall a. CompCollection a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Package
package.subLibraries
        hasExecutables = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ CompCollection StackExecutable -> Bool
forall a. CompCollection a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Package
package.executables
        shouldCopy =
             Bool -> Bool
not Bool
isFinalBuild
          Bool -> Bool -> Bool
&& (Bool
hasLibrary Bool -> Bool -> Bool
|| Bool
hasSubLibraries Bool -> Bool -> Bool
|| Bool
hasExecutables)
    when shouldCopy $ withMVar ee.installLock $ \() -> do
      Utf8Builder -> RIO env ()
announce Utf8Builder
"copy/register"
      RIO env () -> RIO env (Either BuildPrettyException ())
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try (ExcludeTHLoading -> [[Char]] -> RIO env ()
cabal ExcludeTHLoading
KeepTHLoading ([[Char]] -> RIO env ()) -> [[Char]] -> RIO env ()
forall a b. (a -> b) -> a -> b
$ [Char]
"copy" [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]]
copyOpts) RIO env (Either BuildPrettyException ())
-> (Either BuildPrettyException () -> RIO env ()) -> RIO env ()
forall a b. RIO env a -> (a -> RIO env b) -> RIO env b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left err :: BuildPrettyException
err@CabalExitedUnsuccessfully{} ->
          BuildException -> RIO env ()
forall e a. (?callStack::CallStack, Exception e) => e -> RIO env a
forall (m :: * -> *) e a.
(MonadThrow m, ?callStack::CallStack, Exception e) =>
e -> m a
throwM (BuildException -> RIO env ()) -> BuildException -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Bool -> [Char] -> BuildException
CabalCopyFailed
                     (Package
package.buildType BuildType -> BuildType -> Bool
forall a. Eq a => a -> a -> Bool
== BuildType
C.Simple)
                     (BuildPrettyException -> [Char]
forall e. Exception e => e -> [Char]
displayException BuildPrettyException
err)
        Either BuildPrettyException ()
_ -> () -> RIO env ()
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
hasLibrary Bool -> Bool -> Bool
|| Bool
hasSubLibraries) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ ExcludeTHLoading -> [[Char]] -> RIO env ()
cabal ExcludeTHLoading
KeepTHLoading [[Char]
"register"]

    copyDdumpFilesIfNeeded buildingFinals ee.buildOpts.ddumpDir
    installedPkg <-
      fetchAndMarkInstalledPackage ee (taskLocation task) package pkgId
    postProcessRemotePackage
      task.taskType
      ac
      cache
      ee
      installedPkg
      package
      pkgId
      pkgDir
    pure installedPkg

-- | Action in the case that the task relates to a remote package.

postProcessRemotePackage ::
     (HasEnvConfig env)
  => TaskType
  -> ActionContext
  -> ConfigCache
  -> ExecuteEnv
  -> Installed
  -> Package
  -> PackageIdentifier
  -> Path b Dir
  -> RIO env ()
postProcessRemotePackage :: forall env b.
HasEnvConfig env =>
TaskType
-> ActionContext
-> ConfigCache
-> ExecuteEnv
-> Installed
-> Package
-> PackageIdentifier
-> Path b Dir
-> RIO env ()
postProcessRemotePackage
    TaskType
taskType
    ActionContext
ac
    ConfigCache
cache
    ExecuteEnv
ee
    Installed
installedPackage
    Package
package
    PackageIdentifier
pkgId
    Path b Dir
pkgDir
  = case TaskType
taskType of
      TTRemotePackage IsMutable
isMutable Package
_ PackageLocationImmutable
loc -> do
        Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (IsMutable
isMutable IsMutable -> IsMutable -> Bool
forall a. Eq a => a -> a -> Bool
== IsMutable
Immutable) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ BaseConfigOpts
-> PackageLocationImmutable
-> ConfigureOpts
-> Bool
-> Installed
-> Set StackUnqualCompName
-> RIO env ()
forall env.
HasEnvConfig env =>
BaseConfigOpts
-> PackageLocationImmutable
-> ConfigureOpts
-> Bool
-> Installed
-> Set StackUnqualCompName
-> RIO env ()
writePrecompiledCache
          ExecuteEnv
ee.baseConfigOpts
          PackageLocationImmutable
loc
          ConfigCache
cache.configureOpts
          ConfigCache
cache.buildHaddocks
          Installed
installedPackage
          (Package -> Set StackUnqualCompName
buildableExes Package
package)
        -- 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).

        let remaining :: Set ActionId
remaining =
              (ActionId -> Bool) -> Set ActionId -> Set ActionId
forall a. (a -> Bool) -> Set a -> Set a
Set.filter
                (\(ActionId PackageIdentifier
x ActionType
_) -> PackageIdentifier
x PackageIdentifier -> PackageIdentifier -> Bool
forall a. Eq a => a -> a -> Bool
== PackageIdentifier
pkgId)
                ActionContext
ac.remaining
        Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Set ActionId -> Bool
forall a. Set a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Set ActionId
remaining) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Path b Dir -> RIO env ()
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
removeDirRecur Path b Dir
pkgDir
      TaskType
_ -> () -> RIO env ()
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Once all the Cabal-related tasks have run for a package, we should be able

-- to gather the information needed to create an 'Installed' package value. For

-- now, either there's a main library (in which case we consider the 'GhcPkgId'

-- values of the package's libraries) or we just consider it's an executable

-- (and mark all the executables as installed, if any).

--

-- Note that this also modifies the installedDumpPkgsTVar which is used for

-- generating Haddocks.

--

fetchAndMarkInstalledPackage ::
     (HasEnvConfig env, HasTerm env)
  => ExecuteEnv
  -> InstallLocation
  -> Package
  -> PackageIdentifier
  -> RIO env Installed
fetchAndMarkInstalledPackage :: forall env.
(HasEnvConfig env, HasTerm env) =>
ExecuteEnv
-> InstallLocation
-> Package
-> PackageIdentifier
-> RIO env Installed
fetchAndMarkInstalledPackage ExecuteEnv
ee InstallLocation
taskInstallLocation Package
package PackageIdentifier
pkgId = do
  let ghcPkgIdLoader :: Maybe StackUnqualCompName -> RIO env (Maybe GhcPkgId)
ghcPkgIdLoader = ExecuteEnv
-> InstallLocation
-> PackageName
-> Maybe StackUnqualCompName
-> RIO env (Maybe GhcPkgId)
forall env.
(HasTerm env, HasEnvConfig env) =>
ExecuteEnv
-> InstallLocation
-> PackageName
-> Maybe StackUnqualCompName
-> RIO env (Maybe GhcPkgId)
fetchGhcPkgIdForLib ExecuteEnv
ee InstallLocation
taskInstallLocation Package
package.name
  -- Only pure the sub-libraries to cache them if we also cache the main

  -- library (that is, if it exists)

  if Package -> Bool
hasBuildableMainLibrary Package
package
    then do
      let foldSubLibToMap :: StackLibrary
-> RIO env (Map StackUnqualCompName GhcPkgId)
-> RIO env (Map StackUnqualCompName GhcPkgId)
foldSubLibToMap StackLibrary
subLib RIO env (Map StackUnqualCompName GhcPkgId)
mapInMonad = do
            maybeGhcpkgId <- Maybe StackUnqualCompName -> RIO env (Maybe GhcPkgId)
ghcPkgIdLoader (StackUnqualCompName -> Maybe StackUnqualCompName
forall a. a -> Maybe a
Just StackLibrary
subLib.name)
            mapInMonad <&> case maybeGhcpkgId of
              Just GhcPkgId
v -> StackUnqualCompName
-> GhcPkgId
-> Map StackUnqualCompName GhcPkgId
-> Map StackUnqualCompName GhcPkgId
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert StackLibrary
subLib.name GhcPkgId
v
              Maybe GhcPkgId
_ -> Map StackUnqualCompName GhcPkgId
-> Map StackUnqualCompName GhcPkgId
forall a. a -> a
id
      subLibsPkgIds <- CompCollection StackLibrary
-> (StackLibrary
    -> RIO env (Map StackUnqualCompName GhcPkgId)
    -> RIO env (Map StackUnqualCompName GhcPkgId))
-> RIO env (Map StackUnqualCompName GhcPkgId)
-> RIO env (Map StackUnqualCompName GhcPkgId)
forall (m :: * -> *) component a.
Monad m =>
CompCollection component -> (component -> m a -> m a) -> m a -> m a
foldComponentToAnotherCollection
        Package
package.subLibraries
        StackLibrary
-> RIO env (Map StackUnqualCompName GhcPkgId)
-> RIO env (Map StackUnqualCompName GhcPkgId)
foldSubLibToMap
        RIO env (Map StackUnqualCompName GhcPkgId)
forall a. Monoid a => a
mempty
      ghcPkgIdLoader Nothing >>= \case
        Maybe GhcPkgId
Nothing -> BuildException -> RIO env Installed
forall e a. (?callStack::CallStack, Exception e) => e -> RIO env a
forall (m :: * -> *) e a.
(MonadThrow m, ?callStack::CallStack, Exception e) =>
e -> m a
throwM (BuildException -> RIO env Installed)
-> BuildException -> RIO env Installed
forall a b. (a -> b) -> a -> b
$ PackageName -> BuildException
Couldn'tFindPkgId Package
package.name
        Just GhcPkgId
ghcPkgId -> Installed -> RIO env Installed
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Installed -> RIO env Installed) -> Installed -> RIO env Installed
forall a b. (a -> b) -> a -> b
$ PackageIdentifier
-> GhcPkgId -> Map StackUnqualCompName GhcPkgId -> Installed
simpleInstalledLib PackageIdentifier
pkgId GhcPkgId
ghcPkgId Map StackUnqualCompName GhcPkgId
subLibsPkgIds
    else do
      InstallLocation -> PackageIdentifier -> RIO env ()
forall env.
HasEnvConfig env =>
InstallLocation -> PackageIdentifier -> RIO env ()
markExeInstalled InstallLocation
taskInstallLocation PackageIdentifier
pkgId -- TODO unify somehow

                                                  -- with writeFlagCache?

      Installed -> RIO env Installed
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Installed -> RIO env Installed) -> Installed -> RIO env Installed
forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> Installed
Executable PackageIdentifier
pkgId

fetchGhcPkgIdForLib ::
     (HasTerm env, HasEnvConfig env)
  => ExecuteEnv
  -> InstallLocation
  -> PackageName
  -> Maybe Component.StackUnqualCompName
  -> RIO env (Maybe GhcPkgId)
fetchGhcPkgIdForLib :: forall env.
(HasTerm env, HasEnvConfig env) =>
ExecuteEnv
-> InstallLocation
-> PackageName
-> Maybe StackUnqualCompName
-> RIO env (Maybe GhcPkgId)
fetchGhcPkgIdForLib ExecuteEnv
ee InstallLocation
installLocation PackageName
pkgName Maybe StackUnqualCompName
libName = do
  let baseConfigOpts :: BaseConfigOpts
baseConfigOpts = ExecuteEnv
ee.baseConfigOpts
      (Path Abs Dir
installedPkgDb, TVar (Map GhcPkgId DumpPackage)
installedDumpPkgsTVar) =
        case InstallLocation
installLocation of
          InstallLocation
Snap ->
            ( BaseConfigOpts
baseConfigOpts.snapDB
            , ExecuteEnv
ee.snapshotDumpPkgs )
          InstallLocation
Local ->
            ( BaseConfigOpts
baseConfigOpts.localDB
            , ExecuteEnv
ee.localDumpPkgs )
  let commonLoader :: PackageName -> RIO env (Maybe GhcPkgId)
commonLoader = [Path Abs Dir]
-> TVar (Map GhcPkgId DumpPackage)
-> PackageName
-> RIO env (Maybe GhcPkgId)
forall env.
(HasCompiler env, HasProcessContext env, HasTerm env) =>
[Path Abs Dir]
-> TVar (Map GhcPkgId DumpPackage)
-> PackageName
-> RIO env (Maybe GhcPkgId)
loadInstalledPkg [Path Abs Dir
installedPkgDb] TVar (Map GhcPkgId DumpPackage)
installedDumpPkgsTVar
  case Maybe StackUnqualCompName
libName of
    Maybe StackUnqualCompName
Nothing -> PackageName -> RIO env (Maybe GhcPkgId)
commonLoader PackageName
pkgName
    Just StackUnqualCompName
v -> do
      let mungedName :: PackageName
mungedName = MungedPackageName -> PackageName
encodeCompatPackageName (MungedPackageName -> PackageName)
-> MungedPackageName -> PackageName
forall a b. (a -> b) -> a -> b
$ PackageName -> StackUnqualCompName -> MungedPackageName
toCabalMungedPackageName PackageName
pkgName StackUnqualCompName
v
      PackageName -> RIO env (Maybe GhcPkgId)
commonLoader PackageName
mungedName

-- | Copy ddump-* files, if we are building finals and a non-empty ddump-dir

-- has been specified.

copyDdumpFilesIfNeeded :: HasEnvConfig env => Bool -> Maybe Text -> RIO env ()
copyDdumpFilesIfNeeded :: forall env. HasEnvConfig env => Bool -> Maybe Text -> RIO env ()
copyDdumpFilesIfNeeded Bool
buildingFinals Maybe Text
mDdumpPath = Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
buildingFinals (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
  Maybe Text -> (Text -> RIO env ()) -> RIO env ()
forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe Text
mDdumpPath ((Text -> RIO env ()) -> RIO env ())
-> (Text -> RIO env ()) -> RIO env ()
forall a b. (a -> b) -> a -> b
$ \Text
ddumpPath -> Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text -> Bool
T.null Text
ddumpPath) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
    distDir <- RIO env (Path Rel Dir)
forall env (m :: * -> *).
(HasEnvConfig env, MonadReader env m, MonadThrow m) =>
m (Path Rel Dir)
distRelativeDir
    ddumpRelDir <- parseRelDir $ T.unpack ddumpPath
    prettyDebugL
      [ "ddump-dir:"
      , pretty ddumpRelDir
      ]
    prettyDebugL
      [ "dist-dir:"
      , pretty distDir
      ]
    runConduitRes
      $ CF.sourceDirectoryDeep False (toFilePath distDir)
      .| CL.filter (L.isInfixOf ".dump-")
      .| CL.mapM_ (\[Char]
src -> IO () -> ResourceT (RIO env) ()
forall a. IO a -> ResourceT (RIO env) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ResourceT (RIO env) ())
-> IO () -> ResourceT (RIO env) ()
forall a b. (a -> b) -> a -> b
$ do
          parentDir <- Path Rel Dir -> Path Rel Dir
forall b t. Path b t -> Path b Dir
parent (Path Rel Dir -> Path Rel Dir)
-> IO (Path Rel Dir) -> IO (Path Rel Dir)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO (Path Rel Dir)
forall (m :: * -> *). MonadThrow m => [Char] -> m (Path Rel Dir)
parseRelDir [Char]
src
          destBaseDir <-
            (ddumpRelDir </>) <$> stripProperPrefix distDir parentDir
          -- exclude .stack-work dir

          unless (".stack-work" `L.isInfixOf` toFilePath destBaseDir) $ do
            ensureDir destBaseDir
            src' <- parseRelFile src
            copyFile src' (destBaseDir </> filename src'))

getPrecompiled ::
     HasEnvConfig env
  => ConfigCache
  -> TaskType
  -> Path Abs Dir
  -> RIO env (Maybe (PrecompiledCache Abs))
getPrecompiled :: forall env.
HasEnvConfig env =>
ConfigCache
-> TaskType
-> Path Abs Dir
-> RIO env (Maybe (PrecompiledCache Abs))
getPrecompiled ConfigCache
cache TaskType
taskType Path Abs Dir
bcoSnapInstallRoot =
  case TaskType
taskType of
    TTRemotePackage IsMutable
Immutable Package
_ PackageLocationImmutable
loc ->
      PackageLocationImmutable
-> ConfigureOpts -> Bool -> RIO env (Maybe (PrecompiledCache Abs))
forall env.
HasEnvConfig env =>
PackageLocationImmutable
-> ConfigureOpts -> Bool -> RIO env (Maybe (PrecompiledCache Abs))
readPrecompiledCache PackageLocationImmutable
loc ConfigCache
cache.configureOpts ConfigCache
cache.buildHaddocks RIO env (Maybe (PrecompiledCache Abs))
-> (Maybe (PrecompiledCache Abs)
    -> RIO env (Maybe (PrecompiledCache Abs)))
-> RIO env (Maybe (PrecompiledCache Abs))
forall a b. RIO env a -> (a -> RIO env b) -> RIO env b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe (PrecompiledCache Abs)
Nothing -> Maybe (PrecompiledCache Abs)
-> RIO env (Maybe (PrecompiledCache Abs))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (PrecompiledCache Abs)
forall a. Maybe a
Nothing
        -- Only pay attention to precompiled caches that refer to packages

        -- within the snapshot.

        Just PrecompiledCache Abs
pc
          | Bool -> (Path Abs File -> Bool) -> Maybe (Path Abs File) -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False
              (Path Abs Dir
bcoSnapInstallRoot Path Abs Dir -> Path Abs File -> Bool
forall b t. Path b Dir -> Path b t -> Bool
`isProperPrefixOf`)
              PrecompiledCache Abs
pc.library -> Maybe (PrecompiledCache Abs)
-> RIO env (Maybe (PrecompiledCache Abs))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (PrecompiledCache Abs)
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
_ [] = Bool -> f Bool
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
              allM t -> f Bool
f (t
x:[t]
xs) = do
                b <- t -> f Bool
f t
x
                if b then allM f xs else pure False
          b <- IO Bool -> RIO env Bool
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> RIO env Bool) -> IO Bool -> RIO env Bool
forall a b. (a -> b) -> a -> b
$
                  (Path Abs File -> IO Bool) -> [Path Abs File] -> IO Bool
forall {f :: * -> *} {t}. Monad f => (t -> f Bool) -> [t] -> f Bool
allM Path Abs File -> IO Bool
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist ([Path Abs File] -> IO Bool) -> [Path Abs File] -> IO Bool
forall a b. (a -> b) -> a -> b
$ ([Path Abs File] -> [Path Abs File])
-> (Path Abs File -> [Path Abs File] -> [Path Abs File])
-> Maybe (Path Abs File)
-> [Path Abs File]
-> [Path Abs File]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Path Abs File] -> [Path Abs File]
forall a. a -> a
id (:) PrecompiledCache Abs
pc.library PrecompiledCache Abs
pc.exes
          pure $ if b then Just pc else Nothing
    TaskType
_ -> Maybe (PrecompiledCache Abs)
-> RIO env (Maybe (PrecompiledCache Abs))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (PrecompiledCache Abs)
forall a. Maybe a
Nothing

copyPreCompiled ::
     ( HasLogFunc env
     , HasCompiler env
     , HasTerm env
     , HasProcessContext env
     , HasEnvConfig env
     )
  => ExecuteEnv
  -> Task
  -> PackageIdentifier
  -> PrecompiledCache b0
  -> RIO env (Maybe Installed)
copyPreCompiled :: forall env b0.
(HasLogFunc env, HasCompiler env, HasTerm env,
 HasProcessContext env, HasEnvConfig env) =>
ExecuteEnv
-> Task
-> PackageIdentifier
-> PrecompiledCache b0
-> RIO env (Maybe Installed)
copyPreCompiled ExecuteEnv
ee Task
task PackageIdentifier
pkgId (PrecompiledCache Maybe (Path b0 File)
mlib [Path b0 File]
subLibs [Path b0 File]
exes) = do
  let PackageIdentifier PackageName
pname Version
pversion = PackageIdentifier
pkgId
  ExecuteEnv -> TaskType -> Utf8Builder -> RIO env ()
forall env.
HasLogFunc env =>
ExecuteEnv -> TaskType -> Utf8Builder -> RIO env ()
announceTask ExecuteEnv
ee Task
task.taskType Utf8Builder
"using precompiled package"

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

  -- 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 :: [StackUnqualCompName]
subLibNames = Set StackUnqualCompName -> [StackUnqualCompName]
forall a. Set a -> [a]
Set.toList (Set StackUnqualCompName -> [StackUnqualCompName])
-> Set StackUnqualCompName -> [StackUnqualCompName]
forall a b. (a -> b) -> a -> b
$ Package -> Set StackUnqualCompName
buildableSubLibs (Package -> Set StackUnqualCompName)
-> Package -> Set StackUnqualCompName
forall a b. (a -> b) -> a -> b
$ case Task
task.taskType of
      TTLocalMutable LocalPackage
lp -> LocalPackage
lp.package
      TTRemotePackage IsMutable
_ Package
p PackageLocationImmutable
_ -> Package
p
    toMungedPackageId :: StackUnqualCompName -> MungedPackageId
    toMungedPackageId :: StackUnqualCompName -> MungedPackageId
toMungedPackageId StackUnqualCompName
subLib =
      let subLibName :: LibraryName
subLibName = UnqualComponentName -> LibraryName
LSubLibName (UnqualComponentName -> LibraryName)
-> UnqualComponentName -> LibraryName
forall a b. (a -> b) -> a -> b
$ StackUnqualCompName -> UnqualComponentName
toCabalName StackUnqualCompName
subLib
      in  MungedPackageName -> Version -> MungedPackageId
MungedPackageId (PackageName -> LibraryName -> MungedPackageName
MungedPackageName PackageName
pname LibraryName
subLibName) Version
pversion
    toPackageId :: MungedPackageId -> PackageIdentifier
    toPackageId :: MungedPackageId -> PackageIdentifier
toPackageId (MungedPackageId MungedPackageName
n Version
v) =
      PackageName -> Version -> PackageIdentifier
PackageIdentifier (MungedPackageName -> PackageName
encodeCompatPackageName MungedPackageName
n) Version
v
    allToUnregister :: [Either PackageIdentifier GhcPkgId]
    allToUnregister :: [Either PackageIdentifier GhcPkgId]
allToUnregister = Maybe (Either PackageIdentifier GhcPkgId)
-> [Either PackageIdentifier GhcPkgId]
-> [Either PackageIdentifier GhcPkgId]
forall a. Maybe a -> [a] -> [a]
mcons
      (PackageIdentifier -> Either PackageIdentifier GhcPkgId
forall a b. a -> Either a b
Left PackageIdentifier
pkgId Either PackageIdentifier GhcPkgId
-> Maybe (Path b0 File)
-> Maybe (Either PackageIdentifier GhcPkgId)
forall a b. a -> Maybe b -> Maybe a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Maybe (Path b0 File)
mlib)
      ((StackUnqualCompName -> Either PackageIdentifier GhcPkgId)
-> [StackUnqualCompName] -> [Either PackageIdentifier GhcPkgId]
forall a b. (a -> b) -> [a] -> [b]
map (PackageIdentifier -> Either PackageIdentifier GhcPkgId
forall a b. a -> Either a b
Left (PackageIdentifier -> Either PackageIdentifier GhcPkgId)
-> (StackUnqualCompName -> PackageIdentifier)
-> StackUnqualCompName
-> Either PackageIdentifier GhcPkgId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MungedPackageId -> PackageIdentifier
toPackageId (MungedPackageId -> PackageIdentifier)
-> (StackUnqualCompName -> MungedPackageId)
-> StackUnqualCompName
-> PackageIdentifier
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StackUnqualCompName -> MungedPackageId
toMungedPackageId) [StackUnqualCompName]
subLibNames)
    allToRegister :: [Path b0 File]
allToRegister = Maybe (Path b0 File) -> [Path b0 File] -> [Path b0 File]
forall a. Maybe a -> [a] -> [a]
mcons Maybe (Path b0 File)
mlib [Path b0 File]
subLibs

  Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Path b0 File] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Path b0 File]
allToRegister) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
    MVar () -> (() -> RIO env ()) -> RIO env ()
forall (m :: * -> *) a b.
MonadUnliftIO m =>
MVar a -> (a -> m b) -> m b
withMVar ExecuteEnv
ee.installLock ((() -> RIO env ()) -> RIO env ())
-> (() -> RIO env ()) -> RIO env ()
forall a b. (a -> b) -> a -> b
$ \() -> do
      -- We want to ignore the global and user package databases. ghc-pkg

      -- allows us to specify --no-user-package-db and --package-db=<db> on

      -- the command line.

      let pkgDb :: Path Abs Dir
pkgDb = ExecuteEnv
ee.baseConfigOpts.snapDB
      ghcPkgExe <- RIO env GhcPkgExe
forall env. HasCompiler env => RIO env GhcPkgExe
getGhcPkgExe
      -- First unregister, silently, everything that needs to be unregistered.

      whenJust (nonEmpty allToUnregister) $ \NonEmpty (Either PackageIdentifier GhcPkgId)
allToUnregister' -> do
        logLevel <- Getting LogLevel env LogLevel -> RIO env LogLevel
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting LogLevel env LogLevel -> RIO env LogLevel)
-> Getting LogLevel env LogLevel -> RIO env LogLevel
forall a b. (a -> b) -> a -> b
$ (GlobalOpts -> Const LogLevel GlobalOpts)
-> env -> Const LogLevel env
forall env. HasRunner env => Lens' env GlobalOpts
Lens' env GlobalOpts
globalOptsL ((GlobalOpts -> Const LogLevel GlobalOpts)
 -> env -> Const LogLevel env)
-> ((LogLevel -> Const LogLevel LogLevel)
    -> GlobalOpts -> Const LogLevel GlobalOpts)
-> Getting LogLevel env LogLevel
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GlobalOpts -> LogLevel) -> SimpleGetter GlobalOpts LogLevel
forall s a. (s -> a) -> SimpleGetter s a
to (.logLevel)
        let isDebug = LogLevel
logLevel LogLevel -> LogLevel -> Bool
forall a. Eq a => a -> a -> Bool
== LogLevel
LevelDebug
        catchAny
          (unregisterGhcPkgIds isDebug ghcPkgExe pkgDb allToUnregister')
          (const (pure ()))
      -- There appears to be a bug in the ghc-pkg executable such that, on

      -- Windows only, it cannot register a package into a package database that

      -- is also listed in the GHC_PACKAGE_PATH environment variable. See:

      -- https://gitlab.haskell.org/ghc/ghc/-/issues/25962. We work around that

      -- by removing GHC_PACKAGE_PATH from the environment for the register

      -- step.

      wc <- view $ envConfigL . to (.sourceMap.compiler) . to whichCompiler
      withModifyEnvVars (Map.delete $ ghcPkgPathEnvVar wc) $
        forM_ allToRegister $ \Path b0 File
libpath -> do
          let args :: [[Char]]
args = [[Char]
"register", [Char]
"--force", Path b0 File -> [Char]
forall b t. Path b t -> [Char]
toFilePath Path b0 File
libpath]
          GhcPkgExe
-> [Path Abs Dir]
-> [[Char]]
-> RIO env (Either SomeException ByteString)
forall env.
(HasProcessContext env, HasTerm env) =>
GhcPkgExe
-> [Path Abs Dir]
-> [[Char]]
-> RIO env (Either SomeException ByteString)
ghcPkg GhcPkgExe
ghcPkgExe [Path Abs Dir
pkgDb] [[Char]]
args RIO env (Either SomeException ByteString)
-> (Either SomeException ByteString -> RIO env ()) -> RIO env ()
forall a b. RIO env a -> (a -> RIO env b) -> RIO env b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Left SomeException
e -> StyleDoc -> RIO env ()
forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
 MonadIO m) =>
StyleDoc -> m ()
prettyWarn (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$
              StyleDoc
"[S-4541]"
              StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
              StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
                   [ [Char] -> StyleDoc
flow [Char]
"While registering"
                   , Path b0 File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path b0 File
libpath
                   , StyleDoc
"in"
                   , Path Abs Dir -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Abs Dir
pkgDb StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
","
                   , [Char] -> StyleDoc
flow [Char]
"Stack encountered the following error:"
                   ]
              StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
              StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [Char] -> StyleDoc
string (SomeException -> [Char]
forall e. Exception e => e -> [Char]
displayException SomeException
e)
            Right ByteString
_ -> () -> RIO env ()
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  IO () -> RIO env ()
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO env ()) -> IO () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ [Path b0 File] -> (Path b0 File -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Path b0 File]
exes ((Path b0 File -> IO ()) -> IO ())
-> (Path b0 File -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Path b0 File
exe -> do
    Path Abs Dir -> IO ()
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir Path Abs Dir
bindir
    let dst :: Path Abs File
dst = Path Abs Dir
bindir Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path b0 File -> Path Rel File
forall b. Path b File -> Path Rel File
filename Path b0 File
exe
    [Char] -> [Char] -> IO ()
createLink (Path b0 File -> [Char]
forall b t. Path b t -> [Char]
toFilePath Path b0 File
exe) (Path Abs File -> [Char]
forall b t. Path b t -> [Char]
toFilePath Path Abs File
dst) IO () -> (IOError -> IO ()) -> IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (IOError -> m a) -> m a
`catchIO` \IOError
_ -> Path b0 File -> Path Abs File -> IO ()
forall (m :: * -> *) b0 b1.
MonadIO m =>
Path b0 File -> Path b1 File -> m ()
copyFile Path b0 File
exe Path Abs File
dst
  case (Maybe (Path b0 File)
mlib, [Path b0 File]
exes) of
    (Maybe (Path b0 File)
Nothing, Path b0 File
_:[Path b0 File]
_) -> InstallLocation -> PackageIdentifier -> RIO env ()
forall env.
HasEnvConfig env =>
InstallLocation -> PackageIdentifier -> RIO env ()
markExeInstalled (Task -> InstallLocation
taskLocation Task
task) PackageIdentifier
pkgId
    (Maybe (Path b0 File), [Path b0 File])
_ -> () -> RIO env ()
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

  -- Find the package in the database

  let pkgDbs :: [Path Abs Dir]
pkgDbs = [ExecuteEnv
ee.baseConfigOpts.snapDB]

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

      pure $ Just $
        case mpkgid of
          Maybe GhcPkgId
Nothing -> Bool -> Installed -> Installed
forall a. (?callStack::CallStack) => Bool -> a -> a
assert Bool
False (Installed -> Installed) -> Installed -> Installed
forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> Installed
Executable PackageIdentifier
pkgId
          Just GhcPkgId
pkgid -> PackageIdentifier
-> GhcPkgId -> Map StackUnqualCompName GhcPkgId -> Installed
simpleInstalledLib PackageIdentifier
pkgId GhcPkgId
pkgid Map StackUnqualCompName GhcPkgId
forall a. Monoid a => a
mempty
 where
  bindir :: Path Abs Dir
bindir = ExecuteEnv
ee.baseConfigOpts.snapInstallRoot Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
bindirSuffix

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

fulfillHaddockExpectations ::
     (MonadUnliftIO m, HasTerm env, MonadReader env m)
  => PackageName
  -> Maybe Curator
  -> (KeepOutputOpen -> m ())
  -> m ()
fulfillHaddockExpectations :: forall (m :: * -> *) env.
(MonadUnliftIO m, HasTerm env, MonadReader env m) =>
PackageName -> Maybe Curator -> (KeepOutputOpen -> m ()) -> m ()
fulfillHaddockExpectations PackageName
pname Maybe Curator
mcurator KeepOutputOpen -> m ()
action
  | Maybe Curator -> Bool
expectHaddockFailure Maybe Curator
mcurator =
      m () -> m (Either SomeException ())
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny (KeepOutputOpen -> m ()
action KeepOutputOpen
KeepOpen) m (Either SomeException ())
-> (Either SomeException () -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Right () -> [StyleDoc] -> m ()
forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
 MonadIO m) =>
[StyleDoc] -> m ()
prettyWarnL
          [ Style -> StyleDoc -> StyleDoc
style Style
Current (PackageName -> StyleDoc
forall a. IsString a => PackageName -> a
fromPackageName PackageName
pname) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
":"
          , [Char] -> StyleDoc
flow [Char]
"unexpected Haddock success."
          ]
        Left SomeException
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
 where
  expectHaddockFailure :: Maybe Curator -> Bool
expectHaddockFailure = Bool -> (Curator -> Bool) -> Maybe Curator -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (PackageName -> Set PackageName -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member PackageName
pname (Set PackageName -> Bool)
-> (Curator -> Set PackageName) -> Curator -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.expectHaddockFailure))
fulfillHaddockExpectations PackageName
_ Maybe Curator
_ KeepOutputOpen -> m ()
action = KeepOutputOpen -> m ()
action KeepOutputOpen
CloseOnException

-- | 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
  caches <- MemoizedWith EnvConfig (Map NamedComponent FileCache)
-> RIO env (Map NamedComponent FileCache)
forall env (m :: * -> *) a.
(HasEnvConfig env, MonadReader env m, MonadIO m) =>
MemoizedWith EnvConfig a -> m a
runMemoizedWith LocalPackage
lp.newBuildCaches
  (addBuildCache,warnings) <-
    addUnlistedToBuildCache
      lp.package
      lp.cabalFP
      lp.components
      caches
  forM_ (Map.toList addBuildCache) $ \(NamedComponent
component, [FileCache]
newToCache) -> do
    let cache :: FileCache
cache = FileCache
-> NamedComponent -> Map NamedComponent FileCache -> FileCache
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault FileCache
forall k a. Map k a
Map.empty NamedComponent
component Map NamedComponent FileCache
caches
    Path Abs Dir -> NamedComponent -> FileCache -> RIO env ()
forall env.
HasEnvConfig env =>
Path Abs Dir -> NamedComponent -> FileCache -> RIO env ()
writeBuildCache Path Abs Dir
pkgDir NamedComponent
component (FileCache -> RIO env ()) -> FileCache -> RIO env ()
forall a b. (a -> b) -> a -> b
$
      [FileCache] -> FileCache
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions (FileCache
cache FileCache -> [FileCache] -> [FileCache]
forall a. a -> [a] -> [a]
: [FileCache]
newToCache)
  pure warnings
checkForUnlistedFiles TTRemotePackage{} Path Abs Dir
_ = [PackageWarning] -> RIO env [PackageWarning]
forall a. a -> RIO env a
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
  -> [StackUnqualCompName]
  -> ActionContext
  -> ExecuteEnv
  -> Task
  -> InstalledMap
  -> RIO env ()
singleTest :: forall env.
HasEnvConfig env =>
TestOpts
-> [StackUnqualCompName]
-> ActionContext
-> ExecuteEnv
-> Task
-> InstalledMap
-> RIO env ()
singleTest TestOpts
topts [StackUnqualCompName]
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'.

  (allDepsMap, _cache) <- ExecuteEnv
-> Task
-> InstalledMap
-> Bool
-> Bool
-> RIO env (Map PackageIdentifier GhcPkgId, ConfigCache)
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
  mcurator <- view $ buildConfigL . to (.curator)
  let pname = PackageIdentifier -> PackageName
pkgName (PackageIdentifier -> PackageName)
-> PackageIdentifier -> PackageName
forall a b. (a -> b) -> a -> b
$ Task -> PackageIdentifier
taskProvides Task
task
      expectFailure = PackageName -> Maybe Curator -> Bool
expectTestFailure PackageName
pname Maybe Curator
mcurator
  withSingleContext ac ee task.taskType allDepsMap (Just "test") $
    \Package
package Path Abs File
_cabalfp Path Abs Dir
pkgDir KeepOutputOpen -> ExcludeTHLoading -> [[Char]] -> RIO env ()
_cabal Utf8Builder -> RIO env ()
announce OutputType
outputType -> do
      config <- Getting Config env Config -> RIO env Config
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Config env Config
forall env. HasConfig env => Lens' env Config
Lens' env Config
configL
      let needHpc = TestOpts
topts.coverage
      toRun <-
        if topts.runTests
          then if topts.rerunTests
            then pure True
            else
              getTestStatus pkgDir >>= \case
                TestStatus
TSSuccess -> do
                  Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([StackUnqualCompName] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [StackUnqualCompName]
testsToRun) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
                    Utf8Builder -> RIO env ()
announce Utf8Builder
"skipping already passed test"
                  Bool -> RIO env Bool
forall a. a -> RIO env a
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"
                      Bool -> RIO env Bool
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
                  | Bool
otherwise -> do
                      Utf8Builder -> RIO env ()
announce Utf8Builder
"rerunning previously failed test"
                      Bool -> RIO env Bool
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
                TestStatus
TSUnknown -> Bool -> RIO env Bool
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
          else prettyThrowM $ ActionNotFilteredBug "singleTest"
      when toRun $ do
        buildDir <- distDirFromDir pkgDir
        hpcDir <- hpcDirFromDir pkgDir
        when needHpc (ensureDir hpcDir)

        let suitesToRun
              = [ (StackUnqualCompName, TestSuiteInterface)
testSuitePair
                | (StackUnqualCompName, TestSuiteInterface)
testSuitePair <-
                    ((((StackUnqualCompName, StackTestSuite)
 -> (StackUnqualCompName, TestSuiteInterface))
-> [(StackUnqualCompName, StackTestSuite)]
-> [(StackUnqualCompName, TestSuiteInterface)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((StackUnqualCompName, StackTestSuite)
  -> (StackUnqualCompName, TestSuiteInterface))
 -> [(StackUnqualCompName, StackTestSuite)]
 -> [(StackUnqualCompName, TestSuiteInterface)])
-> ((StackTestSuite -> TestSuiteInterface)
    -> (StackUnqualCompName, StackTestSuite)
    -> (StackUnqualCompName, TestSuiteInterface))
-> (StackTestSuite -> TestSuiteInterface)
-> [(StackUnqualCompName, StackTestSuite)]
-> [(StackUnqualCompName, TestSuiteInterface)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StackTestSuite -> TestSuiteInterface)
-> (StackUnqualCompName, StackTestSuite)
-> (StackUnqualCompName, TestSuiteInterface)
forall a b.
(a -> b) -> (StackUnqualCompName, a) -> (StackUnqualCompName, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) (.interface) ([(StackUnqualCompName, StackTestSuite)]
 -> [(StackUnqualCompName, TestSuiteInterface)])
-> (CompCollection StackTestSuite
    -> [(StackUnqualCompName, StackTestSuite)])
-> CompCollection StackTestSuite
-> [(StackUnqualCompName, TestSuiteInterface)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CompCollection StackTestSuite
-> [(StackUnqualCompName, StackTestSuite)]
forall component.
CompCollection component -> [(StackUnqualCompName, component)]
collectionKeyValueList)
                      Package
package.testSuites
                , let testName :: StackUnqualCompName
testName = (StackUnqualCompName, TestSuiteInterface) -> StackUnqualCompName
forall a b. (a, b) -> a
fst (StackUnqualCompName, TestSuiteInterface)
testSuitePair
                , StackUnqualCompName
testName StackUnqualCompName -> [StackUnqualCompName] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [StackUnqualCompName]
testsToRun
                ]

        errs <- fmap Map.unions $ forM suitesToRun $ \(StackUnqualCompName
testName, TestSuiteInterface
suiteInterface) -> do
          let stestName :: [Char]
stestName = StackUnqualCompName -> [Char]
unqualCompToString StackUnqualCompName
testName
          (testName', isTestTypeLib) <-
            case TestSuiteInterface
suiteInterface of
              C.TestSuiteLibV09{} -> ([Char], Bool) -> RIO env ([Char], Bool)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char]
stestName [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"Stub", Bool
True)
              C.TestSuiteExeV10{} -> ([Char], Bool) -> RIO env ([Char], Bool)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char]
stestName, Bool
False)
              TestSuiteInterface
interface -> BuildException -> RIO env ([Char], Bool)
forall e a. (?callStack::CallStack, Exception e) => e -> RIO env a
forall (m :: * -> *) e a.
(MonadThrow m, ?callStack::CallStack, Exception e) =>
e -> m a
throwM (TestSuiteInterface -> BuildException
TestSuiteTypeUnsupported TestSuiteInterface
interface)

          let exeName = [Char]
testName' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                case Config
config.platform of
                  Platform Arch
_ OS
Windows -> [Char]
".exe"
                  Platform
_ -> [Char]
""
          tixPath <- fmap (pkgDir </>) $ parseRelFile $ exeName ++ ".tix"
          exePath <-
            fmap (buildDir </>) $ parseRelFile $
              "build/" ++ testName' ++ "/" ++ exeName
          exists <- doesFileExist 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

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

          thGhcId <-
            case L.find ((== "template-haskell") . pkgName . (.packageIdent) . snd)
                   (Map.toList ee.globalDumpPkgs) of
              Just (GhcPkgId
ghcId, DumpPackage
_) -> GhcPkgId -> RIO env GhcPkgId
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GhcPkgId
ghcId
              Maybe (GhcPkgId, DumpPackage)
Nothing -> BuildException -> RIO env GhcPkgId
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 [Char]
f ProcessContext
pc = ProcessContext -> (EnvVars -> EnvVars) -> IO ProcessContext
forall (m :: * -> *).
MonadIO m =>
ProcessContext -> (EnvVars -> EnvVars) -> m ProcessContext
modifyEnvVars ProcessContext
pc ((EnvVars -> EnvVars) -> IO ProcessContext)
-> (EnvVars -> EnvVars) -> IO ProcessContext
forall a b. (a -> b) -> a -> b
$ \EnvVars
envVars ->
                Text -> Text -> EnvVars -> EnvVars
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
"HASKELL_DIST_DIR" ([Char] -> Text
T.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ Path Abs Dir -> [Char]
forall b t. Path b t -> [Char]
toFilePath Path Abs Dir
buildDir) (EnvVars -> EnvVars) -> EnvVars -> EnvVars
forall a b. (a -> b) -> a -> b
$
                Text -> Text -> EnvVars -> EnvVars
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
"GHC_ENVIRONMENT" ([Char] -> Text
T.pack [Char]
f) EnvVars
envVars
              fp' = ExecuteEnv
ee.tempDir Path Abs Dir -> Path Rel File -> Path Abs File
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

          randomInt <- liftIO (randomIO :: IO Int)
          let randomSuffix = [Char]
"." [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show (Int -> Int
forall a. Num a => a -> a
abs Int
randomInt)
          fp <- toFilePath <$> addExtension randomSuffix fp'
          let snapDBPath =
                Path Abs Dir -> [Char]
forall loc. Path loc Dir -> [Char]
toFilePathNoTrailingSep ExecuteEnv
ee.baseConfigOpts.snapDB
              localDBPath =
                Path Abs Dir -> [Char]
forall loc. Path loc Dir -> [Char]
toFilePathNoTrailingSep ExecuteEnv
ee.baseConfigOpts.localDB
              ghcEnv =
                   Utf8Builder
"clear-package-db\n"
                Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"global-package-db\n"
                Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"package-db "
                Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> [Char] -> Utf8Builder
forall a. IsString a => [Char] -> a
fromString [Char]
snapDBPath
                Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"\n"
                Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"package-db "
                Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> [Char] -> Utf8Builder
forall a. IsString a => [Char] -> a
fromString [Char]
localDBPath
                Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"\n"
                Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> (GhcPkgId -> Utf8Builder) -> [GhcPkgId] -> Utf8Builder
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
                     ( \GhcPkgId
ghcId ->
                            Utf8Builder
"package-id "
                         Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display (GhcPkgId -> Text
ghcPkgIdToText GhcPkgId
ghcId)
                         Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"\n"
                     )
                     ([GhcPkgId]
pkgGhcIdList [GhcPkgId] -> [GhcPkgId] -> [GhcPkgId]
forall a. [a] -> [a] -> [a]
++ GhcPkgId
thGhcIdGhcPkgId -> [GhcPkgId] -> [GhcPkgId]
forall a. a -> [a] -> [a]
:Map PackageIdentifier GhcPkgId -> [GhcPkgId]
forall k a. Map k a -> [a]
Map.elems Map PackageIdentifier GhcPkgId
allDepsMap)
          writeFileUtf8Builder fp ghcEnv
          menv <- liftIO $
            setEnv fp =<< config.processContextSettings EnvSettings
              { includeLocals = taskLocation task == Local
              , includeGhcPackagePath = True
              , stackExe = True
              , localeUtf8 = False
              , keepGhcRts = False
              }
          let emptyResult = StackUnqualCompName
-> Maybe ExitCode -> Map StackUnqualCompName (Maybe ExitCode)
forall k a. k -> a -> Map k a
Map.singleton StackUnqualCompName
testName Maybe ExitCode
forall a. Maybe a
Nothing
          withProcessContext menv $ if exists
            then do
                -- We clear out the .tix files before doing a run.

                when needHpc $ do
                  tixexists <- doesFileExist tixPath
                  when tixexists $
                    prettyWarnL
                      [ flow "Removing HPC file"
                      , pretty tixPath <> "."
                      ]
                  liftIO $ ignoringAbsence (removeFile tixPath)

                let args = TestOpts
topts.additionalArgs
                    argsDisplay = case [[Char]]
args of
                      [] -> Text
""
                      [[Char]]
_ ->    Text
", args: "
                           Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
" " (([Char] -> Text) -> [[Char]] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Text
showProcessArgDebug [[Char]]
args)
                announce $
                     "test (suite: "
                  <> display (unqualCompToText testName)
                  <> display argsDisplay
                  <> ")"

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

                -- redirecting output.

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

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

                mec <- withWorkingDir (toFilePath pkgDir) $
                  optionalTimeout $ proc (toFilePath exePath) args $ \ProcessConfig () () ()
pc0 -> do
                    changeStdin <-
                      if Bool
isTestTypeLib
                        then do
                          logPath <- Package -> Maybe [Char] -> RIO env (Path Abs File)
forall env (m :: * -> *).
(MonadReader env m, HasBuildConfig env, MonadThrow m) =>
Package -> Maybe [Char] -> m (Path Abs File)
buildLogPath Package
package ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
stestName)
                          ensureDir (parent logPath)
                          pure $
                              setStdin
                            $ byteStringInput
                            $ BL.fromStrict
                            $ encodeUtf8 $ fromString $
                            show ( logPath
                                 , toCabalName testName
                                 )
                        else do
                          isTerminal <- Getting Bool env Bool -> RIO env Bool
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting Bool env Bool -> RIO env Bool)
-> Getting Bool env Bool -> RIO env Bool
forall a b. (a -> b) -> a -> b
$ (GlobalOpts -> Const Bool GlobalOpts) -> env -> Const Bool env
forall env. HasRunner env => Lens' env GlobalOpts
Lens' env GlobalOpts
globalOptsL ((GlobalOpts -> Const Bool GlobalOpts) -> env -> Const Bool env)
-> ((Bool -> Const Bool Bool)
    -> GlobalOpts -> Const Bool GlobalOpts)
-> Getting Bool env Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GlobalOpts -> Bool) -> SimpleGetter GlobalOpts Bool
forall s a. (s -> a) -> SimpleGetter s a
to (.terminal)
                          if topts.allowStdin && isTerminal
                            then pure id
                            else pure $ setStdin $ byteStringInput mempty
                    let pc = ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))
-> ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))
changeStdin
                           (ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))
 -> ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ())))
-> ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))
-> ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))
forall a b. (a -> b) -> a -> b
$ StreamSpec 'STOutput (Maybe (RIO env ()))
-> ProcessConfig () () (Maybe (RIO env ()))
-> ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))
forall stdout stdin stdout0 stderr.
StreamSpec 'STOutput stdout
-> ProcessConfig stdin stdout0 stderr
-> ProcessConfig stdin stdout stderr
setStdout StreamSpec 'STOutput (Maybe (RIO env ()))
output
                           (ProcessConfig () () (Maybe (RIO env ()))
 -> ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ())))
-> ProcessConfig () () (Maybe (RIO env ()))
-> ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))
forall a b. (a -> b) -> a -> b
$ StreamSpec 'STOutput (Maybe (RIO env ()))
-> ProcessConfig () () ()
-> ProcessConfig () () (Maybe (RIO env ()))
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
                    withProcessWait pc $ \Process () (Maybe (RIO env ())) (Maybe (RIO env ()))
p -> do
                      case (Process () (Maybe (RIO env ())) (Maybe (RIO env ()))
-> Maybe (RIO env ())
forall stdin stdout stderr. Process stdin stdout stderr -> stdout
getStdout Process () (Maybe (RIO env ())) (Maybe (RIO env ()))
p, Process () (Maybe (RIO env ())) (Maybe (RIO env ()))
-> Maybe (RIO env ())
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) -> () -> RIO env ()
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                        (Just RIO env ()
x, Just RIO env ()
y) -> RIO env () -> RIO env () -> RIO env ()
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) -> Bool -> RIO env () -> RIO env ()
forall a. (?callStack::CallStack) => Bool -> a -> a
assert Bool
False (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
                          RIO env () -> RIO env () -> RIO env ()
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m ()
concurrently_
                            (RIO env () -> Maybe (RIO env ()) -> RIO env ()
forall a. a -> Maybe a -> a
fromMaybe (() -> RIO env ()
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) Maybe (RIO env ())
x)
                            (RIO env () -> Maybe (RIO env ()) -> RIO env ()
forall a. a -> Maybe a -> a
fromMaybe (() -> RIO env ()
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) Maybe (RIO env ())
y)
                      Process () (Maybe (RIO env ())) (Maybe (RIO env ()))
-> RIO env ExitCode
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 of
                  OTConsole Maybe Utf8Builder
Nothing -> StyleDoc -> RIO env ()
forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
 MonadIO m) =>
StyleDoc -> m ()
prettyInfo StyleDoc
blankLine
                  OutputType
_ -> () -> RIO env ()
forall a. a -> RIO env a
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.

                when needHpc $
                  updateTixFile package.name tixPath testName'
                let announceResult Utf8Builder
result =
                      Utf8Builder -> RIO env ()
announce (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$
                           Utf8Builder
"Test suite "
                        Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display (StackUnqualCompName -> Text
unqualCompToText StackUnqualCompName
testName)
                        Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" "
                        Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
result
                case mec of
                  Just ExitCode
ExitSuccess -> do
                    Utf8Builder -> RIO env ()
announceResult Utf8Builder
"passed"
                    Map StackUnqualCompName (Maybe ExitCode)
-> RIO env (Map StackUnqualCompName (Maybe ExitCode))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map StackUnqualCompName (Maybe ExitCode)
forall k a. Map k a
Map.empty
                  Maybe ExitCode
Nothing -> do
                    Utf8Builder -> RIO env ()
announceResult Utf8Builder
"timed out"
                    if Bool
expectFailure
                    then Map StackUnqualCompName (Maybe ExitCode)
-> RIO env (Map StackUnqualCompName (Maybe ExitCode))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map StackUnqualCompName (Maybe ExitCode)
forall k a. Map k a
Map.empty
                    else Map StackUnqualCompName (Maybe ExitCode)
-> RIO env (Map StackUnqualCompName (Maybe ExitCode))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map StackUnqualCompName (Maybe ExitCode)
 -> RIO env (Map StackUnqualCompName (Maybe ExitCode)))
-> Map StackUnqualCompName (Maybe ExitCode)
-> RIO env (Map StackUnqualCompName (Maybe ExitCode))
forall a b. (a -> b) -> a -> b
$ StackUnqualCompName
-> Maybe ExitCode -> Map StackUnqualCompName (Maybe ExitCode)
forall k a. k -> a -> Map k a
Map.singleton StackUnqualCompName
testName Maybe ExitCode
forall a. Maybe a
Nothing
                  Just ExitCode
ec -> do
                    Utf8Builder -> RIO env ()
announceResult Utf8Builder
"failed"
                    if Bool
expectFailure
                    then Map StackUnqualCompName (Maybe ExitCode)
-> RIO env (Map StackUnqualCompName (Maybe ExitCode))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map StackUnqualCompName (Maybe ExitCode)
forall k a. Map k a
Map.empty
                    else Map StackUnqualCompName (Maybe ExitCode)
-> RIO env (Map StackUnqualCompName (Maybe ExitCode))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map StackUnqualCompName (Maybe ExitCode)
 -> RIO env (Map StackUnqualCompName (Maybe ExitCode)))
-> Map StackUnqualCompName (Maybe ExitCode)
-> RIO env (Map StackUnqualCompName (Maybe ExitCode))
forall a b. (a -> b) -> a -> b
$ StackUnqualCompName
-> Maybe ExitCode -> Map StackUnqualCompName (Maybe ExitCode)
forall k a. k -> a -> Map k a
Map.singleton StackUnqualCompName
testName (ExitCode -> Maybe ExitCode
forall a. a -> Maybe a
Just ExitCode
ec)
              else do
                unless expectFailure $
                  logError $
                    displayShow $ TestSuiteExeMissing
                      (package.buildType == C.Simple)
                      exeName
                      (packageNameString package.name)
                      (unqualCompToString testName)
                pure emptyResult

        when needHpc $ do
          let testsToRun' = (StackUnqualCompName -> Text) -> [StackUnqualCompName] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map StackUnqualCompName -> Text
f [StackUnqualCompName]
testsToRun
              f StackUnqualCompName
tName =
                case (.interface) (StackTestSuite -> TestSuiteInterface)
-> Maybe StackTestSuite -> Maybe TestSuiteInterface
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe StackTestSuite
mComponent of
                  Just C.TestSuiteLibV09{} -> StackUnqualCompName -> Text
unqualCompToText StackUnqualCompName
tName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"Stub"
                  Maybe TestSuiteInterface
_ -> StackUnqualCompName -> Text
unqualCompToText StackUnqualCompName
tName
               where
                mComponent :: Maybe StackTestSuite
mComponent = StackUnqualCompName
-> CompCollection StackTestSuite -> Maybe StackTestSuite
forall component.
StackUnqualCompName -> CompCollection component -> Maybe component
collectionLookup StackUnqualCompName
tName Package
package.testSuites
          generateHpcReport pkgDir package testsToRun'

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

        let succeeded = Map StackUnqualCompName (Maybe ExitCode) -> Bool
forall k a. Map k a -> Bool
Map.null Map StackUnqualCompName (Maybe ExitCode)
errs
        unless (succeeded || expectFailure) $
          throwM $ TestSuiteFailure
            (taskProvides task)
            errs
            (case outputType of
               OTLogFile Path Abs File
fp Handle
_ -> Path Abs File -> Maybe (Path Abs File)
forall a. a -> Maybe a
Just Path Abs File
fp
               OTConsole Maybe Utf8Builder
_ -> Maybe (Path Abs File)
forall a. Maybe a
Nothing)
            bs

        setTestStatus pkgDir $ if succeeded then TSSuccess else TSFailure

-- | Implements running a package's benchmarks.

singleBench ::
     HasEnvConfig env
  => BenchmarkOpts
  -> [StackUnqualCompName]
  -> ActionContext
  -> ExecuteEnv
  -> Task
  -> InstalledMap
  -> RIO env ()
singleBench :: forall env.
HasEnvConfig env =>
BenchmarkOpts
-> [StackUnqualCompName]
-> ActionContext
-> ExecuteEnv
-> Task
-> InstalledMap
-> RIO env ()
singleBench BenchmarkOpts
beopts [StackUnqualCompName]
benchesToRun ActionContext
ac ExecuteEnv
ee Task
task InstalledMap
installedMap = do
  (allDepsMap, _cache) <- ExecuteEnv
-> Task
-> InstalledMap
-> Bool
-> Bool
-> RIO env (Map PackageIdentifier GhcPkgId, ConfigCache)
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
  withSingleContext ac ee task.taskType allDepsMap (Just "bench") $
    \Package
_package Path Abs File
_cabalfp Path Abs Dir
_pkgDir KeepOutputOpen -> ExcludeTHLoading -> [[Char]] -> RIO env ()
cabal Utf8Builder -> RIO env ()
announce OutputType
_outputType -> do
      let args :: [[Char]]
args = (StackUnqualCompName -> [Char])
-> [StackUnqualCompName] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map StackUnqualCompName -> [Char]
unqualCompToString [StackUnqualCompName]
benchesToRun [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [[Char]] -> ([Char] -> [[Char]]) -> Maybe [Char] -> [[Char]]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe []
                       (([Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
:[]) ([Char] -> [[Char]]) -> ([Char] -> [Char]) -> [Char] -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
"--benchmark-options=" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<>))
                       BenchmarkOpts
beopts.additionalArgs
      toRun <-
        if BenchmarkOpts
beopts.runBenchmarks
          then Bool -> RIO env Bool
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
          else BuildPrettyException -> RIO env Bool
forall e (m :: * -> *) a.
(Exception e, MonadThrow m, Pretty e) =>
e -> m a
prettyThrowM (BuildPrettyException -> RIO env Bool)
-> BuildPrettyException -> RIO env Bool
forall a b. (a -> b) -> a -> b
$ StyleDoc -> BuildPrettyException
ActionNotFilteredBug StyleDoc
"singleBench"
      when toRun $ do
        announce "benchmarks"
        cabal CloseOnException KeepTHLoading ("bench" : args)

-- 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 [[Char]]
extraBuildOptions WhichCompiler
wc BuildOpts
bopts = do
  colorOpt <- RIO env (Maybe [Char])
forall env.
(HasEnvConfig env, HasRunner env) =>
RIO env (Maybe [Char])
appropriateGhcColorFlag
  let optsFlag = WhichCompiler -> [Char]
compilerOptionsCabalFlag WhichCompiler
wc
      baseOpts = [Char] -> ([Char] -> [Char]) -> Maybe [Char] -> [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"" ([Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++) Maybe [Char]
colorOpt
  if bopts.testOpts.coverage
    then do
      hpcIndexDir <- toFilePathNoTrailingSep <$> hpcRelativeDir
      pure [optsFlag, "-hpcdir " ++ hpcIndexDir ++ baseOpts]
    else
      pure [optsFlag, baseOpts]

-- Library, sub-library, foreign library and executable build components.

primaryComponentOptions :: LocalPackage -> [String]
primaryComponentOptions :: LocalPackage -> [[Char]]
primaryComponentOptions LocalPackage
lp =
  -- TODO: get this information from target parsing instead, which will allow

  -- users to turn off library building if desired

     ( if Package -> Bool
hasBuildableMainLibrary Package
package
         then (Text -> [Char]) -> [Text] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Text -> [Char]
T.unpack
           ([Text] -> [[Char]]) -> [Text] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text
T.append Text
"lib:" ([Char] -> Text
T.pack (PackageName -> [Char]
packageNameString Package
package.name))
           Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map
               (Text -> Text -> Text
T.append Text
"flib:")
               (CompCollection StackForeignLibrary -> [Text]
forall component. CompCollection component -> [Text]
getBuildableListText Package
package.foreignLibraries)
         else []
     )
  [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ (Text -> [Char]) -> [Text] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map
       (Text -> [Char]
T.unpack (Text -> [Char]) -> (Text -> Text) -> Text -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text
T.append Text
"lib:")
       (CompCollection StackLibrary -> [Text]
forall component. CompCollection component -> [Text]
getBuildableListText Package
package.subLibraries)
  [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ Set [Char] -> [[Char]]
forall a. Set a -> [a]
Set.toList
       ( (StackUnqualCompName -> [Char])
-> Set StackUnqualCompName -> Set [Char]
forall a b. (a -> b) -> Set a -> Set b
Set.mapMonotonic
           (\StackUnqualCompName
s -> [Char]
"exe:" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ StackUnqualCompName -> [Char]
unqualCompToString StackUnqualCompName
s)
           (LocalPackage -> Set StackUnqualCompName
exesToBuild LocalPackage
lp)
       )
 where
  package :: Package
package = LocalPackage
lp.package

-- | Either build all executables or, if the user specifies requested

-- components, just build them.

exesToBuild :: LocalPackage -> Set StackUnqualCompName
exesToBuild :: LocalPackage -> Set StackUnqualCompName
exesToBuild LocalPackage
lp = if LocalPackage
lp.wanted
  then Set NamedComponent -> Set StackUnqualCompName
exeComponents LocalPackage
lp.components
  else Package -> Set StackUnqualCompName
buildableExes LocalPackage
lp.package

-- Test-suite and benchmark build components.

finalComponentOptions :: LocalPackage -> [String]
finalComponentOptions :: LocalPackage -> [[Char]]
finalComponentOptions LocalPackage
lp =
  (NamedComponent -> [Char]) -> [NamedComponent] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> [Char]
T.unpack (Text -> [Char])
-> (NamedComponent -> Text) -> NamedComponent -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamedComponent -> Text
renderComponent) ([NamedComponent] -> [[Char]]) -> [NamedComponent] -> [[Char]]
forall a b. (a -> b) -> a -> b
$
  Set NamedComponent -> [NamedComponent]
forall a. Set a -> [a]
Set.toList (Set NamedComponent -> [NamedComponent])
-> Set NamedComponent -> [NamedComponent]
forall a b. (a -> b) -> a -> b
$
  (NamedComponent -> Bool)
-> Set NamedComponent -> Set NamedComponent
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
lp.components

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

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

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

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

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 =
      RIO env b -> RIO env (Either SomeException b)
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny RIO env b
action RIO env (Either SomeException b)
-> (Either SomeException b -> RIO env b) -> RIO env b
forall a b. RIO env a -> (a -> RIO env b) -> RIO env b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Right b
res -> do
          [StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
 MonadIO m) =>
[StyleDoc] -> m ()
prettyWarnL
            [ Style -> StyleDoc -> StyleDoc
style Style
Current (PackageName -> StyleDoc
forall a. IsString a => PackageName -> a
fromPackageName PackageName
pname) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
":"
            , [Char] -> StyleDoc
flow [Char]
"unexpected test build success."
            ]
          b -> RIO env b
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
res
        Left SomeException
_ -> b -> RIO env b
forall a. a -> RIO env a
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 =
      RIO env b -> RIO env (Either SomeException b)
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny RIO env b
action RIO env (Either SomeException b)
-> (Either SomeException b -> RIO env b) -> RIO env b
forall a b. RIO env a -> (a -> RIO env b) -> RIO env b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Right b
res -> do
          [StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
 MonadIO m) =>
[StyleDoc] -> m ()
prettyWarnL
            [ Style -> StyleDoc -> StyleDoc
style Style
Current (PackageName -> StyleDoc
forall a. IsString a => PackageName -> a
fromPackageName PackageName
pname) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
":"
            , [Char] -> StyleDoc
flow [Char]
"unexpected benchmark build success."
            ]
          b -> RIO env b
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
res
        Left SomeException
_ -> b -> RIO env b
forall a. a -> RIO env a
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