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