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

-- | 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           Distribution.Types.UnqualComponentName
                   ( mkUnqualComponentName )
import           Distribution.Version ( mkVersion )
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
                   ( byteStringInput, findExecutable, getStderr, getStdout
                   , inherit, modifyEnvVars, proc, setStderr, setStdin
                   , setStdout, showProcessArgDebug, useHandleOpen, waitExitCode
                   , withProcessWait, withWorkingDir, HasProcessContext
                   )
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 (..), ExecutableBuildStatus (..)
                   , ExecuteEnv (..), KeepOutputOpen (..), OutputType (..)
                   , withSingleContext
                   )
import           Stack.Build.Source ( addUnlistedToBuildCache )
import           Stack.Config.ConfigureScript ( ensureConfigureScript )
import           Stack.Constants
                   ( bindirSuffix, compilerOptionsCabalFlag, relDirBuild
                   , testGhcEnvRelFile
                   )
import           Stack.Constants.Config
                   ( distDirFromDir, distRelativeDir, hpcDirFromDir
                   , hpcRelativeDir, setupConfigFromDir
                   )
import           Stack.Coverage ( generateHpcReport, updateTixFile )
import           Stack.GhcPkg ( ghcPkg, 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 (..), taskAnyMissing
                   , 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 (..), projectRootL )
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
                   ( ActualCompiler (..), WhichCompiler (..), getGhcVersion
                   , whichCompilerL
                   )
import           Stack.Types.CompilerPaths
                   ( CompilerPaths (..), GhcPkgExe (..), HasCompiler (..)
                   , cpWhich, getGhcPkgExe
                   )
import qualified Stack.Types.Component as Component
import           Stack.Types.Config ( Config (..), HasConfig (..) )
import           Stack.Types.ConfigureOpts
                   ( BaseConfigOpts (..), ConfigureOpts (..) )
import           Stack.Types.Curator ( Curator (..) )
import           Stack.Types.DumpPackage ( DumpPackage (..) )
import           Stack.Types.EnvConfig
                   ( EnvConfig (..), HasEnvConfig (..), actualCompilerVersionL
                   , appropriateGhcColorFlag
                   )
import           Stack.Types.EnvSettings ( EnvSettings (..) )
import           Stack.Types.GhcPkgId ( GhcPkgId, unGhcPkgId )
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 (..), installedMapGhcPkgId
                   , runMemoizedWith, simpleInstalledLib
                   , toCabalMungedPackageName
                   )
import           Stack.Types.PackageFile ( PackageWarning (..) )
import           Stack.Types.Platform ( HasPlatform (..) )
import           Stack.Types.Runner ( HasRunner, globalOptsL )
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
installedToGhcPkgId 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
installedToGhcPkgId 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
      installedToGhcPkgId :: PackageIdentifier -> Installed -> Map PackageIdentifier GhcPkgId
installedToGhcPkgId PackageIdentifier
ident (Library PackageIdentifier
ident' InstalledLibraryInfo
libInfo) =
        Bool
-> Map PackageIdentifier GhcPkgId -> Map PackageIdentifier GhcPkgId
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (PackageIdentifier
ident PackageIdentifier -> PackageIdentifier -> Bool
forall a. Eq a => a -> a -> Bool
== PackageIdentifier
ident') (PackageIdentifier
-> InstalledLibraryInfo -> Map PackageIdentifier GhcPkgId
installedMapGhcPkgId PackageIdentifier
ident InstalledLibraryInfo
libInfo)
      installedToGhcPkgId PackageIdentifier
_ (Executable PackageIdentifier
_) = Map PackageIdentifier GhcPkgId
forall a. Monoid a => a
mempty
      TaskConfigOpts Set PackageIdentifier
missing Map PackageIdentifier GhcPkgId -> ConfigureOpts
mkOpts = 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 Set PackageIdentifier
missing
  let 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
      configureOpts' :: ConfigureOpts
configureOpts' = Map PackageIdentifier GhcPkgId -> ConfigureOpts
mkOpts Map PackageIdentifier GhcPkgId
missing'
      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
$sel:configureOpts:ConfigCache :: ConfigureOpts
configureOpts
        , Set GhcPkgId
deps :: Set GhcPkgId
$sel:deps:ConfigCache :: Set GhcPkgId
deps
        , Set ByteString
components :: Set ByteString
$sel:components:ConfigCache :: Set ByteString
components
        , $sel:buildHaddocks:ConfigCache :: Bool
buildHaddocks = Task
task.buildHaddocks
        , $sel:pkgSrc:ConfigCache :: CachePkgSrc
pkgSrc = Task
task.cachePkgSrc
        , $sel:pathEnvVar:ConfigCache :: Text
pathEnvVar = ExecuteEnv
ee.pathEnvVar
        }
      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
  (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 -> [String] -> RIO env ())
-> Path Abs File
-> Task
-> RIO env Bool
ensureConfig ConfigCache
newConfigCache Path Abs Dir
pkgDir BuildOpts
buildOpts RIO env ()
announce ExcludeTHLoading -> [String] -> 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
<$> String -> IO FileStatus
getFileStatus (Path Abs File -> String
forall b t. Path b t -> String
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)
          (String -> IO FileStatus
getFileStatus (Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
setupConfigfp))
  Maybe CTime
newSetupConfigMod <- RIO env (Maybe CTime)
getNewSetupConfigMod
  ByteString
newProjectRoot <- String -> ByteString
S8.pack (String -> ByteString)
-> (Path Abs Dir -> String) -> Path Abs Dir -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs Dir -> String
forall b t. Path b t -> String
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)
projectRootL
  -- See https://github.com/commercialhaskell/stack/issues/3554. This can be

  -- dropped when Stack drops support for GHC < 8.4.

  Bool
taskAnyMissingHackEnabled <-
    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
$ Getting Bool env ActualCompiler
forall env. HasSourceMap env => SimpleGetter env ActualCompiler
SimpleGetter env ActualCompiler
actualCompilerVersionL Getting Bool env ActualCompiler
-> ((Bool -> Const Bool Bool)
    -> ActualCompiler -> Const Bool ActualCompiler)
-> Getting Bool env Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ActualCompiler -> Version) -> SimpleGetter ActualCompiler Version
forall s a. (s -> a) -> SimpleGetter s a
to ActualCompiler -> Version
getGhcVersion Getting Bool ActualCompiler Version
-> ((Bool -> Const Bool Bool) -> Version -> Const Bool Version)
-> (Bool -> Const Bool Bool)
-> ActualCompiler
-> Const Bool ActualCompiler
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Version -> Bool) -> SimpleGetter Version Bool
forall s a. (s -> a) -> SimpleGetter s a
to (Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
< [Int] -> Version
mkVersion [Int
8, Int
4])
  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.

       Bool -> Bool -> Bool
|| (Bool
taskAnyMissingHackEnabled Bool -> Bool -> Bool
&& Task -> Bool
taskAnyMissing Task
task)
      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
newProjectRoot

  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 :: [(String, String)]
programNames =
          case CompilerPaths -> WhichCompiler
