{-# LANGUAGE NoImplicitPrelude     #-}
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase            #-}
{-# 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.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, mainLibraryHasExposedModules
                   )
import           Stack.PackageDump ( conduitDumpPackage, ghcPkgDescribe )
import           Stack.Prelude
import           Stack.Types.Build
                   ( ConfigCache (..), PrecompiledCache (..), Task (..)
                   , TaskConfigOpts (..), TaskType (..), taskIsTarget
                   , taskLocation, taskProvides, taskTargetIsMutable
                   , taskTypePackageIdentifier
                   )
import qualified Stack.Types.Build as ConfigCache ( ConfigCache (..) )
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.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 qualified Stack.Types.ConfigureOpts as 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.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 ConfigCache

getConfigCache ::
     HasEnvConfig env
  => ExecuteEnv
  -> Task
  -> InstalledMap
  -> Bool
  -> Bool
  -> RIO env (Map PackageIdentifier GhcPkgId, ConfigCache)
getConfigCache :: forall env.
HasEnvConfig env =>
ExecuteEnv
-> Task
-> InstalledMap
-> Bool
-> Bool
-> RIO env (Map PackageIdentifier GhcPkgId, ConfigCache)
getConfigCache ExecuteEnv
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{} -> []
  Map PackageIdentifier Installed
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 -> RIO env (Map PackageIdentifier GhcPkgId)
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 :: TaskConfigOpts
cOpts = Task
task.configOpts
  [Map PackageIdentifier GhcPkgId]
missingMapList <- (PackageIdentifier -> RIO env (Map PackageIdentifier GhcPkgId))
-> [PackageIdentifier] -> RIO env [Map PackageIdentifier GhcPkgId]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse PackageIdentifier -> RIO env (Map PackageIdentifier GhcPkgId)
getMissing ([PackageIdentifier] -> RIO env [Map PackageIdentifier GhcPkgId])
-> [PackageIdentifier] -> RIO env [Map PackageIdentifier GhcPkgId]
forall a b. (a -> b) -> a -> b
$ Set PackageIdentifier -> [PackageIdentifier]
forall a. Set a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList TaskConfigOpts
cOpts.missing
  let pcOpts :: PackageConfigureOpts
pcOpts = TaskConfigOpts
cOpts.pkgConfigOpts
      missing' :: Map PackageIdentifier GhcPkgId
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
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' :: ConfigureOpts
configureOpts' = EnvConfig
-> BaseConfigOpts
-> Map PackageIdentifier GhcPkgId
-> Bool
-> IsMutable
-> PackageConfigureOpts
-> ConfigureOpts
ConfigureOpts.configureOpts
        TaskConfigOpts
cOpts.envConfig
        TaskConfigOpts
cOpts.baseConfigOpts
        Map PackageIdentifier GhcPkgId
allDepsMap
        TaskConfigOpts
cOpts.isLocalNonExtraDep
        TaskConfigOpts
cOpts.isMutable
        PackageConfigureOpts
pcOpts
      configureOpts :: ConfigureOpts
configureOpts = ConfigureOpts
configureOpts'
        { nonPathRelated = configureOpts'.nonPathRelated ++ map T.unpack extra }
      deps :: Set GhcPkgId
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 :: Set ByteString
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
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
        }
  (Map PackageIdentifier GhcPkgId, ConfigCache)
-> RIO env (Map PackageIdentifier GhcPkgId, ConfigCache)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map PackageIdentifier GhcPkgId
allDepsMap, ConfigCache
cache)

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

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

  -> Path Abs Dir
     -- ^ package directory

  -> 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
  CTime
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)
  Path Abs File
setupConfigfp <- Path Abs Dir -> RIO env (Path Abs File)
forall env (m :: * -> *).
(HasEnvConfig env, MonadReader env m, MonadThrow m) =>
Path Abs Dir -> m (Path Abs File)
setupConfigFromDir Path Abs Dir
pkgDir
  let getNewSetupConfigMod :: RIO env (Maybe CTime)
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))
  Maybe CTime
newSetupConfigMod <- RIO env (Maybe CTime)
getNewSetupConfigMod
  ByteString
newConfigFileRoot <- [Char] -> ByteString
S8.pack ([Char] -> ByteString)
-> (Path Abs Dir -> [Char]) -> Path Abs Dir -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs Dir -> [Char]
forall b t. Path b t -> [Char]
toFilePath (Path Abs Dir -> ByteString)
-> RIO env (Path Abs Dir) -> RIO env ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting (Path Abs Dir) env (Path Abs Dir) -> RIO env (Path Abs Dir)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Path Abs Dir) env (Path Abs Dir)
forall env r. HasBuildConfig env => Getting r env (Path Abs Dir)
configFileRootL
  Bool
needConfig <-
    if BuildOpts
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 Bool -> RIO env Bool
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
      else do
        -- We can ignore the components portion of the config

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

        -- plan that we need to plan to build additional

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

        -- package configuration.

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

        -- determine if we need to reconfigure.

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

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

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

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

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

        Bool -> RIO env Bool
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> RIO env Bool) -> Bool -> RIO env Bool
forall a b. (a -> b) -> a -> b
$
                (ConfigCache -> ConfigCache)
-> Maybe ConfigCache -> Maybe ConfigCache
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ConfigCache -> ConfigCache
ignoreComponents Maybe ConfigCache
mOldConfigCache
             Maybe ConfigCache -> Maybe ConfigCache -> Bool
forall a. Eq a => a -> a -> Bool
/= ConfigCache -> Maybe ConfigCache
forall a. a -> Maybe a
Just (ConfigCache -> ConfigCache
ignoreComponents ConfigCache
newConfigCache)
          Bool -> Bool -> Bool
|| Maybe CTime
mOldCabalMod Maybe CTime -> Maybe CTime -> Bool
forall a. Eq a => a -> a -> Bool
/= CTime -> Maybe CTime
forall a. a -> Maybe a
Just CTime
newCabalMod
          Bool -> Bool -> Bool
|| Maybe CTime
mOldSetupConfigMod Maybe CTime -> Maybe CTime -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe CTime
newSetupConfigMod
          Bool -> Bool -> Bool
|| Maybe ByteString
mOldProjectRoot Maybe ByteString -> Maybe ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
newConfigFileRoot

  Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Task
task.buildTypeConfig (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
    -- 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

    Path Abs Dir -> RIO env ()
forall env b.
(HasProcessContext env, HasTerm env) =>
Path b Dir -> RIO env ()
ensureConfigureScript Path Abs Dir
pkgDir

  Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
needConfig (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
    Path Abs Dir -> RIO env ()
forall env. HasEnvConfig env => Path Abs Dir -> RIO env ()
deleteCaches Path Abs Dir
pkgDir
    RIO env ()
announce
    CompilerPaths
cp <- Getting CompilerPaths env CompilerPaths -> RIO env CompilerPaths
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting CompilerPaths env CompilerPaths
forall env. HasCompiler env => SimpleGetter env CompilerPaths
SimpleGetter env CompilerPaths
compilerPathsL
    let (GhcPkgExe Path Abs File
pkgPath) = CompilerPaths
cp.pkg
    let programNames :: [([Char], [Char])]
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)
              ]
    [[[Char]]]
