{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
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.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 (..), ExecuteEnv (..), KeepOutputOpen (..)
, OutputType (..), withSingleContext
)
import Stack.Build.Source ( addUnlistedToBuildCache )
import Stack.Config.ConfigureScript ( ensureConfigureScript )
import Stack.Constants
( bindirSuffix, compilerOptionsCabalFlag, testGhcEnvRelFile )
import Stack.Constants.Config
( distDirFromDir, distRelativeDir, hpcDirFromDir
, hpcRelativeDir, setupConfigFromDir
)
import Stack.Coverage ( generateHpcReport, updateTixFile )
import Stack.GhcPkg ( ghcPkg, 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 (..), configFileRootL )
import Stack.Types.BuildOpts
( BenchmarkOpts (..), BuildOpts (..), HaddockOpts (..)
, TestOpts (..)
)
import Stack.Types.BuildOptsCLI ( BuildOptsCLI (..) )
import Stack.Types.CompCollection
( collectionKeyValueList, collectionLookup
, foldComponentToAnotherCollection, getBuildableListText
)
import Stack.Types.Compiler
( ActualCompiler (..), WhichCompiler (..), getGhcVersion
, whichCompilerL
)
import Stack.Types.CompilerPaths
( CompilerPaths (..), GhcPkgExe (..), HasCompiler (..)
, cpWhich, getGhcPkgExe
)
import qualified Stack.Types.Component as Component
import Stack.Types.ComponentUtils
( StackUnqualCompName, toCabalName, unqualCompToString
, unqualCompToText
)
import Stack.Types.Config ( Config (..), HasConfig (..) )
import Stack.Types.ConfigureOpts
( BaseConfigOpts (..), ConfigureOpts (..) )
import qualified Stack.Types.ConfigureOpts as ConfigureOpts
import Stack.Types.Curator ( Curator (..) )
import Stack.Types.DumpPackage ( DumpPackage (..) )
import Stack.Types.EnvConfig
( HasEnvConfig (..), actualCompilerVersionL
, appropriateGhcColorFlag
)
import Stack.Types.EnvSettings ( EnvSettings (..) )
import Stack.Types.GhcPkgId ( GhcPkgId, ghcPkgIdToText )
import Stack.Types.GlobalOpts ( GlobalOpts (..) )
import Stack.Types.Installed
( InstallLocation (..), Installed (..), InstalledMap
, InstalledLibraryInfo (..)
)
import Stack.Types.IsMutable ( IsMutable (..) )
import Stack.Types.NamedComponent
( NamedComponent, exeComponents, isCBench, isCTest
, renderComponent
)
import Stack.Types.Package
( LocalPackage (..), Package (..), installedPackageToGhcPkgId
, runMemoizedWith, simpleInstalledLib
, toCabalMungedPackageName
)
import Stack.Types.PackageFile ( PackageWarning (..) )
import Stack.Types.Runner ( HasRunner, globalOptsL )
import System.IO.Error ( isDoesNotExistError )
import System.PosixCompat.Files
( createLink, getFileStatus, modificationTime )
import System.Random ( randomIO )
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 =
case Task
task.taskType of
TTLocalMutable LocalPackage
_ ->
[ 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
| ExecuteEnv
ee.buildOptsCLI.initialBuildSteps Bool -> Bool -> Bool
&& Task -> Bool
taskIsTarget Task
task
, Just (InstallLocation
_, Installed
installed) <- PackageName -> InstalledMap -> Maybe (InstallLocation, Installed)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (PackageIdentifier -> PackageName
pkgName PackageIdentifier
ident) InstalledMap
installedMap
-> Map PackageIdentifier GhcPkgId
-> RIO env (Map PackageIdentifier GhcPkgId)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map PackageIdentifier GhcPkgId
-> RIO env (Map PackageIdentifier GhcPkgId))
-> Map PackageIdentifier GhcPkgId
-> RIO env (Map PackageIdentifier GhcPkgId)
forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> Installed -> Map PackageIdentifier GhcPkgId
installedPackageToGhcPkgId PackageIdentifier
ident Installed
installed
Just Installed
installed -> Map PackageIdentifier GhcPkgId
-> RIO env (Map PackageIdentifier GhcPkgId)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map PackageIdentifier GhcPkgId
-> RIO env (Map PackageIdentifier GhcPkgId))
-> Map PackageIdentifier GhcPkgId
-> RIO env (Map PackageIdentifier GhcPkgId)
forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> Installed -> Map PackageIdentifier GhcPkgId
installedPackageToGhcPkgId PackageIdentifier
ident Installed
installed
Maybe Installed
_ -> BuildException -> RIO env (Map PackageIdentifier GhcPkgId)
forall e a. (?callStack::CallStack, Exception e) => e -> RIO env a
forall (m :: * -> *) e a.
(MonadThrow m, ?callStack::CallStack, Exception e) =>
e -> m a
throwM (BuildException -> RIO env (Map PackageIdentifier GhcPkgId))
-> BuildException -> RIO env (Map PackageIdentifier GhcPkgId)
forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> BuildException
PackageIdMissingBug PackageIdentifier
ident
let cOpts :: TaskConfigOpts
cOpts = Task
task.configOpts
[Map PackageIdentifier GhcPkgId]
missingMapList <- (PackageIdentifier -> RIO env (Map PackageIdentifier GhcPkgId))
-> [PackageIdentifier] -> RIO env [Map PackageIdentifier GhcPkgId]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse PackageIdentifier -> RIO env (Map PackageIdentifier GhcPkgId)
getMissing ([PackageIdentifier] -> RIO env [Map PackageIdentifier GhcPkgId])
-> [PackageIdentifier] -> RIO env [Map PackageIdentifier GhcPkgId]
forall a b. (a -> b) -> a -> b
$ Set PackageIdentifier -> [PackageIdentifier]
forall a. Set a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList TaskConfigOpts
cOpts.missing
let pcOpts :: PackageConfigureOpts
pcOpts = TaskConfigOpts
cOpts.pkgConfigOpts
missing' :: Map PackageIdentifier GhcPkgId
missing' = [Map PackageIdentifier GhcPkgId] -> Map PackageIdentifier GhcPkgId
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions [Map PackageIdentifier GhcPkgId]
missingMapList
allDepsMap :: Map PackageIdentifier GhcPkgId
allDepsMap = Map PackageIdentifier GhcPkgId
-> Map PackageIdentifier GhcPkgId -> Map PackageIdentifier GhcPkgId
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map PackageIdentifier GhcPkgId
missing' Task
task.present
configureOpts' :: ConfigureOpts
configureOpts' = EnvConfig
-> BaseConfigOpts
-> Map PackageIdentifier GhcPkgId
-> Bool
-> IsMutable
-> PackageConfigureOpts
-> ConfigureOpts
ConfigureOpts.configureOpts
TaskConfigOpts
cOpts.envConfig
TaskConfigOpts
cOpts.baseConfigOpts
Map PackageIdentifier GhcPkgId
allDepsMap
TaskConfigOpts
cOpts.isLocalNonExtraDep
TaskConfigOpts
cOpts.isMutable
PackageConfigureOpts
pcOpts
configureOpts :: ConfigureOpts
configureOpts = ConfigureOpts
configureOpts'
{ nonPathRelated = configureOpts'.nonPathRelated ++ map T.unpack extra }
deps :: Set GhcPkgId
deps = [GhcPkgId] -> Set GhcPkgId
forall a. Ord a => [a] -> Set a
Set.fromList ([GhcPkgId] -> Set GhcPkgId) -> [GhcPkgId] -> Set GhcPkgId
forall a b. (a -> b) -> a -> b
$ Map PackageIdentifier GhcPkgId -> [GhcPkgId]
forall k a. Map k a -> [a]
Map.elems Map PackageIdentifier GhcPkgId
missing' [GhcPkgId] -> [GhcPkgId] -> [GhcPkgId]
forall a. [a] -> [a] -> [a]
++ Map PackageIdentifier GhcPkgId -> [GhcPkgId]
forall k a. Map k a -> [a]
Map.elems Task
task.present
components :: Set ByteString
components = case Task
task.taskType of
TTLocalMutable LocalPackage
lp ->
(NamedComponent -> ByteString)
-> Set NamedComponent -> Set ByteString
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (Text -> ByteString
encodeUtf8 (Text -> ByteString)
-> (NamedComponent -> Text) -> NamedComponent -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamedComponent -> Text
renderComponent) LocalPackage
lp.components
TTRemotePackage{} -> Set ByteString
forall a. Set a
Set.empty
cache :: ConfigCache
cache = ConfigCache
{ ConfigureOpts
configureOpts :: ConfigureOpts
configureOpts :: ConfigureOpts
configureOpts
, Set GhcPkgId
deps :: Set GhcPkgId
deps :: Set GhcPkgId
deps
, Set ByteString
components :: Set ByteString
components :: Set ByteString
components
, buildHaddocks :: Bool
buildHaddocks = Task
task.buildHaddocks
, pkgSrc :: CachePkgSrc
pkgSrc = Task
task.cachePkgSrc
, pathEnvVar :: Text
pathEnvVar = ExecuteEnv
ee.pathEnvVar
}
(Map PackageIdentifier GhcPkgId, ConfigCache)
-> RIO env (Map PackageIdentifier GhcPkgId, ConfigCache)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map PackageIdentifier GhcPkgId
allDepsMap, ConfigCache
cache)
ensureConfig :: HasEnvConfig env
=> ConfigCache
-> Path Abs Dir
-> BuildOpts
-> RIO env ()
-> (ExcludeTHLoading -> [String] -> RIO env ())
-> Path Abs File
-> Task
-> RIO env Bool
ensureConfig :: forall env.
HasEnvConfig env =>
ConfigCache
-> Path Abs Dir
-> BuildOpts
-> RIO env ()
-> (ExcludeTHLoading -> [[Char]] -> RIO env ())
-> Path Abs File
-> Task
-> RIO env Bool
ensureConfig ConfigCache
newConfigCache Path Abs Dir
pkgDir BuildOpts
buildOpts RIO env ()
announce ExcludeTHLoading -> [[Char]] -> RIO env ()
cabal Path Abs File
cabalFP Task
task = do
CTime
newCabalMod <-
IO CTime -> RIO env CTime
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO CTime -> RIO env CTime) -> IO CTime -> RIO env CTime
forall a b. (a -> b) -> a -> b
$ FileStatus -> CTime
modificationTime (FileStatus -> CTime) -> IO FileStatus -> IO CTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO FileStatus
getFileStatus (Path Abs File -> [Char]
forall b t. Path b t -> [Char]
toFilePath Path Abs File
cabalFP)
Path Abs File
setupConfigfp <- Path Abs Dir -> RIO env (Path Abs File)
forall env (m :: * -> *).
(HasEnvConfig env, MonadReader env m, MonadThrow m) =>
Path Abs Dir -> m (Path Abs File)
setupConfigFromDir Path Abs Dir
pkgDir
let getNewSetupConfigMod :: RIO env (Maybe CTime)
getNewSetupConfigMod =
IO (Maybe CTime) -> RIO env (Maybe CTime)
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe CTime) -> RIO env (Maybe CTime))
-> IO (Maybe CTime) -> RIO env (Maybe CTime)
forall a b. (a -> b) -> a -> b
$ (() -> Maybe CTime)
-> (FileStatus -> Maybe CTime)
-> Either () FileStatus
-> Maybe CTime
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe CTime -> () -> Maybe CTime
forall a b. a -> b -> a
const Maybe CTime
forall a. Maybe a
Nothing) (CTime -> Maybe CTime
forall a. a -> Maybe a
Just (CTime -> Maybe CTime)
-> (FileStatus -> CTime) -> FileStatus -> Maybe CTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileStatus -> CTime
modificationTime) (Either () FileStatus -> Maybe CTime)
-> IO (Either () FileStatus) -> IO (Maybe CTime)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
(IOError -> Maybe ()) -> IO FileStatus -> IO (Either () FileStatus)
forall (m :: * -> *) e b a.
(MonadUnliftIO m, Exception e) =>
(e -> Maybe b) -> m a -> m (Either b a)
tryJust
(Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> (IOError -> Bool) -> IOError -> Maybe ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOError -> Bool
isDoesNotExistError)
([Char] -> IO FileStatus
getFileStatus (Path Abs File -> [Char]
forall b t. Path b t -> [Char]
toFilePath Path Abs File
setupConfigfp))
Maybe CTime
newSetupConfigMod <- RIO env (Maybe CTime)
getNewSetupConfigMod
ByteString
newConfigFileRoot <- [Char] -> ByteString
S8.pack ([Char] -> ByteString)
-> (Path Abs Dir -> [Char]) -> Path Abs Dir -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs Dir -> [Char]
forall b t. Path b t -> [Char]
toFilePath (Path Abs Dir -> ByteString)
-> RIO env (Path Abs Dir) -> RIO env ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting (Path Abs Dir) env (Path Abs Dir) -> RIO env (Path Abs Dir)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Path Abs Dir) env (Path Abs Dir)
forall env r. HasBuildConfig env => Getting r env (Path Abs Dir)
configFileRootL
Bool
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
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
let ignoreComponents :: ConfigCache -> ConfigCache
ignoreComponents :: ConfigCache -> ConfigCache
ignoreComponents ConfigCache
cc = ConfigCache
cc { ConfigCache.components = Set.empty }
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
Maybe CTime
mOldSetupConfigMod <- Path Abs Dir -> RIO env (Maybe CTime)
forall env.
HasEnvConfig env =>
Path Abs Dir -> RIO env (Maybe CTime)
tryGetSetupConfigMod Path Abs Dir
pkgDir
Maybe ByteString
mOldProjectRoot <- Path Abs Dir -> RIO env (Maybe ByteString)
forall env.
HasEnvConfig env =>
Path Abs Dir -> RIO env (Maybe ByteString)
tryGetPackageProjectRoot Path Abs Dir
pkgDir
Bool -> RIO env Bool
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> RIO env Bool) -> Bool -> RIO env Bool
forall a b. (a -> b) -> a -> b
$
(ConfigCache -> ConfigCache)
-> Maybe ConfigCache -> Maybe ConfigCache
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ConfigCache -> ConfigCache
ignoreComponents Maybe ConfigCache
mOldConfigCache
Maybe ConfigCache -> Maybe ConfigCache -> Bool
forall a. Eq a => a -> a -> Bool
/= ConfigCache -> Maybe ConfigCache
forall a. a -> Maybe a
Just (ConfigCache -> ConfigCache
ignoreComponents ConfigCache
newConfigCache)
Bool -> Bool -> Bool
|| Maybe CTime
mOldCabalMod Maybe CTime -> Maybe CTime -> Bool
forall a. Eq a => a -> a -> Bool
/= CTime -> Maybe CTime
forall a. a -> Maybe a
Just CTime
newCabalMod
Bool -> Bool -> Bool
|| Maybe CTime
mOldSetupConfigMod Maybe CTime -> Maybe CTime -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe CTime
newSetupConfigMod
Bool -> Bool -> Bool
|| Maybe ByteString
mOldProjectRoot Maybe ByteString -> Maybe ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
newConfigFileRoot
Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Task
task.buildTypeConfig (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
Path Abs Dir -> RIO env ()
forall env b.
(HasProcessContext env, HasTerm env) =>
Path b Dir -> RIO env ()
ensureConfigureScript Path Abs Dir
pkgDir
Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
needConfig (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
Path Abs Dir -> RIO env ()
forall env. HasEnvConfig env => Path Abs Dir -> RIO env ()
deleteCaches Path Abs Dir
pkgDir
RIO env ()
announce
CompilerPaths
cp <- Getting CompilerPaths env CompilerPaths -> RIO env CompilerPaths
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting CompilerPaths env CompilerPaths
forall env. HasCompiler env => SimpleGetter env CompilerPaths
SimpleGetter env CompilerPaths
compilerPathsL
let (GhcPkgExe Path Abs File
pkgPath) = CompilerPaths
cp.pkg
let programNames :: [([Char], [Char])]
programNames =
case CompilerPaths -> WhichCompiler
forall env (m :: * -> *).
(MonadReader env m, HasCompiler env) =>
m WhichCompiler
cpWhich CompilerPaths
cp of
WhichCompiler
Ghc ->
[ ([Char]
"ghc", Path Abs File -> [Char]
forall b t. Path b t -> [Char]
toFilePath CompilerPaths
cp.compiler)
, ([Char]
"ghc-pkg", Path Abs File -> [Char]
forall b t. Path b t -> [Char]
toFilePath Path Abs File
pkgPath)
]
[[[Char]]]
exes <- [([Char], [Char])]
-> (([Char], [Char]) -> RIO env [[Char]]) -> RIO env [[[Char]]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [([Char], [Char])]
programNames ((([Char], [Char]) -> RIO env [[Char]]) -> RIO env [[[Char]]])
-> (([Char], [Char]) -> RIO env [[Char]]) -> RIO env [[[Char]]]
forall a b. (a -> b) -> a -> b
$ \([Char]
name, [Char]
file) -> do
Either ProcessException [Char]
mpath <- [Char] -> RIO env (Either ProcessException [Char])
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasProcessContext env) =>
[Char] -> m (Either ProcessException [Char])
findExecutable [Char]
file
[[Char]] -> RIO env [[Char]]
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([[Char]] -> RIO env [[Char]]) -> [[Char]] -> RIO env [[Char]]
forall a b. (a -> b) -> a -> b
$ case Either ProcessException [Char]
mpath of
Left ProcessException
_ -> []
Right [Char]
x -> [Char] -> [[Char]]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> [[Char]]) -> [Char] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Char]
"--with-", [Char]
name, [Char]
"=", [Char]
x]
let allOpts :: [[Char]]
allOpts =
[[[Char]]] -> [[Char]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[[Char]]]
exes
[[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> ConfigureOpts -> [[Char]]
ConfigureOpts.renderConfigureOpts ConfigCache
newConfigCache.configureOpts
ExcludeTHLoading -> [[Char]] -> RIO env ()
cabal ExcludeTHLoading
KeepTHLoading ([[Char]] -> RIO env ()) -> [[Char]] -> RIO env ()
forall a b. (a -> b) -> a -> b
$ [Char]
"configure" [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]]
allOpts
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
RIO env (Maybe CTime)
getNewSetupConfigMod RIO env (Maybe CTime) -> (Maybe CTime -> RIO env ()) -> RIO env ()
forall a b. RIO env a -> (a -> RIO env b) -> RIO env b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Path Abs Dir -> Maybe CTime -> RIO env ()
forall env.
HasEnvConfig env =>
Path Abs Dir -> Maybe CTime -> RIO env ()
writeSetupConfigMod Path Abs Dir
pkgDir
Path Abs Dir -> ByteString -> RIO env ()
forall env.
HasEnvConfig env =>
Path Abs Dir -> ByteString -> RIO env ()
writePackageProjectRoot Path Abs Dir
pkgDir ByteString
newConfigFileRoot
Bool -> RIO env Bool
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
needConfig
packageNamePrefix :: ExecuteEnv -> PackageName -> String
packageNamePrefix :: ExecuteEnv -> PackageName -> [Char]
packageNamePrefix ExecuteEnv
ee PackageName
name' =
let name :: [Char]
name = PackageName -> [Char]
packageNameString PackageName
name'
paddedName :: [Char]
paddedName =
case ExecuteEnv
ee.largestPackageName of
Maybe Int
Nothing -> [Char]
name
Just Int
len ->
Bool -> [Char] -> [Char]
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= [Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
name) ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
take Int
len ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
name [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Char -> [Char]
forall a. a -> [a]
L.repeat Char
' '
in [Char]
paddedName [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"> "
announceTask ::
HasLogFunc env
=> ExecuteEnv
-> TaskType
-> Utf8Builder
-> RIO env ()
announceTask :: forall env.
HasLogFunc env =>
ExecuteEnv -> TaskType -> Utf8Builder -> RIO env ()
announceTask ExecuteEnv
ee TaskType
taskType Utf8Builder
action = Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$
[Char] -> Utf8Builder
forall a. IsString a => [Char] -> a
fromString
(ExecuteEnv -> PackageName -> [Char]
packageNamePrefix ExecuteEnv
ee (PackageIdentifier -> PackageName
pkgName (TaskType -> PackageIdentifier
taskTypePackageIdentifier TaskType
taskType)))
Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
action
singleBuild :: forall env. (HasEnvConfig env, HasRunner env)
=> ActionContext
-> ExecuteEnv
-> Task
-> InstalledMap
-> Bool
-> RIO env ()
singleBuild :: forall env.
(HasEnvConfig env, HasRunner env) =>
ActionContext
-> ExecuteEnv -> Task -> InstalledMap -> Bool -> RIO env ()
singleBuild
ActionContext
ac
ExecuteEnv
ee
Task
task
InstalledMap
installedMap
Bool
isFinalBuild
= do
(Map PackageIdentifier GhcPkgId
allDepsMap, ConfigCache
cache) <-
ExecuteEnv
-> Task
-> InstalledMap
-> Bool
-> Bool
-> RIO env (Map PackageIdentifier GhcPkgId, ConfigCache)
forall env.
HasEnvConfig env =>
ExecuteEnv
-> Task
-> InstalledMap
-> Bool
-> Bool
-> RIO env (Map PackageIdentifier GhcPkgId, ConfigCache)
getConfigCache ExecuteEnv
ee Task
task InstalledMap
installedMap Bool
enableTests Bool
enableBenchmarks
let bcoSnapInstallRoot :: Path Abs Dir
bcoSnapInstallRoot = ExecuteEnv
ee.baseConfigOpts.snapInstallRoot
Maybe (PrecompiledCache Abs)
mprecompiled <- ConfigCache
-> TaskType
-> Path Abs Dir
-> RIO env (Maybe (PrecompiledCache Abs))
forall env.
HasEnvConfig env =>
ConfigCache
-> TaskType
-> Path Abs Dir
-> RIO env (Maybe (PrecompiledCache Abs))
getPrecompiled ConfigCache
cache Task
task.taskType Path Abs Dir
bcoSnapInstallRoot
Maybe Installed
minstalled <-
case Maybe (PrecompiledCache Abs)
mprecompiled of
Just PrecompiledCache Abs
precompiled -> ExecuteEnv
-> Task
-> PackageIdentifier
-> PrecompiledCache Abs
-> RIO env (Maybe Installed)
forall env b0.
(HasLogFunc env, HasCompiler env, HasTerm env,
HasProcessContext env, HasEnvConfig env) =>
ExecuteEnv
-> Task
-> PackageIdentifier
-> PrecompiledCache b0
-> RIO env (Maybe Installed)
copyPreCompiled ExecuteEnv
ee Task
task PackageIdentifier
pkgId PrecompiledCache Abs
precompiled
Maybe (PrecompiledCache Abs)
Nothing -> do
Maybe Curator
curator <- Getting (Maybe Curator) env (Maybe Curator)
-> RIO env (Maybe Curator)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting (Maybe Curator) env (Maybe Curator)
-> RIO env (Maybe Curator))
-> Getting (Maybe Curator) env (Maybe Curator)
-> RIO env (Maybe Curator)
forall a b. (a -> b) -> a -> b
$ (BuildConfig -> Const (Maybe Curator) BuildConfig)
-> env -> Const (Maybe Curator) env
forall env. HasBuildConfig env => Lens' env BuildConfig
Lens' env BuildConfig
buildConfigL ((BuildConfig -> Const (Maybe Curator) BuildConfig)
-> env -> Const (Maybe Curator) env)
-> ((Maybe Curator -> Const (Maybe Curator) (Maybe Curator))
-> BuildConfig -> Const (Maybe Curator) BuildConfig)
-> Getting (Maybe Curator) env (Maybe Curator)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BuildConfig -> Maybe Curator)
-> SimpleGetter BuildConfig (Maybe Curator)
forall s a. (s -> a) -> SimpleGetter s a
to (.curator)
ActionContext
-> ExecuteEnv
-> Task
-> InstalledMap
-> (Bool, Bool)
-> (Bool, Bool)
-> ConfigCache
-> Maybe Curator
-> Map PackageIdentifier GhcPkgId
-> RIO env (Maybe Installed)
forall env a.
HasEnvConfig env =>
ActionContext
-> ExecuteEnv
-> Task
-> Map PackageName (a, Installed)
-> (Bool, Bool)
-> (Bool, Bool)
-> ConfigCache
-> Maybe Curator
-> Map PackageIdentifier GhcPkgId
-> RIO env (Maybe Installed)
realConfigAndBuild
ActionContext
ac
ExecuteEnv
ee
Task
task
InstalledMap
installedMap
(Bool
enableTests, Bool
enableBenchmarks)
(Bool
isFinalBuild, Bool
buildingFinals)
ConfigCache
cache
Maybe Curator
curator
Map PackageIdentifier GhcPkgId
allDepsMap
Maybe Installed -> (Installed -> RIO env ()) -> RIO env ()
forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe Installed
minstalled ((Installed -> RIO env ()) -> RIO env ())
-> (Installed -> RIO env ()) -> RIO env ()
forall a b. (a -> b) -> a -> b
$ \Installed
installed -> do
Installed -> ConfigCache -> RIO env ()
forall env.
HasEnvConfig env =>
Installed -> ConfigCache -> RIO env ()
writeFlagCache Installed
installed ConfigCache
cache
IO () -> RIO env ()
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO env ()) -> IO () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar (Map PackageIdentifier Installed)
-> (Map PackageIdentifier Installed
-> Map PackageIdentifier Installed)
-> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar ExecuteEnv
ee.ghcPkgIds ((Map PackageIdentifier Installed
-> Map PackageIdentifier Installed)
-> STM ())
-> (Map PackageIdentifier Installed
-> Map PackageIdentifier Installed)
-> STM ()
forall a b. (a -> b) -> a -> b
$ PackageIdentifier
-> Installed
-> Map PackageIdentifier Installed
-> Map PackageIdentifier Installed
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert PackageIdentifier
pkgId Installed
installed
where
pkgId :: PackageIdentifier
pkgId = Task -> PackageIdentifier
taskProvides Task
task
buildingFinals :: Bool
buildingFinals = Bool
isFinalBuild Bool -> Bool -> Bool
|| Task
task.allInOne
enableTests :: Bool
enableTests = Bool
buildingFinals Bool -> Bool -> Bool
&& (NamedComponent -> Bool) -> Set NamedComponent -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any NamedComponent -> Bool
isCTest (Task -> Set NamedComponent
taskComponents Task
task)
enableBenchmarks :: Bool
enableBenchmarks = Bool
buildingFinals Bool -> Bool -> Bool
&& (NamedComponent -> Bool) -> Set NamedComponent -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any NamedComponent -> Bool
isCBench (Task -> Set NamedComponent
taskComponents Task
task)
realConfigAndBuild ::
forall env a. HasEnvConfig env
=> ActionContext
-> ExecuteEnv
-> Task
-> Map PackageName (a, Installed)
-> (Bool, Bool)
-> (Bool, Bool)
-> ConfigCache
-> Maybe Curator
-> Map PackageIdentifier GhcPkgId
-> RIO env (Maybe Installed)
realConfigAndBuild :: forall env a.
HasEnvConfig env =>
ActionContext
-> ExecuteEnv
-> Task
-> Map PackageName (a, Installed)
-> (Bool, Bool)
-> (Bool, Bool)
-> ConfigCache
-> Maybe Curator
-> Map PackageIdentifier GhcPkgId
-> RIO env (Maybe Installed)
realConfigAndBuild
ActionContext
ac
ExecuteEnv
ee
Task
task
Map PackageName (a, Installed)
installedMap
(Bool
enableTests, Bool
enableBenchmarks)
(Bool
isFinalBuild, Bool
buildingFinals)
ConfigCache
cache
Maybe Curator
mcurator0
Map PackageIdentifier GhcPkgId
allDepsMap
= ActionContext
-> ExecuteEnv
-> TaskType
-> Map PackageIdentifier GhcPkgId
-> Maybe [Char]
-> (Package
-> Path Abs File
-> Path Abs Dir
-> (KeepOutputOpen -> ExcludeTHLoading -> [[Char]] -> RIO env ())
-> (Utf8Builder -> RIO env ())
-> OutputType
-> RIO env (Maybe Installed))
-> RIO env (Maybe Installed)
forall env a.
HasEnvConfig env =>
ActionContext
-> ExecuteEnv
-> TaskType
-> Map PackageIdentifier GhcPkgId
-> Maybe [Char]
-> (Package
-> Path Abs File
-> Path Abs Dir
-> (KeepOutputOpen -> ExcludeTHLoading -> [[Char]] -> RIO env ())
-> (Utf8Builder -> RIO env ())
-> OutputType
-> RIO env a)
-> RIO env a
withSingleContext ActionContext
ac ExecuteEnv
ee Task
task.taskType Map PackageIdentifier GhcPkgId
allDepsMap Maybe [Char]
forall a. Maybe a
Nothing ((Package
-> Path Abs File
-> Path Abs Dir
-> (KeepOutputOpen -> ExcludeTHLoading -> [[Char]] -> RIO env ())
-> (Utf8Builder -> RIO env ())
-> OutputType
-> RIO env (Maybe Installed))
-> RIO env (Maybe Installed))
-> (Package
-> Path Abs File
-> Path Abs Dir
-> (KeepOutputOpen -> ExcludeTHLoading -> [[Char]] -> RIO env ())
-> (Utf8Builder -> RIO env ())
-> OutputType
-> RIO env (Maybe Installed))
-> RIO env (Maybe Installed)
forall a b. (a -> b) -> a -> b
$
\Package
package Path Abs File
cabalFP Path Abs Dir
pkgDir KeepOutputOpen -> ExcludeTHLoading -> [[Char]] -> RIO env ()
cabal0 Utf8Builder -> RIO env ()
announce OutputType
_outputType -> do
let cabal :: ExcludeTHLoading -> [[Char]] -> RIO env ()
cabal = KeepOutputOpen -> ExcludeTHLoading -> [[Char]] -> RIO env ()
cabal0 KeepOutputOpen
CloseOnException
Bool
_neededConfig <-
ConfigCache
-> Path Abs Dir
-> BuildOpts
-> RIO env ()
-> (ExcludeTHLoading -> [[Char]] -> RIO env ())
-> Path Abs File
-> Task
-> RIO env Bool
forall env.
HasEnvConfig env =>
ConfigCache
-> Path Abs Dir
-> BuildOpts
-> RIO env ()
-> (ExcludeTHLoading -> [[Char]] -> RIO env ())
-> Path Abs File
-> Task
-> RIO env Bool
ensureConfig
ConfigCache
cache
Path Abs Dir
pkgDir
ExecuteEnv
ee.buildOpts
(Utf8Builder -> RIO env ()
announce (Utf8Builder
"configure" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Text
annSuffix))
ExcludeTHLoading -> [[Char]] -> RIO env ()
cabal
Path Abs File
cabalFP
Task
task
let installedMapHasThisPkg :: Bool
installedMapHasThisPkg :: Bool
installedMapHasThisPkg =
case PackageName
-> Map PackageName (a, Installed) -> Maybe (a, Installed)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Package
package.name Map PackageName (a, Installed)
installedMap of
Just (a
_, Library PackageIdentifier
ident InstalledLibraryInfo
_) -> PackageIdentifier
ident PackageIdentifier -> PackageIdentifier -> Bool
forall a. Eq a => a -> a -> Bool
== PackageIdentifier
pkgId
Just (a
_, Executable PackageIdentifier
_) -> Bool
True
Maybe (a, Installed)
_ -> Bool
False
case ( ExecuteEnv
ee.buildOptsCLI.onlyConfigure
, ExecuteEnv
ee.buildOptsCLI.initialBuildSteps Bool -> Bool -> Bool
&& Task -> Bool
taskIsTarget Task
task
) of
(Bool
True, Bool
_) | [Action] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ActionContext
ac.downstream -> Maybe Installed -> RIO env (Maybe Installed)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Installed
forall a. Maybe a
Nothing
(Bool
_, Bool
True) | [Action] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ActionContext
ac.downstream Bool -> Bool -> Bool
|| Bool
installedMapHasThisPkg -> do
(ExcludeTHLoading -> [[Char]] -> RIO env ())
-> (Utf8Builder -> RIO env ()) -> RIO env ()
initialBuildSteps ExcludeTHLoading -> [[Char]] -> RIO env ()
cabal Utf8Builder -> RIO env ()
announce
Maybe Installed -> RIO env (Maybe Installed)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Installed
forall a. Maybe a
Nothing
(Bool, Bool)
_ -> PackageName
-> Maybe Curator
-> Bool
-> Bool
-> Maybe Installed
-> RIO env (Maybe Installed)
-> RIO env (Maybe Installed)
forall env b.
(?callStack::CallStack, HasTerm env) =>
PackageName
-> Maybe Curator -> Bool -> Bool -> b -> RIO env b -> RIO env b
fulfillCuratorBuildExpectations
PackageName
pname
Maybe Curator
mcurator0
Bool
enableTests
Bool
enableBenchmarks
Maybe Installed
forall a. Maybe a
Nothing
(Installed -> Maybe Installed
forall a. a -> Maybe a
Just (Installed -> Maybe Installed)
-> RIO env Installed -> RIO env (Maybe Installed)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Package
-> Path Abs Dir
-> (KeepOutputOpen -> ExcludeTHLoading -> [[Char]] -> RIO env ())
-> (Utf8Builder -> RIO env ())
-> RIO env Installed
realBuild Package
package Path Abs Dir
pkgDir KeepOutputOpen -> ExcludeTHLoading -> [[Char]] -> RIO env ()
cabal0 Utf8Builder -> RIO env ()
announce)
where
pkgId :: PackageIdentifier
pkgId = Task -> PackageIdentifier
taskProvides Task
task
PackageIdentifier PackageName
pname Version
_ = PackageIdentifier
pkgId
doHaddock :: Maybe Curator -> Package -> Bool
doHaddock Maybe Curator
curator Package
package =
Task
task.buildHaddocks
Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
isFinalBuild
Bool -> Bool -> Bool
&& Package -> Bool
mainLibraryHasExposedModules Package
package
Bool -> Bool -> Bool
&& Bool -> (Curator -> Bool) -> Maybe Curator -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (PackageName -> Set PackageName -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.notMember PackageName
pname (Set PackageName -> Bool)
-> (Curator -> Set PackageName) -> Curator -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.skipHaddock)) Maybe Curator
curator
annSuffix :: Text
annSuffix = if Text
result Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"" then Text
"" else Text
" (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
result Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
where
result :: Text
result = Text -> [Text] -> Text
T.intercalate Text
" + " ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ [[Text]] -> [Text]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [Text
"lib" | Task
task.allInOne Bool -> Bool -> Bool
&& Bool
hasLib]
, [Text
"sub-lib" | Task
task.allInOne Bool -> Bool -> Bool
&& Bool
hasSubLib]
, [Text
"exe" | Task
task.allInOne Bool -> Bool -> Bool
&& Bool
hasExe]
, [Text
"test" | Bool
enableTests]
, [Text
"bench" | Bool
enableBenchmarks]
]
(Bool
hasLib, Bool
hasSubLib, Bool
hasExe) = case Task
task.taskType of
TTLocalMutable LocalPackage
lp ->
let package :: Package
package = LocalPackage
lp.package
hasLibrary :: Bool
hasLibrary = Package -> Bool
hasBuildableMainLibrary Package
package
hasSubLibraries :: Bool
hasSubLibraries = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ CompCollection StackLibrary -> Bool
forall a. CompCollection a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Package
package.subLibraries
hasExecutables :: Bool
hasExecutables = Bool -> Bool
not (Bool -> Bool)
-> (Set StackUnqualCompName -> Bool)
-> Set StackUnqualCompName
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set StackUnqualCompName -> Bool
forall a. Set a -> Bool
Set.null (Set StackUnqualCompName -> Bool)
-> Set StackUnqualCompName -> Bool
forall a b. (a -> b) -> a -> b
$ LocalPackage -> Set StackUnqualCompName
exesToBuild LocalPackage
lp
in (Bool
hasLibrary, Bool
hasSubLibraries, Bool
hasExecutables)
TaskType
_ -> (Bool
False, Bool
False, Bool
False)
initialBuildSteps :: (ExcludeTHLoading -> [[Char]] -> RIO env ())
-> (Utf8Builder -> RIO env ()) -> RIO env ()
initialBuildSteps ExcludeTHLoading -> [[Char]] -> RIO env ()
cabal Utf8Builder -> RIO env ()
announce = do
Utf8Builder -> RIO env ()
announce (Utf8Builder
"initial-build-steps" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Text
annSuffix)
ExcludeTHLoading -> [[Char]] -> RIO env ()
cabal ExcludeTHLoading
KeepTHLoading [[Char]
"repl", [Char]
"stack-initial-build-steps"]
realBuild ::
Package
-> Path Abs Dir
-> (KeepOutputOpen -> ExcludeTHLoading -> [String] -> RIO env ())
-> (Utf8Builder -> RIO env ())
-> RIO env Installed
realBuild :: Package
-> Path Abs Dir
-> (KeepOutputOpen -> ExcludeTHLoading -> [[Char]] -> RIO env ())
-> (Utf8Builder -> RIO env ())
-> RIO env Installed
realBuild Package
package Path Abs Dir
pkgDir KeepOutputOpen -> ExcludeTHLoading -> [[Char]] -> RIO env ()
cabal0 Utf8Builder -> RIO env ()
announce = do
let cabal :: ExcludeTHLoading -> [[Char]] -> RIO env ()
cabal = KeepOutputOpen -> ExcludeTHLoading -> [[Char]] -> RIO env ()
cabal0 KeepOutputOpen
CloseOnException
WhichCompiler
wc <- Getting WhichCompiler env WhichCompiler -> RIO env WhichCompiler
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting WhichCompiler env WhichCompiler -> RIO env WhichCompiler)
-> Getting WhichCompiler env WhichCompiler -> RIO env WhichCompiler
forall a b. (a -> b) -> a -> b
$ Getting WhichCompiler env ActualCompiler
forall env. HasSourceMap env => SimpleGetter env ActualCompiler
SimpleGetter env ActualCompiler
actualCompilerVersionL Getting WhichCompiler env ActualCompiler
-> ((WhichCompiler -> Const WhichCompiler WhichCompiler)
-> ActualCompiler -> Const WhichCompiler ActualCompiler)
-> Getting WhichCompiler env WhichCompiler
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WhichCompiler -> Const WhichCompiler WhichCompiler)
-> ActualCompiler -> Const WhichCompiler ActualCompiler
forall r. Getting r ActualCompiler WhichCompiler
whichCompilerL
InstallLocation -> PackageIdentifier -> RIO env ()
forall env.
HasEnvConfig env =>
InstallLocation -> PackageIdentifier -> RIO env ()
markExeNotInstalled (Task -> InstallLocation
taskLocation Task
task) PackageIdentifier
pkgId
case Task
task.taskType of
TTLocalMutable LocalPackage
lp -> do
Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
enableTests (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Path Abs Dir -> TestStatus -> RIO env ()
forall env.
HasEnvConfig env =>
Path Abs Dir -> TestStatus -> RIO env ()
setTestStatus Path Abs Dir
pkgDir TestStatus
TSUnknown
Map NamedComponent (Map [Char] FileCacheInfo)
caches <- MemoizedWith
EnvConfig (Map NamedComponent (Map [Char] FileCacheInfo))
-> RIO env (Map NamedComponent (Map [Char] FileCacheInfo))
forall env (m :: * -> *) a.
(HasEnvConfig env, MonadReader env m, MonadIO m) =>
MemoizedWith EnvConfig a -> m a
runMemoizedWith LocalPackage
lp.newBuildCaches
((NamedComponent, Map [Char] FileCacheInfo) -> RIO env ())
-> [(NamedComponent, Map [Char] FileCacheInfo)] -> RIO env ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_
((NamedComponent -> Map [Char] FileCacheInfo -> RIO env ())
-> (NamedComponent, Map [Char] FileCacheInfo) -> RIO env ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Path Abs Dir
-> NamedComponent -> Map [Char] FileCacheInfo -> RIO env ()
forall env.
HasEnvConfig env =>
Path Abs Dir
-> NamedComponent -> Map [Char] FileCacheInfo -> RIO env ()
writeBuildCache Path Abs Dir
pkgDir))
(Map NamedComponent (Map [Char] FileCacheInfo)
-> [(NamedComponent, Map [Char] FileCacheInfo)]
forall k a. Map k a -> [(k, a)]
Map.toList Map NamedComponent (Map [Char] FileCacheInfo)
caches)
TTRemotePackage{} -> () -> RIO env ()
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
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
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
let showModuleWarning :: PackageWarning -> StyleDoc
showModuleWarning (UnlistedModulesWarning NamedComponent
comp [ModuleName]
modules) =
StyleDoc
"- In" StyleDoc -> StyleDoc -> StyleDoc
<+>
[Char] -> StyleDoc
forall a. IsString a => [Char] -> a
fromString (Text -> [Char]
T.unpack (NamedComponent -> Text
renderComponent NamedComponent
comp)) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<>
StyleDoc
":" StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<>
Int -> StyleDoc -> StyleDoc
indent Int
4 ( [StyleDoc] -> StyleDoc
forall a. Monoid a => [a] -> a
mconcat
([StyleDoc] -> StyleDoc) -> [StyleDoc] -> StyleDoc
forall a b. (a -> b) -> a -> b
$ StyleDoc -> [StyleDoc] -> [StyleDoc]
forall a. a -> [a] -> [a]
L.intersperse StyleDoc
line
([StyleDoc] -> [StyleDoc]) -> [StyleDoc] -> [StyleDoc]
forall a b. (a -> b) -> a -> b
$ (ModuleName -> StyleDoc) -> [ModuleName] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map
(Style -> StyleDoc -> StyleDoc
style Style
Good (StyleDoc -> StyleDoc)
-> (ModuleName -> StyleDoc) -> ModuleName -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> StyleDoc
forall a. IsString a => [Char] -> a
fromString ([Char] -> StyleDoc)
-> (ModuleName -> [Char]) -> ModuleName -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> [Char]
forall a. Pretty a => a -> [Char]
C.display)
[ModuleName]
modules
)
Maybe (Path Abs File, [PackageWarning])
-> ((Path Abs File, [PackageWarning]) -> RIO env ()) -> RIO env ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (Path Abs File, [PackageWarning])
mlocalWarnings (((Path Abs File, [PackageWarning]) -> RIO env ()) -> RIO env ())
-> ((Path Abs File, [PackageWarning]) -> RIO env ()) -> RIO env ()
forall a b. (a -> b) -> a -> b
$ \(Path Abs File
cabalFP, [PackageWarning]
warnings) ->
Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([PackageWarning] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PackageWarning]
warnings) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ StyleDoc -> RIO env ()
forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
MonadIO m) =>
StyleDoc -> m ()
prettyWarn (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$
[Char] -> StyleDoc
flow [Char]
"The following modules should be added to \
\exposed-modules or other-modules in" StyleDoc -> StyleDoc -> StyleDoc
<+>
Path Abs File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
cabalFP
StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
":"
StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> Int -> StyleDoc -> StyleDoc
indent Int
4 ( [StyleDoc] -> StyleDoc
forall a. Monoid a => [a] -> a
mconcat
([StyleDoc] -> StyleDoc) -> [StyleDoc] -> StyleDoc
forall a b. (a -> b) -> a -> b
$ StyleDoc -> [StyleDoc] -> [StyleDoc]
forall a. a -> [a] -> [a]
L.intersperse StyleDoc
line
([StyleDoc] -> [StyleDoc]) -> [StyleDoc] -> [StyleDoc]
forall a b. (a -> b) -> a -> b
$ (PackageWarning -> StyleDoc) -> [PackageWarning] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map PackageWarning -> StyleDoc
showModuleWarning [PackageWarning]
warnings
)
StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [Char] -> StyleDoc
flow [Char]
"Missing modules in the Cabal file are likely to cause \
\undefined reference errors from the linker, along with \
\other problems."
ActualCompiler
actualCompiler <- Getting ActualCompiler env ActualCompiler -> RIO env ActualCompiler
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting ActualCompiler env ActualCompiler
forall env. HasSourceMap env => SimpleGetter env ActualCompiler
SimpleGetter env ActualCompiler
actualCompilerVersionL
() <- Utf8Builder -> RIO env ()
announce
( Utf8Builder
"build"
Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Text
annSuffix
Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" with "
Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> ActualCompiler -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display ActualCompiler
actualCompiler
)
Config
config <- Getting Config env Config -> RIO env Config
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Config env Config
forall env. HasConfig env => Lens' env Config
Lens' env Config
configL
[[Char]]
extraOpts <- WhichCompiler -> BuildOpts -> RIO env [[Char]]
forall env.
(HasEnvConfig env, HasRunner env) =>
WhichCompiler -> BuildOpts -> RIO env [[Char]]
extraBuildOptions WhichCompiler
wc ExecuteEnv
ee.buildOpts
let stripTHLoading :: ExcludeTHLoading
stripTHLoading
| Config
config.hideTHLoading = ExcludeTHLoading
ExcludeTHLoading
| Bool
otherwise = ExcludeTHLoading
KeepTHLoading
([[Char]]
buildOpts, [[Char]]
copyOpts) <-
case (Task
task.taskType, Task
task.allInOne, Bool
isFinalBuild) of
(TaskType
_, Bool
True, Bool
True) -> BuildException -> RIO env ([[Char]], [[Char]])
forall e a. (?callStack::CallStack, Exception e) => e -> RIO env a
forall (m :: * -> *) e a.
(MonadThrow m, ?callStack::CallStack, Exception e) =>
e -> m a
throwM BuildException
AllInOneBuildBug
(TTLocalMutable LocalPackage
lp, Bool
False, Bool
False) ->
let componentOpts :: [[Char]]
componentOpts = LocalPackage -> [[Char]]
primaryComponentOptions LocalPackage
lp
in ([[Char]], [[Char]]) -> RIO env ([[Char]], [[Char]])
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([[Char]]
componentOpts, [[Char]]
componentOpts)
(TTLocalMutable LocalPackage
lp, Bool
False, Bool
True) -> ([[Char]], [[Char]]) -> RIO env ([[Char]], [[Char]])
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LocalPackage -> [[Char]]
finalComponentOptions LocalPackage
lp, [])
(TTLocalMutable LocalPackage
lp, Bool
True, Bool
False) ->
let componentOpts :: [[Char]]
componentOpts = LocalPackage -> [[Char]]
primaryComponentOptions LocalPackage
lp
in ([[Char]], [[Char]]) -> RIO env ([[Char]], [[Char]])
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([[Char]]
componentOpts [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> LocalPackage -> [[Char]]
finalComponentOptions LocalPackage
lp, [[Char]]
componentOpts)
(TTRemotePackage{}, Bool
_, Bool
_) -> ([[Char]], [[Char]]) -> RIO env ([[Char]], [[Char]])
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], [])
ExcludeTHLoading -> [[Char]] -> RIO env ()
cabal ExcludeTHLoading
stripTHLoading ([Char]
"build" [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]]
buildOpts [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [[Char]]
extraOpts)
RIO env () -> (BuildPrettyException -> RIO env ()) -> RIO env ()
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \BuildPrettyException
ex -> case BuildPrettyException
ex of
CabalExitedUnsuccessfully{} ->
Bool -> RIO env ()
postBuildCheck Bool
False RIO env () -> RIO env () -> RIO env ()
forall a b. RIO env a -> RIO env b -> RIO env b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> BuildPrettyException -> RIO env ()
forall e (m :: * -> *) a.
(Exception e, MonadThrow m, Pretty e) =>
e -> m a
prettyThrowM BuildPrettyException
ex
BuildPrettyException
_ -> BuildPrettyException -> RIO env ()
forall e a. (?callStack::CallStack, Exception e) => e -> RIO env a
forall (m :: * -> *) e a.
(MonadThrow m, ?callStack::CallStack, Exception e) =>
e -> m a
throwM BuildPrettyException
ex
Bool -> RIO env ()
postBuildCheck Bool
True
Maybe Curator
mcurator <- Getting (Maybe Curator) env (Maybe Curator)
-> RIO env (Maybe Curator)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting (Maybe Curator) env (Maybe Curator)
-> RIO env (Maybe Curator))
-> Getting (Maybe Curator) env (Maybe Curator)
-> RIO env (Maybe Curator)
forall a b. (a -> b) -> a -> b
$ (BuildConfig -> Const (Maybe Curator) BuildConfig)
-> env -> Const (Maybe Curator) env
forall env. HasBuildConfig env => Lens' env BuildConfig
Lens' env BuildConfig
buildConfigL ((BuildConfig -> Const (Maybe Curator) BuildConfig)
-> env -> Const (Maybe Curator) env)
-> ((Maybe Curator -> Const (Maybe Curator) (Maybe Curator))
-> BuildConfig -> Const (Maybe Curator) BuildConfig)
-> Getting (Maybe Curator) env (Maybe Curator)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BuildConfig -> Maybe Curator)
-> SimpleGetter BuildConfig (Maybe Curator)
forall s a. (s -> a) -> SimpleGetter s a
to (.curator)
Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Curator -> Package -> Bool
doHaddock Maybe Curator
mcurator Package
package) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
let isTaskTargetMutable :: Bool
isTaskTargetMutable = Task -> IsMutable
taskTargetIsMutable Task
task IsMutable -> IsMutable -> Bool
forall a. Eq a => a -> a -> Bool
== IsMutable
Mutable
isHaddockForHackage :: Bool
isHaddockForHackage =
ExecuteEnv
ee.buildOpts.haddockForHackage Bool -> Bool -> Bool
&& Bool
isTaskTargetMutable
Utf8Builder -> RIO env ()
announce (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ if Bool
isHaddockForHackage
then Utf8Builder
"haddock for Hackage"
else Utf8Builder
"haddock"
let quickjump :: [[Char]]
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] -> [[Char]
"--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 :: [[Char]]
args = [[[Char]]] -> [[Char]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
( ( if Bool
isHaddockForHackage
then
[ [ [Char]
"--for-hackage" ] ]
else
[ [ [Char]
"--html"
, [Char]
"--hoogle"
, [Char]
"--html-location=../$pkg-$version/"
]
, [ [Char]
"--haddock-option=--hyperlinked-source"
| ExecuteEnv
ee.buildOpts.haddockHyperlinkSource
]
, [ [Char]
"--executables" | ExecuteEnv
ee.buildOpts.haddockExecutables ]
, [ [Char]
"--tests" | ExecuteEnv
ee.buildOpts.haddockTests ]
, [ [Char]
"--benchmarks" | ExecuteEnv
ee.buildOpts.haddockBenchmarks ]
, [ [Char]
"--internal" | ExecuteEnv
ee.buildOpts.haddockInternal ]
, [[Char]]
quickjump
]
)
[[[Char]]] -> [[[Char]]] -> [[[Char]]]
forall a. Semigroup a => a -> a -> a
<> [ [ [Char]
"--haddock-option=" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
opt
| [Char]
opt <- ExecuteEnv
ee.buildOpts.haddockOpts.additionalArgs
]
]
)
KeepOutputOpen -> ExcludeTHLoading -> [[Char]] -> RIO env ()
cabal0 KeepOutputOpen
keep ExcludeTHLoading
KeepTHLoading ([[Char]] -> RIO env ()) -> [[Char]] -> RIO env ()
forall a b. (a -> b) -> a -> b
$ [Char]
"haddock" [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]]
args
let hasLibrary :: Bool
hasLibrary = Package -> Bool
hasBuildableMainLibrary Package
package
hasSubLibraries :: Bool
hasSubLibraries = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ CompCollection StackLibrary -> Bool
forall a. CompCollection a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Package
package.subLibraries
hasExecutables :: Bool
hasExecutables = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ CompCollection StackExecutable -> Bool
forall a. CompCollection a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Package
package.executables
shouldCopy :: Bool
shouldCopy =
Bool -> Bool
not Bool
isFinalBuild
Bool -> Bool -> Bool
&& (Bool
hasLibrary Bool -> Bool -> Bool
|| Bool
hasSubLibraries Bool -> Bool -> Bool
|| Bool
hasExecutables)
Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
shouldCopy (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ MVar () -> (() -> RIO env ()) -> RIO env ()
forall (m :: * -> *) a b.
MonadUnliftIO m =>
MVar a -> (a -> m b) -> m b
withMVar ExecuteEnv
ee.installLock ((() -> RIO env ()) -> RIO env ())
-> (() -> RIO env ()) -> RIO env ()
forall a b. (a -> b) -> a -> b
$ \() -> do
Utf8Builder -> RIO env ()
announce Utf8Builder
"copy/register"
Either BuildPrettyException ()
eres <- RIO env () -> RIO env (Either BuildPrettyException ())
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try (RIO env () -> RIO env (Either BuildPrettyException ()))
-> RIO env () -> RIO env (Either BuildPrettyException ())
forall a b. (a -> b) -> a -> b
$ ExcludeTHLoading -> [[Char]] -> RIO env ()
cabal ExcludeTHLoading
KeepTHLoading ([[Char]] -> RIO env ()) -> [[Char]] -> RIO env ()
forall a b. (a -> b) -> a -> b
$ [Char]
"copy" [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]]
copyOpts
case Either BuildPrettyException ()
eres of
Left err :: BuildPrettyException
err@CabalExitedUnsuccessfully{} ->
BuildException -> RIO env ()
forall e a. (?callStack::CallStack, Exception e) => e -> RIO env a
forall (m :: * -> *) e a.
(MonadThrow m, ?callStack::CallStack, Exception e) =>
e -> m a
throwM (BuildException -> RIO env ()) -> BuildException -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Bool -> [Char] -> BuildException
CabalCopyFailed
(Package
package.buildType BuildType -> BuildType -> Bool
forall a. Eq a => a -> a -> Bool
== BuildType
C.Simple)
(BuildPrettyException -> [Char]
forall e. Exception e => e -> [Char]
displayException BuildPrettyException
err)
Either BuildPrettyException ()
_ -> () -> RIO env ()
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
hasLibrary Bool -> Bool -> Bool
|| Bool
hasSubLibraries) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ ExcludeTHLoading -> [[Char]] -> RIO env ()
cabal ExcludeTHLoading
KeepTHLoading [[Char]
"register"]
Bool -> Maybe Text -> RIO env ()
forall env. HasEnvConfig env => Bool -> Maybe Text -> RIO env ()
copyDdumpFilesIfNeeded Bool
buildingFinals ExecuteEnv
ee.buildOpts.ddumpDir
Installed
installedPkg <-
ExecuteEnv
-> InstallLocation
-> Package
-> PackageIdentifier
-> RIO env Installed
forall env.
(HasEnvConfig env, HasTerm env) =>
ExecuteEnv
-> InstallLocation
-> Package
-> PackageIdentifier
-> RIO env Installed
fetchAndMarkInstalledPackage ExecuteEnv
ee (Task -> InstallLocation
taskLocation Task
task) Package
package PackageIdentifier
pkgId
TaskType
-> ActionContext
-> ConfigCache
-> ExecuteEnv
-> Installed
-> Package
-> PackageIdentifier
-> Path Abs Dir
-> RIO env ()
forall env b.
HasEnvConfig env =>
TaskType
-> ActionContext
-> ConfigCache
-> ExecuteEnv
-> Installed
-> Package
-> PackageIdentifier
-> Path b Dir
-> RIO env ()
postProcessRemotePackage
Task
task.taskType
ActionContext
ac
ConfigCache
cache
ExecuteEnv
ee
Installed
installedPkg
Package
package
PackageIdentifier
pkgId
Path Abs Dir
pkgDir
Installed -> RIO env Installed
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Installed
installedPkg
postProcessRemotePackage ::
(HasEnvConfig env)
=> TaskType
-> ActionContext
-> ConfigCache
-> ExecuteEnv
-> Installed
-> Package
-> PackageIdentifier
-> Path b Dir
-> RIO env ()
postProcessRemotePackage :: forall env b.
HasEnvConfig env =>
TaskType
-> ActionContext
-> ConfigCache
-> ExecuteEnv
-> Installed
-> Package
-> PackageIdentifier
-> Path b Dir
-> RIO env ()
postProcessRemotePackage
TaskType
taskType
ActionContext
ac
ConfigCache
cache
ExecuteEnv
ee
Installed
installedPackage
Package
package
PackageIdentifier
pkgId
Path b Dir
pkgDir
= case TaskType
taskType of
TTRemotePackage IsMutable
isMutable Package
_ PackageLocationImmutable
loc -> do
Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (IsMutable
isMutable IsMutable -> IsMutable -> Bool
forall a. Eq a => a -> a -> Bool
== IsMutable
Immutable) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ BaseConfigOpts
-> PackageLocationImmutable
-> ConfigureOpts
-> Bool
-> Installed
-> Set StackUnqualCompName
-> RIO env ()
forall env.
HasEnvConfig env =>
BaseConfigOpts
-> PackageLocationImmutable
-> ConfigureOpts
-> Bool
-> Installed
-> Set StackUnqualCompName
-> RIO env ()
writePrecompiledCache
ExecuteEnv
ee.baseConfigOpts
PackageLocationImmutable
loc
ConfigCache
cache.configureOpts
ConfigCache
cache.buildHaddocks
Installed
installedPackage
(Package -> Set StackUnqualCompName
buildableExes Package
package)
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 ()
fetchAndMarkInstalledPackage ::
(HasEnvConfig env, HasTerm env)
=> ExecuteEnv
-> InstallLocation
-> Package
-> PackageIdentifier
-> RIO env Installed
fetchAndMarkInstalledPackage :: forall env.
(HasEnvConfig env, HasTerm env) =>
ExecuteEnv
-> InstallLocation
-> Package
-> PackageIdentifier
-> RIO env Installed
fetchAndMarkInstalledPackage ExecuteEnv
ee InstallLocation
taskInstallLocation Package
package PackageIdentifier
pkgId = do
let ghcPkgIdLoader :: Maybe StackUnqualCompName -> RIO env (Maybe GhcPkgId)
ghcPkgIdLoader = ExecuteEnv
-> InstallLocation
-> PackageName
-> Maybe StackUnqualCompName
-> RIO env (Maybe GhcPkgId)
forall env.
(HasTerm env, HasEnvConfig env) =>
ExecuteEnv
-> InstallLocation
-> PackageName
-> Maybe StackUnqualCompName
-> RIO env (Maybe GhcPkgId)
fetchGhcPkgIdForLib ExecuteEnv
ee InstallLocation
taskInstallLocation Package
package.name
if Package -> Bool
hasBuildableMainLibrary Package
package
then do
let foldSubLibToMap :: StackLibrary
-> RIO env (Map StackUnqualCompName GhcPkgId)
-> RIO env (Map StackUnqualCompName GhcPkgId)
foldSubLibToMap StackLibrary
subLib RIO env (Map StackUnqualCompName GhcPkgId)
mapInMonad = do
Maybe GhcPkgId
maybeGhcpkgId <- Maybe StackUnqualCompName -> RIO env (Maybe GhcPkgId)
ghcPkgIdLoader (StackUnqualCompName -> Maybe StackUnqualCompName
forall a. a -> Maybe a
Just StackLibrary
subLib.name)
RIO env (Map StackUnqualCompName GhcPkgId)
mapInMonad RIO env (Map StackUnqualCompName GhcPkgId)
-> (Map StackUnqualCompName GhcPkgId
-> Map StackUnqualCompName GhcPkgId)
-> RIO env (Map StackUnqualCompName GhcPkgId)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> case Maybe GhcPkgId
maybeGhcpkgId of
Just GhcPkgId
v -> StackUnqualCompName
-> GhcPkgId
-> Map StackUnqualCompName GhcPkgId
-> Map StackUnqualCompName GhcPkgId
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert StackLibrary
subLib.name GhcPkgId
v
Maybe GhcPkgId
_ -> Map StackUnqualCompName GhcPkgId
-> Map StackUnqualCompName GhcPkgId
forall a. a -> a
id
Map StackUnqualCompName GhcPkgId
subLibsPkgIds <- CompCollection StackLibrary
-> (StackLibrary
-> RIO env (Map StackUnqualCompName GhcPkgId)
-> RIO env (Map StackUnqualCompName GhcPkgId))
-> RIO env (Map StackUnqualCompName GhcPkgId)
-> RIO env (Map StackUnqualCompName GhcPkgId)
forall (m :: * -> *) component a.
Monad m =>
CompCollection component -> (component -> m a -> m a) -> m a -> m a
foldComponentToAnotherCollection
Package
package.subLibraries
StackLibrary
-> RIO env (Map StackUnqualCompName GhcPkgId)
-> RIO env (Map StackUnqualCompName GhcPkgId)
foldSubLibToMap
RIO env (Map StackUnqualCompName GhcPkgId)
forall a. Monoid a => a
mempty
Maybe GhcPkgId
mGhcPkgId <- Maybe StackUnqualCompName -> RIO env (Maybe GhcPkgId)
ghcPkgIdLoader Maybe StackUnqualCompName
forall a. Maybe a
Nothing
case Maybe GhcPkgId
mGhcPkgId of
Maybe GhcPkgId
Nothing -> BuildException -> RIO env Installed
forall e a. (?callStack::CallStack, Exception e) => e -> RIO env a
forall (m :: * -> *) e a.
(MonadThrow m, ?callStack::CallStack, Exception e) =>
e -> m a
throwM (BuildException -> RIO env Installed)
-> BuildException -> RIO env Installed
forall a b. (a -> b) -> a -> b
$ PackageName -> BuildException
Couldn'tFindPkgId Package
package.name
Just GhcPkgId
ghcPkgId -> Installed -> RIO env Installed
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Installed -> RIO env Installed) -> Installed -> RIO env Installed
forall a b. (a -> b) -> a -> b
$ PackageIdentifier
-> GhcPkgId -> Map StackUnqualCompName GhcPkgId -> Installed
simpleInstalledLib PackageIdentifier
pkgId GhcPkgId
ghcPkgId Map StackUnqualCompName GhcPkgId
subLibsPkgIds
else do
InstallLocation -> PackageIdentifier -> RIO env ()
forall env.
HasEnvConfig env =>
InstallLocation -> PackageIdentifier -> RIO env ()
markExeInstalled InstallLocation
taskInstallLocation PackageIdentifier
pkgId
Installed -> RIO env Installed
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Installed -> RIO env Installed) -> Installed -> RIO env Installed
forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> Installed
Executable PackageIdentifier
pkgId
fetchGhcPkgIdForLib ::
(HasTerm env, HasEnvConfig env)
=> ExecuteEnv
-> InstallLocation
-> PackageName
-> Maybe Component.StackUnqualCompName
-> RIO env (Maybe GhcPkgId)
fetchGhcPkgIdForLib :: forall env.
(HasTerm env, HasEnvConfig env) =>
ExecuteEnv
-> InstallLocation
-> PackageName
-> Maybe StackUnqualCompName
-> RIO env (Maybe GhcPkgId)
fetchGhcPkgIdForLib ExecuteEnv
ee InstallLocation
installLocation PackageName
pkgName Maybe StackUnqualCompName
libName = do
let baseConfigOpts :: BaseConfigOpts
baseConfigOpts = ExecuteEnv
ee.baseConfigOpts
(Path Abs Dir
installedPkgDb, TVar (Map GhcPkgId DumpPackage)
installedDumpPkgsTVar) =
case InstallLocation
installLocation of
InstallLocation
Snap ->
( BaseConfigOpts
baseConfigOpts.snapDB
, ExecuteEnv
ee.snapshotDumpPkgs )
InstallLocation
Local ->
( BaseConfigOpts
baseConfigOpts.localDB
, ExecuteEnv
ee.localDumpPkgs )
let commonLoader :: PackageName -> RIO env (Maybe GhcPkgId)
commonLoader = [Path Abs Dir]
-> TVar (Map GhcPkgId DumpPackage)
-> PackageName
-> RIO env (Maybe GhcPkgId)
forall env.
(HasCompiler env, HasProcessContext env, HasTerm env) =>
[Path Abs Dir]
-> TVar (Map GhcPkgId DumpPackage)
-> PackageName
-> RIO env (Maybe GhcPkgId)
loadInstalledPkg [Path Abs Dir
installedPkgDb] TVar (Map GhcPkgId DumpPackage)
installedDumpPkgsTVar
case Maybe StackUnqualCompName
libName of
Maybe StackUnqualCompName
Nothing -> PackageName -> RIO env (Maybe GhcPkgId)
commonLoader PackageName
pkgName
Just StackUnqualCompName
v -> do
let mungedName :: PackageName
mungedName = MungedPackageName -> PackageName
encodeCompatPackageName (MungedPackageName -> PackageName)
-> MungedPackageName -> PackageName
forall a b. (a -> b) -> a -> b
$ PackageName -> StackUnqualCompName -> MungedPackageName
toCabalMungedPackageName PackageName
pkgName StackUnqualCompName
v
PackageName -> RIO env (Maybe GhcPkgId)
commonLoader PackageName
mungedName
copyDdumpFilesIfNeeded :: HasEnvConfig env => Bool -> Maybe Text -> RIO env ()
copyDdumpFilesIfNeeded :: forall env. HasEnvConfig env => Bool -> Maybe Text -> RIO env ()
copyDdumpFilesIfNeeded Bool
buildingFinals Maybe Text
mDdumpPath = Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
buildingFinals (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
Maybe Text -> (Text -> RIO env ()) -> RIO env ()
forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe Text
mDdumpPath ((Text -> RIO env ()) -> RIO env ())
-> (Text -> RIO env ()) -> RIO env ()
forall a b. (a -> b) -> a -> b
$ \Text
ddumpPath -> Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text -> Bool
T.null Text
ddumpPath) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
Path Rel Dir
distDir <- RIO env (Path Rel Dir)
forall env (m :: * -> *).
(HasEnvConfig env, MonadReader env m, MonadThrow m) =>
m (Path Rel Dir)
distRelativeDir
Path Rel Dir
ddumpRelDir <- [Char] -> RIO env (Path Rel Dir)
forall (m :: * -> *). MonadThrow m => [Char] -> m (Path Rel Dir)
parseRelDir ([Char] -> RIO env (Path Rel Dir))
-> [Char] -> RIO env (Path Rel Dir)
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
ddumpPath
[StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
MonadIO m) =>
[StyleDoc] -> m ()
prettyDebugL
[ StyleDoc
"ddump-dir:"
, Path Rel Dir -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Rel Dir
ddumpRelDir
]
[StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
MonadIO m) =>
[StyleDoc] -> m ()
prettyDebugL
[ StyleDoc
"dist-dir:"
, Path Rel Dir -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Rel Dir
distDir
]
ConduitT () Void (ResourceT (RIO env)) () -> RIO env ()
forall (m :: * -> *) r.
MonadUnliftIO m =>
ConduitT () Void (ResourceT m) r -> m r
runConduitRes
(ConduitT () Void (ResourceT (RIO env)) () -> RIO env ())
-> ConduitT () Void (ResourceT (RIO env)) () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Bool -> [Char] -> ConduitT () [Char] (ResourceT (RIO env)) ()
forall (m :: * -> *) i.
MonadResource m =>
Bool -> [Char] -> ConduitT i [Char] m ()
CF.sourceDirectoryDeep Bool
False (Path Rel Dir -> [Char]
forall b t. Path b t -> [Char]
toFilePath Path Rel Dir
distDir)
ConduitT () [Char] (ResourceT (RIO env)) ()
-> ConduitT [Char] Void (ResourceT (RIO env)) ()
-> ConduitT () Void (ResourceT (RIO env)) ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ([Char] -> Bool) -> ConduitT [Char] [Char] (ResourceT (RIO env)) ()
forall (m :: * -> *) a. Monad m => (a -> Bool) -> ConduitT a a m ()
CL.filter ([Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
L.isInfixOf [Char]
".dump-")
ConduitT [Char] [Char] (ResourceT (RIO env)) ()
-> ConduitT [Char] Void (ResourceT (RIO env)) ()
-> ConduitT [Char] Void (ResourceT (RIO env)) ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ([Char] -> ResourceT (RIO env) ())
-> ConduitT [Char] Void (ResourceT (RIO env)) ()
forall (m :: * -> *) a o.
Monad m =>
(a -> m ()) -> ConduitT a o m ()
CL.mapM_ (\[Char]
src -> IO () -> ResourceT (RIO env) ()
forall a. IO a -> ResourceT (RIO env) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ResourceT (RIO env) ())
-> IO () -> ResourceT (RIO env) ()
forall a b. (a -> b) -> a -> b
$ do
Path Rel Dir
parentDir <- Path Rel Dir -> Path Rel Dir
forall b t. Path b t -> Path b Dir
parent (Path Rel Dir -> Path Rel Dir)
-> IO (Path Rel Dir) -> IO (Path Rel Dir)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO (Path Rel Dir)
forall (m :: * -> *). MonadThrow m => [Char] -> m (Path Rel Dir)
parseRelDir [Char]
src
Path Rel Dir
destBaseDir <-
(Path Rel Dir
ddumpRelDir </>) (Path Rel Dir -> Path Rel Dir)
-> IO (Path Rel Dir) -> IO (Path Rel Dir)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Path Rel Dir -> Path Rel Dir -> IO (Path Rel Dir)
forall (m :: * -> *) b t.
MonadThrow m =>
Path b Dir -> Path b t -> m (Path Rel t)
stripProperPrefix Path Rel Dir
distDir Path Rel Dir
parentDir
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Char]
".stack-work" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`L.isInfixOf` Path Rel Dir -> [Char]
forall b t. Path b t -> [Char]
toFilePath Path Rel Dir
destBaseDir) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Path Rel Dir -> IO ()
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir Path Rel Dir
destBaseDir
Path Rel File
src' <- [Char] -> IO (Path Rel File)
forall (m :: * -> *). MonadThrow m => [Char] -> m (Path Rel File)
parseRelFile [Char]
src
Path Rel File -> Path Rel File -> IO ()
forall (m :: * -> *) b0 b1.
MonadIO m =>
Path b0 File -> Path b1 File -> m ()
copyFile Path Rel File
src' (Path Rel Dir
destBaseDir Path Rel Dir -> Path Rel File -> Path Rel File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File -> Path Rel File
forall b. Path b File -> Path Rel File
filename Path Rel File
src'))
getPrecompiled ::
HasEnvConfig env
=> ConfigCache
-> TaskType
-> Path Abs Dir
-> RIO env (Maybe (PrecompiledCache Abs))
getPrecompiled :: forall env.
HasEnvConfig env =>
ConfigCache
-> TaskType
-> Path Abs Dir
-> RIO env (Maybe (PrecompiledCache Abs))
getPrecompiled ConfigCache
cache TaskType
taskType Path Abs Dir
bcoSnapInstallRoot =
case TaskType
taskType of
TTRemotePackage IsMutable
Immutable Package
_ PackageLocationImmutable
loc -> do
Maybe (PrecompiledCache Abs)
mpc <- PackageLocationImmutable
-> ConfigureOpts -> Bool -> RIO env (Maybe (PrecompiledCache Abs))
forall env.
HasEnvConfig env =>
PackageLocationImmutable
-> ConfigureOpts -> Bool -> RIO env (Maybe (PrecompiledCache Abs))
readPrecompiledCache
PackageLocationImmutable
loc
ConfigCache
cache.configureOpts
ConfigCache
cache.buildHaddocks
case Maybe (PrecompiledCache Abs)
mpc of
Maybe (PrecompiledCache Abs)
Nothing -> Maybe (PrecompiledCache Abs)
-> RIO env (Maybe (PrecompiledCache Abs))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (PrecompiledCache Abs)
forall a. Maybe a
Nothing
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
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"
let
subLibNames :: [StackUnqualCompName]
subLibNames = Set StackUnqualCompName -> [StackUnqualCompName]
forall a. Set a -> [a]
Set.toList (Set StackUnqualCompName -> [StackUnqualCompName])
-> Set StackUnqualCompName -> [StackUnqualCompName]
forall a b. (a -> b) -> a -> b
$ Package -> Set StackUnqualCompName
buildableSubLibs (Package -> Set StackUnqualCompName)
-> Package -> Set StackUnqualCompName
forall a b. (a -> b) -> a -> b
$ case Task
task.taskType of
TTLocalMutable LocalPackage
lp -> LocalPackage
lp.package
TTRemotePackage IsMutable
_ Package
p PackageLocationImmutable
_ -> Package
p
toMungedPackageId :: StackUnqualCompName -> MungedPackageId
toMungedPackageId :: StackUnqualCompName -> MungedPackageId
toMungedPackageId StackUnqualCompName
subLib =
let subLibName :: LibraryName
subLibName = UnqualComponentName -> LibraryName
LSubLibName (UnqualComponentName -> LibraryName)
-> UnqualComponentName -> LibraryName
forall a b. (a -> b) -> a -> b
$ StackUnqualCompName -> UnqualComponentName
toCabalName StackUnqualCompName
subLib
in MungedPackageName -> Version -> MungedPackageId
MungedPackageId (PackageName -> LibraryName -> MungedPackageName
MungedPackageName PackageName
pname LibraryName
subLibName) Version
pversion
toPackageId :: MungedPackageId -> PackageIdentifier
toPackageId :: MungedPackageId -> PackageIdentifier
toPackageId (MungedPackageId MungedPackageName
n Version
v) =
PackageName -> Version -> PackageIdentifier
PackageIdentifier (MungedPackageName -> PackageName
encodeCompatPackageName MungedPackageName
n) Version
v
allToUnregister :: [Either PackageIdentifier GhcPkgId]
allToUnregister :: [Either PackageIdentifier GhcPkgId]
allToUnregister = Maybe (Either PackageIdentifier GhcPkgId)
-> [Either PackageIdentifier GhcPkgId]
-> [Either PackageIdentifier GhcPkgId]
forall a. Maybe a -> [a] -> [a]
mcons
(PackageIdentifier -> Either PackageIdentifier GhcPkgId
forall a b. a -> Either a b
Left PackageIdentifier
pkgId Either PackageIdentifier GhcPkgId
-> Maybe (Path b0 File)
-> Maybe (Either PackageIdentifier GhcPkgId)
forall a b. a -> Maybe b -> Maybe a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Maybe (Path b0 File)
mlib)
((StackUnqualCompName -> Either PackageIdentifier GhcPkgId)
-> [StackUnqualCompName] -> [Either PackageIdentifier GhcPkgId]
forall a b. (a -> b) -> [a] -> [b]
map (PackageIdentifier -> Either PackageIdentifier GhcPkgId
forall a b. a -> Either a b
Left (PackageIdentifier -> Either PackageIdentifier GhcPkgId)
-> (StackUnqualCompName -> PackageIdentifier)
-> StackUnqualCompName
-> Either PackageIdentifier GhcPkgId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MungedPackageId -> PackageIdentifier
toPackageId (MungedPackageId -> PackageIdentifier)
-> (StackUnqualCompName -> MungedPackageId)
-> StackUnqualCompName
-> PackageIdentifier
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StackUnqualCompName -> MungedPackageId
toMungedPackageId) [StackUnqualCompName]
subLibNames)
allToRegister :: [Path b0 File]
allToRegister = Maybe (Path b0 File) -> [Path b0 File] -> [Path b0 File]
forall a. Maybe a -> [a] -> [a]
mcons Maybe (Path b0 File)
mlib [Path b0 File]
subLibs
Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Path b0 File] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Path b0 File]
allToRegister) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
MVar () -> (() -> RIO env ()) -> RIO env ()
forall (m :: * -> *) a b.
MonadUnliftIO m =>
MVar a -> (a -> m b) -> m b
withMVar ExecuteEnv
ee.installLock ((() -> RIO env ()) -> RIO env ())
-> (() -> RIO env ()) -> RIO env ()
forall a b. (a -> b) -> a -> b
$ \() -> do
let pkgDb :: Path Abs Dir
pkgDb = ExecuteEnv
ee.baseConfigOpts.snapDB
GhcPkgExe
ghcPkgExe <- RIO env GhcPkgExe
forall env. HasCompiler env => RIO env GhcPkgExe
getGhcPkgExe
Maybe (NonEmpty (Either PackageIdentifier GhcPkgId))
-> (NonEmpty (Either PackageIdentifier GhcPkgId) -> RIO env ())
-> RIO env ()
forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust ([Either PackageIdentifier GhcPkgId]
-> Maybe (NonEmpty (Either PackageIdentifier GhcPkgId))
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [Either PackageIdentifier GhcPkgId]
allToUnregister) ((NonEmpty (Either PackageIdentifier GhcPkgId) -> RIO env ())
-> RIO env ())
-> (NonEmpty (Either PackageIdentifier GhcPkgId) -> RIO env ())
-> RIO env ()
forall a b. (a -> b) -> a -> b
$ \NonEmpty (Either PackageIdentifier GhcPkgId)
allToUnregister' -> 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 ()))
[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]
-> [[Char]]
-> RIO env (Either SomeException ByteString)
forall env.
(HasProcessContext env, HasTerm env) =>
GhcPkgExe
-> [Path Abs Dir]
-> [[Char]]
-> RIO env (Either SomeException ByteString)
ghcPkg GhcPkgExe
ghcPkgExe [Path Abs Dir
pkgDb] [[Char]
"register", [Char]
"--force", Path b0 File -> [Char]
forall b t. Path b t -> [Char]
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
[Char] -> [Char] -> IO ()
createLink (Path b0 File -> [Char]
forall b t. Path b t -> [Char]
toFilePath Path b0 File
exe) (Path Abs File -> [Char]
forall b t. Path b t -> [Char]
toFilePath Path Abs File
dst) IO () -> (IOError -> IO ()) -> IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (IOError -> m a) -> m a
`catchIO` \IOError
_ -> Path b0 File -> Path Abs File -> IO ()
forall (m :: * -> *) b0 b1.
MonadIO m =>
Path b0 File -> Path b1 File -> m ()
copyFile Path b0 File
exe Path Abs File
dst
case (Maybe (Path b0 File)
mlib, [Path b0 File]
exes) of
(Maybe (Path b0 File)
Nothing, Path b0 File
_:[Path b0 File]
_) -> InstallLocation -> PackageIdentifier -> RIO env ()
forall env.
HasEnvConfig env =>
InstallLocation -> PackageIdentifier -> RIO env ()
markExeInstalled (Task -> InstallLocation
taskLocation Task
task) PackageIdentifier
pkgId
(Maybe (Path b0 File), [Path b0 File])
_ -> () -> RIO env ()
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
let pkgDbs :: [Path Abs Dir]
pkgDbs = [ExecuteEnv
ee.baseConfigOpts.snapDB]
case Maybe (Path b0 File)
mlib of
Maybe (Path b0 File)
Nothing -> Maybe Installed -> RIO env (Maybe Installed)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Installed -> RIO env (Maybe Installed))
-> Maybe Installed -> RIO env (Maybe Installed)
forall a b. (a -> b) -> a -> b
$ Installed -> Maybe Installed
forall a. a -> Maybe a
Just (Installed -> Maybe Installed) -> Installed -> Maybe Installed
forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> Installed
Executable PackageIdentifier
pkgId
Just Path b0 File
_ -> do
Maybe GhcPkgId
mpkgid <- [Path Abs Dir]
-> TVar (Map GhcPkgId DumpPackage)
-> PackageName
-> RIO env (Maybe GhcPkgId)
forall env.
(HasCompiler env, HasProcessContext env, HasTerm env) =>
[Path Abs Dir]
-> TVar (Map GhcPkgId DumpPackage)
-> PackageName
-> RIO env (Maybe GhcPkgId)
loadInstalledPkg [Path Abs Dir]
pkgDbs ExecuteEnv
ee.snapshotDumpPkgs PackageName
pname
Maybe Installed -> RIO env (Maybe Installed)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Installed -> RIO env (Maybe Installed))
-> Maybe Installed -> RIO env (Maybe Installed)
forall a b. (a -> b) -> a -> b
$ Installed -> Maybe Installed
forall a. a -> Maybe a
Just (Installed -> Maybe Installed) -> Installed -> Maybe Installed
forall a b. (a -> b) -> a -> b
$
case Maybe GhcPkgId
mpkgid of
Maybe GhcPkgId
Nothing -> Bool -> Installed -> Installed
forall a. (?callStack::CallStack) => Bool -> a -> a
assert Bool
False (Installed -> Installed) -> Installed -> Installed
forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> Installed
Executable PackageIdentifier
pkgId
Just GhcPkgId
pkgid -> PackageIdentifier
-> GhcPkgId -> Map StackUnqualCompName GhcPkgId -> Installed
simpleInstalledLib PackageIdentifier
pkgId GhcPkgId
pkgid Map StackUnqualCompName GhcPkgId
forall a. Monoid a => a
mempty
where
bindir :: Path Abs Dir
bindir = ExecuteEnv
ee.baseConfigOpts.snapInstallRoot Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
bindirSuffix
loadInstalledPkg ::
(HasCompiler env, HasProcessContext env, HasTerm env)
=> [Path Abs Dir]
-> TVar (Map GhcPkgId DumpPackage)
-> PackageName
-> RIO env (Maybe GhcPkgId)
loadInstalledPkg :: forall env.
(HasCompiler env, HasProcessContext env, HasTerm env) =>
[Path Abs Dir]
-> TVar (Map GhcPkgId DumpPackage)
-> PackageName
-> RIO env (Maybe GhcPkgId)
loadInstalledPkg [Path Abs Dir]
pkgDbs TVar (Map GhcPkgId DumpPackage)
tvar PackageName
name = do
GhcPkgExe
pkgexe <- RIO env GhcPkgExe
forall env. HasCompiler env => RIO env GhcPkgExe
getGhcPkgExe
[DumpPackage]
dps <- GhcPkgExe
-> PackageName
-> [Path Abs Dir]
-> ConduitM Text Void (RIO env) [DumpPackage]
-> RIO env [DumpPackage]
forall env a.
(HasCompiler env, HasProcessContext env, HasTerm env) =>
GhcPkgExe
-> PackageName
-> [Path Abs Dir]
-> ConduitM Text Void (RIO env) a
-> RIO env a
ghcPkgDescribe GhcPkgExe
pkgexe PackageName
name [Path Abs Dir]
pkgDbs (ConduitM Text Void (RIO env) [DumpPackage]
-> RIO env [DumpPackage])
-> ConduitM Text Void (RIO env) [DumpPackage]
-> RIO env [DumpPackage]
forall a b. (a -> b) -> a -> b
$ ConduitM Text DumpPackage (RIO env) ()
forall (m :: * -> *).
MonadThrow m =>
ConduitM Text DumpPackage m ()
conduitDumpPackage ConduitM Text DumpPackage (RIO env) ()
-> ConduitT DumpPackage Void (RIO env) [DumpPackage]
-> ConduitM Text Void (RIO env) [DumpPackage]
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT DumpPackage Void (RIO env) [DumpPackage]
forall (m :: * -> *) a o. Monad m => ConduitT a o m [a]
CL.consume
case [DumpPackage]
dps of
[] -> Maybe GhcPkgId -> RIO env (Maybe GhcPkgId)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe GhcPkgId
forall a. Maybe a
Nothing
[DumpPackage
dp] -> do
IO () -> RIO env ()
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO env ()) -> IO () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar (Map GhcPkgId DumpPackage)
-> (Map GhcPkgId DumpPackage -> Map GhcPkgId DumpPackage) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar (Map GhcPkgId DumpPackage)
tvar (GhcPkgId
-> DumpPackage
-> Map GhcPkgId DumpPackage
-> Map GhcPkgId DumpPackage
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert DumpPackage
dp.ghcPkgId DumpPackage
dp)
Maybe GhcPkgId -> RIO env (Maybe GhcPkgId)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe GhcPkgId -> RIO env (Maybe GhcPkgId))
-> Maybe GhcPkgId -> RIO env (Maybe GhcPkgId)
forall a b. (a -> b) -> a -> b
$ GhcPkgId -> Maybe GhcPkgId
forall a. a -> Maybe a
Just DumpPackage
dp.ghcPkgId
[DumpPackage]
_ -> BuildException -> RIO env (Maybe GhcPkgId)
forall e a. (?callStack::CallStack, Exception e) => e -> RIO env a
forall (m :: * -> *) e a.
(MonadThrow m, ?callStack::CallStack, Exception e) =>
e -> m a
throwM (BuildException -> RIO env (Maybe GhcPkgId))
-> BuildException -> RIO env (Maybe GhcPkgId)
forall a b. (a -> b) -> a -> b
$ PackageName -> [DumpPackage] -> BuildException
MultipleResultsBug PackageName
name [DumpPackage]
dps
fulfillHaddockExpectations ::
(MonadUnliftIO m, HasTerm env, MonadReader env m)
=> PackageName
-> Maybe Curator
-> (KeepOutputOpen -> m ())
-> m ()
fulfillHaddockExpectations :: forall (m :: * -> *) env.
(MonadUnliftIO m, HasTerm env, MonadReader env m) =>
PackageName -> Maybe Curator -> (KeepOutputOpen -> m ()) -> m ()
fulfillHaddockExpectations PackageName
pname Maybe Curator
mcurator KeepOutputOpen -> m ()
action
| Maybe Curator -> Bool
expectHaddockFailure Maybe Curator
mcurator = do
Either SomeException ()
eres <- m () -> m (Either SomeException ())
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny (m () -> m (Either SomeException ()))
-> m () -> m (Either SomeException ())
forall a b. (a -> b) -> a -> b
$ KeepOutputOpen -> m ()
action KeepOutputOpen
KeepOpen
case Either SomeException ()
eres of
Right () -> [StyleDoc] -> m ()
forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
MonadIO m) =>
[StyleDoc] -> m ()
prettyWarnL
[ Style -> StyleDoc -> StyleDoc
style Style
Current (PackageName -> StyleDoc
forall a. IsString a => PackageName -> a
fromPackageName PackageName
pname) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
":"
, [Char] -> StyleDoc
flow [Char]
"unexpected Haddock success."
]
Left SomeException
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
where
expectHaddockFailure :: Maybe Curator -> Bool
expectHaddockFailure = Bool -> (Curator -> Bool) -> Maybe Curator -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (PackageName -> Set PackageName -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member PackageName
pname (Set PackageName -> Bool)
-> (Curator -> Set PackageName) -> Curator -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.expectHaddockFailure))
fulfillHaddockExpectations PackageName
_ Maybe Curator
_ KeepOutputOpen -> m ()
action = KeepOutputOpen -> m ()
action KeepOutputOpen
CloseOnException
checkForUnlistedFiles ::
HasEnvConfig env
=> TaskType
-> Path Abs Dir
-> RIO env [PackageWarning]
checkForUnlistedFiles :: forall env.
HasEnvConfig env =>
TaskType -> Path Abs Dir -> RIO env [PackageWarning]
checkForUnlistedFiles (TTLocalMutable LocalPackage
lp) Path Abs Dir
pkgDir = do
Map NamedComponent (Map [Char] FileCacheInfo)
caches <- MemoizedWith
EnvConfig (Map NamedComponent (Map [Char] FileCacheInfo))
-> RIO env (Map NamedComponent (Map [Char] FileCacheInfo))
forall env (m :: * -> *) a.
(HasEnvConfig env, MonadReader env m, MonadIO m) =>
MemoizedWith EnvConfig a -> m a
runMemoizedWith LocalPackage
lp.newBuildCaches
(Map NamedComponent [Map [Char] FileCacheInfo]
addBuildCache,[PackageWarning]
warnings) <-
Package
-> Path Abs File
-> Set NamedComponent
-> Map NamedComponent (Map [Char] FileCacheInfo)
-> RIO
env
(Map NamedComponent [Map [Char] FileCacheInfo], [PackageWarning])
forall env a.
HasEnvConfig env =>
Package
-> Path Abs File
-> Set NamedComponent
-> Map NamedComponent (Map [Char] a)
-> RIO
env
(Map NamedComponent [Map [Char] FileCacheInfo], [PackageWarning])
addUnlistedToBuildCache
LocalPackage
lp.package
LocalPackage
lp.cabalFP
LocalPackage
lp.components
Map NamedComponent (Map [Char] FileCacheInfo)
caches
[(NamedComponent, [Map [Char] FileCacheInfo])]
-> ((NamedComponent, [Map [Char] FileCacheInfo]) -> RIO env ())
-> RIO env ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Map NamedComponent [Map [Char] FileCacheInfo]
-> [(NamedComponent, [Map [Char] FileCacheInfo])]
forall k a. Map k a -> [(k, a)]
Map.toList Map NamedComponent [Map [Char] FileCacheInfo]
addBuildCache) (((NamedComponent, [Map [Char] FileCacheInfo]) -> RIO env ())
-> RIO env ())
-> ((NamedComponent, [Map [Char] FileCacheInfo]) -> RIO env ())
-> RIO env ()
forall a b. (a -> b) -> a -> b
$ \(NamedComponent
component, [Map [Char] FileCacheInfo]
newToCache) -> do
let cache :: Map [Char] FileCacheInfo
cache = Map [Char] FileCacheInfo
-> NamedComponent
-> Map NamedComponent (Map [Char] FileCacheInfo)
-> Map [Char] FileCacheInfo
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Map [Char] FileCacheInfo
forall k a. Map k a
Map.empty NamedComponent
component Map NamedComponent (Map [Char] FileCacheInfo)
caches
Path Abs Dir
-> NamedComponent -> Map [Char] FileCacheInfo -> RIO env ()
forall env.
HasEnvConfig env =>
Path Abs Dir
-> NamedComponent -> Map [Char] FileCacheInfo -> RIO env ()
writeBuildCache Path Abs Dir
pkgDir NamedComponent
component (Map [Char] FileCacheInfo -> RIO env ())
-> Map [Char] FileCacheInfo -> RIO env ()
forall a b. (a -> b) -> a -> b
$
[Map [Char] FileCacheInfo] -> Map [Char] FileCacheInfo
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions (Map [Char] FileCacheInfo
cache Map [Char] FileCacheInfo
-> [Map [Char] FileCacheInfo] -> [Map [Char] FileCacheInfo]
forall a. a -> [a] -> [a]
: [Map [Char] FileCacheInfo]
newToCache)
[PackageWarning] -> RIO env [PackageWarning]
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [PackageWarning]
warnings
checkForUnlistedFiles TTRemotePackage{} Path Abs Dir
_ = [PackageWarning] -> RIO env [PackageWarning]
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
singleTest :: HasEnvConfig env
=> TestOpts
-> [StackUnqualCompName]
-> ActionContext
-> ExecuteEnv
-> Task
-> InstalledMap
-> RIO env ()
singleTest :: forall env.
HasEnvConfig env =>
TestOpts
-> [StackUnqualCompName]
-> ActionContext
-> ExecuteEnv
-> Task
-> InstalledMap
-> RIO env ()
singleTest TestOpts
topts [StackUnqualCompName]
testsToRun ActionContext
ac ExecuteEnv
ee Task
task InstalledMap
installedMap = do
(Map PackageIdentifier GhcPkgId
allDepsMap, ConfigCache
_cache) <- ExecuteEnv
-> Task
-> InstalledMap
-> Bool
-> Bool
-> RIO env (Map PackageIdentifier GhcPkgId, ConfigCache)
forall env.
HasEnvConfig env =>
ExecuteEnv
-> Task
-> InstalledMap
-> Bool
-> Bool
-> RIO env (Map PackageIdentifier GhcPkgId, ConfigCache)
getConfigCache ExecuteEnv
ee Task
task InstalledMap
installedMap Bool
True Bool
False
Maybe Curator
mcurator <- Getting (Maybe Curator) env (Maybe Curator)
-> RIO env (Maybe Curator)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting (Maybe Curator) env (Maybe Curator)
-> RIO env (Maybe Curator))
-> Getting (Maybe Curator) env (Maybe Curator)
-> RIO env (Maybe Curator)
forall a b. (a -> b) -> a -> b
$ (BuildConfig -> Const (Maybe Curator) BuildConfig)
-> env -> Const (Maybe Curator) env
forall env. HasBuildConfig env => Lens' env BuildConfig
Lens' env BuildConfig
buildConfigL ((BuildConfig -> Const (Maybe Curator) BuildConfig)
-> env -> Const (Maybe Curator) env)
-> ((Maybe Curator -> Const (Maybe Curator) (Maybe Curator))
-> BuildConfig -> Const (Maybe Curator) BuildConfig)
-> Getting (Maybe Curator) env (Maybe Curator)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BuildConfig -> Maybe Curator)
-> SimpleGetter BuildConfig (Maybe Curator)
forall s a. (s -> a) -> SimpleGetter s a
to (.curator)
let pname :: PackageName
pname = PackageIdentifier -> PackageName
pkgName (PackageIdentifier -> PackageName)
-> PackageIdentifier -> PackageName
forall a b. (a -> b) -> a -> b
$ Task -> PackageIdentifier
taskProvides Task
task
expectFailure :: Bool
expectFailure = PackageName -> Maybe Curator -> Bool
expectTestFailure PackageName
pname Maybe Curator
mcurator
ActionContext
-> ExecuteEnv
-> TaskType
-> Map PackageIdentifier GhcPkgId
-> Maybe [Char]
-> (Package
-> Path Abs File
-> Path Abs Dir
-> (KeepOutputOpen -> ExcludeTHLoading -> [[Char]] -> RIO env ())
-> (Utf8Builder -> RIO env ())
-> OutputType
-> RIO env ())
-> RIO env ()
forall env a.
HasEnvConfig env =>
ActionContext
-> ExecuteEnv
-> TaskType
-> Map PackageIdentifier GhcPkgId
-> Maybe [Char]
-> (Package
-> Path Abs File
-> Path Abs Dir
-> (KeepOutputOpen -> ExcludeTHLoading -> [[Char]] -> RIO env ())
-> (Utf8Builder -> RIO env ())
-> OutputType
-> RIO env a)
-> RIO env a
withSingleContext ActionContext
ac ExecuteEnv
ee Task
task.taskType Map PackageIdentifier GhcPkgId
allDepsMap ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
"test") ((Package
-> Path Abs File
-> Path Abs Dir
-> (KeepOutputOpen -> ExcludeTHLoading -> [[Char]] -> RIO env ())
-> (Utf8Builder -> RIO env ())
-> OutputType
-> RIO env ())
-> RIO env ())
-> (Package
-> Path Abs File
-> Path Abs Dir
-> (KeepOutputOpen -> ExcludeTHLoading -> [[Char]] -> RIO env ())
-> (Utf8Builder -> RIO env ())
-> OutputType
-> RIO env ())
-> RIO env ()
forall a b. (a -> b) -> a -> b
$
\Package
package Path Abs File
_cabalfp Path Abs Dir
pkgDir KeepOutputOpen -> ExcludeTHLoading -> [[Char]] -> RIO env ()
_cabal Utf8Builder -> RIO env ()
announce OutputType
outputType -> do
Config
config <- Getting Config env Config -> RIO env Config
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Config env Config
forall env. HasConfig env => Lens' env Config
Lens' env Config
configL
let needHpc :: Bool
needHpc = TestOpts
topts.coverage
Bool
toRun <-
if TestOpts
topts.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 ([StackUnqualCompName] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [StackUnqualCompName]
testsToRun) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
Utf8Builder -> RIO env ()
announce Utf8Builder
"skipping already passed test"
Bool -> RIO env Bool
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
TestStatus
TSFailure
| Bool
expectFailure -> do
Utf8Builder -> RIO env ()
announce Utf8Builder
"skipping already failed test that's expected to fail"
Bool -> RIO env Bool
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
| Bool
otherwise -> do
Utf8Builder -> RIO env ()
announce Utf8Builder
"rerunning previously failed test"
Bool -> RIO env Bool
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
TestStatus
TSUnknown -> Bool -> RIO env Bool
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
toRun (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
Path Abs Dir
buildDir <- Path Abs Dir -> RIO env (Path Abs Dir)
forall env (m :: * -> *).
(HasEnvConfig env, MonadReader env m, MonadThrow m) =>
Path Abs Dir -> m (Path Abs Dir)
distDirFromDir Path Abs Dir
pkgDir
Path Abs Dir
hpcDir <- Path Abs Dir -> RIO env (Path Abs Dir)
forall env (m :: * -> *).
(HasEnvConfig env, MonadReader env m, MonadThrow m) =>
Path Abs Dir -> m (Path Abs Dir)
hpcDirFromDir Path Abs Dir
pkgDir
Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
needHpc (Path Abs Dir -> RIO env ()
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir Path Abs Dir
hpcDir)
let suitesToRun :: [(StackUnqualCompName, TestSuiteInterface)]
suitesToRun
= [ (StackUnqualCompName, TestSuiteInterface)
testSuitePair
| (StackUnqualCompName, TestSuiteInterface)
testSuitePair <-
((((StackUnqualCompName, StackTestSuite)
-> (StackUnqualCompName, TestSuiteInterface))
-> [(StackUnqualCompName, StackTestSuite)]
-> [(StackUnqualCompName, TestSuiteInterface)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((StackUnqualCompName, StackTestSuite)
-> (StackUnqualCompName, TestSuiteInterface))
-> [(StackUnqualCompName, StackTestSuite)]
-> [(StackUnqualCompName, TestSuiteInterface)])
-> ((StackTestSuite -> TestSuiteInterface)
-> (StackUnqualCompName, StackTestSuite)
-> (StackUnqualCompName, TestSuiteInterface))
-> (StackTestSuite -> TestSuiteInterface)
-> [(StackUnqualCompName, StackTestSuite)]
-> [(StackUnqualCompName, TestSuiteInterface)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StackTestSuite -> TestSuiteInterface)
-> (StackUnqualCompName, StackTestSuite)
-> (StackUnqualCompName, TestSuiteInterface)
forall a b.
(a -> b) -> (StackUnqualCompName, a) -> (StackUnqualCompName, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) (.interface) ([(StackUnqualCompName, StackTestSuite)]
-> [(StackUnqualCompName, TestSuiteInterface)])
-> (CompCollection StackTestSuite
-> [(StackUnqualCompName, StackTestSuite)])
-> CompCollection StackTestSuite
-> [(StackUnqualCompName, TestSuiteInterface)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CompCollection StackTestSuite
-> [(StackUnqualCompName, StackTestSuite)]
forall component.
CompCollection component -> [(StackUnqualCompName, component)]
collectionKeyValueList)
Package
package.testSuites
, let testName :: StackUnqualCompName
testName = (StackUnqualCompName, TestSuiteInterface) -> StackUnqualCompName
forall a b. (a, b) -> a
fst (StackUnqualCompName, TestSuiteInterface)
testSuitePair
, StackUnqualCompName
testName StackUnqualCompName -> [StackUnqualCompName] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [StackUnqualCompName]
testsToRun
]
Map StackUnqualCompName (Maybe ExitCode)
errs <- ([Map StackUnqualCompName (Maybe ExitCode)]
-> Map StackUnqualCompName (Maybe ExitCode))
-> RIO env [Map StackUnqualCompName (Maybe ExitCode)]
-> RIO env (Map StackUnqualCompName (Maybe ExitCode))
forall a b. (a -> b) -> RIO env a -> RIO env b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Map StackUnqualCompName (Maybe ExitCode)]
-> Map StackUnqualCompName (Maybe ExitCode)
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions (RIO env [Map StackUnqualCompName (Maybe ExitCode)]
-> RIO env (Map StackUnqualCompName (Maybe ExitCode)))
-> RIO env [Map StackUnqualCompName (Maybe ExitCode)]
-> RIO env (Map StackUnqualCompName (Maybe ExitCode))
forall a b. (a -> b) -> a -> b
$ [(StackUnqualCompName, TestSuiteInterface)]
-> ((StackUnqualCompName, TestSuiteInterface)
-> RIO env (Map StackUnqualCompName (Maybe ExitCode)))
-> RIO env [Map StackUnqualCompName (Maybe ExitCode)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(StackUnqualCompName, TestSuiteInterface)]
suitesToRun (((StackUnqualCompName, TestSuiteInterface)
-> RIO env (Map StackUnqualCompName (Maybe ExitCode)))
-> RIO env [Map StackUnqualCompName (Maybe ExitCode)])
-> ((StackUnqualCompName, TestSuiteInterface)
-> RIO env (Map StackUnqualCompName (Maybe ExitCode)))
-> RIO env [Map StackUnqualCompName (Maybe ExitCode)]
forall a b. (a -> b) -> a -> b
$ \(StackUnqualCompName
testName, TestSuiteInterface
suiteInterface) -> do
let stestName :: [Char]
stestName = StackUnqualCompName -> [Char]
unqualCompToString StackUnqualCompName
testName
([Char]
testName', Bool
isTestTypeLib) <-
case TestSuiteInterface
suiteInterface of
C.TestSuiteLibV09{} -> ([Char], Bool) -> RIO env ([Char], Bool)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char]
stestName [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"Stub", Bool
True)
C.TestSuiteExeV10{} -> ([Char], Bool) -> RIO env ([Char], Bool)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char]
stestName, Bool
False)
TestSuiteInterface
interface -> BuildException -> RIO env ([Char], Bool)
forall e a. (?callStack::CallStack, Exception e) => e -> RIO env a
forall (m :: * -> *) e a.
(MonadThrow m, ?callStack::CallStack, Exception e) =>
e -> m a
throwM (TestSuiteInterface -> BuildException
TestSuiteTypeUnsupported TestSuiteInterface
interface)
let exeName :: [Char]
exeName = [Char]
testName' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
case Config
config.platform of
Platform Arch
_ OS
Windows -> [Char]
".exe"
Platform
_ -> [Char]
""
Path Abs File
tixPath <- (Path Rel File -> Path Abs File)
-> RIO env (Path Rel File) -> RIO env (Path Abs File)
forall a b. (a -> b) -> RIO env a -> RIO env b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Path Abs Dir
pkgDir </>) (RIO env (Path Rel File) -> RIO env (Path Abs File))
-> RIO env (Path Rel File) -> RIO env (Path Abs File)
forall a b. (a -> b) -> a -> b
$ [Char] -> RIO env (Path Rel File)
forall (m :: * -> *). MonadThrow m => [Char] -> m (Path Rel File)
parseRelFile ([Char] -> RIO env (Path Rel File))
-> [Char] -> RIO env (Path Rel File)
forall a b. (a -> b) -> a -> b
$ [Char]
exeName [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
".tix"
Path Abs File
exePath <-
(Path Rel File -> Path Abs File)
-> RIO env (Path Rel File) -> RIO env (Path Abs File)
forall a b. (a -> b) -> RIO env a -> RIO env b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Path Abs Dir
buildDir </>) (RIO env (Path Rel File) -> RIO env (Path Abs File))
-> RIO env (Path Rel File) -> RIO env (Path Abs File)
forall a b. (a -> b) -> a -> b
$ [Char] -> RIO env (Path Rel File)
forall (m :: * -> *). MonadThrow m => [Char] -> m (Path Rel File)
parseRelFile ([Char] -> RIO env (Path Rel File))
-> [Char] -> RIO env (Path Rel File)
forall a b. (a -> b) -> a -> b
$
[Char]
"build/" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
testName' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"/" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
exeName
Bool
exists <- Path Abs File -> RIO env Bool
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
exePath
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
_ -> []
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
let setEnv :: [Char] -> ProcessContext -> IO ProcessContext
setEnv [Char]
f ProcessContext
pc = ProcessContext -> (EnvVars -> EnvVars) -> IO ProcessContext
forall (m :: * -> *).
MonadIO m =>
ProcessContext -> (EnvVars -> EnvVars) -> m ProcessContext
modifyEnvVars ProcessContext
pc ((EnvVars -> EnvVars) -> IO ProcessContext)
-> (EnvVars -> EnvVars) -> IO ProcessContext
forall a b. (a -> b) -> a -> b
$ \EnvVars
envVars ->
Text -> Text -> EnvVars -> EnvVars
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
"HASKELL_DIST_DIR" ([Char] -> Text
T.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ Path Abs Dir -> [Char]
forall b t. Path b t -> [Char]
toFilePath Path Abs Dir
buildDir) (EnvVars -> EnvVars) -> EnvVars -> EnvVars
forall a b. (a -> b) -> a -> b
$
Text -> Text -> EnvVars -> EnvVars
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
"GHC_ENVIRONMENT" ([Char] -> Text
T.pack [Char]
f) EnvVars
envVars
fp' :: Path Abs File
fp' = ExecuteEnv
ee.tempDir Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
testGhcEnvRelFile
Int
randomInt <- IO Int -> RIO env Int
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int
forall a (m :: * -> *). (Random a, MonadIO m) => m a
randomIO :: IO Int)
let randomSuffix :: [Char]
randomSuffix = [Char]
"." [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show (Int -> Int
forall a. Num a => a -> a
abs Int
randomInt)
[Char]
fp <- Path Abs File -> [Char]
forall b t. Path b t -> [Char]
toFilePath (Path Abs File -> [Char])
-> RIO env (Path Abs File) -> RIO env [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> Path Abs File -> RIO env (Path Abs File)
forall (m :: * -> *) b.
MonadThrow m =>
[Char] -> Path b File -> m (Path b File)
addExtension [Char]
randomSuffix Path Abs File
fp'
let snapDBPath :: [Char]
snapDBPath =
Path Abs Dir -> [Char]
forall loc. Path loc Dir -> [Char]
toFilePathNoTrailingSep ExecuteEnv
ee.baseConfigOpts.snapDB
localDBPath :: [Char]
localDBPath =
Path Abs Dir -> [Char]
forall loc. Path loc Dir -> [Char]
toFilePathNoTrailingSep ExecuteEnv
ee.baseConfigOpts.localDB
ghcEnv :: Utf8Builder
ghcEnv =
Utf8Builder
"clear-package-db\n"
Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"global-package-db\n"
Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"package-db "
Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> [Char] -> Utf8Builder
forall a. IsString a => [Char] -> a
fromString [Char]
snapDBPath
Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"\n"
Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"package-db "
Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> [Char] -> Utf8Builder
forall a. IsString a => [Char] -> a
fromString [Char]
localDBPath
Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"\n"
Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> (GhcPkgId -> Utf8Builder) -> [GhcPkgId] -> Utf8Builder
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
( \GhcPkgId
ghcId ->
Utf8Builder
"package-id "
Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display (GhcPkgId -> Text
ghcPkgIdToText GhcPkgId
ghcId)
Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"\n"
)
([GhcPkgId]
pkgGhcIdList [GhcPkgId] -> [GhcPkgId] -> [GhcPkgId]
forall a. [a] -> [a] -> [a]
++ GhcPkgId
thGhcIdGhcPkgId -> [GhcPkgId] -> [GhcPkgId]
forall a. a -> [a] -> [a]
:Map PackageIdentifier GhcPkgId -> [GhcPkgId]
forall k a. Map k a -> [a]
Map.elems Map PackageIdentifier GhcPkgId
allDepsMap)
[Char] -> Utf8Builder -> RIO env ()
forall (m :: * -> *). MonadIO m => [Char] -> Utf8Builder -> m ()
writeFileUtf8Builder [Char]
fp Utf8Builder
ghcEnv
ProcessContext
menv <- IO ProcessContext -> RIO env ProcessContext
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ProcessContext -> RIO env ProcessContext)
-> IO ProcessContext -> RIO env ProcessContext
forall a b. (a -> b) -> a -> b
$
[Char] -> ProcessContext -> IO ProcessContext
setEnv [Char]
fp (ProcessContext -> IO ProcessContext)
-> IO ProcessContext -> IO ProcessContext
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Config
config.processContextSettings EnvSettings
{ includeLocals :: Bool
includeLocals = Task -> InstallLocation
taskLocation Task
task InstallLocation -> InstallLocation -> Bool
forall a. Eq a => a -> a -> Bool
== InstallLocation
Local
, includeGhcPackagePath :: Bool
includeGhcPackagePath = Bool
True
, stackExe :: Bool
stackExe = Bool
True
, localeUtf8 :: Bool
localeUtf8 = Bool
False
, keepGhcRts :: Bool
keepGhcRts = Bool
False
}
let emptyResult :: Map StackUnqualCompName (Maybe ExitCode)
emptyResult = StackUnqualCompName
-> Maybe ExitCode -> Map StackUnqualCompName (Maybe ExitCode)
forall k a. k -> a -> Map k a
Map.singleton StackUnqualCompName
testName Maybe ExitCode
forall a. Maybe a
Nothing
ProcessContext
-> RIO env (Map StackUnqualCompName (Maybe ExitCode))
-> RIO env (Map StackUnqualCompName (Maybe ExitCode))
forall env a.
HasProcessContext env =>
ProcessContext -> RIO env a -> RIO env a
withProcessContext ProcessContext
menv (RIO env (Map StackUnqualCompName (Maybe ExitCode))
-> RIO env (Map StackUnqualCompName (Maybe ExitCode)))
-> RIO env (Map StackUnqualCompName (Maybe ExitCode))
-> RIO env (Map StackUnqualCompName (Maybe ExitCode))
forall a b. (a -> b) -> a -> b
$ if Bool
exists
then do
Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
needHpc (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
Bool
tixexists <- Path Abs File -> RIO env Bool
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
tixPath
Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
tixexists (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
[StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
MonadIO m) =>
[StyleDoc] -> m ()
prettyWarnL
[ [Char] -> StyleDoc
flow [Char]
"Removing HPC file"
, Path Abs File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
tixPath StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
]
IO () -> RIO env ()
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO env ()) -> IO () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall (m :: * -> *) a. (MonadIO m, MonadCatch m) => m a -> m ()
ignoringAbsence (Path Abs File -> IO ()
forall (m :: * -> *) b. MonadIO m => Path b File -> m ()
removeFile Path Abs File
tixPath)
let args :: [[Char]]
args = TestOpts
topts.additionalArgs
argsDisplay :: Text
argsDisplay = case [[Char]]
args of
[] -> Text
""
[[Char]]
_ -> Text
", args: "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
" " (([Char] -> Text) -> [[Char]] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Text
showProcessArgDebug [[Char]]
args)
Utf8Builder -> RIO env ()
announce (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$
Utf8Builder
"test (suite: "
Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display (StackUnqualCompName -> Text
unqualCompToText StackUnqualCompName
testName)
Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Text
argsDisplay
Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
")"
case OutputType
outputType of
OTConsole Maybe Utf8Builder
_ -> do
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, ?callStack::CallStack, MonadReader env m,
HasLogFunc env) =>
Utf8Builder -> m ()
logStickyDone Utf8Builder
""
IO () -> RIO env ()
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO env ()) -> IO () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Handle -> IO ()
forall (m :: * -> *). MonadIO m => Handle -> m ()
hFlush Handle
stdout
IO () -> RIO env ()
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO env ()) -> IO () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Handle -> IO ()
forall (m :: * -> *). MonadIO m => Handle -> m ()
hFlush Handle
stderr
OTLogFile Path Abs File
_ Handle
_ -> () -> RIO env ()
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
let output :: StreamSpec 'STOutput (Maybe (RIO env ()))
output = case OutputType
outputType of
OTConsole Maybe Utf8Builder
Nothing -> Maybe (RIO env ())
forall a. Maybe a
Nothing Maybe (RIO env ())
-> StreamSpec 'STOutput ()
-> StreamSpec 'STOutput (Maybe (RIO env ()))
forall a b. a -> StreamSpec 'STOutput b -> StreamSpec 'STOutput a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ StreamSpec 'STOutput ()
forall (anyStreamType :: StreamType). StreamSpec anyStreamType ()
inherit
OTConsole (Just Utf8Builder
prefix) -> (ConduitT () ByteString (RIO env) () -> Maybe (RIO env ()))
-> StreamSpec 'STOutput (ConduitT () ByteString (RIO env) ())
-> StreamSpec 'STOutput (Maybe (RIO env ()))
forall a b.
(a -> b) -> StreamSpec 'STOutput a -> StreamSpec 'STOutput b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
( \ConduitT () ByteString (RIO env) ()
src -> RIO env () -> Maybe (RIO env ())
forall a. a -> Maybe a
Just (RIO env () -> Maybe (RIO env ()))
-> RIO env () -> Maybe (RIO env ())
forall a b. (a -> b) -> a -> b
$
ConduitT () Void (RIO env) () -> RIO env ()
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT () Void (RIO env) () -> RIO env ())
-> ConduitT () Void (RIO env) () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ ConduitT () ByteString (RIO env) ()
src
ConduitT () ByteString (RIO env) ()
-> ConduitT ByteString Void (RIO env) ()
-> ConduitT () Void (RIO env) ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT ByteString Text (RIO env) ()
forall (m :: * -> *). Monad m => ConduitT ByteString Text m ()
CT.decodeUtf8Lenient
ConduitT ByteString Text (RIO env) ()
-> ConduitT Text Void (RIO env) ()
-> ConduitT ByteString Void (RIO env) ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT Text Text (RIO env) ()
forall (m :: * -> *). Monad m => ConduitT Text Text m ()
CT.lines
ConduitT Text Text (RIO env) ()
-> ConduitT Text Void (RIO env) ()
-> ConduitT Text Void (RIO env) ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| (Text -> Text) -> ConduitT Text Text (RIO env) ()
forall (m :: * -> *) a b. Monad m => (a -> b) -> ConduitT a b m ()
CL.map Text -> Text
stripCR
ConduitT Text Text (RIO env) ()
-> ConduitT Text Void (RIO env) ()
-> ConduitT Text Void (RIO env) ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| (Text -> RIO env ()) -> ConduitT Text Void (RIO env) ()
forall (m :: * -> *) a o.
Monad m =>
(a -> m ()) -> ConduitT a o m ()
CL.mapM_ (\Text
t -> Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
prefix Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Text
t)
)
StreamSpec 'STOutput (ConduitT () ByteString (RIO env) ())
forall (m :: * -> *) i.
MonadIO m =>
StreamSpec 'STOutput (ConduitM i ByteString m ())
createSource
OTLogFile Path Abs File
_ Handle
h -> Maybe (RIO env ())
forall a. Maybe a
Nothing Maybe (RIO env ())
-> StreamSpec 'STOutput ()
-> StreamSpec 'STOutput (Maybe (RIO env ()))
forall a b. a -> StreamSpec 'STOutput b -> StreamSpec 'STOutput a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Handle -> StreamSpec 'STOutput ()
forall (anyStreamType :: StreamType).
Handle -> StreamSpec anyStreamType ()
useHandleOpen Handle
h
optionalTimeout :: RIO env ExitCode -> RIO env (Maybe ExitCode)
optionalTimeout RIO env ExitCode
action
| Just Int
maxSecs <- TestOpts
topts.maximumTimeSeconds, Int
maxSecs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 =
Int -> RIO env ExitCode -> RIO env (Maybe ExitCode)
forall (m :: * -> *) a.
MonadUnliftIO m =>
Int -> m a -> m (Maybe a)
timeout (Int
maxSecs Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000000) RIO env ExitCode
action
| Bool
otherwise = ExitCode -> Maybe ExitCode
forall a. a -> Maybe a
Just (ExitCode -> Maybe ExitCode)
-> RIO env ExitCode -> RIO env (Maybe ExitCode)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RIO env ExitCode
action
Maybe ExitCode
mec <- [Char] -> RIO env (Maybe ExitCode) -> RIO env (Maybe ExitCode)
forall env (m :: * -> *) a.
(HasProcessContext env, MonadReader env m, MonadIO m) =>
[Char] -> m a -> m a
withWorkingDir (Path Abs Dir -> [Char]
forall b t. Path b t -> [Char]
toFilePath Path Abs Dir
pkgDir) (RIO env (Maybe ExitCode) -> RIO env (Maybe ExitCode))
-> RIO env (Maybe ExitCode) -> RIO env (Maybe ExitCode)
forall a b. (a -> b) -> a -> b
$
RIO env ExitCode -> RIO env (Maybe ExitCode)
optionalTimeout (RIO env ExitCode -> RIO env (Maybe ExitCode))
-> RIO env ExitCode -> RIO env (Maybe ExitCode)
forall a b. (a -> b) -> a -> b
$ [Char]
-> [[Char]]
-> (ProcessConfig () () () -> RIO env ExitCode)
-> RIO env ExitCode
forall env (m :: * -> *) a.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
MonadIO m, ?callStack::CallStack) =>
[Char] -> [[Char]] -> (ProcessConfig () () () -> m a) -> m a
proc (Path Abs File -> [Char]
forall b t. Path b t -> [Char]
toFilePath Path Abs File
exePath) [[Char]]
args ((ProcessConfig () () () -> RIO env ExitCode) -> RIO env ExitCode)
-> (ProcessConfig () () () -> RIO env ExitCode) -> RIO env ExitCode
forall a b. (a -> b) -> a -> b
$ \ProcessConfig () () ()
pc0 -> do
ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))
-> ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))
changeStdin <-
if Bool
isTestTypeLib
then do
Path Abs File
logPath <- Package -> Maybe [Char] -> RIO env (Path Abs File)
forall env (m :: * -> *).
(MonadReader env m, HasBuildConfig env, MonadThrow m) =>
Package -> Maybe [Char] -> m (Path Abs File)
buildLogPath Package
package ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
stestName)
Path Abs Dir -> RIO env ()
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir (Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent Path Abs File
logPath)
(ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))
-> ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ())))
-> RIO
env
(ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))
-> ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ())))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))
-> ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ())))
-> RIO
env
(ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))
-> ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))))
-> (ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))
-> ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ())))
-> RIO
env
(ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))
-> ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ())))
forall a b. (a -> b) -> a -> b
$
StreamSpec 'STInput ()
-> ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))
-> ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))
forall stdin stdin0 stdout stderr.
StreamSpec 'STInput stdin
-> ProcessConfig stdin0 stdout stderr
-> ProcessConfig stdin stdout stderr
setStdin
(StreamSpec 'STInput ()
-> ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))
-> ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ())))
-> StreamSpec 'STInput ()
-> ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))
-> ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))
forall a b. (a -> b) -> a -> b
$ ByteString -> StreamSpec 'STInput ()
byteStringInput
(ByteString -> StreamSpec 'STInput ())
-> ByteString -> StreamSpec 'STInput ()
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BL.fromStrict
(ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
forall a. IsString a => [Char] -> a
fromString ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$
(Path Abs File, UnqualComponentName) -> [Char]
forall a. Show a => a -> [Char]
show ( Path Abs File
logPath
, StackUnqualCompName -> UnqualComponentName
toCabalName StackUnqualCompName
testName
)
else do
Bool
isTerminal <- Getting Bool env Bool -> RIO env Bool
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting Bool env Bool -> RIO env Bool)
-> Getting Bool env Bool -> RIO env Bool
forall a b. (a -> b) -> a -> b
$ (GlobalOpts -> Const Bool GlobalOpts) -> env -> Const Bool env
forall env. HasRunner env => Lens' env GlobalOpts
Lens' env GlobalOpts
globalOptsL ((GlobalOpts -> Const Bool GlobalOpts) -> env -> Const Bool env)
-> ((Bool -> Const Bool Bool)
-> GlobalOpts -> Const Bool GlobalOpts)
-> Getting Bool env Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GlobalOpts -> Bool) -> SimpleGetter GlobalOpts Bool
forall s a. (s -> a) -> SimpleGetter s a
to (.terminal)
if TestOpts
topts.allowStdin Bool -> Bool -> Bool
&& Bool
isTerminal
then (ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))
-> ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ())))
-> RIO
env
(ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))
-> ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ())))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))
-> ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))
forall a. a -> a
id
else (ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))
-> ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ())))
-> RIO
env
(ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))
-> ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ())))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))
-> ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ())))
-> RIO
env
(ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))
-> ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))))
-> (ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))
-> ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ())))
-> RIO
env
(ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))
-> ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ())))
forall a b. (a -> b) -> a -> b
$ StreamSpec 'STInput ()
-> ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))
-> ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))
forall stdin stdin0 stdout stderr.
StreamSpec 'STInput stdin
-> ProcessConfig stdin0 stdout stderr
-> ProcessConfig stdin stdout stderr
setStdin (StreamSpec 'STInput ()
-> ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))
-> ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ())))
-> StreamSpec 'STInput ()
-> ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))
-> ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))
forall a b. (a -> b) -> a -> b
$ ByteString -> StreamSpec 'STInput ()
byteStringInput ByteString
forall a. Monoid a => a
mempty
let pc :: ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))
pc = ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))
-> ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))
changeStdin
(ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))
-> ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ())))
-> ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))
-> ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))
forall a b. (a -> b) -> a -> b
$ StreamSpec 'STOutput (Maybe (RIO env ()))
-> ProcessConfig () () (Maybe (RIO env ()))
-> ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))
forall stdout stdin stdout0 stderr.
StreamSpec 'STOutput stdout
-> ProcessConfig stdin stdout0 stderr
-> ProcessConfig stdin stdout stderr
setStdout StreamSpec 'STOutput (Maybe (RIO env ()))
output
(ProcessConfig () () (Maybe (RIO env ()))
-> ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ())))
-> ProcessConfig () () (Maybe (RIO env ()))
-> ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))
forall a b. (a -> b) -> a -> b
$ StreamSpec 'STOutput (Maybe (RIO env ()))
-> ProcessConfig () () ()
-> ProcessConfig () () (Maybe (RIO env ()))
forall stderr stdin stdout stderr0.
StreamSpec 'STOutput stderr
-> ProcessConfig stdin stdout stderr0
-> ProcessConfig stdin stdout stderr
setStderr StreamSpec 'STOutput (Maybe (RIO env ()))
output
ProcessConfig () () ()
pc0
ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))
-> (Process () (Maybe (RIO env ())) (Maybe (RIO env ()))
-> RIO env ExitCode)
-> RIO env ExitCode
forall (m :: * -> *) stdin stdout stderr a.
MonadUnliftIO m =>
ProcessConfig stdin stdout stderr
-> (Process stdin stdout stderr -> m a) -> m a
withProcessWait ProcessConfig () (Maybe (RIO env ())) (Maybe (RIO env ()))
pc ((Process () (Maybe (RIO env ())) (Maybe (RIO env ()))
-> RIO env ExitCode)
-> RIO env ExitCode)
-> (Process () (Maybe (RIO env ())) (Maybe (RIO env ()))
-> RIO env ExitCode)
-> RIO env ExitCode
forall a b. (a -> b) -> a -> b
$ \Process () (Maybe (RIO env ())) (Maybe (RIO env ()))
p -> do
case (Process () (Maybe (RIO env ())) (Maybe (RIO env ()))
-> Maybe (RIO env ())
forall stdin stdout stderr. Process stdin stdout stderr -> stdout
getStdout Process () (Maybe (RIO env ())) (Maybe (RIO env ()))
p, Process () (Maybe (RIO env ())) (Maybe (RIO env ()))
-> Maybe (RIO env ())
forall stdin stdout stderr. Process stdin stdout stderr -> stderr
getStderr Process () (Maybe (RIO env ())) (Maybe (RIO env ()))
p) of
(Maybe (RIO env ())
Nothing, Maybe (RIO env ())
Nothing) -> () -> RIO env ()
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
(Just RIO env ()
x, Just RIO env ()
y) -> RIO env () -> RIO env () -> RIO env ()
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m ()
concurrently_ RIO env ()
x RIO env ()
y
(Maybe (RIO env ())
x, Maybe (RIO env ())
y) -> Bool -> RIO env () -> RIO env ()
forall a. (?callStack::CallStack) => Bool -> a -> a
assert Bool
False (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
RIO env () -> RIO env () -> RIO env ()
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m ()
concurrently_
(RIO env () -> Maybe (RIO env ()) -> RIO env ()
forall a. a -> Maybe a -> a
fromMaybe (() -> RIO env ()
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) Maybe (RIO env ())
x)
(RIO env () -> Maybe (RIO env ()) -> RIO env ()
forall a. a -> Maybe a -> a
fromMaybe (() -> RIO env ()
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) Maybe (RIO env ())
y)
Process () (Maybe (RIO env ())) (Maybe (RIO env ()))
-> RIO env ExitCode
forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
Process stdin stdout stderr -> m ExitCode
waitExitCode Process () (Maybe (RIO env ())) (Maybe (RIO env ()))
p
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 ()
Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
needHpc (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
PackageName -> Path Abs File -> [Char] -> RIO env ()
forall env.
HasEnvConfig env =>
PackageName -> Path Abs File -> [Char] -> RIO env ()
updateTixFile Package
package.name Path Abs File
tixPath [Char]
testName'
let announceResult :: Utf8Builder -> RIO env ()
announceResult Utf8Builder
result =
Utf8Builder -> RIO env ()
announce (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$
Utf8Builder
"Test suite "
Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display (StackUnqualCompName -> Text
unqualCompToText StackUnqualCompName
testName)
Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" "
Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
result
case Maybe ExitCode
mec of
Just ExitCode
ExitSuccess -> do
Utf8Builder -> RIO env ()
announceResult Utf8Builder
"passed"
Map StackUnqualCompName (Maybe ExitCode)
-> RIO env (Map StackUnqualCompName (Maybe ExitCode))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map StackUnqualCompName (Maybe ExitCode)
forall k a. Map k a
Map.empty
Maybe ExitCode
Nothing -> do
Utf8Builder -> RIO env ()
announceResult Utf8Builder
"timed out"
if Bool
expectFailure
then Map StackUnqualCompName (Maybe ExitCode)
-> RIO env (Map StackUnqualCompName (Maybe ExitCode))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map StackUnqualCompName (Maybe ExitCode)
forall k a. Map k a
Map.empty
else Map StackUnqualCompName (Maybe ExitCode)
-> RIO env (Map StackUnqualCompName (Maybe ExitCode))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map StackUnqualCompName (Maybe ExitCode)
-> RIO env (Map StackUnqualCompName (Maybe ExitCode)))
-> Map StackUnqualCompName (Maybe ExitCode)
-> RIO env (Map StackUnqualCompName (Maybe ExitCode))
forall a b. (a -> b) -> a -> b
$ StackUnqualCompName
-> Maybe ExitCode -> Map StackUnqualCompName (Maybe ExitCode)
forall k a. k -> a -> Map k a
Map.singleton StackUnqualCompName
testName Maybe ExitCode
forall a. Maybe a
Nothing
Just ExitCode
ec -> do
Utf8Builder -> RIO env ()
announceResult Utf8Builder
"failed"
if Bool
expectFailure
then Map StackUnqualCompName (Maybe ExitCode)
-> RIO env (Map StackUnqualCompName (Maybe ExitCode))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map StackUnqualCompName (Maybe ExitCode)
forall k a. Map k a
Map.empty
else Map StackUnqualCompName (Maybe ExitCode)
-> RIO env (Map StackUnqualCompName (Maybe ExitCode))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map StackUnqualCompName (Maybe ExitCode)
-> RIO env (Map StackUnqualCompName (Maybe ExitCode)))
-> Map StackUnqualCompName (Maybe ExitCode)
-> RIO env (Map StackUnqualCompName (Maybe ExitCode))
forall a b. (a -> b) -> a -> b
$ StackUnqualCompName
-> Maybe ExitCode -> Map StackUnqualCompName (Maybe ExitCode)
forall k a. k -> a -> Map k a
Map.singleton StackUnqualCompName
testName (ExitCode -> Maybe ExitCode
forall a. a -> Maybe a
Just ExitCode
ec)
else do
Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
expectFailure (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logError (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$
BuildException -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow (BuildException -> Utf8Builder) -> BuildException -> Utf8Builder
forall a b. (a -> b) -> a -> b
$ Bool -> [Char] -> [Char] -> [Char] -> BuildException
TestSuiteExeMissing
(Package
package.buildType BuildType -> BuildType -> Bool
forall a. Eq a => a -> a -> Bool
== BuildType
C.Simple)
[Char]
exeName
(PackageName -> [Char]
packageNameString Package
package.name)
(StackUnqualCompName -> [Char]
unqualCompToString StackUnqualCompName
testName)
Map StackUnqualCompName (Maybe ExitCode)
-> RIO env (Map StackUnqualCompName (Maybe ExitCode))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map StackUnqualCompName (Maybe ExitCode)
emptyResult
Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
needHpc (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
let testsToRun' :: [Text]
testsToRun' = (StackUnqualCompName -> Text) -> [StackUnqualCompName] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map StackUnqualCompName -> Text
f [StackUnqualCompName]
testsToRun
f :: StackUnqualCompName -> Text
f StackUnqualCompName
tName =
case (.interface) (StackTestSuite -> TestSuiteInterface)
-> Maybe StackTestSuite -> Maybe TestSuiteInterface
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe StackTestSuite
mComponent of
Just C.TestSuiteLibV09{} -> StackUnqualCompName -> Text
unqualCompToText StackUnqualCompName
tName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"Stub"
Maybe TestSuiteInterface
_ -> StackUnqualCompName -> Text
unqualCompToText StackUnqualCompName
tName
where
mComponent :: Maybe StackTestSuite
mComponent = StackUnqualCompName
-> CompCollection StackTestSuite -> Maybe StackTestSuite
forall component.
StackUnqualCompName -> CompCollection component -> Maybe component
collectionLookup StackUnqualCompName
tName Package
package.testSuites
Path Abs Dir -> Package -> [Text] -> RIO env ()
forall env.
HasEnvConfig env =>
Path Abs Dir -> Package -> [Text] -> RIO env ()
generateHpcReport Path Abs Dir
pkgDir Package
package [Text]
testsToRun'
ByteString
bs <- IO ByteString -> RIO env ByteString
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> RIO env ByteString)
-> IO ByteString -> RIO env ByteString
forall a b. (a -> b) -> a -> b
$
case OutputType
outputType of
OTConsole Maybe Utf8Builder
_ -> ByteString -> IO ByteString
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
""
OTLogFile Path Abs File
logFile Handle
h -> do
Handle -> IO ()
forall (m :: * -> *). MonadIO m => Handle -> m ()
hClose Handle
h
[Char] -> IO ByteString
S.readFile ([Char] -> IO ByteString) -> [Char] -> IO ByteString
forall a b. (a -> b) -> a -> b
$ Path Abs File -> [Char]
forall b t. Path b t -> [Char]
toFilePath Path Abs File
logFile
let succeeded :: Bool
succeeded = Map StackUnqualCompName (Maybe ExitCode) -> Bool
forall k a. Map k a -> Bool
Map.null Map StackUnqualCompName (Maybe ExitCode)
errs
Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
succeeded Bool -> Bool -> Bool
|| Bool
expectFailure) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
BuildException -> RIO env ()
forall e a. (?callStack::CallStack, Exception e) => e -> RIO env a
forall (m :: * -> *) e a.
(MonadThrow m, ?callStack::CallStack, Exception e) =>
e -> m a
throwM (BuildException -> RIO env ()) -> BuildException -> RIO env ()
forall a b. (a -> b) -> a -> b
$ PackageIdentifier
-> Map StackUnqualCompName (Maybe ExitCode)
-> Maybe (Path Abs File)
-> ByteString
-> BuildException
TestSuiteFailure
(Task -> PackageIdentifier
taskProvides Task
task)
Map StackUnqualCompName (Maybe ExitCode)
errs
(case OutputType
outputType of
OTLogFile Path Abs File
fp Handle
_ -> Path Abs File -> Maybe (Path Abs File)
forall a. a -> Maybe a
Just Path Abs File
fp
OTConsole Maybe Utf8Builder
_ -> Maybe (Path Abs File)
forall a. Maybe a
Nothing)
ByteString
bs
Path Abs Dir -> TestStatus -> RIO env ()
forall env.
HasEnvConfig env =>
Path Abs Dir -> TestStatus -> RIO env ()
setTestStatus Path Abs Dir
pkgDir (TestStatus -> RIO env ()) -> TestStatus -> RIO env ()
forall a b. (a -> b) -> a -> b
$ if Bool
succeeded then TestStatus
TSSuccess else TestStatus
TSFailure
singleBench :: HasEnvConfig env
=> BenchmarkOpts
-> [StackUnqualCompName]
-> ActionContext
-> ExecuteEnv
-> Task
-> InstalledMap
-> RIO env ()
singleBench :: forall env.
HasEnvConfig env =>
BenchmarkOpts
-> [StackUnqualCompName]
-> ActionContext
-> ExecuteEnv
-> Task
-> InstalledMap
-> RIO env ()
singleBench BenchmarkOpts
beopts [StackUnqualCompName]
benchesToRun ActionContext
ac ExecuteEnv
ee Task
task InstalledMap
installedMap = do
(Map PackageIdentifier GhcPkgId
allDepsMap, ConfigCache
_cache) <- ExecuteEnv
-> Task
-> InstalledMap
-> Bool
-> Bool
-> RIO env (Map PackageIdentifier GhcPkgId, ConfigCache)
forall env.
HasEnvConfig env =>
ExecuteEnv
-> Task
-> InstalledMap
-> Bool
-> Bool
-> RIO env (Map PackageIdentifier GhcPkgId, ConfigCache)
getConfigCache ExecuteEnv
ee Task
task InstalledMap
installedMap Bool
False Bool
True
ActionContext
-> ExecuteEnv
-> TaskType
-> Map PackageIdentifier GhcPkgId
-> Maybe [Char]
-> (Package
-> Path Abs File
-> Path Abs Dir
-> (KeepOutputOpen -> ExcludeTHLoading -> [[Char]] -> RIO env ())
-> (Utf8Builder -> RIO env ())
-> OutputType
-> RIO env ())
-> RIO env ()
forall env a.
HasEnvConfig env =>
ActionContext
-> ExecuteEnv
-> TaskType
-> Map PackageIdentifier GhcPkgId
-> Maybe [Char]
-> (Package
-> Path Abs File
-> Path Abs Dir
-> (KeepOutputOpen -> ExcludeTHLoading -> [[Char]] -> RIO env ())
-> (Utf8Builder -> RIO env ())
-> OutputType
-> RIO env a)
-> RIO env a
withSingleContext ActionContext
ac ExecuteEnv
ee Task
task.taskType Map PackageIdentifier GhcPkgId
allDepsMap ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
"bench") ((Package
-> Path Abs File
-> Path Abs Dir
-> (KeepOutputOpen -> ExcludeTHLoading -> [[Char]] -> RIO env ())
-> (Utf8Builder -> RIO env ())
-> OutputType
-> RIO env ())
-> RIO env ())
-> (Package
-> Path Abs File
-> Path Abs Dir
-> (KeepOutputOpen -> ExcludeTHLoading -> [[Char]] -> RIO env ())
-> (Utf8Builder -> RIO env ())
-> OutputType
-> RIO env ())
-> RIO env ()
forall a b. (a -> b) -> a -> b
$
\Package
_package Path Abs File
_cabalfp Path Abs Dir
_pkgDir KeepOutputOpen -> ExcludeTHLoading -> [[Char]] -> RIO env ()
cabal Utf8Builder -> RIO env ()
announce OutputType
_outputType -> do
let args :: [[Char]]
args = (StackUnqualCompName -> [Char])
-> [StackUnqualCompName] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map StackUnqualCompName -> [Char]
unqualCompToString [StackUnqualCompName]
benchesToRun [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [[Char]] -> ([Char] -> [[Char]]) -> Maybe [Char] -> [[Char]]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe []
(([Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
:[]) ([Char] -> [[Char]]) -> ([Char] -> [Char]) -> [Char] -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
"--benchmark-options=" <>))
BenchmarkOpts
beopts.additionalArgs
Bool
toRun <-
if BenchmarkOpts
beopts.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 -> [[Char]] -> RIO env ()
cabal KeepOutputOpen
CloseOnException ExcludeTHLoading
KeepTHLoading ([Char]
"bench" [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]]
args)
extraBuildOptions ::
(HasEnvConfig env, HasRunner env)
=> WhichCompiler
-> BuildOpts
-> RIO env [String]
WhichCompiler
wc BuildOpts
bopts = do
Maybe [Char]
colorOpt <- RIO env (Maybe [Char])
forall env.
(HasEnvConfig env, HasRunner env) =>
RIO env (Maybe [Char])
appropriateGhcColorFlag
let optsFlag :: [Char]
optsFlag = WhichCompiler -> [Char]
compilerOptionsCabalFlag WhichCompiler
wc
baseOpts :: [Char]
baseOpts = [Char] -> ([Char] -> [Char]) -> Maybe [Char] -> [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"" ([Char]
" " ++) Maybe [Char]
colorOpt
if BuildOpts
bopts.testOpts.coverage
then do
[Char]
hpcIndexDir <- Path Rel Dir -> [Char]
forall loc. Path loc Dir -> [Char]
toFilePathNoTrailingSep (Path Rel Dir -> [Char])
-> RIO env (Path Rel Dir) -> RIO env [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RIO env (Path Rel Dir)
forall env (m :: * -> *).
(HasEnvConfig env, MonadReader env m, MonadThrow m) =>
m (Path Rel Dir)
hpcRelativeDir
[[Char]] -> RIO env [[Char]]
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [[Char]
optsFlag, [Char]
"-hpcdir " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
hpcIndexDir [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
baseOpts]
else
[[Char]] -> RIO env [[Char]]
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [[Char]
optsFlag, [Char]
baseOpts]
primaryComponentOptions :: LocalPackage -> [String]
primaryComponentOptions :: LocalPackage -> [[Char]]
primaryComponentOptions LocalPackage
lp =
( if Package -> Bool
hasBuildableMainLibrary Package
package
then (Text -> [Char]) -> [Text] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Text -> [Char]
T.unpack
([Text] -> [[Char]]) -> [Text] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text
T.append Text
"lib:" ([Char] -> Text
T.pack (PackageName -> [Char]
packageNameString Package
package.name))
Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map
(Text -> Text -> Text
T.append Text
"flib:")
(CompCollection StackForeignLibrary -> [Text]
forall component. CompCollection component -> [Text]
getBuildableListText Package
package.foreignLibraries)
else []
)
[[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ (Text -> [Char]) -> [Text] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map
(Text -> [Char]
T.unpack (Text -> [Char]) -> (Text -> Text) -> Text -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text
T.append Text
"lib:")
(CompCollection StackLibrary -> [Text]
forall component. CompCollection component -> [Text]
getBuildableListText Package
package.subLibraries)
[[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ Set [Char] -> [[Char]]
forall a. Set a -> [a]
Set.toList
( (StackUnqualCompName -> [Char])
-> Set StackUnqualCompName -> Set [Char]
forall a b. (a -> b) -> Set a -> Set b
Set.mapMonotonic
(\StackUnqualCompName
s -> [Char]
"exe:" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ StackUnqualCompName -> [Char]
unqualCompToString StackUnqualCompName
s)
(LocalPackage -> Set StackUnqualCompName
exesToBuild LocalPackage
lp)
)
where
package :: Package
package = LocalPackage
lp.package
exesToBuild :: LocalPackage -> Set StackUnqualCompName
exesToBuild :: LocalPackage -> Set StackUnqualCompName
exesToBuild LocalPackage
lp = if LocalPackage
lp.wanted
then Set NamedComponent -> Set StackUnqualCompName
exeComponents LocalPackage
lp.components
else Package -> Set StackUnqualCompName
buildableExes LocalPackage
lp.package
finalComponentOptions :: LocalPackage -> [String]
finalComponentOptions :: LocalPackage -> [[Char]]
finalComponentOptions LocalPackage
lp =
(NamedComponent -> [Char]) -> [NamedComponent] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> [Char]
T.unpack (Text -> [Char])
-> (NamedComponent -> Text) -> NamedComponent -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamedComponent -> Text
renderComponent) ([NamedComponent] -> [[Char]]) -> [NamedComponent] -> [[Char]]
forall a b. (a -> b) -> a -> b
$
Set NamedComponent -> [NamedComponent]
forall a. Set a -> [a]
Set.toList (Set NamedComponent -> [NamedComponent])
-> Set NamedComponent -> [NamedComponent]
forall a b. (a -> b) -> a -> b
$
(NamedComponent -> Bool)
-> Set NamedComponent -> Set NamedComponent
forall a. (a -> Bool) -> Set a -> Set a
Set.filter (\NamedComponent
c -> NamedComponent -> Bool
isCTest NamedComponent
c Bool -> Bool -> Bool
|| NamedComponent -> Bool
isCBench NamedComponent
c) LocalPackage
lp.components
taskComponents :: Task -> Set NamedComponent
taskComponents :: Task -> Set NamedComponent
taskComponents Task
task =
case Task
task.taskType of
TTLocalMutable LocalPackage
lp -> LocalPackage
lp.components
TTRemotePackage{} -> Set NamedComponent
forall a. Set a
Set.empty
expectTestFailure :: PackageName -> Maybe Curator -> Bool
expectTestFailure :: PackageName -> Maybe Curator -> Bool
expectTestFailure PackageName
pname =
Bool -> (Curator -> Bool) -> Maybe Curator -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (PackageName -> Set PackageName -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member PackageName
pname (Set PackageName -> Bool)
-> (Curator -> Set PackageName) -> Curator -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.expectTestFailure))
expectBenchmarkFailure :: PackageName -> Maybe Curator -> Bool
expectBenchmarkFailure :: PackageName -> Maybe Curator -> Bool
expectBenchmarkFailure PackageName
pname =
Bool -> (Curator -> Bool) -> Maybe Curator -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (PackageName -> Set PackageName -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member PackageName
pname (Set PackageName -> Bool)
-> (Curator -> Set PackageName) -> Curator -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.expectBenchmarkFailure))
fulfillCuratorBuildExpectations ::
(HasCallStack, HasTerm env)
=> PackageName
-> Maybe Curator
-> Bool
-> Bool
-> b
-> RIO env b
-> RIO env b
fulfillCuratorBuildExpectations :: forall env b.
(?callStack::CallStack, HasTerm env) =>
PackageName
-> Maybe Curator -> Bool -> Bool -> b -> RIO env b -> RIO env b
fulfillCuratorBuildExpectations PackageName
pname Maybe Curator
mcurator Bool
enableTests Bool
_ b
defValue RIO env b
action
| Bool
enableTests Bool -> Bool -> Bool
&& PackageName -> Maybe Curator -> Bool
expectTestFailure PackageName
pname Maybe Curator
mcurator = do
Either SomeException b
eres <- RIO env b -> RIO env (Either SomeException b)
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny RIO env b
action
case Either SomeException b
eres of
Right b
res -> do
[StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
MonadIO m) =>
[StyleDoc] -> m ()
prettyWarnL
[ Style -> StyleDoc -> StyleDoc
style Style
Current (PackageName -> StyleDoc
forall a. IsString a => PackageName -> a
fromPackageName PackageName
pname) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
":"
, [Char] -> StyleDoc
flow [Char]
"unexpected test build success."
]
b -> RIO env b
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
res
Left SomeException
_ -> b -> RIO env b
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
defValue
fulfillCuratorBuildExpectations PackageName
pname Maybe Curator
mcurator Bool
_ Bool
enableBench b
defValue RIO env b
action
| Bool
enableBench Bool -> Bool -> Bool
&& PackageName -> Maybe Curator -> Bool
expectBenchmarkFailure PackageName
pname Maybe Curator
mcurator = do
Either SomeException b
eres <- RIO env b -> RIO env (Either SomeException b)
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny RIO env b
action
case Either SomeException b
eres of
Right b
res -> do
[StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
MonadIO m) =>
[StyleDoc] -> m ()
prettyWarnL
[ Style -> StyleDoc -> StyleDoc
style Style
Current (PackageName -> StyleDoc
forall a. IsString a => PackageName -> a
fromPackageName PackageName
pname) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
":"
, [Char] -> StyleDoc
flow [Char]
"unexpected benchmark build success."
]
b -> RIO env b
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
res
Left SomeException
_ -> b -> RIO env b
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
defValue
fulfillCuratorBuildExpectations PackageName
_ Maybe Curator
_ Bool
_ Bool
_ b
_ RIO env b
action = RIO env b
action