forall env (m :: * -> *).
(MonadReader env m, HasCompiler env) =>
m WhichCompiler
cpWhich CompilerPaths
cp of
            WhichCompiler
Ghc ->
              [ (String
"ghc", Path Abs File -> String
forall b t. Path b t -> String
toFilePath CompilerPaths
cp.compiler)
              , (String
"ghc-pkg", Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
pkgPath)
              ]
    [[String]]
exes <- [(String, String)]
-> ((String, String) -> RIO env [String]) -> RIO env [[String]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(String, String)]
programNames (((String, String) -> RIO env [String]) -> RIO env [[String]])
-> ((String, String) -> RIO env [String]) -> RIO env [[String]]
forall a b. (a -> b) -> a -> b
$ \(String
name, String
file) -> do
      Either ProcessException String
mpath <- String -> RIO env (Either ProcessException String)
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasProcessContext env) =>
String -> m (Either ProcessException String)
findExecutable String
file
      [String] -> RIO env [String]
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([String] -> RIO env [String]) -> [String] -> RIO env [String]
forall a b. (a -> b) -> a -> b
$ case Either ProcessException String
mpath of
          Left ProcessException
_ -> []
          Right String
x -> String -> [String]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"--with-", String
name, String
"=", String
x]
    -- Configure cabal with arguments determined by

    -- Stack.Types.Build.ureOpts

    ExcludeTHLoading -> [String] -> RIO env ()
cabal ExcludeTHLoading
KeepTHLoading ([String] -> RIO env ()) -> [String] -> RIO env ()
forall a b. (a -> b) -> a -> b
$ String
"configure" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[String]]
exes
      , ConfigCache
newConfigCache.configureOpts.pathRelated
      , ConfigCache
newConfigCache.configureOpts.nonPathRelated
      ]
    -- 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
newProjectRoot
  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 -> String
packageNamePrefix ExecuteEnv
ee PackageName
name' =
  let name :: String
name = PackageName -> String
packageNameString PackageName
name'
      paddedName :: String
paddedName =
        case ExecuteEnv
ee.largestPackageName of
          Maybe Int
Nothing -> String
name
          Just Int
len ->
            Bool -> String -> String
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
name) (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
len (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char -> String
forall a. a -> [a]
L.repeat Char
' '
  in  String
paddedName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"> "

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
$
     String -> Utf8Builder
forall a. IsString a => String -> a
fromString
       (ExecuteEnv -> PackageName -> String
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 'ATBuild' and

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

--

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

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

--

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

--

-- * Runs the build step

--

-- * Generates haddocks

--

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

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

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

--   handled by 'copyExecutables'.

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

            -> RIO env ()
singleBuild :: forall env.
(HasEnvConfig env, HasRunner env) =>
ActionContext
-> ExecuteEnv -> Task -> InstalledMap -> Bool -> RIO env ()
singleBuild
    ActionContext
ac
    ExecuteEnv
ee
    Task
task
    InstalledMap
installedMap
    Bool
isFinalBuild
  = do
    Version
cabalVersion <- Getting Version env Version -> RIO env Version
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting Version env Version -> RIO env Version)
-> Getting Version env Version -> RIO env Version
forall a b. (a -> b) -> a -> b
$ (EnvConfig -> Const Version EnvConfig) -> env -> Const Version env
forall env. HasEnvConfig env => Lens' env EnvConfig
Lens' env EnvConfig
envConfigL ((EnvConfig -> Const Version EnvConfig)
 -> env -> Const Version env)
-> ((Version -> Const Version Version)
    -> EnvConfig -> Const Version EnvConfig)
-> Getting Version env Version
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EnvConfig -> Version) -> SimpleGetter EnvConfig Version
forall s a. (s -> a) -> SimpleGetter s a
to (.compilerPaths.cabalVersion)
    -- The old version of Cabal (the library) copy did not allow the components

    -- to be copied to be specified.

    let isOldCabalCopy :: Bool
isOldCabalCopy = Version
cabalVersion Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
< [Int] -> Version
mkVersion [Int
2, Int
0]
    (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)
          Bool
-> ConfigCache
-> Maybe Curator
-> Map PackageIdentifier GhcPkgId
-> RIO env (Maybe Installed)
realConfigAndBuild Bool
isOldCabalCopy ConfigCache
cache Maybe Curator
curator Map PackageIdentifier GhcPkgId
allDepsMap
    case Maybe Installed
minstalled of
      Maybe Installed
Nothing -> () -> RIO env ()
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Just 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
  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

  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)

  annSuffix :: Bool -> Map Text ExecutableBuildStatus -> Text
annSuffix Bool
isOldCabalCopy Map Text ExecutableBuildStatus
executableBuildStatuses =
    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 Text -> Bool) -> Set Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Text -> Bool
forall a. Set a -> Bool
Set.null (Set Text -> Bool) -> Set Text -> Bool
forall a b. (a -> b) -> a -> b
$
              Bool -> Map Text ExecutableBuildStatus -> LocalPackage -> Set Text
exesToBuild Bool
isOldCabalCopy Map Text ExecutableBuildStatus
executableBuildStatuses 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)

  realConfigAndBuild :: Bool
-> ConfigCache
-> Maybe Curator
-> Map PackageIdentifier GhcPkgId
-> RIO env (Maybe Installed)
realConfigAndBuild Bool
isOldCabalCopy ConfigCache
cache Maybe Curator
mcurator Map PackageIdentifier GhcPkgId
allDepsMap =
    ActionContext