exes <- [([Char], [Char])]
-> (([Char], [Char]) -> RIO env [[Char]]) -> RIO env [[[Char]]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [([Char], [Char])]
programNames ((([Char], [Char]) -> RIO env [[Char]]) -> RIO env [[[Char]]])
-> (([Char], [Char]) -> RIO env [[Char]]) -> RIO env [[[Char]]]
forall a b. (a -> b) -> a -> b
$ \([Char]
name, [Char]
file) -> do
      Either ProcessException [Char]
mpath <- [Char] -> RIO env (Either ProcessException [Char])
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasProcessContext env) =>
[Char] -> m (Either ProcessException [Char])
findExecutable [Char]
file
      [[Char]] -> RIO env [[Char]]
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([[Char]] -> RIO env [[Char]]) -> [[Char]] -> RIO env [[Char]]
forall a b. (a -> b) -> a -> b
$ case Either ProcessException [Char]
mpath of
        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]]
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]]
ConfigureOpts.renderConfigureOpts ConfigCache
newConfigCache.configureOpts
    -- Configure cabal with arguments determined by

    -- Stack.Types.Build.configureOpts

    ExcludeTHLoading -> [[Char]] -> RIO env ()
cabal ExcludeTHLoading
KeepTHLoading ([[Char]] -> RIO env ()) -> [[Char]] -> RIO env ()
forall a b. (a -> b) -> a -> b
$ [Char]
"configure" [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]]
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
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 ()
    Path Abs Dir -> CTime -> RIO env ()
forall env. HasEnvConfig env => Path Abs Dir -> CTime -> RIO env ()
writeCabalMod Path Abs Dir
pkgDir CTime
newCabalMod
    -- This file gets updated one more time by the configure step, so get the

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

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

    -- reasonable too.

    RIO env (Maybe CTime)
getNewSetupConfigMod RIO env (Maybe CTime) -> (Maybe CTime -> 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
>>= Path Abs Dir -> Maybe CTime -> RIO env ()
forall env.
HasEnvConfig env =>
Path Abs Dir -> Maybe CTime -> RIO env ()
writeSetupConfigMod Path Abs Dir
pkgDir
    Path Abs Dir -> ByteString -> RIO env ()
forall env.
HasEnvConfig env =>
Path Abs Dir -> ByteString -> RIO env ()
writePackageProjectRoot Path Abs Dir
pkgDir ByteString
newConfigFileRoot
  Bool -> RIO env Bool
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
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. 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
    (Map PackageIdentifier GhcPkgId
allDepsMap, ConfigCache
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 :: Path Abs Dir
bcoSnapInstallRoot = ExecuteEnv
ee.baseConfigOpts.snapInstallRoot
    Maybe (PrecompiledCache Abs)
mprecompiled <- ConfigCache
-> TaskType
-> Path Abs Dir
-> RIO env (Maybe (PrecompiledCache Abs))
forall env.
HasEnvConfig env =>
ConfigCache
-> TaskType
-> Path Abs Dir
-> RIO env (Maybe (PrecompiledCache Abs))
getPrecompiled ConfigCache
cache Task
task.taskType Path Abs Dir
bcoSnapInstallRoot
    Maybe Installed
minstalled <-
      case Maybe (PrecompiledCache Abs)
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
          Maybe Curator
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)
          ActionContext
-> ExecuteEnv
-> Task
-> InstalledMap
-> (Bool, Bool)
-> (Bool, Bool)
-> ConfigCache
-> Maybe Curator
-> Map PackageIdentifier GhcPkgId
-> RIO env (Maybe Installed)
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
            InstalledMap
installedMap
            (Bool
enableTests, Bool
enableBenchmarks)
            (Bool
isFinalBuild, Bool
buildingFinals)
            ConfigCache
cache
            Maybe Curator
curator
            Map PackageIdentifier GhcPkgId
allDepsMap
    Maybe Installed -> (Installed -> RIO env ()) -> RIO env ()
forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe Installed
minstalled ((Installed -> RIO env ()) -> RIO env ())
-> (Installed -> RIO env ()) -> RIO env ()
forall a b. (a -> b) -> a -> b
$ \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
        Bool
_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 :: 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 ( ExecuteEnv
ee.buildOptsCLI.onlyConfigure
             , ExecuteEnv
ee.buildOptsCLI.initialBuildSteps Bool -> Bool -> Bool
&& Task -> Bool
taskIsTarget Task
task
             ) of
          -- A full build is done if there are downstream actions,

          -- because their configure step will require that this

          -- package is built. See

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

          (Bool
True, Bool
_) | [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 -> Package -> Bool
doHaddock Maybe Curator
curator Package
package =
       Task
task.buildHaddocks
    Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
isFinalBuild
       -- Works around haddock failing on bytestring-builder since it has no

       -- modules when bytestring is new enough.

    Bool -> Bool -> Bool
&& Package -> Bool
mainLibraryHasExposedModules Package
package
       -- 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
    WhichCompiler
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

    InstallLocation -> PackageIdentifier -> RIO env ()
forall env.
HasEnvConfig env =>
InstallLocation -> PackageIdentifier -> RIO env ()
markExeNotInstalled (Task -> InstallLocation
taskLocation Task
task) PackageIdentifier
pkgId
    case Task
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
        Map NamedComponent (Map [Char] FileCacheInfo)
caches <- MemoizedWith
  EnvConfig (Map NamedComponent (Map [Char] FileCacheInfo))
-> RIO env (Map NamedComponent (Map [Char] FileCacheInfo))
forall env (m :: * -> *) a.
(HasEnvConfig env, MonadReader env m, MonadIO m) =>
MemoizedWith EnvConfig a -> m a
runMemoizedWith LocalPackage
lp.newBuildCaches
        ((NamedComponent, Map [Char] FileCacheInfo) -> RIO env ())
-> [(NamedComponent, Map [Char] FileCacheInfo)] -> RIO env ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_
          ((NamedComponent -> Map [Char] FileCacheInfo -> RIO env ())
-> (NamedComponent, Map [Char] FileCacheInfo) -> RIO env ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Path Abs Dir
-> NamedComponent -> Map [Char] FileCacheInfo -> RIO env ()
forall env.
HasEnvConfig env =>
Path Abs Dir
-> NamedComponent -> Map [Char] FileCacheInfo -> RIO env ()
writeBuildCache Path Abs Dir
pkgDir))
          (Map NamedComponent (Map [Char] FileCacheInfo)
-> [(NamedComponent, Map [Char] FileCacheInfo)]
forall k a. Map k a -> [(k, a)]
Map.toList Map NamedComponent (Map [Char] FileCacheInfo)
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 -> RIO env ()
postBuildCheck Bool
_succeeded = do
          Maybe (Path Abs File, [PackageWarning])
mlocalWarnings <- case Task
task.taskType of
            TTLocalMutable LocalPackage
lp -> do
                [PackageWarning]
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?

                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 ((Path Abs File, [PackageWarning])
-> Maybe (Path Abs File, [PackageWarning])
forall a. a -> Maybe a
Just (LocalPackage
lp.cabalFP, [PackageWarning]
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 :: PackageWarning -> StyleDoc
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
                         )
          Maybe (Path Abs File, [PackageWarning])
-> ((Path Abs File, [PackageWarning]) -> RIO env ()) -> RIO env ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (Path Abs File, [PackageWarning])
mlocalWarnings (((Path Abs File, [PackageWarning]) -> RIO env ()) -> RIO env ())
-> ((Path Abs File, [PackageWarning]) -> RIO env ()) -> RIO env ()
forall a b. (a -> b) -> a -> b
$ \(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
actualCompiler <- Getting ActualCompiler env ActualCompiler -> RIO env ActualCompiler
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting ActualCompiler env ActualCompiler
forall env. HasSourceMap env => SimpleGetter env ActualCompiler
SimpleGetter env ActualCompiler
actualCompilerVersionL
    () <- Utf8Builder -> RIO env ()
announce
      (  Utf8Builder
"build"
      Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Text
annSuffix
      Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" with "
      Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> ActualCompiler -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display ActualCompiler
actualCompiler
      )
    Config
config <- Getting Config env Config -> RIO env Config
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Config env Config
forall env. HasConfig env => Lens' env Config
Lens' env Config
configL
    [[Char]]
extraOpts <- WhichCompiler -> BuildOpts -> RIO env [[Char]]
forall env.
(HasEnvConfig env, HasRunner env) =>
WhichCompiler -> BuildOpts -> RIO env [[Char]]
extraBuildOptions WhichCompiler
wc ExecuteEnv
ee.buildOpts
    let stripTHLoading :: ExcludeTHLoading
stripTHLoading
          | Config
config.hideTHLoading = ExcludeTHLoading
ExcludeTHLoading
          | Bool
otherwise                  = ExcludeTHLoading
KeepTHLoading
    ([[Char]]
buildOpts, [[Char]]
copyOpts) <-
      case (Task
task.taskType, Task
task.allInOne, Bool
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 ([], [])
    ExcludeTHLoading -> [[Char]] -> RIO env ()
cabal ExcludeTHLoading
stripTHLoading ([Char]
"build" [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]]
buildOpts [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [[Char]]
extraOpts)
      RIO env () -> (BuildPrettyException -> RIO env ()) -> RIO env ()
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \BuildPrettyException
ex -> case BuildPrettyException
ex of
        CabalExitedUnsuccessfully{} ->
          Bool -> RIO env ()
postBuildCheck Bool
False 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
    Bool -> RIO env ()
postBuildCheck Bool
True

    Maybe Curator
mcurator <- 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)
    Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Curator -> Package -> Bool
doHaddock Maybe Curator
mcurator Package
package) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
      let isTaskTargetMutable :: Bool
isTaskTargetMutable = Task -> IsMutable
taskTargetIsMutable Task
task IsMutable -> IsMutable -> Bool
forall a. Eq a => a -> a -> Bool
== IsMutable
Mutable
          isHaddockForHackage :: Bool
isHaddockForHackage =
            ExecuteEnv
ee.buildOpts.haddockForHackage Bool -> Bool -> Bool
&& Bool
isTaskTargetMutable
      Utf8Builder -> RIO env ()
announce (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ if Bool
isHaddockForHackage
        then Utf8Builder
"haddock for Hackage"
        else Utf8Builder
"haddock"

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

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

      PackageName
-> Maybe Curator -> (KeepOutputOpen -> RIO env ()) -> RIO env ()
forall (m :: * -> *) env.
(MonadUnliftIO m, HasTerm env, MonadReader env m) =>
PackageName -> Maybe Curator -> (KeepOutputOpen -> m ()) -> m ()
fulfillHaddockExpectations PackageName
pname Maybe Curator
mcurator ((KeepOutputOpen -> RIO env ()) -> RIO env ())
-> (KeepOutputOpen -> RIO env ()) -> RIO env ()
forall a b. (a -> b) -> a -> b
$ \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 :: 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) -> 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
shouldCopy =
             Bool -> Bool
not Bool
isFinalBuild
          Bool -> Bool -> Bool
&& (Bool
hasLibrary Bool -> Bool -> Bool
|| Bool
hasSubLibraries Bool -> Bool -> Bool
|| Bool
hasExecutables)
    Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
shouldCopy (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
      Utf8Builder -> RIO env ()
announce Utf8Builder
"copy/register"
      Either BuildPrettyException ()
eres <- RIO env () -> RIO env (Either BuildPrettyException ())
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try (RIO env () -> RIO env (Either BuildPrettyException ()))
-> RIO env () -> RIO env (Either BuildPrettyException ())
forall a b. (a -> b) -> a -> b
$ 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
      case Either BuildPrettyException ()
eres of
        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"]

    Bool -> Maybe Text -> RIO env ()
forall env. HasEnvConfig env => Bool -> Maybe Text -> RIO env ()
copyDdumpFilesIfNeeded Bool
buildingFinals ExecuteEnv
ee.buildOpts.ddumpDir
    Installed
installedPkg <-
      ExecuteEnv
-> InstallLocation
-> Package
-> PackageIdentifier
-> RIO env Installed
forall env.
(HasEnvConfig env, HasTerm env) =>
ExecuteEnv
-> InstallLocation
-> Package
-> PackageIdentifier
-> RIO env Installed
fetchAndMarkInstalledPackage ExecuteEnv
ee (Task -> InstallLocation
taskLocation Task
task) Package
package PackageIdentifier
pkgId
    TaskType
-> ActionContext
-> ConfigCache
-> ExecuteEnv
-> Installed
-> Package
-> PackageIdentifier
-> Path Abs Dir
-> RIO env ()
forall env b.
HasEnvConfig env =>
TaskType
-> ActionContext
-> ConfigCache
-> ExecuteEnv
-> Installed
-> Package
-> PackageIdentifier
-> Path b Dir
-> RIO env ()
postProcessRemotePackage
      Task
task.taskType
      ActionContext
ac
      ConfigCache
cache
      ExecuteEnv
ee
      Installed
installedPkg
      Package
package
      PackageIdentifier
pkgId
      Path Abs Dir
pkgDir
    Installed -> RIO env Installed
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Installed
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
            Maybe GhcPkgId
maybeGhcpkgId <- Maybe StackUnqualCompName -> RIO env (Maybe GhcPkgId)
ghcPkgIdLoader (StackUnqualCompName -> Maybe StackUnqualCompName
forall a. a -> Maybe a
Just StackLibrary
subLib.name)
            RIO env (Map StackUnqualCompName GhcPkgId)
mapInMonad RIO env (Map StackUnqualCompName GhcPkgId)
-> (Map StackUnqualCompName GhcPkgId
    -> Map StackUnqualCompName GhcPkgId)
-> RIO env (Map StackUnqualCompName GhcPkgId)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> case Maybe GhcPkgId
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
      Map StackUnqualCompName GhcPkgId
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
      Maybe GhcPkgId
mGhcPkgId <- Maybe StackUnqualCompName -> RIO env (Maybe GhcPkgId)
ghcPkgIdLoader Maybe StackUnqualCompName
forall a. Maybe a
Nothing
      case Maybe GhcPkgId
mGhcPkgId of
        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
    Path Rel Dir
distDir <- RIO env (Path Rel Dir)
forall env (m :: * -> *).
(HasEnvConfig env, MonadReader env m, MonadThrow m) =>
m (Path Rel Dir)
distRelativeDir
    Path Rel Dir
ddumpRelDir <- [Char] -> RIO env (Path Rel Dir)
forall (m :: * -> *). MonadThrow m => [Char] -> m (Path Rel Dir)
parseRelDir ([Char] -> RIO env (Path Rel Dir))
-> [Char] -> RIO env (Path Rel Dir)
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
ddumpPath
    [StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
 MonadIO m) =>
[StyleDoc] -> m ()
prettyDebugL
      [ StyleDoc
"ddump-dir:"
      , Path Rel Dir -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Rel Dir
ddumpRelDir
      ]
    [StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
 MonadIO m) =>
[StyleDoc] -> m ()
prettyDebugL
      [ StyleDoc
"dist-dir:"
      , Path Rel Dir -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Rel Dir
distDir
      ]
    ConduitT () Void (ResourceT (RIO env)) () -> RIO env ()
forall (m :: * -> *) r.
MonadUnliftIO m =>
ConduitT () Void (ResourceT m) r -> m r
runConduitRes
      (ConduitT () Void (ResourceT (RIO env)) () -> RIO env ())
-> ConduitT () Void (ResourceT (RIO env)) () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Bool -> [Char] -> ConduitT () [Char] (ResourceT (RIO env)) ()
forall (m :: * -> *) i.
MonadResource m =>
Bool -> [Char] -> ConduitT i [Char] m ()
CF.sourceDirectoryDeep Bool
False (Path Rel Dir -> [Char]
forall b t. Path b t -> [Char]
toFilePath Path Rel Dir
distDir)
      ConduitT () [Char] (ResourceT (RIO env)) ()
-> ConduitT [Char] Void (ResourceT (RIO env)) ()
-> ConduitT () Void (ResourceT (RIO env)) ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ([Char] -> Bool) -> ConduitT [Char] [Char] (ResourceT (RIO env)) ()
forall (m :: * -> *) a. Monad m => (a -> Bool) -> ConduitT a a m ()
CL.filter ([Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
L.isInfixOf [Char]
".dump-")
      ConduitT [Char] [Char] (ResourceT (RIO env)) ()
-> ConduitT [Char] Void (ResourceT (RIO env)) ()
-> ConduitT [Char] Void (ResourceT (RIO env)) ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ([Char] -> ResourceT (RIO env) ())
-> ConduitT [Char] Void (ResourceT (RIO env)) ()
forall (m :: * -> *) a o.
Monad m =>
(a -> m ()) -> ConduitT a o m ()
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
          Path Rel Dir
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
          Path Rel Dir
destBaseDir <-
            (Path Rel Dir
ddumpRelDir </>) (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
<$> Path Rel Dir -> Path Rel Dir -> IO (Path Rel Dir)
forall (m :: * -> *) b t.
MonadThrow m =>
Path b Dir -> Path b t -> m (Path Rel t)
stripProperPrefix Path Rel Dir
distDir Path Rel Dir
parentDir
          -- exclude .stack-work dir

          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Char]
".stack-work" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`L.isInfixOf` Path Rel Dir -> [Char]
forall b t. Path b t -> [Char]
toFilePath Path Rel Dir
destBaseDir) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            Path Rel Dir -> IO ()
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir Path Rel Dir
destBaseDir
            Path Rel File
src' <- [Char] -> IO (Path Rel File)
forall (m :: * -> *). MonadThrow m => [Char] -> m (Path Rel File)
parseRelFile [Char]
src
            Path Rel File -> Path Rel File -> IO ()
forall (m :: * -> *) b0 b1.
MonadIO m =>
Path b0 File -> Path b1 File -> m ()
copyFile Path Rel File
src' (Path Rel Dir
destBaseDir Path Rel Dir -> Path Rel File -> Path Rel File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File -> Path Rel File
forall b. Path b File -> Path Rel File
filename Path Rel File
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 -> do
      Maybe (PrecompiledCache Abs)
mpc <- 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
      case Maybe (PrecompiledCache Abs)
mpc of
        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 `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
                Bool
b <- t -> f Bool
f t
x
                if Bool
b then (t -> f Bool) -> [t] -> f Bool
allM t -> f Bool
f [t]
xs else Bool -> f Bool
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
          Bool
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
          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)
 -> RIO env (Maybe (PrecompiledCache Abs)))
-> Maybe (PrecompiledCache Abs)
-> RIO env (Maybe (PrecompiledCache Abs))
forall a b. (a -> b) -> a -> b
$ if Bool
b then PrecompiledCache Abs -> Maybe (PrecompiledCache Abs)
forall a. a -> Maybe a
Just PrecompiledCache Abs
pc else Maybe (PrecompiledCache Abs)
forall a. Maybe a
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
ghcPkgExe <- RIO env GhcPkgExe
forall env. HasCompiler env => RIO env GhcPkgExe
getGhcPkgExe
      -- First unregister, silently, everything that needs to be unregistered.

      Maybe (NonEmpty (Either PackageIdentifier GhcPkgId))
-> (NonEmpty (Either PackageIdentifier GhcPkgId) -> RIO env ())
-> RIO env ()
forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust ([Either PackageIdentifier GhcPkgId]
-> Maybe (NonEmpty (Either PackageIdentifier GhcPkgId))
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [Either PackageIdentifier GhcPkgId]
allToUnregister) ((NonEmpty (Either PackageIdentifier GhcPkgId) -> RIO env ())
 -> RIO env ())
-> (NonEmpty (Either PackageIdentifier GhcPkgId) -> RIO env ())
-> RIO env ()
forall a b. (a -> b) -> a -> b
$ \NonEmpty (Either PackageIdentifier GhcPkgId)
allToUnregister' -> do
        LogLevel
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 :: Bool
isDebug = LogLevel
logLevel LogLevel -> LogLevel -> Bool
forall a. Eq a => a -> a -> Bool
== LogLevel
LevelDebug
        RIO env () -> (SomeException -> RIO env ()) -> RIO env ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
catchAny
          (Bool
-> GhcPkgExe
-> Path Abs Dir
-> NonEmpty (Either PackageIdentifier GhcPkgId)
-> RIO env ()
forall env.
(HasCompiler env, HasProcessContext env, HasTerm env) =>
Bool
-> GhcPkgExe
-> Path Abs Dir
-> NonEmpty (Either PackageIdentifier GhcPkgId)
-> RIO env ()
unregisterGhcPkgIds Bool
isDebug GhcPkgExe
ghcPkgExe Path Abs Dir
pkgDb NonEmpty (Either PackageIdentifier GhcPkgId)
allToUnregister')
          (RIO env () -> SomeException -> RIO env ()
forall a b. a -> b -> a
const (() -> RIO env ()
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
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.

      WhichCompiler
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
$ (EnvConfig -> Const WhichCompiler EnvConfig)
-> env -> Const WhichCompiler env
forall env. HasEnvConfig env => Lens' env EnvConfig
Lens' env EnvConfig
envConfigL ((EnvConfig -> Const WhichCompiler EnvConfig)
 -> env -> Const WhichCompiler env)
-> ((WhichCompiler -> Const WhichCompiler WhichCompiler)
    -> EnvConfig -> Const WhichCompiler EnvConfig)
-> Getting WhichCompiler env WhichCompiler
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EnvConfig -> ActualCompiler)
-> SimpleGetter EnvConfig ActualCompiler
forall s a. (s -> a) -> SimpleGetter s a
to (.sourceMap.compiler) Getting WhichCompiler EnvConfig ActualCompiler
-> ((WhichCompiler -> Const WhichCompiler WhichCompiler)
    -> ActualCompiler -> Const WhichCompiler ActualCompiler)
-> (WhichCompiler -> Const WhichCompiler WhichCompiler)
-> EnvConfig
-> Const WhichCompiler EnvConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ActualCompiler -> WhichCompiler)
-> forall r. Getting r ActualCompiler WhichCompiler
forall s a. (s -> a) -> SimpleGetter s a
to ActualCompiler -> WhichCompiler
whichCompiler
      (EnvVars -> EnvVars) -> RIO env () -> RIO env ()
forall env (m :: * -> *) a.
(HasProcessContext env, MonadReader env m, MonadIO m) =>
(EnvVars -> EnvVars) -> m a -> m a
withModifyEnvVars (Text -> EnvVars -> EnvVars
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete (Text -> EnvVars -> EnvVars) -> Text -> EnvVars -> EnvVars
forall a b. (a -> b) -> a -> b
$ WhichCompiler -> Text
ghcPkgPathEnvVar WhichCompiler
wc) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
        [Path b0 File] -> (Path b0 File -> RIO env ()) -> RIO env ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Path b0 File]
allToRegister ((Path b0 File -> RIO env ()) -> RIO env ())
-> (Path b0 File -> RIO env ()) -> RIO env ()
forall a b. (a -> b) -> a -> b
$ \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
      Maybe GhcPkgId
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

      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
$
        case Maybe GhcPkgId
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
  GhcPkgExe
pkgexe <- RIO env GhcPkgExe
forall env. HasCompiler env => RIO env GhcPkgExe
getGhcPkgExe
  [DumpPackage]
dps <- GhcPkgExe
-> PackageName
-> [Path Abs Dir]
-> ConduitM Text Void (RIO env) [DumpPackage]
-> RIO env [DumpPackage]
forall env a.
(HasCompiler env, HasProcessContext env, HasTerm env) =>
GhcPkgExe
-> PackageName
-> [Path Abs Dir]
-> ConduitM Text Void (RIO env) a
-> RIO env a
ghcPkgDescribe GhcPkgExe
pkgexe PackageName
name [Path Abs Dir]
pkgDbs (ConduitM Text Void (RIO env) [DumpPackage]
 -> RIO env [DumpPackage])
-> ConduitM Text Void (RIO env) [DumpPackage]
-> RIO env [DumpPackage]
forall a b. (a -> b) -> a -> b
$ ConduitM Text DumpPackage (RIO env) ()
forall (m :: * -> *).
MonadThrow m =>
ConduitM Text DumpPackage m ()
conduitDumpPackage ConduitM Text DumpPackage (RIO env) ()
-> ConduitT DumpPackage Void (RIO env) [DumpPackage]
-> ConduitM Text Void (RIO env) [DumpPackage]
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT DumpPackage Void (RIO env) [DumpPackage]
forall (m :: * -> *) a o. Monad m => ConduitT a o m [a]
CL.consume
  case [DumpPackage]
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 = do
      Either SomeException ()
eres <- m () -> m (Either SomeException ())
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny (m () -> m (Either SomeException ()))
-> m () -> m (Either SomeException ())
forall a b. (a -> b) -> a -> b
$ KeepOutputOpen -> m ()
action KeepOutputOpen
KeepOpen
      case Either SomeException ()
eres of
        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
  Map NamedComponent (Map [Char] FileCacheInfo)
caches <- MemoizedWith
  EnvConfig (Map NamedComponent (Map [Char] FileCacheInfo))
-> RIO env (Map NamedComponent (Map [Char] FileCacheInfo))
forall env (m :: * -> *) a.
(HasEnvConfig env, MonadReader env m, MonadIO m) =>
MemoizedWith EnvConfig a -> m a
runMemoizedWith LocalPackage
lp.newBuildCaches
  (Map NamedComponent [Map [Char] FileCacheInfo]
addBuildCache,[PackageWarning]
warnings) <-
    Package
-> Path Abs File
-> Set NamedComponent
-> Map NamedComponent (Map [Char] FileCacheInfo)
-> RIO
     env
     (Map NamedComponent [Map [Char] FileCacheInfo], [PackageWarning])
forall env a.
HasEnvConfig env =>
Package
-> Path Abs File
-> Set NamedComponent
-> Map NamedComponent (Map [Char] a)
-> RIO
     env
     (Map NamedComponent [Map [Char] FileCacheInfo], [PackageWarning])
addUnlistedToBuildCache
      LocalPackage
lp.package
      LocalPackage
lp.cabalFP
      LocalPackage
lp.components
      Map NamedComponent (Map [Char] FileCacheInfo)
caches
  [(NamedComponent, [Map [Char] FileCacheInfo])]
-> ((NamedComponent, [Map [Char] FileCacheInfo]) -> RIO env ())
-> RIO env ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Map NamedComponent [Map [Char] FileCacheInfo]
-> [(NamedComponent, [Map [Char] FileCacheInfo])]
forall k a. Map k a -> [(k, a)]
Map.toList Map NamedComponent [Map [Char] FileCacheInfo]
addBuildCache) (((NamedComponent, [Map [Char] FileCacheInfo]) -> RIO env ())
 -> RIO env ())
-> ((NamedComponent, [Map [Char] FileCacheInfo]) -> RIO env ())
-> RIO env ()
forall a b. (a -> b) -> a -> b
$ \(NamedComponent
component, [Map [Char] FileCacheInfo]
newToCache) -> do
    let cache :: Map [Char] FileCacheInfo
cache = Map [Char] FileCacheInfo
-> NamedComponent
-> Map NamedComponent (Map [Char] FileCacheInfo)
-> Map [Char] FileCacheInfo
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Map [Char] FileCacheInfo
forall k a. Map k a
Map.empty NamedComponent
component Map NamedComponent (Map [Char] FileCacheInfo)
caches
    Path Abs Dir
-> NamedComponent -> Map [Char] FileCacheInfo -> RIO env ()
forall env.
HasEnvConfig env =>
Path Abs Dir
-> NamedComponent -> Map [Char] FileCacheInfo -> RIO env ()
writeBuildCache Path Abs Dir
pkgDir NamedComponent
component (Map [Char] FileCacheInfo -> RIO env ())
-> Map [Char] FileCacheInfo -> RIO env ()
forall a b. (a -> b) -> a -> b
$
      [Map [Char] FileCacheInfo] -> Map [Char] FileCacheInfo
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions (Map [Char] FileCacheInfo
cache Map [Char] FileCacheInfo
-> [Map [Char] FileCacheInfo] -> [Map [Char] FileCacheInfo]
forall a. a -> [a] -> [a]
: [Map [Char] FileCacheInfo]
newToCache)
  [PackageWarning] -> RIO env [PackageWarning]
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [PackageWarning]
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'.

  (Map PackageIdentifier GhcPkgId
allDepsMap, ConfigCache
_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
  Maybe Curator
mcurator <- 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)
  let pname :: PackageName
pname = PackageIdentifier -> PackageName
pkgName (PackageIdentifier -> PackageName)
-> PackageIdentifier -> PackageName
forall a b. (a -> b) -> a -> b
$ Task -> PackageIdentifier
taskProvides Task
task
      expectFailure :: Bool
expectFailure = PackageName -> Maybe Curator -> Bool
expectTestFailure PackageName
pname Maybe Curator
mcurator
  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 ())
-> RIO env ()
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 ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
"test") ((Package
  -> Path Abs File
  -> Path Abs Dir
  -> (KeepOutputOpen -> ExcludeTHLoading -> [[Char]] -> RIO env ())
  -> (Utf8Builder -> RIO env ())
  -> OutputType
  -> RIO env ())
 -> RIO env ())
-> (Package
    -> Path Abs File
    -> Path Abs Dir
    -> (KeepOutputOpen -> ExcludeTHLoading -> [[Char]] -> RIO env ())
    -> (Utf8Builder -> RIO env ())
    -> OutputType
    -> RIO env ())
-> RIO env ()
forall a b. (a -> b) -> a -> b
$
    \Package
package Path Abs File
_cabalfp Path Abs Dir
pkgDir KeepOutputOpen -> ExcludeTHLoading -> [[Char]] -> RIO env ()
_cabal Utf8Builder -> RIO env ()
announce OutputType
outputType -> do
      Config
config <- Getting Config env Config -> RIO env Config
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Config env Config
forall env. HasConfig env => Lens' env Config
Lens' env Config
configL
      let needHpc :: Bool
needHpc = TestOpts
topts.coverage
      Bool
toRun <-
        if TestOpts
topts.runTests
          then if TestOpts
topts.rerunTests
            then Bool -> RIO env Bool
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
            else do
              TestStatus
status <- Path Abs Dir -> RIO env TestStatus
forall env. HasEnvConfig env => Path Abs Dir -> RIO env TestStatus
getTestStatus Path Abs Dir
pkgDir
              case TestStatus
status of
                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 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
"singleTest"
      Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
toRun (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
        Path Abs Dir
buildDir <- Path Abs Dir -> RIO env (Path Abs Dir)
forall env (m :: * -> *).
(HasEnvConfig env, MonadReader env m, MonadThrow m) =>
Path Abs Dir -> m (Path Abs Dir)
distDirFromDir Path Abs Dir
pkgDir
        Path Abs Dir
hpcDir <- Path Abs Dir -> RIO env (Path Abs Dir)
forall env (m :: * -> *).
(HasEnvConfig env, MonadReader env m, MonadThrow m) =>
Path Abs Dir -> m (Path Abs Dir)
hpcDirFromDir Path Abs Dir
pkgDir
        Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
needHpc (Path Abs Dir -> RIO env ()
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir Path Abs Dir
hpcDir)

        let suitesToRun :: [(StackUnqualCompName, TestSuiteInterface)]
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
                ]

        Map StackUnqualCompName (Maybe ExitCode)
errs <- ([Map StackUnqualCompName (Maybe ExitCode)]
 -> Map StackUnqualCompName (Maybe ExitCode))
-> RIO env [Map StackUnqualCompName (Maybe ExitCode)]
-> RIO env (Map StackUnqualCompName (Maybe ExitCode))
forall a b. (a -> b) -> RIO env a -> RIO env b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Map StackUnqualCompName (Maybe ExitCode)]
-> Map StackUnqualCompName (Maybe ExitCode)
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions (RIO env [Map StackUnqualCompName (Maybe ExitCode)]
 -> RIO env (Map StackUnqualCompName (Maybe ExitCode)))
-> RIO env [Map StackUnqualCompName (Maybe ExitCode)]
-> RIO env (Map StackUnqualCompName (Maybe ExitCode))
forall a b. (a -> b) -> a -> b
$ [(StackUnqualCompName, TestSuiteInterface)]
-> ((StackUnqualCompName, TestSuiteInterface)
    -> RIO env (Map StackUnqualCompName (Maybe ExitCode)))
-> RIO env [Map StackUnqualCompName (Maybe ExitCode)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(StackUnqualCompName, TestSuiteInterface)]
suitesToRun (((StackUnqualCompName, TestSuiteInterface)
  -> RIO env (Map StackUnqualCompName (Maybe ExitCode)))
 -> RIO env [Map StackUnqualCompName (Maybe ExitCode)])
-> ((StackUnqualCompName, TestSuiteInterface)
    -> RIO env (Map StackUnqualCompName (Maybe ExitCode)))
-> RIO env [Map StackUnqualCompName (Maybe ExitCode)]
forall a b. (a -> b) -> a -> b
$ \(StackUnqualCompName
testName, TestSuiteInterface
suiteInterface) -> do
          let stestName :: [Char]
stestName = StackUnqualCompName -> [Char]
unqualCompToString StackUnqualCompName
testName
          ([Char]
testName', Bool
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]
exeName = [Char]
testName' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                case Config
config.platform of
                  Platform Arch
_ OS
Windows -> [Char]
".exe"
                  Platform
_ -> [Char]
""
          Path Abs File
tixPath <- (Path Rel File -> Path Abs File)
-> RIO env (Path Rel File) -> RIO env (Path Abs File)
forall a b. (a -> b) -> RIO env a -> RIO env b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Path Abs Dir
pkgDir </>) (RIO env (Path Rel File) -> RIO env (Path Abs File))
-> RIO env (Path Rel File) -> RIO env (Path Abs File)
forall a b. (a -> b) -> a -> b
$ [Char] -> RIO env (Path Rel File)
forall (m :: * -> *). MonadThrow m => [Char] -> m (Path Rel File)
parseRelFile ([Char] -> RIO env (Path Rel File))
-> [Char] -> RIO env (Path Rel File)
forall a b. (a -> b) -> a -> b
$ [Char]
exeName [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
".tix"
          Path Abs File
exePath <-
            (Path Rel File -> Path Abs File)
-> RIO env (Path Rel File) -> RIO env (Path Abs File)
forall a b. (a -> b) -> RIO env a -> RIO env b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Path Abs Dir
buildDir </>) (RIO env (Path Rel File) -> RIO env (Path Abs File))
-> RIO env (Path Rel File) -> RIO env (Path Abs File)
forall a b. (a -> b) -> a -> b
$ [Char] -> RIO env (Path Rel File)
forall (m :: * -> *). MonadThrow m => [Char] -> m (Path Rel File)
parseRelFile ([Char] -> RIO env (Path Rel File))
-> [Char] -> RIO env (Path Rel File)
forall a b. (a -> b) -> a -> b
$
              [Char]
"build/" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
testName' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"/" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
exeName
          Bool
exists <- Path Abs File -> RIO env Bool
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
exePath
          -- in Stack.Package.packageFromPackageDescription we filter out

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

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

          -- it back here but unfortunately unconditionally

          Maybe Installed
installed <- case PackageName -> InstalledMap -> Maybe (InstallLocation, Installed)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
pname InstalledMap
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
              Map PackageIdentifier Installed
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
              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
$ PackageIdentifier
-> Map PackageIdentifier Installed -> Maybe Installed
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Task -> PackageIdentifier
taskProvides Task
task) Map PackageIdentifier Installed
idMap
          let pkgGhcIdList :: [GhcPkgId]
pkgGhcIdList = case Maybe Installed
installed of
                               Just (Library PackageIdentifier
_ InstalledLibraryInfo
libInfo) -> [InstalledLibraryInfo
libInfo.ghcPkgId]
                               Maybe Installed
_ -> []
          -- doctest relies on template-haskell in QuickCheck-based tests

          GhcPkgId
thGhcId <-
            case ((GhcPkgId, DumpPackage) -> Bool)
-> [(GhcPkgId, DumpPackage)] -> Maybe (GhcPkgId, DumpPackage)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find ((PackageName -> PackageName -> Bool
forall a. Eq a => a -> a -> Bool
== PackageName
"template-haskell") (PackageName -> Bool)
-> ((GhcPkgId, DumpPackage) -> PackageName)
-> (GhcPkgId, DumpPackage)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageIdentifier -> PackageName
pkgName (PackageIdentifier -> PackageName)
-> ((GhcPkgId, DumpPackage) -> PackageIdentifier)
-> (GhcPkgId, DumpPackage)
-> PackageName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.packageIdent) (DumpPackage -> PackageIdentifier)
-> ((GhcPkgId, DumpPackage) -> DumpPackage)
-> (GhcPkgId, DumpPackage)
-> PackageIdentifier
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GhcPkgId, DumpPackage) -> DumpPackage
forall a b. (a, b) -> b
snd)
                   (Map GhcPkgId DumpPackage -> [(GhcPkgId, DumpPackage)]
forall k a. Map k a -> [(k, a)]
Map.toList ExecuteEnv
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] -> ProcessContext -> IO ProcessContext
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' :: Path Abs File
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

          Int
randomInt <- IO Int -> RIO env Int
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int
forall a (m :: * -> *). (Random a, MonadIO m) => m a
randomIO :: IO Int)
          let randomSuffix :: [Char]
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)
          [Char]
fp <- Path Abs File -> [Char]
forall b t. Path b t -> [Char]
toFilePath (Path Abs File -> [Char])
-> RIO env (Path Abs File) -> RIO env [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> Path Abs File -> RIO env (Path Abs File)
forall (m :: * -> *) b.
MonadThrow m =>
[Char] -> Path b File -> m (Path b File)
addExtension [Char]
randomSuffix Path Abs File
fp'
          let snapDBPath :: [Char]
snapDBPath =
                Path Abs Dir -> [Char]
forall loc. Path loc Dir -> [Char]
toFilePathNoTrailingSep ExecuteEnv
ee.baseConfigOpts.snapDB
              localDBPath :: [Char]
localDBPath =
                Path Abs Dir -> [Char]
forall loc. Path loc Dir -> [Char]
toFilePathNoTrailingSep ExecuteEnv
ee.baseConfigOpts.localDB
              ghcEnv :: Utf8Builder
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)
          [Char] -> Utf8Builder -> RIO env ()
forall (m :: * -> *). MonadIO m => [Char] -> Utf8Builder -> m ()
writeFileUtf8Builder [Char]
fp Utf8Builder
ghcEnv
          ProcessContext
menv <- IO ProcessContext -> RIO env ProcessContext
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ProcessContext -> RIO env ProcessContext)
-> IO ProcessContext -> RIO env ProcessContext
forall a b. (a -> b) -> a -> b
$
            [Char] -> ProcessContext -> IO ProcessContext
setEnv [Char]
fp (ProcessContext -> IO ProcessContext)
-> IO ProcessContext -> IO ProcessContext
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Config
config.processContextSettings EnvSettings
              { includeLocals :: Bool
includeLocals = Task -> InstallLocation
taskLocation Task
task InstallLocation -> InstallLocation -> Bool
forall a. Eq a => a -> a -> Bool
== InstallLocation
Local
              , includeGhcPackagePath :: Bool
includeGhcPackagePath = Bool
True
              , stackExe :: Bool
stackExe = Bool
True
              , localeUtf8 :: Bool
localeUtf8 = Bool
False
              , keepGhcRts :: Bool
keepGhcRts = Bool
False
              }
          let emptyResult :: Map StackUnqualCompName (Maybe ExitCode)
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
          ProcessContext
-> RIO env (Map StackUnqualCompName (Maybe ExitCode))
-> RIO env (Map StackUnqualCompName (Maybe ExitCode))
forall env a.
HasProcessContext env =>
ProcessContext -> RIO env a -> RIO env a
withProcessContext ProcessContext
menv (RIO env (Map StackUnqualCompName (Maybe ExitCode))
 -> RIO env (Map StackUnqualCompName (Maybe ExitCode)))
-> RIO env (Map StackUnqualCompName (Maybe ExitCode))
-> RIO env (Map StackUnqualCompName (Maybe ExitCode))
forall a b. (a -> b) -> a -> b
$ if Bool
exists
            then do
                -- We clear out the .tix files before doing a run.

                Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
needHpc (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
                  Bool
tixexists <- Path Abs File -> RIO env Bool
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
tixPath
                  Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
tixexists (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 ()
prettyWarnL
                      [ [Char] -> StyleDoc
flow [Char]
"Removing HPC file"
                      , Path Abs File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
tixPath StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
                      ]
                  IO () -> RIO env ()
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO env ()) -> IO () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall (m :: * -> *) a. (MonadIO m, MonadCatch m) => m a -> m ()
ignoringAbsence (Path Abs File -> IO ()
forall (m :: * -> *) b. MonadIO m => Path b File -> m ()
removeFile Path Abs File
tixPath)

                let args :: [[Char]]
args = TestOpts
topts.additionalArgs
                    argsDisplay :: Text
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)
                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
<> Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Text
argsDisplay
                  Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
")"

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

                -- redirecting output.

                case OutputType
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 :: StreamSpec 'STOutput (Maybe (RIO env ()))
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 -> RIO env (Maybe ExitCode)
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

                Maybe ExitCode
mec <- [Char] -> RIO env (Maybe ExitCode) -> RIO env (Maybe ExitCode)
forall env (m :: * -> *) a.
(HasProcessContext env, MonadReader env m, MonadIO m) =>
[Char] -> m a -> m a
withWorkingDir (Path Abs Dir -> [Char]
forall b t. Path b t -> [Char]
toFilePath Path Abs Dir
pkgDir) (RIO env (Maybe ExitCode) -> RIO env (Maybe ExitCode))
-> RIO env (Maybe ExitCode) -> RIO env (Maybe ExitCode)
forall a b. (a -> b) -> a -> b
$
                  RIO env ExitCode -> RIO env (Maybe ExitCode)
optionalTimeout (RIO env ExitCode -> RIO env (Maybe ExitCode))
-> RIO env ExitCode -> RIO env (Maybe ExitCode)
forall a b. (a -> b) -> a -> b
$ [Char]
-> [[Char]]
-> (ProcessConfig () () () -> RIO env ExitCode)
-> RIO env ExitCode
forall env (m :: * -> *) a.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
 MonadIO m, ?callStack::CallStack) =>
[Char] -> [[Char]] -> (ProcessConfig () () () -> m a) -> m a
proc (Path Abs File -> [Char]
forall b t. Path b t -> [Char]
toFilePath Path Abs File
exePath) [[Char]]
args ((ProcessConfig () () () -> RIO env ExitCode) -> RIO env ExitCode)
-> (ProcessConfig () () () -> RIO env ExitCode) -> RIO env ExitCode
forall a b. (a -> b) -> a -> b
$ \ProcessConfig () () ()
pc0 -> do
                    ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))
-> ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))
changeStdin <-
                      if Bool
isTestTypeLib
                        then do
                          Path Abs File
logPath <- 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)
                          Path Abs Dir -> RIO env ()
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir (Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent Path Abs File
logPath)
                          (ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))
 -> ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ())))
-> RIO
     env
     (ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))
      -> ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ())))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))
  -> ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ())))
 -> RIO
      env
      (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 ())))
-> RIO
     env
     (ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))
      -> ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ())))
forall a b. (a -> b) -> a -> b
$
                              StreamSpec 'STInput ()
-> ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))
-> ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))
forall stdin stdin0 stdout stderr.
StreamSpec 'STInput stdin
-> ProcessConfig stdin0 stdout stderr
-> ProcessConfig stdin stdout stderr
setStdin
                            (StreamSpec 'STInput ()
 -> ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))
 -> ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ())))
-> StreamSpec 'STInput ()
-> ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))
-> ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))
forall a b. (a -> b) -> a -> b
$ ByteString -> StreamSpec 'STInput ()
byteStringInput
                            (ByteString -> StreamSpec 'STInput ())
-> ByteString -> StreamSpec 'STInput ()
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BL.fromStrict
                            (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
forall a. IsString a => [Char] -> a
fromString ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$
                            (Path Abs File, UnqualComponentName) -> [Char]
forall a. Show a => a -> [Char]
show ( Path Abs File
logPath
                                 , StackUnqualCompName -> UnqualComponentName
toCabalName StackUnqualCompName
testName
                                 )
                        else do
                          Bool
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 TestOpts
topts.allowStdin Bool -> Bool -> Bool
&& Bool
isTerminal
                            then (ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))
 -> ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ())))
-> RIO
     env
     (ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))
      -> ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ())))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))
-> ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))
forall a. a -> a
id
                            else (ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))
 -> ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ())))
-> RIO
     env
     (ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))
      -> ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ())))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))
  -> ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ())))
 -> RIO
      env
      (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 ())))
-> RIO
     env
     (ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))
      -> ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ())))
forall a b. (a -> b) -> a -> b
$ StreamSpec 'STInput ()
-> ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))
-> ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))
forall stdin stdin0 stdout stderr.
StreamSpec 'STInput stdin
-> ProcessConfig stdin0 stdout stderr
-> ProcessConfig stdin stdout stderr
setStdin (StreamSpec 'STInput ()
 -> ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))
 -> ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ())))
-> StreamSpec 'STInput ()
-> ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))
-> ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))
forall a b. (a -> b) -> a -> b
$ ByteString -> StreamSpec 'STInput ()
byteStringInput ByteString
forall a. Monoid a => a
mempty
                    let pc :: ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))
pc = ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))
-> ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))
changeStdin
                           (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
                    ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))
-> (Process () (Maybe (RIO env ())) (Maybe (RIO env ()))
    -> RIO env ExitCode)
-> RIO env ExitCode
forall (m :: * -> *) stdin stdout stderr a.
MonadUnliftIO m =>
ProcessConfig stdin stdout stderr
-> (Process stdin stdout stderr -> m a) -> m a
withProcessWait ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))
pc ((Process () (Maybe (RIO env ())) (Maybe (RIO env ()))
  -> RIO env ExitCode)
 -> RIO env ExitCode)
-> (Process () (Maybe (RIO env ())) (Maybe (RIO env ()))
    -> RIO env ExitCode)
-> RIO env ExitCode
forall a b. (a -> b) -> a -> b
$ \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
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.

                Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
needHpc (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
                  PackageName -> Path Abs File -> [Char] -> RIO env ()
forall env.
HasEnvConfig env =>
PackageName -> Path Abs File -> [Char] -> RIO env ()
updateTixFile Package
package.name Path Abs File
tixPath [Char]
testName'
                let announceResult :: Utf8Builder -> RIO env ()
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 Maybe ExitCode
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
                Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
expectFailure (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
                  Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
 ?callStack::CallStack) =>
Utf8Builder -> m ()
logError (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$
                    BuildException -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow (BuildException -> Utf8Builder) -> BuildException -> Utf8Builder
forall a b. (a -> b) -> a -> b
$ Bool -> [Char] -> [Char] -> [Char] -> BuildException
TestSuiteExeMissing
                      (Package
package.buildType BuildType -> BuildType -> Bool
forall a. Eq a => a -> a -> Bool
== BuildType
C.Simple)
                      [Char]
exeName
                      (PackageName -> [Char]
packageNameString Package
package.name)
                      (StackUnqualCompName -> [Char]
unqualCompToString StackUnqualCompName
testName)
                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)
emptyResult

        Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
needHpc (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
          let testsToRun' :: [Text]
testsToRun' = (StackUnqualCompName -> Text) -> [StackUnqualCompName] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map StackUnqualCompName -> Text
f [StackUnqualCompName]
testsToRun
              f :: StackUnqualCompName -> Text
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
          Path Abs Dir -> Package -> [Text] -> RIO env ()
forall env.
HasEnvConfig env =>
Path Abs Dir -> Package -> [Text] -> RIO env ()
generateHpcReport Path Abs Dir
pkgDir Package
package [Text]
testsToRun'

        ByteString
bs <- IO ByteString -> RIO env ByteString
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> RIO env ByteString)
-> IO ByteString -> RIO env ByteString
forall a b. (a -> b) -> a -> b
$
          case OutputType
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 :: Bool
succeeded = Map StackUnqualCompName (Maybe ExitCode) -> Bool
forall k a. Map k a -> Bool
Map.null Map StackUnqualCompName (Maybe ExitCode)
errs
        Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
succeeded Bool -> Bool -> Bool
|| Bool
expectFailure) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
          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
$ PackageIdentifier
-> Map StackUnqualCompName (Maybe ExitCode)
-> Maybe (Path Abs File)
-> ByteString
-> BuildException
TestSuiteFailure
            (Task -> PackageIdentifier
taskProvides Task
task)
            Map StackUnqualCompName (Maybe ExitCode)
errs
            (case OutputType
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)
            ByteString
bs

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

-- | Implements running a package's benchmarks.

singleBench ::
     HasEnvConfig env
  => BenchmarkOpts
  -> [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
  (Map PackageIdentifier GhcPkgId
allDepsMap, ConfigCache
_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
  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 ())
-> RIO env ()
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 ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
"bench") ((Package
  -> Path Abs File
  -> Path Abs Dir
  -> (KeepOutputOpen -> ExcludeTHLoading -> [[Char]] -> RIO env ())
  -> (Utf8Builder -> RIO env ())
  -> OutputType
  -> RIO env ())
 -> RIO env ())
-> (Package
    -> Path Abs File
    -> Path Abs Dir
    -> (KeepOutputOpen -> ExcludeTHLoading -> [[Char]] -> RIO env ())
    -> (Utf8Builder -> RIO env ())
    -> OutputType
    -> RIO env ())
-> RIO env ()
forall a b. (a -> b) -> a -> b
$
    \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=" <>))
                       BenchmarkOpts
beopts.additionalArgs
      Bool
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"
      Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
toRun (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
        Utf8Builder -> RIO env ()
announce Utf8Builder
"benchmarks"
        KeepOutputOpen -> ExcludeTHLoading -> [[Char]] -> RIO env ()
cabal KeepOutputOpen
CloseOnException ExcludeTHLoading
KeepTHLoading ([Char]
"bench" [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]]
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
  Maybe [Char]
colorOpt <- RIO env (Maybe [Char])
forall env.
(HasEnvConfig env, HasRunner env) =>
RIO env (Maybe [Char])
appropriateGhcColorFlag
  let optsFlag :: [Char]
optsFlag = WhichCompiler -> [Char]
compilerOptionsCabalFlag WhichCompiler
wc
      baseOpts :: [Char]
baseOpts = [Char] -> ([Char] -> [Char]) -> Maybe [Char] -> [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"" ([Char]
" " ++) Maybe [Char]
colorOpt
  if BuildOpts
bopts.testOpts.coverage
    then do
      [Char]
hpcIndexDir <- Path Rel Dir -> [Char]
forall loc. Path loc Dir -> [Char]
toFilePathNoTrailingSep (Path Rel Dir -> [Char])
-> RIO env (Path Rel Dir) -> RIO env [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RIO env (Path Rel Dir)
forall env (m :: * -> *).
(HasEnvConfig env, MonadReader env m, MonadThrow m) =>
m (Path Rel Dir)
hpcRelativeDir
      [[Char]] -> RIO env [[Char]]
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [[Char]
optsFlag, [Char]
"-hpcdir " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
hpcIndexDir [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
baseOpts]
    else
      [[Char]] -> RIO env [[Char]]
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [[Char]
optsFlag, [Char]
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 = do
      Either SomeException b
eres <- RIO env b -> RIO env (Either SomeException b)
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny RIO env b
action
      case Either SomeException b
eres of
        Right b
res -> do
          [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 = do
      Either SomeException b
eres <- RIO env b -> RIO env (Either SomeException b)
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny RIO env b
action
      case Either SomeException b
eres of
        Right b
res -> do
          [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