-> ExecuteEnv
-> TaskType
-> Map PackageIdentifier GhcPkgId
-> Maybe String
-> (Package
    -> Path Abs File
    -> Path Abs Dir
    -> (KeepOutputOpen -> ExcludeTHLoading -> [String] -> 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 String
-> (Package
    -> Path Abs File
    -> Path Abs Dir
    -> (KeepOutputOpen -> ExcludeTHLoading -> [String] -> RIO env ())
    -> (Utf8Builder -> RIO env ())
    -> OutputType
    -> RIO env a)
-> RIO env a
withSingleContext ActionContext
ac ExecuteEnv
ee Task
task.taskType Map PackageIdentifier GhcPkgId
allDepsMap Maybe String
forall a. Maybe a
Nothing ((Package
  -> Path Abs File
  -> Path Abs Dir
  -> (KeepOutputOpen -> ExcludeTHLoading -> [String] -> RIO env ())
  -> (Utf8Builder -> RIO env ())
  -> OutputType
  -> RIO env (Maybe Installed))
 -> RIO env (Maybe Installed))
-> (Package
    -> Path Abs File
    -> Path Abs Dir
    -> (KeepOutputOpen -> ExcludeTHLoading -> [String] -> 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 -> [String] -> RIO env ()
cabal0 Utf8Builder -> RIO env ()
announce OutputType
_outputType -> do
        let cabal :: ExcludeTHLoading -> [String] -> RIO env ()
cabal = KeepOutputOpen -> ExcludeTHLoading -> [String] -> RIO env ()
cabal0 KeepOutputOpen
CloseOnException
        Map Text ExecutableBuildStatus
executableBuildStatuses <- Package -> Path Abs Dir -> RIO env (Map Text ExecutableBuildStatus)
forall env.
HasEnvConfig env =>
Package -> Path Abs Dir -> RIO env (Map Text ExecutableBuildStatus)
getExecutableBuildStatuses Package
package Path Abs Dir
pkgDir
        Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (  Bool -> Bool
not (Bool -> Map Text ExecutableBuildStatus -> Bool
forall k. Bool -> Map k ExecutableBuildStatus -> Bool
cabalIsSatisfied Bool
isOldCabalCopy Map Text ExecutableBuildStatus
executableBuildStatuses)
             Bool -> Bool -> Bool
&& Task -> Bool
taskIsTarget Task
task
             ) (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 ()
prettyInfoL
            [ String -> StyleDoc
flow String
"Building all executables for"
            , Style -> StyleDoc -> StyleDoc
style Style
Current (PackageName -> StyleDoc
forall a. IsString a => PackageName -> a
fromPackageName Package
package.name)
            , String -> StyleDoc
flow String
"once. After a successful build of all of them, only \
                   \specified executables will be rebuilt."
            ]
        Bool
_neededConfig <-
          ConfigCache
-> Path Abs Dir
-> BuildOpts
-> RIO env ()
-> (ExcludeTHLoading -> [String] -> RIO env ())
-> Path Abs File
-> Task
-> RIO env Bool
forall env.
HasEnvConfig env =>
ConfigCache
-> Path Abs Dir
-> BuildOpts
-> RIO env ()
-> (ExcludeTHLoading -> [String] -> 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 (Bool -> Map Text ExecutableBuildStatus -> Text
annSuffix Bool
isOldCabalCopy Map Text ExecutableBuildStatus
executableBuildStatuses)
                )
            )
            ExcludeTHLoading -> [String] -> RIO env ()
cabal
            Path Abs File
cabalFP
            Task
task
        let installedMapHasThisPkg :: Bool
            installedMapHasThisPkg :: Bool
installedMapHasThisPkg =
              case PackageName -> InstalledMap -> Maybe (InstallLocation, Installed)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Package
package.name InstalledMap
installedMap of
                Just (InstallLocation
_, Library PackageIdentifier
ident InstalledLibraryInfo
_) -> PackageIdentifier
ident PackageIdentifier -> PackageIdentifier -> Bool
forall a. Eq a => a -> a -> Bool
== PackageIdentifier
pkgId
                Just (InstallLocation
_, Executable PackageIdentifier
_) -> Bool
True
                Maybe (InstallLocation, 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
            Bool
-> Map Text ExecutableBuildStatus
-> (ExcludeTHLoading -> [String] -> RIO env ())
-> (Utf8Builder -> RIO env ())
-> RIO env ()
initialBuildSteps Bool
isOldCabalCopy Map Text ExecutableBuildStatus
executableBuildStatuses ExcludeTHLoading -> [String] -> 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
mcurator
                 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
<$>
                    Bool
-> ConfigCache
-> Package
-> Path Abs Dir
-> (KeepOutputOpen -> ExcludeTHLoading -> [String] -> RIO env ())
-> (Utf8Builder -> RIO env ())
-> Map Text ExecutableBuildStatus
-> RIO env Installed
realBuild Bool
isOldCabalCopy ConfigCache
cache Package
package Path Abs Dir
pkgDir KeepOutputOpen -> ExcludeTHLoading -> [String] -> RIO env ()
cabal0 Utf8Builder -> RIO env ()
announce Map Text ExecutableBuildStatus
executableBuildStatuses)

  initialBuildSteps :: Bool
-> Map Text ExecutableBuildStatus
-> (ExcludeTHLoading -> [String] -> RIO env ())
-> (Utf8Builder -> RIO env ())
-> RIO env ()
initialBuildSteps Bool
isOldCabalCopy Map Text ExecutableBuildStatus
executableBuildStatuses ExcludeTHLoading -> [String] -> 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 (Bool -> Map Text ExecutableBuildStatus -> Text
annSuffix Bool
isOldCabalCopy Map Text ExecutableBuildStatus
executableBuildStatuses)
      )
    ExcludeTHLoading -> [String] -> RIO env ()
cabal ExcludeTHLoading
KeepTHLoading [String
"repl", String
"stack-initial-build-steps"]

  realBuild ::
       Bool
       -- ^ Is Cabal copy limited to all libraries and executables?

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

    -> Map Text ExecutableBuildStatus
    -> RIO env Installed
  realBuild :: Bool
-> ConfigCache
-> Package
-> Path Abs Dir
-> (KeepOutputOpen -> ExcludeTHLoading -> [String] -> RIO env ())
-> (Utf8Builder -> RIO env ())
-> Map Text ExecutableBuildStatus
-> RIO env Installed
realBuild Bool
isOldCabalCopy ConfigCache
cache Package
package Path Abs Dir
pkgDir KeepOutputOpen -> ExcludeTHLoading -> [String] -> RIO env ()
cabal0 Utf8Builder -> RIO env ()
announce Map Text ExecutableBuildStatus
executableBuildStatuses = do
    let cabal :: ExcludeTHLoading -> [String] -> RIO env ()
cabal = KeepOutputOpen -> ExcludeTHLoading -> [String] -> RIO env ()
cabal0 KeepOutputOpen
CloseOnException
    WhichCompiler
wc <- 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 String FileCacheInfo)
caches <- MemoizedWith
  EnvConfig (Map NamedComponent (Map String FileCacheInfo))
-> RIO env (Map NamedComponent (Map String FileCacheInfo))
forall env (m :: * -> *) a.
(HasEnvConfig env, MonadReader env m, MonadIO m) =>
MemoizedWith EnvConfig a -> m a
runMemoizedWith LocalPackage
lp.newBuildCaches
        ((NamedComponent, Map String FileCacheInfo) -> RIO env ())
-> [(NamedComponent, Map String FileCacheInfo)] -> RIO env ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_
          ((NamedComponent -> Map String FileCacheInfo -> RIO env ())
-> (NamedComponent, Map String FileCacheInfo) -> RIO env ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Path Abs Dir
-> NamedComponent -> Map String FileCacheInfo -> RIO env ()
forall env.
HasEnvConfig env =>
Path Abs Dir
-> NamedComponent -> Map String FileCacheInfo -> RIO env ()
writeBuildCache Path Abs Dir
pkgDir))
          (Map NamedComponent (Map String FileCacheInfo)
-> [(NamedComponent, Map String FileCacheInfo)]
forall k a. Map k a -> [(k, a)]
Map.toList Map NamedComponent (Map String 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
<+>
                String -> StyleDoc
forall a. IsString a => String -> a
fromString (Text -> String
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
. String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc)
-> (ModuleName -> String) -> ModuleName -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> String
forall a. Pretty a => a -> String
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
$
                 String -> StyleDoc
flow String
"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
<> String -> StyleDoc
flow String
"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 (Bool -> Map Text ExecutableBuildStatus -> Text
annSuffix Bool
isOldCabalCopy Map Text ExecutableBuildStatus
executableBuildStatuses)
      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
    [String]
extraOpts <- WhichCompiler -> BuildOpts -> RIO env [String]
forall env.
(HasEnvConfig env, HasRunner env) =>
WhichCompiler -> BuildOpts -> RIO env [String]
extraBuildOptions WhichCompiler
wc ExecuteEnv
ee.buildOpts
    let stripTHLoading :: ExcludeTHLoading
stripTHLoading
          | Config
config.hideTHLoading = ExcludeTHLoading
ExcludeTHLoading
          | Bool
otherwise                  = ExcludeTHLoading
KeepTHLoading
    ([String]
buildOpts, [String]
copyOpts) <-
      case (Task
task.taskType, Task
task.allInOne, Bool
isFinalBuild) of
        (TaskType
_, Bool
True, Bool
True) -> BuildException -> RIO env ([String], [String])
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 :: [String]
componentOpts =
                Bool -> Map Text ExecutableBuildStatus -> LocalPackage -> [String]
primaryComponentOptions Bool
isOldCabalCopy Map Text ExecutableBuildStatus
executableBuildStatuses LocalPackage
lp
          in  ([String], [String]) -> RIO env ([String], [String])
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([String]
componentOpts, [String]
componentOpts)
        (TTLocalMutable LocalPackage
lp, Bool
False, Bool
True) -> ([String], [String]) -> RIO env ([String], [String])
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LocalPackage -> [String]
finalComponentOptions LocalPackage
lp, [])
        (TTLocalMutable LocalPackage
lp, Bool
True, Bool
False) ->
          let componentOpts :: [String]
componentOpts =
                Bool -> Map Text ExecutableBuildStatus -> LocalPackage -> [String]
primaryComponentOptions Bool
isOldCabalCopy Map Text ExecutableBuildStatus
executableBuildStatuses LocalPackage
lp
          in ([String], [String]) -> RIO env ([String], [String])
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([String]
componentOpts [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> LocalPackage -> [String]
finalComponentOptions LocalPackage
lp, [String]
componentOpts)
        (TTRemotePackage{}, Bool
_, Bool
_) -> ([String], [String]) -> RIO env ([String], [String])
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], [])
    ExcludeTHLoading -> [String] -> RIO env ()
cabal ExcludeTHLoading
stripTHLoading (String
"build" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
buildOpts [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String]
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 :: [String]
quickjump =
            case ActualCompiler
actualCompiler of
              ACGhc Version
ghcVer
                | Version
ghcVer Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
>= [Int] -> Version
mkVersion [Int
8, Int
4] -> [String
"--haddock-option=--quickjump"]
              ActualCompiler
_ -> []

      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 :: [String]
args = [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
              (  ( if Bool
isHaddockForHackage
                    then
                      [ [ String
"--for-hackage" ] ]
                    else
                      [ [ String
"--html"
                        , String
"--hoogle"
                        , String
"--html-location=../$pkg-$version/"
                        ]
                      , [ String
"--haddock-option=--hyperlinked-source"
                        | ExecuteEnv
ee.buildOpts.haddockHyperlinkSource
                        ]
                      , [ String
"--internal" | ExecuteEnv
ee.buildOpts.haddockInternal  ]
                      , [String]
quickjump
                      ]
                 )
              [[String]] -> [[String]] -> [[String]]
forall a. Semigroup a => a -> a -> a
<> [ [ String
"--haddock-option=" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
opt
                   | String
opt <- ExecuteEnv
ee.buildOpts.haddockOpts.additionalArgs
                   ]
                 ]
              )

        KeepOutputOpen -> ExcludeTHLoading -> [String] -> RIO env ()
cabal0 KeepOutputOpen
keep ExcludeTHLoading
KeepTHLoading ([String] -> RIO env ()) -> [String] -> RIO env ()
forall a b. (a -> b) -> a -> b
$ String
"haddock" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
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"
      let copyArgs :: [String]
copyArgs = String
"copy" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: if Bool
isOldCabalCopy then [] else [String]
copyOpts
      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 -> [String] -> RIO env ()
cabal ExcludeTHLoading
KeepTHLoading [String]
copyArgs
      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 -> String -> BuildException
CabalCopyFailed
                     (Package
package.buildType BuildType -> BuildType -> Bool
forall a. Eq a => a -> a -> Bool
== BuildType
C.Simple)
                     (BuildPrettyException -> String
forall e. Exception e => e -> String
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 -> [String] -> RIO env ()
cabal ExcludeTHLoading
KeepTHLoading [String
"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.
(HasTerm env, HasEnvConfig 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 Text
-> RIO env ()
forall env.
HasEnvConfig env =>
BaseConfigOpts
-> PackageLocationImmutable
-> ConfigureOpts
-> Bool
-> Installed
-> Set Text
-> RIO env ()
writePrecompiledCache
          ExecuteEnv
ee.baseConfigOpts
          PackageLocationImmutable
loc
          ConfigCache
cache.configureOpts
          ConfigCache
cache.buildHaddocks
          Installed
installedPackage
          (Package -> Set Text
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 ::
     (HasTerm env, HasEnvConfig env)
  => ExecuteEnv
  -> InstallLocation
  -> Package
  -> PackageIdentifier
  -> RIO env Installed
fetchAndMarkInstalledPackage :: forall env.
(HasTerm env, HasEnvConfig env) =>
ExecuteEnv
-> InstallLocation
-> Package
-> PackageIdentifier
-> RIO env Installed
fetchAndMarkInstalledPackage ExecuteEnv
ee InstallLocation
taskInstallLocation Package
package PackageIdentifier
pkgId = do
  let baseConfigOpts :: BaseConfigOpts
baseConfigOpts = ExecuteEnv
ee.baseConfigOpts
      (Path Abs Dir
installedPkgDb, TVar (Map GhcPkgId DumpPackage)
installedDumpPkgsTVar) =
        case InstallLocation
taskInstallLocation of
          InstallLocation
Snap ->
            ( BaseConfigOpts
baseConfigOpts.snapDB
            , ExecuteEnv
ee.snapshotDumpPkgs )
          InstallLocation
Local ->
            ( BaseConfigOpts
baseConfigOpts.localDB
            , ExecuteEnv
ee.localDumpPkgs )
  -- 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 getAndStoreGhcPkgId :: PackageName -> RIO env (Maybe GhcPkgId)
getAndStoreGhcPkgId =
            [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
          foldSubLibToMap :: StackLibrary
-> RIO env (Map StackUnqualCompName GhcPkgId)
-> RIO env (Map StackUnqualCompName GhcPkgId)
foldSubLibToMap StackLibrary
subLib RIO env (Map StackUnqualCompName GhcPkgId)
mapInMonad = do
            let mungedName :: MungedPackageName
mungedName = PackageName -> StackUnqualCompName -> MungedPackageName
toCabalMungedPackageName Package
package.name StackLibrary
subLib.name
            Maybe GhcPkgId
maybeGhcpkgId <-
              PackageName -> RIO env (Maybe GhcPkgId)
getAndStoreGhcPkgId (MungedPackageName -> PackageName
encodeCompatPackageName MungedPackageName
mungedName)
            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 <- PackageName -> RIO env (Maybe GhcPkgId)
getAndStoreGhcPkgId Package
package.name
      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

-- | 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 <- String -> RIO env (Path Rel Dir)
forall (m :: * -> *). MonadThrow m => String -> m (Path Rel Dir)
parseRelDir (String -> RIO env (Path Rel Dir))
-> String -> RIO env (Path Rel Dir)
forall a b. (a -> b) -> a -> b
$ Text -> String
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 -> String -> ConduitT () String (ResourceT (RIO env)) ()
forall (m :: * -> *) i.
MonadResource m =>
Bool -> String -> ConduitT i String m ()
CF.sourceDirectoryDeep Bool
False (Path Rel Dir -> String
forall b t. Path b t -> String
toFilePath Path Rel Dir
distDir)
      ConduitT () String (ResourceT (RIO env)) ()
-> ConduitT String 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
.| (String -> Bool) -> ConduitT String String (ResourceT (RIO env)) ()
forall (m :: * -> *) a. Monad m => (a -> Bool) -> ConduitT a a m ()
CL.filter (String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
L.isInfixOf String
".dump-")
      ConduitT String String (ResourceT (RIO env)) ()
-> ConduitT String Void (ResourceT (RIO env)) ()
-> ConduitT String 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
.| (String -> ResourceT (RIO env) ())
-> ConduitT String Void (ResourceT (RIO env)) ()
forall (m :: * -> *) a o.
Monad m =>
(a -> m ()) -> ConduitT a o m ()
CL.mapM_ (\String
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
<$> String -> IO (Path Rel Dir)
forall (m :: * -> *). MonadThrow m => String -> m (Path Rel Dir)
parseRelDir String
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 (String
".stack-work" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`L.isInfixOf` Path Rel Dir -> String
forall b t. Path b t -> String
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' <- String -> IO (Path Rel File)
forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile String
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'))

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

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

--

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

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

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

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

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

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

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 :: [Text]
subLibNames = Set Text -> [Text]
forall a. Set a -> [a]
Set.toList (Set Text -> [Text]) -> Set Text -> [Text]
forall a b. (a -> b) -> a -> b
$ Package -> Set Text
buildableSubLibs (Package -> Set Text) -> Package -> Set Text
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 :: Text -> MungedPackageId
    toMungedPackageId :: Text -> MungedPackageId
toMungedPackageId Text
subLib =
      let subLibName :: LibraryName
subLibName = UnqualComponentName -> LibraryName
LSubLibName (UnqualComponentName -> LibraryName)
-> UnqualComponentName -> LibraryName
forall a b. (a -> b) -> a -> b
$ String -> UnqualComponentName
mkUnqualComponentName (String -> UnqualComponentName) -> String -> UnqualComponentName
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
subLib
      in  MungedPackageName -> Version -> MungedPackageId
MungedPackageId (PackageName -> LibraryName -> MungedPackageName
MungedPackageName PackageName
pname LibraryName
subLibName) Version
pversion
    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)
      ((Text -> Either PackageIdentifier GhcPkgId)
-> [Text] -> [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)
-> (Text -> PackageIdentifier)
-> Text
-> Either PackageIdentifier GhcPkgId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MungedPackageId -> PackageIdentifier
toPackageId (MungedPackageId -> PackageIdentifier)
-> (Text -> MungedPackageId) -> Text -> PackageIdentifier
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> MungedPackageId
toMungedPackageId) [Text]
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.

      case [Either PackageIdentifier GhcPkgId]
-> Maybe (NonEmpty (Either PackageIdentifier GhcPkgId))
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [Either PackageIdentifier GhcPkgId]
allToUnregister of
        Maybe (NonEmpty (Either PackageIdentifier GhcPkgId))
Nothing -> () -> RIO env ()
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Just NonEmpty (Either PackageIdentifier GhcPkgId)
allToUnregister' -> 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
False 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 ()))
      -- Now, register the cached conf files.

      [Path b0 File]
-> (Path b0 File -> RIO env (Either SomeException ByteString))
-> 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 (Either SomeException ByteString))
 -> RIO env ())
-> (Path b0 File -> RIO env (Either SomeException ByteString))
-> RIO env ()
forall a b. (a -> b) -> a -> b
$ \Path b0 File
libpath ->
        GhcPkgExe
-> [Path Abs Dir]
-> [String]
-> RIO env (Either SomeException ByteString)
forall env.
(HasProcessContext env, HasTerm env) =>
GhcPkgExe
-> [Path Abs Dir]
-> [String]
-> RIO env (Either SomeException ByteString)
ghcPkg GhcPkgExe
ghcPkgExe [Path Abs Dir
pkgDb] [String
"register", String
"--force", Path b0 File -> String
forall b t. Path b t -> String
toFilePath Path b0 File
libpath]

  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
    String -> String -> IO ()
createLink (Path b0 File -> String
forall b t. Path b t -> String
toFilePath Path b0 File
exe) (Path Abs File -> String
forall b t. Path b t -> String
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
":"
          , String -> StyleDoc
flow String
"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 String FileCacheInfo)
caches <- MemoizedWith
  EnvConfig (Map NamedComponent (Map String FileCacheInfo))
-> RIO env (Map NamedComponent (Map String FileCacheInfo))
forall env (m :: * -> *) a.
(HasEnvConfig env, MonadReader env m, MonadIO m) =>
MemoizedWith EnvConfig a -> m a
runMemoizedWith LocalPackage
lp.newBuildCaches
  (Map NamedComponent [Map String FileCacheInfo]
addBuildCache,[PackageWarning]
warnings) <-
    Package
-> Path Abs File
-> Set NamedComponent
-> Map NamedComponent (Map String FileCacheInfo)
-> RIO
     env
     (Map NamedComponent [Map String FileCacheInfo], [PackageWarning])
forall env a.
HasEnvConfig env =>
Package
-> Path Abs File
-> Set NamedComponent
-> Map NamedComponent (Map String a)
-> RIO
     env
     (Map NamedComponent [Map String FileCacheInfo], [PackageWarning])
addUnlistedToBuildCache
      LocalPackage
lp.package
      LocalPackage
lp.cabalFP
      LocalPackage
lp.components
      Map NamedComponent (Map String FileCacheInfo)
caches
  [(NamedComponent, [Map String FileCacheInfo])]
-> ((NamedComponent, [Map String FileCacheInfo]) -> RIO env ())
-> RIO env ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Map NamedComponent [Map String FileCacheInfo]
-> [(NamedComponent, [Map String FileCacheInfo])]
forall k a. Map k a -> [(k, a)]
Map.toList Map NamedComponent [Map String FileCacheInfo]
addBuildCache) (((NamedComponent, [Map String FileCacheInfo]) -> RIO env ())
 -> RIO env ())
-> ((NamedComponent, [Map String FileCacheInfo]) -> RIO env ())
-> RIO env ()
forall a b. (a -> b) -> a -> b
$ \(NamedComponent
component, [Map String FileCacheInfo]
newToCache) -> do
    let cache :: Map String FileCacheInfo
cache = Map String FileCacheInfo
-> NamedComponent
-> Map NamedComponent (Map String FileCacheInfo)
-> Map String FileCacheInfo
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Map String FileCacheInfo
forall k a. Map k a
Map.empty NamedComponent
component Map NamedComponent (Map String FileCacheInfo)
caches
    Path Abs Dir
-> NamedComponent -> Map String FileCacheInfo -> RIO env ()
forall env.
HasEnvConfig env =>
Path Abs Dir
-> NamedComponent -> Map String FileCacheInfo -> RIO env ()
writeBuildCache Path Abs Dir
pkgDir NamedComponent
component (Map String FileCacheInfo -> RIO env ())
-> Map String FileCacheInfo -> RIO env ()
forall a b. (a -> b) -> a -> b
$
      [Map String FileCacheInfo] -> Map String FileCacheInfo
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions (Map String FileCacheInfo
cache Map String FileCacheInfo
-> [Map String FileCacheInfo] -> [Map String FileCacheInfo]
forall a. a -> [a] -> [a]
: [Map String 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
           -> [Text]
           -> ActionContext
           -> ExecuteEnv
           -> Task
           -> InstalledMap
           -> RIO env ()
singleTest :: forall env.
HasEnvConfig env =>
TestOpts
-> [Text]
-> ActionContext
-> ExecuteEnv
-> Task
-> InstalledMap
-> RIO env ()
singleTest TestOpts
topts [Text]
testsToRun ActionContext
ac ExecuteEnv
ee Task
task InstalledMap
installedMap = do
  -- FIXME: Since this doesn't use cabal, we should be able to avoid using a

  -- full blown 'withSingleContext'.

  (Map PackageIdentifier GhcPkgId
allDepsMap, ConfigCache
_cache) <- 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 String
-> (Package
    -> Path Abs File
    -> Path Abs Dir
    -> (KeepOutputOpen -> ExcludeTHLoading -> [String] -> RIO env ())
    -> (Utf8Builder -> RIO env ())
    -> OutputType
    -> RIO env ())
-> RIO env ()
forall env a.
HasEnvConfig env =>
ActionContext
-> ExecuteEnv
-> TaskType
-> Map PackageIdentifier GhcPkgId
-> Maybe String
-> (Package
    -> Path Abs File
    -> Path Abs Dir
    -> (KeepOutputOpen -> ExcludeTHLoading -> [String] -> RIO env ())
    -> (Utf8Builder -> RIO env ())
    -> OutputType
    -> RIO env a)
-> RIO env a
withSingleContext ActionContext
ac ExecuteEnv
ee Task
task.taskType Map PackageIdentifier GhcPkgId
allDepsMap (String -> Maybe String
forall a. a -> Maybe a
Just String
"test") ((Package
  -> Path Abs File
  -> Path Abs Dir
  -> (KeepOutputOpen -> ExcludeTHLoading -> [String] -> RIO env ())
  -> (Utf8Builder -> RIO env ())
  -> OutputType
  -> RIO env ())
 -> RIO env ())
-> (Package
    -> Path Abs File
    -> Path Abs Dir
    -> (KeepOutputOpen -> ExcludeTHLoading -> [String] -> 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 -> [String] -> 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.disableRun
          then do
            Utf8Builder -> RIO env ()
announce Utf8Builder
"Test running disabled by --no-run-tests flag."
            Bool -> RIO env Bool
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
          else 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 ([Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
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

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

        Map Text (Maybe ExitCode)
errs <- ([Map Text (Maybe ExitCode)] -> Map Text (Maybe ExitCode))
-> RIO env [Map Text (Maybe ExitCode)]
-> RIO env (Map Text (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 Text (Maybe ExitCode)] -> Map Text (Maybe ExitCode)
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions (RIO env [Map Text (Maybe ExitCode)]
 -> RIO env (Map Text (Maybe ExitCode)))
-> RIO env [Map Text (Maybe ExitCode)]
-> RIO env (Map Text (Maybe ExitCode))
forall a b. (a -> b) -> a -> b
$ [(Text, TestSuiteInterface)]
-> ((Text, TestSuiteInterface)
    -> RIO env (Map Text (Maybe ExitCode)))
-> RIO env [Map Text (Maybe ExitCode)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Text, TestSuiteInterface)]
suitesToRun (((Text, TestSuiteInterface)
  -> RIO env (Map Text (Maybe ExitCode)))
 -> RIO env [Map Text (Maybe ExitCode)])
-> ((Text, TestSuiteInterface)
    -> RIO env (Map Text (Maybe ExitCode)))
-> RIO env [Map Text (Maybe ExitCode)]
forall a b. (a -> b) -> a -> b
$ \(Text
testName, TestSuiteInterface
suiteInterface) -> do
          let stestName :: String
stestName = Text -> String
T.unpack Text
testName
          (String
testName', Bool
isTestTypeLib) <-
            case TestSuiteInterface
suiteInterface of
              C.TestSuiteLibV09{} -> (String, Bool) -> RIO env (String, Bool)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
stestName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Stub", Bool
True)
              C.TestSuiteExeV10{} -> (String, Bool) -> RIO env (String, Bool)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
stestName, Bool
False)
              TestSuiteInterface
interface -> BuildException -> RIO env (String, 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 :: String
exeName = String
testName' String -> String -> String
forall a. [a] -> [a] -> [a]
++
                case Config
config.platform of
                  Platform Arch
_ OS
Windows -> String
".exe"
                  Platform
_ -> String
""
          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
$ String -> RIO env (Path Rel File)
forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile (String -> RIO env (Path Rel File))
-> String -> RIO env (Path Rel File)
forall a b. (a -> b) -> a -> b
$ String
exeName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".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
$ String -> RIO env (Path Rel File)
forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile (String -> RIO env (Path Rel File))
-> String -> RIO env (Path Rel File)
forall a b. (a -> b) -> a -> b
$
              String
"build/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
testName' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
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 :: String -> ProcessContext -> IO ProcessContext
setEnv String
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" (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Path Abs Dir -> String
forall b t. Path b t -> String
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" (String -> Text
T.pack String
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 :: String
randomSuffix = String
"." String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (Int -> Int
forall a. Num a => a -> a
abs Int
randomInt)
          String
fp <- Path Abs File -> String
forall b t. Path b t -> String
toFilePath (Path Abs File -> String)
-> RIO env (Path Abs File) -> RIO env String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Path Abs File -> RIO env (Path Abs File)
forall (m :: * -> *) b.
MonadThrow m =>
String -> Path b File -> m (Path b File)
addExtension String
randomSuffix Path Abs File
fp'
          let snapDBPath :: String
snapDBPath =
                Path Abs Dir -> String
forall loc. Path loc Dir -> String
toFilePathNoTrailingSep ExecuteEnv
ee.baseConfigOpts.snapDB
              localDBPath :: String
localDBPath =
                Path Abs Dir -> String
forall loc. Path loc Dir -> String
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
<> String -> Utf8Builder
forall a. IsString a => String -> a
fromString String
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
<> String -> Utf8Builder
forall a. IsString a => String -> a
fromString String
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
unGhcPkgId 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)
          String -> Utf8Builder -> RIO env ()
forall (m :: * -> *). MonadIO m => String -> Utf8Builder -> m ()
writeFileUtf8Builder String
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
$
            String -> ProcessContext -> IO ProcessContext
setEnv String
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
              { $sel:includeLocals:EnvSettings :: Bool
includeLocals = Task -> InstallLocation
taskLocation Task
task InstallLocation -> InstallLocation -> Bool
forall a. Eq a => a -> a -> Bool
== InstallLocation
Local
              , $sel:includeGhcPackagePath:EnvSettings :: Bool
includeGhcPackagePath = Bool
True
              , $sel:stackExe:EnvSettings :: Bool
stackExe = Bool
True
              , $sel:localeUtf8:EnvSettings :: Bool
localeUtf8 = Bool
False
              , $sel:keepGhcRts:EnvSettings :: Bool
keepGhcRts = Bool
False
              }
          let emptyResult :: Map Text (Maybe ExitCode)
emptyResult = Text -> Maybe ExitCode -> Map Text (Maybe ExitCode)
forall k a. k -> a -> Map k a
Map.singleton Text
testName Maybe ExitCode
forall a. Maybe a
Nothing
          ProcessContext
-> RIO env (Map Text (Maybe ExitCode))
-> RIO env (Map Text (Maybe ExitCode))
forall env a.
HasProcessContext env =>
ProcessContext -> RIO env a -> RIO env a
withProcessContext ProcessContext
menv (RIO env (Map Text (Maybe ExitCode))
 -> RIO env (Map Text (Maybe ExitCode)))
-> RIO env (Map Text (Maybe ExitCode))
-> RIO env (Map Text (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
                      [ String -> StyleDoc
flow String
"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 :: [String]
args = TestOpts
topts.additionalArgs
                    argsDisplay :: Text
argsDisplay = case [String]
args of
                      [] -> Text
""
                      [String]
_ ->    Text
", args: "
                           Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
" " ((String -> Text) -> [String] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map String -> Text
showProcessArgDebug [String]
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 Text
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 <- String -> RIO env (Maybe ExitCode) -> RIO env (Maybe ExitCode)
forall env (m :: * -> *) a.
(HasProcessContext env, MonadReader env m, MonadIO m) =>
String -> m a -> m a
withWorkingDir (Path Abs Dir -> String
forall b t. Path b t -> String
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
$ String
-> [String]
-> (ProcessConfig () () () -> RIO env ExitCode)
-> RIO env ExitCode
forall env (m :: * -> *) a.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
 MonadIO m, ?callStack::CallStack) =>
String -> [String] -> (ProcessConfig () () () -> m a) -> m a
proc (Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
exePath) [String]
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 String -> RIO env (Path Abs File)
forall env (m :: * -> *).
(MonadReader env m, HasBuildConfig env, MonadThrow m) =>
Package -> Maybe String -> m (Path Abs File)
buildLogPath Package
package (String -> Maybe String
forall a. a -> Maybe a
Just String
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
$ String -> Text
forall a. IsString a => String -> a
fromString (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$
                            (Path Abs File, UnqualComponentName) -> String
forall a. Show a => a -> String
show ( Path Abs File
logPath
                                 , String -> UnqualComponentName
mkUnqualComponentName (Text -> String
T.unpack Text
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 -> String -> RIO env ()
forall env.
HasEnvConfig env =>
PackageName -> Path Abs File -> String -> RIO env ()
updateTixFile Package
package.name Path Abs File
tixPath String
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 Text
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 Text (Maybe ExitCode) -> RIO env (Map Text (Maybe ExitCode))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map Text (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 Text (Maybe ExitCode) -> RIO env (Map Text (Maybe ExitCode))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map Text (Maybe ExitCode)
forall k a. Map k a
Map.empty
                    else Map Text (Maybe ExitCode) -> RIO env (Map Text (Maybe ExitCode))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map Text (Maybe ExitCode) -> RIO env (Map Text (Maybe ExitCode)))
-> Map Text (Maybe ExitCode) -> RIO env (Map Text (Maybe ExitCode))
forall a b. (a -> b) -> a -> b
$ Text -> Maybe ExitCode -> Map Text (Maybe ExitCode)
forall k a. k -> a -> Map k a
Map.singleton Text
testName Maybe ExitCode
forall a. Maybe a
Nothing
                  Just ExitCode
ec -> do
                    Utf8Builder -> RIO env ()
announceResult Utf8Builder
"failed"
                    if Bool
expectFailure
                    then Map Text (Maybe ExitCode) -> RIO env (Map Text (Maybe ExitCode))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map Text (Maybe ExitCode)
forall k a. Map k a
Map.empty
                    else Map Text (Maybe ExitCode) -> RIO env (Map Text (Maybe ExitCode))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map Text (Maybe ExitCode) -> RIO env (Map Text (Maybe ExitCode)))
-> Map Text (Maybe ExitCode) -> RIO env (Map Text (Maybe ExitCode))
forall a b. (a -> b) -> a -> b
$ Text -> Maybe ExitCode -> Map Text (Maybe ExitCode)
forall k a. k -> a -> Map k a
Map.singleton Text
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 -> String -> String -> String -> BuildException
TestSuiteExeMissing
                      (Package
package.buildType BuildType -> BuildType -> Bool
forall a. Eq a => a -> a -> Bool
== BuildType
C.Simple)
                      String
exeName
                      (PackageName -> String
packageNameString Package
package.name)
                      (Text -> String
T.unpack Text
testName)
                Map Text (Maybe ExitCode) -> RIO env (Map Text (Maybe ExitCode))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map Text (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' = (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
f [Text]
testsToRun
              f :: Text -> Text
f Text
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{} -> Text
tName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"Stub"
                  Maybe TestSuiteInterface
_ -> Text
tName
               where
                mComponent :: Maybe StackTestSuite
mComponent = Text -> CompCollection StackTestSuite -> Maybe StackTestSuite
forall component.
Text -> CompCollection component -> Maybe component
collectionLookup Text
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
              String -> IO ByteString
S.readFile (String -> IO ByteString) -> String -> IO ByteString
forall a b. (a -> b) -> a -> b
$ Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
logFile

        let succeeded :: Bool
succeeded = Map Text (Maybe ExitCode) -> Bool
forall k a. Map k a -> Bool
Map.null Map Text (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 Text (Maybe ExitCode)
-> Maybe (Path Abs File)
-> ByteString
-> BuildException
TestSuiteFailure
            (Task -> PackageIdentifier
taskProvides Task
task)
            Map Text (Maybe ExitCode)
errs
            (case OutputType
outputType of
               OTLogFile Path Abs File
fp Handle
_ -> 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
            -> [Text]
            -> ActionContext
            -> ExecuteEnv
            -> Task
            -> InstalledMap
            -> RIO env ()
singleBench :: forall env.
HasEnvConfig env =>
BenchmarkOpts
-> [Text]
-> ActionContext
-> ExecuteEnv
-> Task
-> InstalledMap
-> RIO env ()
singleBench BenchmarkOpts
beopts [Text]
benchesToRun ActionContext
ac ExecuteEnv
ee Task
task InstalledMap
installedMap = do
  (Map PackageIdentifier GhcPkgId
allDepsMap, ConfigCache
_cache) <- 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 String
-> (Package
    -> Path Abs File
    -> Path Abs Dir
    -> (KeepOutputOpen -> ExcludeTHLoading -> [String] -> RIO env ())
    -> (Utf8Builder -> RIO env ())
    -> OutputType
    -> RIO env ())
-> RIO env ()
forall env a.
HasEnvConfig env =>
ActionContext
-> ExecuteEnv
-> TaskType
-> Map PackageIdentifier GhcPkgId
-> Maybe String
-> (Package
    -> Path Abs File
    -> Path Abs Dir
    -> (KeepOutputOpen -> ExcludeTHLoading -> [String] -> RIO env ())
    -> (Utf8Builder -> RIO env ())
    -> OutputType
    -> RIO env a)
-> RIO env a
withSingleContext ActionContext
ac ExecuteEnv
ee Task
task.taskType Map PackageIdentifier GhcPkgId
allDepsMap (String -> Maybe String
forall a. a -> Maybe a
Just String
"bench") ((Package
  -> Path Abs File
  -> Path Abs Dir
  -> (KeepOutputOpen -> ExcludeTHLoading -> [String] -> RIO env ())
  -> (Utf8Builder -> RIO env ())
  -> OutputType
  -> RIO env ())
 -> RIO env ())
-> (Package
    -> Path Abs File
    -> Path Abs Dir
    -> (KeepOutputOpen -> ExcludeTHLoading -> [String] -> 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 -> [String] -> RIO env ()
cabal Utf8Builder -> RIO env ()
announce OutputType
_outputType -> do
      let args :: [String]
args = (Text -> String) -> [Text] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Text -> String
T.unpack [Text]
benchesToRun [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String] -> (String -> [String]) -> Maybe String -> [String]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe []
                       ((String -> [String] -> [String]
forall a. a -> [a] -> [a]
:[]) (String -> [String]) -> (String -> String) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"--benchmark-options=" <>))
                       BenchmarkOpts
beopts.additionalArgs

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

      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 -> [String] -> RIO env ()
cabal KeepOutputOpen
CloseOnException ExcludeTHLoading
KeepTHLoading (String
"bench" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
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 [String]
extraBuildOptions WhichCompiler
wc BuildOpts
bopts = do
  Maybe String
colorOpt <- RIO env (Maybe String)
forall env.
(HasEnvConfig env, HasRunner env) =>
RIO env (Maybe String)
appropriateGhcColorFlag
  let optsFlag :: String
optsFlag = WhichCompiler -> String
compilerOptionsCabalFlag WhichCompiler
wc
      baseOpts :: String
baseOpts = String -> (String -> String) -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (String
" " ++) Maybe String
colorOpt
  if BuildOpts
bopts.testOpts.coverage
    then do
      String
hpcIndexDir <- Path Rel Dir -> String
forall loc. Path loc Dir -> String
toFilePathNoTrailingSep (Path Rel Dir -> String)
-> RIO env (Path Rel Dir) -> RIO env String
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
      [String] -> RIO env [String]
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [String
optsFlag, String
"-hpcdir " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
hpcIndexDir String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
baseOpts]
    else
      [String] -> RIO env [String]
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [String
optsFlag, String
baseOpts]

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

primaryComponentOptions ::
     Bool
     -- ^ Is Cabal copy limited to all libraries and executables?

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

  -- users to turn off library building if desired

     ( if Package -> Bool
hasBuildableMainLibrary Package
package
         then (Text -> String) -> [Text] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Text -> String
T.unpack
           ([Text] -> [String]) -> [Text] -> [String]
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text
T.append Text
"lib:" (String -> Text
T.pack (PackageName -> String
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 []
     )
  [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (Text -> String) -> [Text] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map
       (Text -> String
T.unpack (Text -> String) -> (Text -> Text) -> Text -> String
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)
  [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (Text -> String) -> [Text] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map
       (Text -> String
T.unpack (Text -> String) -> (Text -> Text) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text
T.append Text
"exe:")
       (Set Text -> [Text]
forall a. Set a -> [a]
Set.toList (Set Text -> [Text]) -> Set Text -> [Text]
forall a b. (a -> b) -> a -> b
$ Bool -> Map Text ExecutableBuildStatus -> LocalPackage -> Set Text
exesToBuild Bool
isOldCabalCopy Map Text ExecutableBuildStatus
executableBuildStatuses LocalPackage
lp)
 where
  package :: Package
package = LocalPackage
lp.package

-- | History of this function:

--

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

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

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

--   all executables every time.

--

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

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

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

--   thereafter pay attention to user-wanted components.

--

-- * The Cabal bug was fixed, in that the copy command of later Cabal versions

--   allowed components to be specified. Consequently, Cabal may be satisified,

--   even if all of a package's executables have not yet been built.

exesToBuild ::
     Bool
     -- ^ Is Cabal copy limited to all libraries and executables?

  -> Map Text ExecutableBuildStatus
  -> LocalPackage
  -> Set Text
exesToBuild :: Bool -> Map Text ExecutableBuildStatus -> LocalPackage -> Set Text
exesToBuild Bool
isOldCabalCopy Map Text ExecutableBuildStatus
executableBuildStatuses LocalPackage
lp =
  if Bool -> Map Text ExecutableBuildStatus -> Bool
forall k. Bool -> Map k ExecutableBuildStatus -> Bool
cabalIsSatisfied Bool
isOldCabalCopy Map Text ExecutableBuildStatus
executableBuildStatuses Bool -> Bool -> Bool
&& LocalPackage
lp.wanted
    then Set NamedComponent -> Set Text
exeComponents LocalPackage
lp.components
    else Package -> Set Text
buildableExes LocalPackage
lp.package

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

cabalIsSatisfied ::
     Bool
     -- ^ Is Cabal copy limited to all libraries and executables?

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

-- Test-suite and benchmark build components.

finalComponentOptions :: LocalPackage -> [String]
finalComponentOptions :: LocalPackage -> [String]
finalComponentOptions LocalPackage
lp =
  (NamedComponent -> String) -> [NamedComponent] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> String
T.unpack (Text -> String)
-> (NamedComponent -> Text) -> NamedComponent -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamedComponent -> Text
renderComponent) ([NamedComponent] -> [String]) -> [NamedComponent] -> [String]
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
":"
            , String -> StyleDoc
flow String
"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
":"
            , String -> StyleDoc
flow String
"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