{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
module Stack.Build.Execute
( printPlan
, preFetch
, executePlan
, ExecuteEnv
, withExecuteEnv
, withSingleContext
, ExcludeTHLoading (..)
, KeepOutputOpen (..)
) where
import Control.Concurrent.Execute
import Control.Concurrent.STM ( check )
import Crypto.Hash
import Data.Attoparsec.Text ( char, choice, digit, parseOnly )
import qualified Data.Attoparsec.Text as P ( string )
import qualified Data.ByteArray as Mem ( convert )
import qualified Data.ByteString as S
import qualified Data.ByteString.Builder
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Base64.URL as B64URL
import Data.Char ( isSpace )
import Conduit
import qualified Data.Conduit.Binary as CB
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 Data.List.NonEmpty ( nonEmpty )
import qualified Data.List.NonEmpty as NonEmpty ( toList )
import Data.List.Split ( chunksOf )
import qualified Data.Map.Strict as M
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified Data.Text as T
import Data.Text.Encoding ( decodeUtf8 )
import Data.Tuple
import Data.Time
( ZonedTime, getZonedTime, formatTime, defaultTimeLocale )
import qualified Data.ByteString.Char8 as S8
import qualified Distribution.PackageDescription as C
import qualified Distribution.Simple.Build.Macros as C
import Distribution.System ( OS (Windows), Platform (Platform) )
import qualified Distribution.Text as C
import Distribution.Types.PackageName ( mkPackageName )
import Distribution.Types.UnqualComponentName
( mkUnqualComponentName )
import Distribution.Verbosity ( showForCabal )
import Distribution.Version ( mkVersion )
import Pantry.Internal.Companion
import Path
import Path.CheckInstall
import Path.Extra ( toFilePathNoTrailingSep, rejectMissingFile )
import Path.IO
hiding ( findExecutable, makeAbsolute, withSystemTempDir )
import RIO.Process
import Stack.Build.Cache
import Stack.Build.Haddock
import Stack.Build.Installed
import Stack.Build.Source
import Stack.Build.Target
import Stack.Config
import Stack.Constants
import Stack.Constants.Config
import Stack.Coverage
import Stack.DefaultColorWhen ( defaultColorWhen )
import Stack.GhcPkg
import Stack.Package
import Stack.PackageDump
import Stack.Prelude
import Stack.Types.Build
import Stack.Types.Compiler
import Stack.Types.Config
import Stack.Types.GhcPkgId
import Stack.Types.NamedComponent
import Stack.Types.Package
import Stack.Types.PackageFile
import Stack.Types.Version
import qualified System.Directory as D
import System.Environment ( getExecutablePath, lookupEnv )
import System.FileLock
( withTryFileLock, SharedExclusive (Exclusive)
, withFileLock
)
import qualified System.FilePath as FP
import System.IO.Error ( isDoesNotExistError )
import System.PosixCompat.Files
( createLink, modificationTime, getFileStatus )
import System.Random ( randomIO )
data ExecutableBuildStatus
= ExecutableBuilt
| ExecutableNotBuilt
deriving (Int -> ExecutableBuildStatus -> ShowS
[ExecutableBuildStatus] -> ShowS
ExecutableBuildStatus -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [ExecutableBuildStatus] -> ShowS
$cshowList :: [ExecutableBuildStatus] -> ShowS
show :: ExecutableBuildStatus -> [Char]
$cshow :: ExecutableBuildStatus -> [Char]
showsPrec :: Int -> ExecutableBuildStatus -> ShowS
$cshowsPrec :: Int -> ExecutableBuildStatus -> ShowS
Show, ExecutableBuildStatus -> ExecutableBuildStatus -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ExecutableBuildStatus -> ExecutableBuildStatus -> Bool
$c/= :: ExecutableBuildStatus -> ExecutableBuildStatus -> Bool
== :: ExecutableBuildStatus -> ExecutableBuildStatus -> Bool
$c== :: ExecutableBuildStatus -> ExecutableBuildStatus -> Bool
Eq, Eq ExecutableBuildStatus
ExecutableBuildStatus -> ExecutableBuildStatus -> Bool
ExecutableBuildStatus -> ExecutableBuildStatus -> Ordering
ExecutableBuildStatus
-> ExecutableBuildStatus -> ExecutableBuildStatus
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ExecutableBuildStatus
-> ExecutableBuildStatus -> ExecutableBuildStatus
$cmin :: ExecutableBuildStatus
-> ExecutableBuildStatus -> ExecutableBuildStatus
max :: ExecutableBuildStatus
-> ExecutableBuildStatus -> ExecutableBuildStatus
$cmax :: ExecutableBuildStatus
-> ExecutableBuildStatus -> ExecutableBuildStatus
>= :: ExecutableBuildStatus -> ExecutableBuildStatus -> Bool
$c>= :: ExecutableBuildStatus -> ExecutableBuildStatus -> Bool
> :: ExecutableBuildStatus -> ExecutableBuildStatus -> Bool
$c> :: ExecutableBuildStatus -> ExecutableBuildStatus -> Bool
<= :: ExecutableBuildStatus -> ExecutableBuildStatus -> Bool
$c<= :: ExecutableBuildStatus -> ExecutableBuildStatus -> Bool
< :: ExecutableBuildStatus -> ExecutableBuildStatus -> Bool
$c< :: ExecutableBuildStatus -> ExecutableBuildStatus -> Bool
compare :: ExecutableBuildStatus -> ExecutableBuildStatus -> Ordering
$ccompare :: ExecutableBuildStatus -> ExecutableBuildStatus -> Ordering
Ord)
preFetch :: HasEnvConfig env => Plan -> RIO env ()
preFetch :: forall env. HasEnvConfig env => Plan -> RIO env ()
preFetch Plan
plan
| forall a. Set a -> Bool
Set.null Set PackageLocationImmutable
pkgLocs = forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Nothing to fetch"
| Bool
otherwise = do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$
Utf8Builder
"Prefetching: " forall a. Semigroup a => a -> a -> a
<>
forall a. Monoid a => [a] -> a
mconcat (forall a. a -> [a] -> [a]
L.intersperse Utf8Builder
", " (forall a. Display a => a -> Utf8Builder
display forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Set a -> [a]
Set.toList Set PackageLocationImmutable
pkgLocs))
forall env (f :: * -> *).
(HasPantryConfig env, HasLogFunc env, HasProcessContext env,
Foldable f) =>
f PackageLocationImmutable -> RIO env ()
fetchPackages Set PackageLocationImmutable
pkgLocs
where
pkgLocs :: Set PackageLocationImmutable
pkgLocs = forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Task -> Set PackageLocationImmutable
toPkgLoc forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [a]
Map.elems forall a b. (a -> b) -> a -> b
$ Plan -> Map PackageName Task
planTasks Plan
plan
toPkgLoc :: Task -> Set PackageLocationImmutable
toPkgLoc Task
task =
case Task -> TaskType
taskType Task
task of
TTLocalMutable{} -> forall a. Set a
Set.empty
TTRemotePackage IsMutable
_ Package
_ PackageLocationImmutable
pkgloc -> forall a. a -> Set a
Set.singleton PackageLocationImmutable
pkgloc
printPlan :: HasRunner env => Plan -> RIO env ()
printPlan :: forall env. HasRunner env => Plan -> RIO env ()
printPlan Plan
plan = do
case forall k a. Map k a -> [a]
Map.elems forall a b. (a -> b) -> a -> b
$ Plan -> Map GhcPkgId (PackageIdentifier, Text)
planUnregisterLocal Plan
plan of
[] -> forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"No packages would be unregistered."
[(PackageIdentifier, Text)]
xs -> do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"Would unregister locally:"
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(PackageIdentifier, Text)]
xs forall a b. (a -> b) -> a -> b
$ \(PackageIdentifier
ident, Text
reason) -> forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$
forall a. IsString a => [Char] -> a
fromString (PackageIdentifier -> [Char]
packageIdentifierString PackageIdentifier
ident) forall a. Semigroup a => a -> a -> a
<>
if Text -> Bool
T.null Text
reason
then Utf8Builder
""
else Utf8Builder
" (" forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Text
reason forall a. Semigroup a => a -> a -> a
<> Utf8Builder
")"
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
""
case forall k a. Map k a -> [a]
Map.elems forall a b. (a -> b) -> a -> b
$ Plan -> Map PackageName Task
planTasks Plan
plan of
[] -> forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"Nothing to build."
[Task]
xs -> do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"Would build:"
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logInfo forall b c a. (b -> c) -> (a -> b) -> a -> c
. Task -> Utf8Builder
displayTask) [Task]
xs
let hasTests :: Task -> Bool
hasTests = Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> Bool
Set.null forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set NamedComponent -> Set Text
testComponents forall b c a. (b -> c) -> (a -> b) -> a -> c
. Task -> Set NamedComponent
taskComponents
hasBenches :: Task -> Bool
hasBenches = Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> Bool
Set.null forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set NamedComponent -> Set Text
benchComponents forall b c a. (b -> c) -> (a -> b) -> a -> c
. Task -> Set NamedComponent
taskComponents
tests :: [Task]
tests = forall k a. Map k a -> [a]
Map.elems forall a b. (a -> b) -> a -> b
$ forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter Task -> Bool
hasTests forall a b. (a -> b) -> a -> b
$ Plan -> Map PackageName Task
planFinals Plan
plan
benches :: [Task]
benches = forall k a. Map k a -> [a]
Map.elems forall a b. (a -> b) -> a -> b
$ forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter Task -> Bool
hasBenches forall a b. (a -> b) -> a -> b
$ Plan -> Map PackageName Task
planFinals Plan
plan
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Task]
tests) forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
""
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"Would test:"
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logInfo forall b c a. (b -> c) -> (a -> b) -> a -> c
. Task -> Utf8Builder
displayTask) [Task]
tests
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Task]
benches) forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
""
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"Would benchmark:"
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logInfo forall b c a. (b -> c) -> (a -> b) -> a -> c
. Task -> Utf8Builder
displayTask) [Task]
benches
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
""
case forall k a. Map k a -> [(k, a)]
Map.toList forall a b. (a -> b) -> a -> b
$ Plan -> Map Text InstallLocation
planInstallExes Plan
plan of
[] -> forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"No executables to be installed."
[(Text, InstallLocation)]
xs -> do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"Would install executables:"
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Text, InstallLocation)]
xs forall a b. (a -> b) -> a -> b
$ \(Text
name, InstallLocation
loc) -> forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$
forall a. Display a => a -> Utf8Builder
display Text
name forall a. Semigroup a => a -> a -> a
<>
Utf8Builder
" from " forall a. Semigroup a => a -> a -> a
<>
(case InstallLocation
loc of
InstallLocation
Snap -> Utf8Builder
"snapshot"
InstallLocation
Local -> Utf8Builder
"local") forall a. Semigroup a => a -> a -> a
<>
Utf8Builder
" database"
displayTask :: Task -> Utf8Builder
displayTask :: Task -> Utf8Builder
displayTask Task
task =
forall a. IsString a => [Char] -> a
fromString (PackageIdentifier -> [Char]
packageIdentifierString (Task -> PackageIdentifier
taskProvides Task
task)) forall a. Semigroup a => a -> a -> a
<>
Utf8Builder
": database=" forall a. Semigroup a => a -> a -> a
<>
(case Task -> InstallLocation
taskLocation Task
task of
InstallLocation
Snap -> Utf8Builder
"snapshot"
InstallLocation
Local -> Utf8Builder
"local") forall a. Semigroup a => a -> a -> a
<>
Utf8Builder
", source=" forall a. Semigroup a => a -> a -> a
<>
(case Task -> TaskType
taskType Task
task of
TTLocalMutable LocalPackage
lp -> forall a. IsString a => [Char] -> a
fromString forall a b. (a -> b) -> a -> b
$ forall b t. Path b t -> [Char]
toFilePath forall a b. (a -> b) -> a -> b
$ forall b t. Path b t -> Path b Dir
parent forall a b. (a -> b) -> a -> b
$ LocalPackage -> Path Abs File
lpCabalFile LocalPackage
lp
TTRemotePackage IsMutable
_ Package
_ PackageLocationImmutable
pl -> forall a. Display a => a -> Utf8Builder
display PackageLocationImmutable
pl) forall a. Semigroup a => a -> a -> a
<>
(if forall a. Set a -> Bool
Set.null Set PackageIdentifier
missing
then Utf8Builder
""
else Utf8Builder
", after: " forall a. Semigroup a => a -> a -> a
<>
forall a. Monoid a => [a] -> a
mconcat (forall a. a -> [a] -> [a]
L.intersperse Utf8Builder
"," (forall a. IsString a => [Char] -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageIdentifier -> [Char]
packageIdentifierString forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Set a -> [a]
Set.toList Set PackageIdentifier
missing)))
where
missing :: Set PackageIdentifier
missing = TaskConfigOpts -> Set PackageIdentifier
tcoMissing forall a b. (a -> b) -> a -> b
$ Task -> TaskConfigOpts
taskConfigOpts Task
task
data ExecuteEnv = ExecuteEnv
{ ExecuteEnv -> MVar ()
eeConfigureLock :: !(MVar ())
, ExecuteEnv -> MVar ()
eeInstallLock :: !(MVar ())
, ExecuteEnv -> BuildOpts
eeBuildOpts :: !BuildOpts
, ExecuteEnv -> BuildOptsCLI
eeBuildOptsCLI :: !BuildOptsCLI
, ExecuteEnv -> BaseConfigOpts
eeBaseConfigOpts :: !BaseConfigOpts
, ExecuteEnv -> TVar (Map PackageIdentifier Installed)
eeGhcPkgIds :: !(TVar (Map PackageIdentifier Installed))
, ExecuteEnv -> Path Abs Dir
eeTempDir :: !(Path Abs Dir)
, ExecuteEnv -> Path Abs File
eeSetupHs :: !(Path Abs File)
, ExecuteEnv -> Path Abs File
eeSetupShimHs :: !(Path Abs File)
, ExecuteEnv -> Maybe (Path Abs File)
eeSetupExe :: !(Maybe (Path Abs File))
, ExecuteEnv -> Version
eeCabalPkgVer :: !Version
, ExecuteEnv -> Int
eeTotalWanted :: !Int
, ExecuteEnv -> [LocalPackage]
eeLocals :: ![LocalPackage]
, ExecuteEnv -> Path Abs Dir
eeGlobalDB :: !(Path Abs Dir)
, ExecuteEnv -> Map GhcPkgId DumpPackage
eeGlobalDumpPkgs :: !(Map GhcPkgId DumpPackage)
, ExecuteEnv -> TVar (Map GhcPkgId DumpPackage)
eeSnapshotDumpPkgs :: !(TVar (Map GhcPkgId DumpPackage))
, ExecuteEnv -> TVar (Map GhcPkgId DumpPackage)
eeLocalDumpPkgs :: !(TVar (Map GhcPkgId DumpPackage))
, ExecuteEnv -> TChan (Path Abs Dir, Path Abs File)
eeLogFiles :: !(TChan (Path Abs Dir, Path Abs File))
, ExecuteEnv -> IORef (Set PackageName)
eeCustomBuilt :: !(IORef (Set PackageName))
, ExecuteEnv -> Maybe Int
eeLargestPackageName :: !(Maybe Int)
, ExecuteEnv -> Text
eePathEnvVar :: !Text
}
buildSetupArgs :: [String]
buildSetupArgs :: [[Char]]
buildSetupArgs =
[ [Char]
"-rtsopts"
, [Char]
"-threaded"
, [Char]
"-clear-package-db"
, [Char]
"-global-package-db"
, [Char]
"-hide-all-packages"
, [Char]
"-package"
, [Char]
"base"
, [Char]
"-main-is"
, [Char]
"StackSetupShim.mainOverride"
]
simpleSetupCode :: Builder
simpleSetupCode :: Builder
simpleSetupCode = Builder
"import Distribution.Simple\nmain = defaultMain"
simpleSetupHash :: String
simpleSetupHash :: [Char]
simpleSetupHash =
Text -> [Char]
T.unpack forall a b. (a -> b) -> a -> b
$ ByteString -> Text
decodeUtf8 forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
S.take Int
8 forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
B64URL.encode forall a b. (a -> b) -> a -> b
$ forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
Mem.convert forall a b. (a -> b) -> a -> b
$ forall ba alg.
(ByteArrayAccess ba, HashAlgorithm alg) =>
alg -> ba -> Digest alg
hashWith SHA256
SHA256 forall a b. (a -> b) -> a -> b
$
LByteString -> ByteString
toStrictBytes forall a b. (a -> b) -> a -> b
$
Builder -> LByteString
Data.ByteString.Builder.toLazyByteString forall a b. (a -> b) -> a -> b
$
Text -> Builder
encodeUtf8Builder ([Char] -> Text
T.pack ([[Char]] -> [Char]
unwords [[Char]]
buildSetupArgs)) forall a. Semigroup a => a -> a -> a
<> Builder
setupGhciShimCode forall a. Semigroup a => a -> a -> a
<> Builder
simpleSetupCode
getSetupExe :: HasEnvConfig env
=> Path Abs File
-> Path Abs File
-> Path Abs Dir
-> RIO env (Maybe (Path Abs File))
getSetupExe :: forall env.
HasEnvConfig env =>
Path Abs File
-> Path Abs File -> Path Abs Dir -> RIO env (Maybe (Path Abs File))
getSetupExe Path Abs File
setupHs Path Abs File
setupShimHs Path Abs Dir
tmpdir = do
WhichCompiler
wc <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasSourceMap env => SimpleGetter env ActualCompiler
actualCompilerVersionLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall r. Getting r ActualCompiler WhichCompiler
whichCompilerL
Path Rel Dir
platformDir <- forall env (m :: * -> *).
(MonadReader env m, HasEnvConfig env, MonadThrow m) =>
m (Path Rel Dir)
platformGhcRelDir
Config
config <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasConfig env => Lens' env Config
configL
[Char]
cabalVersionString <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasCompiler env => SimpleGetter env Version
cabalVersionLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to Version -> [Char]
versionString
[Char]
actualCompilerVersionString <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasSourceMap env => SimpleGetter env ActualCompiler
actualCompilerVersionLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to ActualCompiler -> [Char]
compilerVersionString
Platform
platform <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasPlatform env => Lens' env Platform
platformL
let baseNameS :: [Char]
baseNameS = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [Char]
"Cabal-simple_"
, [Char]
simpleSetupHash
, [Char]
"_"
, [Char]
cabalVersionString
, [Char]
"_"
, [Char]
actualCompilerVersionString
]
exeNameS :: [Char]
exeNameS = [Char]
baseNameS forall a. [a] -> [a] -> [a]
++
case Platform
platform of
Platform Arch
_ OS
Windows -> [Char]
".exe"
Platform
_ -> [Char]
""
outputNameS :: [Char]
outputNameS =
case WhichCompiler
wc of
WhichCompiler
Ghc -> [Char]
exeNameS
setupDir :: Path Abs Dir
setupDir =
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall s. HasConfig s => Lens' s (Path Abs Dir)
stackRootL Config
config forall b t. Path b Dir -> Path Rel t -> Path b t
</>
Path Rel Dir
relDirSetupExeCache forall b t. Path b Dir -> Path Rel t -> Path b t
</>
Path Rel Dir
platformDir
Path Abs File
exePath <- (Path Abs Dir
setupDir forall b t. Path b Dir -> Path Rel t -> Path b t
</>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadThrow m => [Char] -> m (Path Rel File)
parseRelFile [Char]
exeNameS
Bool
exists <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO Bool
D.doesFileExist forall a b. (a -> b) -> a -> b
$ forall b t. Path b t -> [Char]
toFilePath Path Abs File
exePath
if Bool
exists
then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Path Abs File
exePath
else do
Path Abs File
tmpExePath <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Path Abs Dir
setupDir forall b t. Path b Dir -> Path Rel t -> Path b t
</>) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadThrow m => [Char] -> m (Path Rel File)
parseRelFile forall a b. (a -> b) -> a -> b
$ [Char]
"tmp-" forall a. [a] -> [a] -> [a]
++ [Char]
exeNameS
Path Abs File
tmpOutputPath <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Path Abs Dir
setupDir forall b t. Path b Dir -> Path Rel t -> Path b t
</>) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadThrow m => [Char] -> m (Path Rel File)
parseRelFile forall a b. (a -> b) -> a -> b
$ [Char]
"tmp-" forall a. [a] -> [a] -> [a]
++ [Char]
outputNameS
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir Path Abs Dir
setupDir
let args :: [[Char]]
args = [[Char]]
buildSetupArgs forall a. [a] -> [a] -> [a]
++
[ [Char]
"-package"
, [Char]
"Cabal-" forall a. [a] -> [a] -> [a]
++ [Char]
cabalVersionString
, forall b t. Path b t -> [Char]
toFilePath Path Abs File
setupHs
, forall b t. Path b t -> [Char]
toFilePath Path Abs File
setupShimHs
, [Char]
"-o"
, forall b t. Path b t -> [Char]
toFilePath Path Abs File
tmpOutputPath
]
Path Abs File
compilerPath <- forall env. HasCompiler env => RIO env (Path Abs File)
getCompilerPath
forall env (m :: * -> *) a.
(HasProcessContext env, MonadReader env m, MonadIO m) =>
[Char] -> m a -> m a
withWorkingDir (forall b t. Path b t -> [Char]
toFilePath Path Abs Dir
tmpdir) forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *) a.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
MonadIO m, ?callStack::CallStack) =>
[Char] -> [[Char]] -> (ProcessConfig () () () -> m a) -> m a
proc (forall b t. Path b t -> [Char]
toFilePath Path Abs File
compilerPath) [[Char]]
args (\ProcessConfig () () ()
pc0 -> do
let pc :: ProcessConfig () () ()
pc = forall stdout stdin stdout0 stderr.
StreamSpec 'STOutput stdout
-> ProcessConfig stdin stdout0 stderr
-> ProcessConfig stdin stdout stderr
setStdout (forall (anyStreamType :: StreamType).
Handle -> StreamSpec anyStreamType ()
useHandleOpen Handle
stderr) ProcessConfig () () ()
pc0
forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
ProcessConfig stdin stdout stderr -> m ()
runProcess_ ProcessConfig () () ()
pc)
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \ExitCodeException
ece ->
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ forall e. (Exception e, Pretty e) => e -> PrettyException
PrettyException forall a b. (a -> b) -> a -> b
$
ExitCode
-> Maybe PackageIdentifier
-> Path Abs File
-> [[Char]]
-> Maybe (Path Abs File)
-> [Text]
-> BuildPrettyException
SetupHsBuildFailure
(ExitCodeException -> ExitCode
eceExitCode ExitCodeException
ece)
forall a. Maybe a
Nothing
Path Abs File
compilerPath
[[Char]]
args
forall a. Maybe a
Nothing
[]
forall (m :: * -> *) b0 b1.
MonadIO m =>
Path b0 File -> Path b1 File -> m ()
renameFile Path Abs File
tmpExePath Path Abs File
exePath
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Path Abs File
exePath
withExecuteEnv :: forall env a. HasEnvConfig env
=> BuildOpts
-> BuildOptsCLI
-> BaseConfigOpts
-> [LocalPackage]
-> [DumpPackage]
-> [DumpPackage]
-> [DumpPackage]
-> Maybe Int
-> (ExecuteEnv -> RIO env a)
-> RIO env a
withExecuteEnv :: forall env a.
HasEnvConfig env =>
BuildOpts
-> BuildOptsCLI
-> BaseConfigOpts
-> [LocalPackage]
-> [DumpPackage]
-> [DumpPackage]
-> [DumpPackage]
-> Maybe Int
-> (ExecuteEnv -> RIO env a)
-> RIO env a
withExecuteEnv BuildOpts
bopts BuildOptsCLI
boptsCli BaseConfigOpts
baseConfigOpts [LocalPackage]
locals [DumpPackage]
globalPackages [DumpPackage]
snapshotPackages [DumpPackage]
localPackages Maybe Int
mlargestPackageName ExecuteEnv -> RIO env a
inner =
[Char] -> (Path Abs Dir -> RIO env a) -> RIO env a
createTempDirFunction [Char]
stackProgName forall a b. (a -> b) -> a -> b
$ \Path Abs Dir
tmpdir -> do
MVar ()
configLock <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => a -> m (MVar a)
newMVar ()
MVar ()
installLock <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => a -> m (MVar a)
newMVar ()
TVar (Map PackageIdentifier Installed)
idMap <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO forall k a. Map k a
Map.empty
Config
config <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasConfig env => Lens' env Config
configL
IORef (Set PackageName)
customBuiltRef <- forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef forall a. Set a
Set.empty
let setupSrcDir :: Path Abs Dir
setupSrcDir =
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall s. HasConfig s => Lens' s (Path Abs Dir)
stackRootL Config
config forall b t. Path b Dir -> Path Rel t -> Path b t
</>
Path Rel Dir
relDirSetupExeSrc
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir Path Abs Dir
setupSrcDir
Path Rel File
setupFileName <- forall (m :: * -> *). MonadThrow m => [Char] -> m (Path Rel File)
parseRelFile ([Char]
"setup-" forall a. [a] -> [a] -> [a]
++ [Char]
simpleSetupHash forall a. [a] -> [a] -> [a]
++ [Char]
".hs")
let setupHs :: Path Abs File
setupHs = Path Abs Dir
setupSrcDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
setupFileName
Bool
setupHsExists <- forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
setupHs
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
setupHsExists forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) absrel.
MonadIO m =>
Path absrel File -> Builder -> m ()
writeBinaryFileAtomic Path Abs File
setupHs Builder
simpleSetupCode
Path Rel File
setupShimFileName <- forall (m :: * -> *). MonadThrow m => [Char] -> m (Path Rel File)
parseRelFile ([Char]
"setup-shim-" forall a. [a] -> [a] -> [a]
++ [Char]
simpleSetupHash forall a. [a] -> [a] -> [a]
++ [Char]
".hs")
let setupShimHs :: Path Abs File
setupShimHs = Path Abs Dir
setupSrcDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
setupShimFileName
Bool
setupShimHsExists <- forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
setupShimHs
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
setupShimHsExists forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) absrel.
MonadIO m =>
Path absrel File -> Builder -> m ()
writeBinaryFileAtomic Path Abs File
setupShimHs Builder
setupGhciShimCode
Maybe (Path Abs File)
setupExe <- forall env.
HasEnvConfig env =>
Path Abs File
-> Path Abs File -> Path Abs Dir -> RIO env (Maybe (Path Abs File))
getSetupExe Path Abs File
setupHs Path Abs File
setupShimHs Path Abs Dir
tmpdir
Version
cabalPkgVer <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasCompiler env => SimpleGetter env Version
cabalVersionL
Path Abs Dir
globalDB <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasCompiler env => SimpleGetter env CompilerPaths
compilerPathsLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to CompilerPaths -> Path Abs Dir
cpGlobalDB
TVar (Map GhcPkgId DumpPackage)
snapshotPackagesTVar <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO ([DumpPackage] -> Map GhcPkgId DumpPackage
toDumpPackagesByGhcPkgId [DumpPackage]
snapshotPackages)
TVar (Map GhcPkgId DumpPackage)
localPackagesTVar <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO ([DumpPackage] -> Map GhcPkgId DumpPackage
toDumpPackagesByGhcPkgId [DumpPackage]
localPackages)
TChan (Path Abs Dir, Path Abs File)
logFilesTChan <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall a. STM (TChan a)
newTChan
let totalWanted :: Int
totalWanted = forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter LocalPackage -> Bool
lpWanted [LocalPackage]
locals
Text
pathEnvVar <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty [Char] -> Text
T.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO (Maybe [Char])
lookupEnv [Char]
"PATH"
ExecuteEnv -> RIO env a
inner ExecuteEnv
{ eeBuildOpts :: BuildOpts
eeBuildOpts = BuildOpts
bopts
, eeBuildOptsCLI :: BuildOptsCLI
eeBuildOptsCLI = BuildOptsCLI
boptsCli
, eeConfigureLock :: MVar ()
eeConfigureLock = MVar ()
configLock
, eeInstallLock :: MVar ()
eeInstallLock = MVar ()
installLock
, eeBaseConfigOpts :: BaseConfigOpts
eeBaseConfigOpts = BaseConfigOpts
baseConfigOpts
, eeGhcPkgIds :: TVar (Map PackageIdentifier Installed)
eeGhcPkgIds = TVar (Map PackageIdentifier Installed)
idMap
, eeTempDir :: Path Abs Dir
eeTempDir = Path Abs Dir
tmpdir
, eeSetupHs :: Path Abs File
eeSetupHs = Path Abs File
setupHs
, eeSetupShimHs :: Path Abs File
eeSetupShimHs = Path Abs File
setupShimHs
, eeSetupExe :: Maybe (Path Abs File)
eeSetupExe = Maybe (Path Abs File)
setupExe
, eeCabalPkgVer :: Version
eeCabalPkgVer = Version
cabalPkgVer
, eeTotalWanted :: Int
eeTotalWanted = Int
totalWanted
, eeLocals :: [LocalPackage]
eeLocals = [LocalPackage]
locals
, eeGlobalDB :: Path Abs Dir
eeGlobalDB = Path Abs Dir
globalDB
, eeGlobalDumpPkgs :: Map GhcPkgId DumpPackage
eeGlobalDumpPkgs = [DumpPackage] -> Map GhcPkgId DumpPackage
toDumpPackagesByGhcPkgId [DumpPackage]
globalPackages
, eeSnapshotDumpPkgs :: TVar (Map GhcPkgId DumpPackage)
eeSnapshotDumpPkgs = TVar (Map GhcPkgId DumpPackage)
snapshotPackagesTVar
, eeLocalDumpPkgs :: TVar (Map GhcPkgId DumpPackage)
eeLocalDumpPkgs = TVar (Map GhcPkgId DumpPackage)
localPackagesTVar
, eeLogFiles :: TChan (Path Abs Dir, Path Abs File)
eeLogFiles = TChan (Path Abs Dir, Path Abs File)
logFilesTChan
, eeCustomBuilt :: IORef (Set PackageName)
eeCustomBuilt = IORef (Set PackageName)
customBuiltRef
, eeLargestPackageName :: Maybe Int
eeLargestPackageName = Maybe Int
mlargestPackageName
, eePathEnvVar :: Text
eePathEnvVar = Text
pathEnvVar
} forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
`finally` TChan (Path Abs Dir, Path Abs File) -> Int -> RIO env ()
dumpLogs TChan (Path Abs Dir, Path Abs File)
logFilesTChan Int
totalWanted
where
toDumpPackagesByGhcPkgId :: [DumpPackage] -> Map GhcPkgId DumpPackage
toDumpPackagesByGhcPkgId = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (\DumpPackage
dp -> (DumpPackage -> GhcPkgId
dpGhcPkgId DumpPackage
dp, DumpPackage
dp))
createTempDirFunction :: [Char] -> (Path Abs Dir -> RIO env a) -> RIO env a
createTempDirFunction
| BuildOpts -> Bool
boptsKeepTmpFiles BuildOpts
bopts = forall (m :: * -> *) a.
MonadUnliftIO m =>
[Char] -> (Path Abs Dir -> m a) -> m a
withKeepSystemTempDir
| Bool
otherwise = forall (m :: * -> *) a.
MonadUnliftIO m =>
[Char] -> (Path Abs Dir -> m a) -> m a
withSystemTempDir
dumpLogs :: TChan (Path Abs Dir, Path Abs File) -> Int -> RIO env ()
dumpLogs :: TChan (Path Abs Dir, Path Abs File) -> Int -> RIO env ()
dumpLogs TChan (Path Abs Dir, Path Abs File)
chan Int
totalWanted = do
[(Path Abs Dir, Path Abs File)]
allLogs <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically STM [(Path Abs Dir, Path Abs File)]
drainChan
case [(Path Abs Dir, Path Abs File)]
allLogs of
[] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
(Path Abs Dir, Path Abs File)
firstLog:[(Path Abs Dir, Path Abs File)]
_ -> do
DumpLogs
toDump <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasConfig env => Lens' env Config
configLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to Config -> DumpLogs
configDumpLogs
case DumpLogs
toDump of
DumpLogs
DumpAllLogs -> forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ([Char] -> (Path Abs Dir, Path Abs File) -> RIO env ()
dumpLog [Char]
"") [(Path Abs Dir, Path Abs File)]
allLogs
DumpLogs
DumpWarningLogs -> forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Path Abs Dir, Path Abs File) -> RIO env ()
dumpLogIfWarning [(Path Abs Dir, Path Abs File)]
allLogs
DumpLogs
DumpNoLogs
| Int
totalWanted forall a. Ord a => a -> a -> Bool
> Int
1 ->
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$
Utf8Builder
"Build output has been captured to log files, use " forall a. Semigroup a => a -> a -> a
<>
Utf8Builder
"--dump-logs to see it on the console"
| Bool
otherwise -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Log files have been written to: " forall a. Semigroup a => a -> a -> a
<>
forall a. IsString a => [Char] -> a
fromString (forall b t. Path b t -> [Char]
toFilePath (forall b t. Path b t -> Path b Dir
parent (forall a b. (a, b) -> b
snd (Path Abs Dir, Path Abs File)
firstLog)))
Bool
colors <- forall env. (HasRunner env, HasEnvConfig env) => RIO env Bool
shouldForceGhcColorFlag
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
colors forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Path Abs File -> IO ()
stripColors forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(Path Abs Dir, Path Abs File)]
allLogs
where
drainChan :: STM [(Path Abs Dir, Path Abs File)]
drainChan :: STM [(Path Abs Dir, Path Abs File)]
drainChan = do
Maybe (Path Abs Dir, Path Abs File)
mx <- forall a. TChan a -> STM (Maybe a)
tryReadTChan TChan (Path Abs Dir, Path Abs File)
chan
case Maybe (Path Abs Dir, Path Abs File)
mx of
Maybe (Path Abs Dir, Path Abs File)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure []
Just (Path Abs Dir, Path Abs File)
x -> do
[(Path Abs Dir, Path Abs File)]
xs <- STM [(Path Abs Dir, Path Abs File)]
drainChan
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ (Path Abs Dir, Path Abs File)
xforall a. a -> [a] -> [a]
:[(Path Abs Dir, Path Abs File)]
xs
dumpLogIfWarning :: (Path Abs Dir, Path Abs File) -> RIO env ()
dumpLogIfWarning :: (Path Abs Dir, Path Abs File) -> RIO env ()
dumpLogIfWarning (Path Abs Dir
pkgDir, Path Abs File
filepath) = do
[Text]
firstWarning <- forall (m :: * -> *) (n :: * -> *) i a.
(MonadUnliftIO m, MonadIO n) =>
[Char] -> (ConduitM i ByteString n () -> m a) -> m a
withSourceFile (forall b t. Path b t -> [Char]
toFilePath Path Abs File
filepath) forall a b. (a -> b) -> a -> b
$ \ConduitM () ByteString (RIO env) ()
src ->
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit
forall a b. (a -> b) -> a -> b
$ ConduitM () ByteString (RIO env) ()
src
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *). Monad m => ConduitT ByteString Text m ()
CT.decodeUtf8Lenient
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *). Monad m => ConduitT Text Text m ()
CT.lines
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) a b. Monad m => (a -> b) -> ConduitT a b m ()
CL.map Text -> Text
stripCR
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) a. Monad m => (a -> Bool) -> ConduitT a a m ()
CL.filter Text -> Bool
isWarning
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) a o. Monad m => Int -> ConduitT a o m [a]
CL.take Int
1
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
firstWarning) forall a b. (a -> b) -> a -> b
$ [Char] -> (Path Abs Dir, Path Abs File) -> RIO env ()
dumpLog [Char]
" due to warnings" (Path Abs Dir
pkgDir, Path Abs File
filepath)
isWarning :: Text -> Bool
isWarning :: Text -> Bool
isWarning Text
t = Text
": Warning:" Text -> Text -> Bool
`T.isSuffixOf` Text
t
Bool -> Bool -> Bool
|| Text
": warning:" Text -> Text -> Bool
`T.isInfixOf` Text
t
Bool -> Bool -> Bool
|| Text
"mwarning:" Text -> Text -> Bool
`T.isInfixOf` Text
t
dumpLog :: String -> (Path Abs Dir, Path Abs File) -> RIO env ()
dumpLog :: [Char] -> (Path Abs Dir, Path Abs File) -> RIO env ()
dumpLog [Char]
msgSuffix (Path Abs Dir
pkgDir, Path Abs File
filepath) = do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$
Utf8Builder
"\n-- Dumping log file" forall a. Semigroup a => a -> a -> a
<>
forall a. IsString a => [Char] -> a
fromString [Char]
msgSuffix forall a. Semigroup a => a -> a -> a
<>
Utf8Builder
": " forall a. Semigroup a => a -> a -> a
<>
forall a. IsString a => [Char] -> a
fromString (forall b t. Path b t -> [Char]
toFilePath Path Abs File
filepath) forall a. Semigroup a => a -> a -> a
<>
Utf8Builder
"\n"
ActualCompiler
compilerVer <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasSourceMap env => SimpleGetter env ActualCompiler
actualCompilerVersionL
forall (m :: * -> *) (n :: * -> *) i a.
(MonadUnliftIO m, MonadIO n) =>
[Char] -> (ConduitM i ByteString n () -> m a) -> m a
withSourceFile (forall b t. Path b t -> [Char]
toFilePath Path Abs File
filepath) forall a b. (a -> b) -> a -> b
$ \ConduitM () ByteString (RIO env) ()
src ->
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit
forall a b. (a -> b) -> a -> b
$ ConduitM () ByteString (RIO env) ()
src
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *). Monad m => ConduitT ByteString Text m ()
CT.decodeUtf8Lenient
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *).
MonadIO m =>
ExcludeTHLoading
-> ConvertPathsToAbsolute
-> Path Abs Dir
-> ActualCompiler
-> ConduitM Text Text m ()
mungeBuildOutput ExcludeTHLoading
ExcludeTHLoading ConvertPathsToAbsolute
ConvertPathsToAbsolute Path Abs Dir
pkgDir ActualCompiler
compilerVer
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) a o.
Monad m =>
(a -> m ()) -> ConduitT a o m ()
CL.mapM_ (forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logInfo forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Display a => a -> Utf8Builder
display)
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Utf8Builder
"\n-- End of log file: " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (forall b t. Path b t -> [Char]
toFilePath Path Abs File
filepath) forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"\n"
stripColors :: Path Abs File -> IO ()
stripColors :: Path Abs File -> IO ()
stripColors Path Abs File
fp = do
let colorfp :: [Char]
colorfp = forall b t. Path b t -> [Char]
toFilePath Path Abs File
fp forall a. [a] -> [a] -> [a]
++ [Char]
"-color"
forall (m :: * -> *) (n :: * -> *) i a.
(MonadUnliftIO m, MonadIO n) =>
[Char] -> (ConduitM i ByteString n () -> m a) -> m a
withSourceFile (forall b t. Path b t -> [Char]
toFilePath Path Abs File
fp) forall a b. (a -> b) -> a -> b
$ \ConduitM () ByteString IO ()
src ->
forall (m :: * -> *) (n :: * -> *) o a.
(MonadUnliftIO m, MonadIO n) =>
[Char] -> (ConduitM ByteString o n () -> m a) -> m a
withSinkFile [Char]
colorfp forall a b. (a -> b) -> a -> b
$ \ConduitM ByteString Void IO ()
sink ->
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit forall a b. (a -> b) -> a -> b
$ ConduitM () ByteString IO ()
src forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitM ByteString Void IO ()
sink
forall (m :: * -> *) (n :: * -> *) i a.
(MonadUnliftIO m, MonadIO n) =>
[Char] -> (ConduitM i ByteString n () -> m a) -> m a
withSourceFile [Char]
colorfp forall a b. (a -> b) -> a -> b
$ \ConduitM () ByteString IO ()
src ->
forall (m :: * -> *) (n :: * -> *) o a.
(MonadUnliftIO m, MonadIO n) =>
[Char] -> (ConduitM ByteString o n () -> m a) -> m a
withSinkFile (forall b t. Path b t -> [Char]
toFilePath Path Abs File
fp) forall a b. (a -> b) -> a -> b
$ \ConduitM ByteString Void IO ()
sink ->
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit forall a b. (a -> b) -> a -> b
$ ConduitM () ByteString IO ()
src forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT ByteString ByteString IO ()
noColors forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitM ByteString Void IO ()
sink
where
noColors :: ConduitT ByteString ByteString IO ()
noColors = do
forall (m :: * -> *).
Monad m =>
(Word8 -> Bool) -> ConduitT ByteString ByteString m ()
CB.takeWhile (forall a. Eq a => a -> a -> Bool
/= Word8
27)
Maybe Word8
mnext <- forall (m :: * -> *) o.
Monad m =>
ConduitT ByteString o m (Maybe Word8)
CB.head
case Maybe Word8
mnext of
Maybe Word8
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Just Word8
x -> forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Word8
x forall a. Eq a => a -> a -> Bool
== Word8
27) forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *) o.
Monad m =>
(Word8 -> Bool) -> ConduitT ByteString o m ()
CB.dropWhile (forall a. Eq a => a -> a -> Bool
/= Word8
109)
forall (m :: * -> *) o.
Monad m =>
Int -> ConduitT ByteString o m ()
CB.drop Int
1
ConduitT ByteString ByteString IO ()
noColors
executePlan :: HasEnvConfig env
=> BuildOptsCLI
-> BaseConfigOpts
-> [LocalPackage]
-> [DumpPackage]
-> [DumpPackage]
-> [DumpPackage]
-> InstalledMap
-> Map PackageName Target
-> Plan
-> RIO env ()
executePlan :: forall env.
HasEnvConfig env =>
BuildOptsCLI
-> BaseConfigOpts
-> [LocalPackage]
-> [DumpPackage]
-> [DumpPackage]
-> [DumpPackage]
-> InstalledMap
-> Map PackageName Target
-> Plan
-> RIO env ()
executePlan BuildOptsCLI
boptsCli BaseConfigOpts
baseConfigOpts [LocalPackage]
locals [DumpPackage]
globalPackages [DumpPackage]
snapshotPackages [DumpPackage]
localPackages InstalledMap
installedMap Map PackageName Target
targets Plan
plan = do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Executing the build plan"
BuildOpts
bopts <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall s. HasConfig s => Lens' s BuildOpts
buildOptsL
forall env a.
HasEnvConfig env =>
BuildOpts
-> BuildOptsCLI
-> BaseConfigOpts
-> [LocalPackage]
-> [DumpPackage]
-> [DumpPackage]
-> [DumpPackage]
-> Maybe Int
-> (ExecuteEnv -> RIO env a)
-> RIO env a
withExecuteEnv BuildOpts
bopts BuildOptsCLI
boptsCli BaseConfigOpts
baseConfigOpts [LocalPackage]
locals [DumpPackage]
globalPackages [DumpPackage]
snapshotPackages [DumpPackage]
localPackages Maybe Int
mlargestPackageName
(forall env.
HasEnvConfig env =>
InstalledMap
-> Map PackageName Target -> Plan -> ExecuteEnv -> RIO env ()
executePlan' InstalledMap
installedMap Map PackageName Target
targets Plan
plan)
forall env.
HasEnvConfig env =>
Map Text InstallLocation -> RIO env ()
copyExecutables (Plan -> Map Text InstallLocation
planInstallExes Plan
plan)
Config
config <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasConfig env => Lens' env Config
configL
ProcessContext
menv' <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Config -> EnvSettings -> IO ProcessContext
configProcessContextSettings Config
config EnvSettings
{ esIncludeLocals :: Bool
esIncludeLocals = Bool
True
, esIncludeGhcPackagePath :: Bool
esIncludeGhcPackagePath = Bool
True
, esStackExe :: Bool
esStackExe = Bool
True
, esLocaleUtf8 :: Bool
esLocaleUtf8 = Bool
False
, esKeepGhcRts :: Bool
esKeepGhcRts = Bool
False
}
forall env a.
HasProcessContext env =>
ProcessContext -> RIO env a -> RIO env a
withProcessContext ProcessContext
menv' forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (BuildOptsCLI -> [([Char], [[Char]])]
boptsCLIExec BuildOptsCLI
boptsCli) forall a b. (a -> b) -> a -> b
$ \([Char]
cmd, [[Char]]
args) ->
forall env (m :: * -> *) a.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
MonadIO m, ?callStack::CallStack) =>
[Char] -> [[Char]] -> (ProcessConfig () () () -> m a) -> m a
proc [Char]
cmd [[Char]]
args forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
ProcessConfig stdin stdout stderr -> m ()
runProcess_
where
mlargestPackageName :: Maybe Int
mlargestPackageName =
forall a. Set a -> Maybe a
Set.lookupMax forall a b. (a -> b) -> a -> b
$
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (forall (t :: * -> *) a. Foldable t => t a -> Int
length forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> [Char]
packageNameString) forall a b. (a -> b) -> a -> b
$
forall k a. Map k a -> Set k
Map.keysSet (Plan -> Map PackageName Task
planTasks Plan
plan) forall a. Semigroup a => a -> a -> a
<> forall k a. Map k a -> Set k
Map.keysSet (Plan -> Map PackageName Task
planFinals Plan
plan)
copyExecutables ::
HasEnvConfig env
=> Map Text InstallLocation
-> RIO env ()
copyExecutables :: forall env.
HasEnvConfig env =>
Map Text InstallLocation -> RIO env ()
copyExecutables Map Text InstallLocation
exes | forall k a. Map k a -> Bool
Map.null Map Text InstallLocation
exes = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
copyExecutables Map Text InstallLocation
exes = do
Path Abs Dir
snapBin <- (forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
bindirSuffix) forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` forall env. HasEnvConfig env => RIO env (Path Abs Dir)
installationRootDeps
Path Abs Dir
localBin <- (forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
bindirSuffix) forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` forall env. HasEnvConfig env => RIO env (Path Abs Dir)
installationRootLocal
Bool
compilerSpecific <- BuildOpts -> Bool
boptsInstallCompilerTool forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall s. HasConfig s => Lens' s BuildOpts
buildOptsL
Path Abs Dir
destDir <- if Bool
compilerSpecific
then forall (m :: * -> *) env.
(MonadThrow m, MonadReader env m, HasEnvConfig env) =>
m (Path Abs Dir)
bindirCompilerTools
else forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasConfig env => Lens' env Config
configLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to Config -> Path Abs Dir
configLocalBin
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir Path Abs Dir
destDir
[Char]
destDir' <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> IO [Char]
D.canonicalizePath forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b t. Path b t -> [Char]
toFilePath forall a b. (a -> b) -> a -> b
$ Path Abs Dir
destDir
Platform
platform <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasPlatform env => Lens' env Platform
platformL
let ext :: [Char]
ext =
case Platform
platform of
Platform Arch
_ OS
Windows -> [Char]
".exe"
Platform
_ -> [Char]
""
[Char]
currExe <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [Char]
getExecutablePath
[Text]
installed <- forall (m :: * -> *) a b.
Monad m =>
[a] -> (a -> m (Maybe b)) -> m [b]
forMaybeM (forall k a. Map k a -> [(k, a)]
Map.toList Map Text InstallLocation
exes) forall a b. (a -> b) -> a -> b
$ \(Text
name, InstallLocation
loc) -> do
let bindir :: Path Abs Dir
bindir =
case InstallLocation
loc of
InstallLocation
Snap -> Path Abs Dir
snapBin
InstallLocation
Local -> Path Abs Dir
localBin
Maybe (Path Abs File)
mfp <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(MonadIO m, MonadCatch m) =>
m a -> m (Maybe a)
forgivingAbsence (forall (m :: * -> *).
MonadIO m =>
Path Abs Dir -> [Char] -> m (Path Abs File)
resolveFile Path Abs Dir
bindir forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
name forall a. [a] -> [a] -> [a]
++ [Char]
ext)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *).
MonadIO m =>
Maybe (Path Abs File) -> m (Maybe (Path Abs File))
rejectMissingFile
case Maybe (Path Abs File)
mfp of
Maybe (Path Abs File)
Nothing -> do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$
Utf8Builder
"Couldn't find executable " forall a. Semigroup a => a -> a -> a
<>
forall a. Display a => a -> Utf8Builder
display Text
name forall a. Semigroup a => a -> a -> a
<>
Utf8Builder
" in directory " forall a. Semigroup a => a -> a -> a
<>
forall a. IsString a => [Char] -> a
fromString (forall b t. Path b t -> [Char]
toFilePath Path Abs Dir
bindir)
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
Just Path Abs File
file -> do
let destFile :: [Char]
destFile = [Char]
destDir' [Char] -> ShowS
FP.</> Text -> [Char]
T.unpack Text
name forall a. [a] -> [a] -> [a]
++ [Char]
ext
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$
Utf8Builder
"Copying from " forall a. Semigroup a => a -> a -> a
<>
forall a. IsString a => [Char] -> a
fromString (forall b t. Path b t -> [Char]
toFilePath Path Abs File
file) forall a. Semigroup a => a -> a -> a
<>
Utf8Builder
" to " forall a. Semigroup a => a -> a -> a
<>
forall a. IsString a => [Char] -> a
fromString [Char]
destFile
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ case Platform
platform of
Platform Arch
_ OS
Windows | [Char] -> [Char] -> Bool
FP.equalFilePath [Char]
destFile [Char]
currExe ->
[Char] -> [Char] -> IO ()
windowsRenameCopy (forall b t. Path b t -> [Char]
toFilePath Path Abs File
file) [Char]
destFile
Platform
_ -> [Char] -> [Char] -> IO ()
D.copyFile (forall b t. Path b t -> [Char]
toFilePath Path Abs File
file) [Char]
destFile
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (Text
name forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack [Char]
ext)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
installed) forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
""
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$
Utf8Builder
"Copied executables to " forall a. Semigroup a => a -> a -> a
<>
forall a. IsString a => [Char] -> a
fromString [Char]
destDir' forall a. Semigroup a => a -> a -> a
<>
Utf8Builder
":"
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Text]
installed forall a b. (a -> b) -> a -> b
$ \Text
exe -> forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder
"- " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Text
exe)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
compilerSpecific forall a b. (a -> b) -> a -> b
$ forall env. HasConfig env => [Char] -> [Text] -> RIO env ()
warnInstallSearchPathIssues [Char]
destDir' [Text]
installed
windowsRenameCopy :: FilePath -> FilePath -> IO ()
windowsRenameCopy :: [Char] -> [Char] -> IO ()
windowsRenameCopy [Char]
src [Char]
dest = do
[Char] -> [Char] -> IO ()
D.copyFile [Char]
src [Char]
new
[Char] -> [Char] -> IO ()
D.renameFile [Char]
dest [Char]
old
[Char] -> [Char] -> IO ()
D.renameFile [Char]
new [Char]
dest
where
new :: [Char]
new = [Char]
dest forall a. [a] -> [a] -> [a]
++ [Char]
".new"
old :: [Char]
old = [Char]
dest forall a. [a] -> [a] -> [a]
++ [Char]
".old"
executePlan' :: HasEnvConfig env
=> InstalledMap
-> Map PackageName Target
-> Plan
-> ExecuteEnv
-> RIO env ()
executePlan' :: forall env.
HasEnvConfig env =>
InstalledMap
-> Map PackageName Target -> Plan -> ExecuteEnv -> RIO env ()
executePlan' InstalledMap
installedMap0 Map PackageName Target
targets Plan
plan ee :: ExecuteEnv
ee@ExecuteEnv {Int
[LocalPackage]
Maybe Int
Maybe (Path Abs File)
MVar ()
Version
Map GhcPkgId DumpPackage
Text
TVar (Map PackageIdentifier Installed)
TVar (Map GhcPkgId DumpPackage)
IORef (Set PackageName)
Path Abs File
Path Abs Dir
TChan (Path Abs Dir, Path Abs File)
BuildOptsCLI
BuildOpts
BaseConfigOpts
eePathEnvVar :: Text
eeLargestPackageName :: Maybe Int
eeCustomBuilt :: IORef (Set PackageName)
eeLogFiles :: TChan (Path Abs Dir, Path Abs File)
eeLocalDumpPkgs :: TVar (Map GhcPkgId DumpPackage)
eeSnapshotDumpPkgs :: TVar (Map GhcPkgId DumpPackage)
eeGlobalDumpPkgs :: Map GhcPkgId DumpPackage
eeGlobalDB :: Path Abs Dir
eeLocals :: [LocalPackage]
eeTotalWanted :: Int
eeCabalPkgVer :: Version
eeSetupExe :: Maybe (Path Abs File)
eeSetupShimHs :: Path Abs File
eeSetupHs :: Path Abs File
eeTempDir :: Path Abs Dir
eeGhcPkgIds :: TVar (Map PackageIdentifier Installed)
eeBaseConfigOpts :: BaseConfigOpts
eeBuildOptsCLI :: BuildOptsCLI
eeBuildOpts :: BuildOpts
eeInstallLock :: MVar ()
eeConfigureLock :: MVar ()
eePathEnvVar :: ExecuteEnv -> Text
eeLargestPackageName :: ExecuteEnv -> Maybe Int
eeCustomBuilt :: ExecuteEnv -> IORef (Set PackageName)
eeLogFiles :: ExecuteEnv -> TChan (Path Abs Dir, Path Abs File)
eeLocalDumpPkgs :: ExecuteEnv -> TVar (Map GhcPkgId DumpPackage)
eeSnapshotDumpPkgs :: ExecuteEnv -> TVar (Map GhcPkgId DumpPackage)
eeGlobalDumpPkgs :: ExecuteEnv -> Map GhcPkgId DumpPackage
eeGlobalDB :: ExecuteEnv -> Path Abs Dir
eeLocals :: ExecuteEnv -> [LocalPackage]
eeTotalWanted :: ExecuteEnv -> Int
eeCabalPkgVer :: ExecuteEnv -> Version
eeSetupExe :: ExecuteEnv -> Maybe (Path Abs File)
eeSetupShimHs :: ExecuteEnv -> Path Abs File
eeSetupHs :: ExecuteEnv -> Path Abs File
eeTempDir :: ExecuteEnv -> Path Abs Dir
eeGhcPkgIds :: ExecuteEnv -> TVar (Map PackageIdentifier Installed)
eeBaseConfigOpts :: ExecuteEnv -> BaseConfigOpts
eeBuildOptsCLI :: ExecuteEnv -> BuildOptsCLI
eeBuildOpts :: ExecuteEnv -> BuildOpts
eeInstallLock :: ExecuteEnv -> MVar ()
eeConfigureLock :: ExecuteEnv -> MVar ()
..} = do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TestOpts -> Bool
toCoverage forall a b. (a -> b) -> a -> b
$ BuildOpts -> TestOpts
boptsTestOpts BuildOpts
eeBuildOpts) forall env. HasEnvConfig env => RIO env ()
deleteHpcReports
ActualCompiler
cv <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasSourceMap env => SimpleGetter env ActualCompiler
actualCompilerVersionL
case forall a. [a] -> Maybe (NonEmpty a)
nonEmpty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
Map.toList forall a b. (a -> b) -> a -> b
$ Plan -> Map GhcPkgId (PackageIdentifier, Text)
planUnregisterLocal Plan
plan of
Maybe (NonEmpty (GhcPkgId, (PackageIdentifier, Text)))
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Just NonEmpty (GhcPkgId, (PackageIdentifier, Text))
ids -> do
Path Abs Dir
localDB <- forall env. HasEnvConfig env => RIO env (Path Abs Dir)
packageDatabaseLocal
forall env.
(HasProcessContext env, HasLogFunc env, HasPlatform env,
HasCompiler env) =>
ActualCompiler
-> Path Abs Dir
-> NonEmpty (GhcPkgId, (PackageIdentifier, Text))
-> RIO env ()
unregisterPackages ActualCompiler
cv Path Abs Dir
localDB NonEmpty (GhcPkgId, (PackageIdentifier, Text))
ids
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar (Map GhcPkgId DumpPackage)
eeLocalDumpPkgs forall a b. (a -> b) -> a -> b
$ \Map GhcPkgId DumpPackage
initMap ->
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall k a. Ord k => k -> Map k a -> Map k a
Map.delete) Map GhcPkgId DumpPackage
initMap forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [k]
Map.keys (Plan -> Map GhcPkgId (PackageIdentifier, Text)
planUnregisterLocal Plan
plan)
RIO env () -> IO ()
run <- forall (m :: * -> *) a. MonadUnliftIO m => m (m a -> IO a)
askRunInIO
Bool
concurrentTests <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasConfig env => Lens' env Config
configLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to Config -> Bool
configConcurrentTests
Maybe (MVar ())
mtestLock <- if Bool
concurrentTests then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall (m :: * -> *) a. MonadIO m => a -> m (MVar a)
newMVar ())
let actions :: [Action]
actions = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall env.
HasEnvConfig env =>
InstalledMap
-> Maybe (MVar ())
-> (RIO env () -> IO ())
-> ExecuteEnv
-> (Maybe Task, Maybe Task)
-> [Action]
toActions InstalledMap
installedMap' Maybe (MVar ())
mtestLock RIO env () -> IO ()
run ExecuteEnv
ee) forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [a]
Map.elems forall a b. (a -> b) -> a -> b
$ forall k a b c.
Ord k =>
(k -> a -> b -> Maybe c)
-> (Map k a -> Map k c)
-> (Map k b -> Map k c)
-> Map k a
-> Map k b
-> Map k c
Map.mergeWithKey
(\PackageName
_ Task
b Task
f -> forall a. a -> Maybe a
Just (forall a. a -> Maybe a
Just Task
b, forall a. a -> Maybe a
Just Task
f))
(forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Task
b -> (forall a. a -> Maybe a
Just Task
b, forall a. Maybe a
Nothing)))
(forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Task
f -> (forall a. Maybe a
Nothing, forall a. a -> Maybe a
Just Task
f)))
(Plan -> Map PackageName Task
planTasks Plan
plan)
(Plan -> Map PackageName Task
planFinals Plan
plan)
Int
threads <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasConfig env => Lens' env Config
configLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to Config -> Int
configJobs
let keepGoing :: Bool
keepGoing =
forall a. a -> Maybe a -> a
fromMaybe (Bool -> Bool
not (forall k a. Map k a -> Bool
M.null (Plan -> Map PackageName Task
planFinals Plan
plan))) (BuildOpts -> Maybe Bool
boptsKeepGoing BuildOpts
eeBuildOpts)
Bool
terminal <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasRunner env => Lens' env Bool
terminalL
[SomeException]
errs <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Int
-> Bool
-> [Action]
-> (TVar Int -> TVar (Set ActionId) -> IO ())
-> IO [SomeException]
runActions Int
threads Bool
keepGoing [Action]
actions forall a b. (a -> b) -> a -> b
$ \TVar Int
doneVar TVar (Set ActionId)
actionsVar -> do
let total :: Int
total = forall (t :: * -> *) a. Foldable t => t a -> Int
length [Action]
actions
loop :: Int -> IO ()
loop Int
prev
| Int
prev forall a. Eq a => a -> a -> Bool
== Int
total =
RIO env () -> IO ()
run forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) env.
(MonadIO m, ?callStack::CallStack, MonadReader env m,
HasLogFunc env) =>
Utf8Builder -> m ()
logStickyDone (Utf8Builder
"Completed " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Int
total forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" action(s).")
| Bool
otherwise = do
Set ActionId
inProgress <- forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar (Set ActionId)
actionsVar
let packageNames :: [PackageName]
packageNames = forall a b. (a -> b) -> [a] -> [b]
map (\(ActionId PackageIdentifier
pkgID ActionType
_) -> PackageIdentifier -> PackageName
pkgName PackageIdentifier
pkgID) (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Set ActionId
inProgress)
nowBuilding :: [PackageName] -> Utf8Builder
nowBuilding :: [PackageName] -> Utf8Builder
nowBuilding [] = Utf8Builder
""
nowBuilding [PackageName]
names = forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ Utf8Builder
": " forall a. a -> [a] -> [a]
: forall a. a -> [a] -> [a]
L.intersperse Utf8Builder
", " (forall a b. (a -> b) -> [a] -> [b]
map (forall a. IsString a => [Char] -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> [Char]
packageNameString) [PackageName]
names)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
terminal forall a b. (a -> b) -> a -> b
$ RIO env () -> IO ()
run forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) env.
(MonadIO m, ?callStack::CallStack, MonadReader env m,
HasLogFunc env) =>
Utf8Builder -> m ()
logSticky forall a b. (a -> b) -> a -> b
$
Utf8Builder
"Progress " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Int
prev forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"/" forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Int
total forall a. Semigroup a => a -> a -> a
<>
[PackageName] -> Utf8Builder
nowBuilding [PackageName]
packageNames
Int
done <- forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$ do
Int
done <- forall a. TVar a -> STM a
readTVar TVar Int
doneVar
Bool -> STM ()
check forall a b. (a -> b) -> a -> b
$ Int
done forall a. Eq a => a -> a -> Bool
/= Int
prev
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
done
Int -> IO ()
loop Int
done
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
total forall a. Ord a => a -> a -> Bool
> Int
1) forall a b. (a -> b) -> a -> b
$ Int -> IO ()
loop Int
0
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TestOpts -> Bool
toCoverage forall a b. (a -> b) -> a -> b
$ BuildOpts -> TestOpts
boptsTestOpts BuildOpts
eeBuildOpts) forall a b. (a -> b) -> a -> b
$ do
forall env. HasEnvConfig env => RIO env ()
generateHpcUnifiedReport
forall env. HasEnvConfig env => RIO env ()
generateHpcMarkupIndex
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SomeException]
errs) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ forall e. (Exception e, Pretty e) => e -> PrettyException
PrettyException ([SomeException] -> BuildPrettyException
ExecutionFailure [SomeException]
errs)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (BuildOpts -> Bool
boptsHaddock BuildOpts
eeBuildOpts) forall a b. (a -> b) -> a -> b
$ do
Map GhcPkgId DumpPackage
snapshotDumpPkgs <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar (Map GhcPkgId DumpPackage)
eeSnapshotDumpPkgs)
Map GhcPkgId DumpPackage
localDumpPkgs <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar (Map GhcPkgId DumpPackage)
eeLocalDumpPkgs)
forall env.
(HasProcessContext env, HasLogFunc env, HasCompiler env) =>
BaseConfigOpts
-> Map GhcPkgId DumpPackage -> [LocalPackage] -> RIO env ()
generateLocalHaddockIndex BaseConfigOpts
eeBaseConfigOpts Map GhcPkgId DumpPackage
localDumpPkgs [LocalPackage]
eeLocals
forall env.
(HasProcessContext env, HasLogFunc env, HasCompiler env) =>
BaseConfigOpts
-> Map GhcPkgId DumpPackage
-> Map GhcPkgId DumpPackage
-> Map GhcPkgId DumpPackage
-> [LocalPackage]
-> RIO env ()
generateDepsHaddockIndex BaseConfigOpts
eeBaseConfigOpts Map GhcPkgId DumpPackage
eeGlobalDumpPkgs Map GhcPkgId DumpPackage
snapshotDumpPkgs Map GhcPkgId DumpPackage
localDumpPkgs [LocalPackage]
eeLocals
forall env.
(HasProcessContext env, HasLogFunc env, HasCompiler env) =>
BaseConfigOpts
-> Map GhcPkgId DumpPackage
-> Map GhcPkgId DumpPackage
-> RIO env ()
generateSnapHaddockIndex BaseConfigOpts
eeBaseConfigOpts Map GhcPkgId DumpPackage
eeGlobalDumpPkgs Map GhcPkgId DumpPackage
snapshotDumpPkgs
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (BuildOpts -> Bool
boptsOpenHaddocks BuildOpts
eeBuildOpts) forall a b. (a -> b) -> a -> b
$ do
let planPkgs, localPkgs, installedPkgs, availablePkgs
:: Map PackageName (PackageIdentifier, InstallLocation)
planPkgs :: Map PackageName (PackageIdentifier, InstallLocation)
planPkgs = forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (Task -> PackageIdentifier
taskProvides forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Task -> InstallLocation
taskLocation) (Plan -> Map PackageName Task
planTasks Plan
plan)
localPkgs :: Map PackageName (PackageIdentifier, InstallLocation)
localPkgs =
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
[(Package -> PackageName
packageName Package
p, (Package -> PackageIdentifier
packageIdentifier Package
p, InstallLocation
Local)) | Package
p <- forall a b. (a -> b) -> [a] -> [b]
map LocalPackage -> Package
lpPackage [LocalPackage]
eeLocals]
installedPkgs :: Map PackageName (PackageIdentifier, InstallLocation)
installedPkgs = forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (forall a b. (a, b) -> (b, a)
swap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Installed -> PackageIdentifier
installedPackageIdentifier) InstalledMap
installedMap'
availablePkgs :: Map PackageName (PackageIdentifier, InstallLocation)
availablePkgs = forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions [Map PackageName (PackageIdentifier, InstallLocation)
planPkgs, Map PackageName (PackageIdentifier, InstallLocation)
localPkgs, Map PackageName (PackageIdentifier, InstallLocation)
installedPkgs]
forall env.
HasTerm env =>
BaseConfigOpts
-> Map PackageName (PackageIdentifier, InstallLocation)
-> Set PackageName
-> RIO env ()
openHaddocksInBrowser BaseConfigOpts
eeBaseConfigOpts Map PackageName (PackageIdentifier, InstallLocation)
availablePkgs (forall k a. Map k a -> Set k
Map.keysSet Map PackageName Target
targets)
where
installedMap' :: InstalledMap
installedMap' = forall k a b. Ord k => Map k a -> Map k b -> Map k a
Map.difference InstalledMap
installedMap0
forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\(PackageIdentifier
ident, Text
_) -> (PackageIdentifier -> PackageName
pkgName PackageIdentifier
ident, ()))
forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [a]
Map.elems
forall a b. (a -> b) -> a -> b
$ Plan -> Map GhcPkgId (PackageIdentifier, Text)
planUnregisterLocal Plan
plan
unregisterPackages ::
(HasProcessContext env, HasLogFunc env, HasPlatform env, HasCompiler env)
=> ActualCompiler
-> Path Abs Dir
-> NonEmpty (GhcPkgId, (PackageIdentifier, Text))
-> RIO env ()
unregisterPackages :: forall env.
(HasProcessContext env, HasLogFunc env, HasPlatform env,
HasCompiler env) =>
ActualCompiler
-> Path Abs Dir
-> NonEmpty (GhcPkgId, (PackageIdentifier, Text))
-> RIO env ()
unregisterPackages ActualCompiler
cv Path Abs Dir
localDB NonEmpty (GhcPkgId, (PackageIdentifier, Text))
ids = do
let logReason :: PackageIdentifier -> Text -> m ()
logReason PackageIdentifier
ident Text
reason =
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$
forall a. IsString a => [Char] -> a
fromString (PackageIdentifier -> [Char]
packageIdentifierString PackageIdentifier
ident) forall a. Semigroup a => a -> a -> a
<> Utf8Builder
": unregistering" forall a. Semigroup a => a -> a -> a
<>
if Text -> Bool
T.null Text
reason
then Utf8Builder
""
else Utf8Builder
" (" forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Text
reason forall a. Semigroup a => a -> a -> a
<> Utf8Builder
")"
let unregisterSinglePkg :: (PackageIdentifier
-> GhcPkgId -> Either PackageIdentifier GhcPkgId)
-> (GhcPkgId, (PackageIdentifier, Text)) -> RIO env ()
unregisterSinglePkg PackageIdentifier -> GhcPkgId -> Either PackageIdentifier GhcPkgId
select (GhcPkgId
gid, (PackageIdentifier
ident, Text
reason)) = do
forall {m :: * -> *} {env}.
(MonadIO m, MonadReader env m, HasLogFunc env) =>
PackageIdentifier -> Text -> m ()
logReason PackageIdentifier
ident Text
reason
GhcPkgExe
pkg <- forall env. HasCompiler env => RIO env GhcPkgExe
getGhcPkgExe
forall env.
(HasProcessContext env, HasLogFunc env) =>
GhcPkgExe
-> Path Abs Dir
-> NonEmpty (Either PackageIdentifier GhcPkgId)
-> RIO env ()
unregisterGhcPkgIds GhcPkgExe
pkg Path Abs Dir
localDB forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> GhcPkgId -> Either PackageIdentifier GhcPkgId
select PackageIdentifier
ident GhcPkgId
gid forall a. a -> [a] -> NonEmpty a
:| []
case ActualCompiler
cv of
ACGhc Version
v | Version
v forall a. Ord a => a -> a -> Bool
>= [Int] -> Version
mkVersion [Int
8, Int
2, Int
1] -> do
Platform
platform <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasPlatform env => Lens' env Platform
platformL
let batchSize :: Int
batchSize = case Platform
platform of
Platform Arch
_ OS
Windows -> Int
100
Platform
_ -> Int
500
let chunksOfNE :: Int -> NonEmpty a -> [NonEmpty a]
chunksOfNE Int
size = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall a. [a] -> Maybe (NonEmpty a)
nonEmpty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Int -> [e] -> [[e]]
chunksOf Int
size forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NonEmpty a -> [a]
NonEmpty.toList
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (forall {a}. Int -> NonEmpty a -> [NonEmpty a]
chunksOfNE Int
batchSize NonEmpty (GhcPkgId, (PackageIdentifier, Text))
ids) forall a b. (a -> b) -> a -> b
$ \NonEmpty (GhcPkgId, (PackageIdentifier, Text))
batch -> do
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ NonEmpty (GhcPkgId, (PackageIdentifier, Text))
batch forall a b. (a -> b) -> a -> b
$ \(GhcPkgId
_, (PackageIdentifier
ident, Text
reason)) -> forall {m :: * -> *} {env}.
(MonadIO m, MonadReader env m, HasLogFunc env) =>
PackageIdentifier -> Text -> m ()
logReason PackageIdentifier
ident Text
reason
GhcPkgExe
pkg <- forall env. HasCompiler env => RIO env GhcPkgExe
getGhcPkgExe
forall env.
(HasProcessContext env, HasLogFunc env) =>
GhcPkgExe
-> Path Abs Dir
-> NonEmpty (Either PackageIdentifier GhcPkgId)
-> RIO env ()
unregisterGhcPkgIds GhcPkgExe
pkg Path Abs Dir
localDB forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) NonEmpty (GhcPkgId, (PackageIdentifier, Text))
batch
ACGhc Version
v | Version
v forall a. Ord a => a -> a -> Bool
>= [Int] -> Version
mkVersion [Int
7, Int
9] -> forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ NonEmpty (GhcPkgId, (PackageIdentifier, Text))
ids forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PackageIdentifier
-> GhcPkgId -> Either PackageIdentifier GhcPkgId)
-> (GhcPkgId, (PackageIdentifier, Text)) -> RIO env ()
unregisterSinglePkg forall a b. (a -> b) -> a -> b
$ \PackageIdentifier
_ident GhcPkgId
gid -> forall a b. b -> Either a b
Right GhcPkgId
gid
ActualCompiler
_ -> forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ NonEmpty (GhcPkgId, (PackageIdentifier, Text))
ids forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PackageIdentifier
-> GhcPkgId -> Either PackageIdentifier GhcPkgId)
-> (GhcPkgId, (PackageIdentifier, Text)) -> RIO env ()
unregisterSinglePkg forall a b. (a -> b) -> a -> b
$ \PackageIdentifier
ident GhcPkgId
_gid -> forall a b. a -> Either a b
Left PackageIdentifier
ident
toActions :: HasEnvConfig env
=> InstalledMap
-> Maybe (MVar ())
-> (RIO env () -> IO ())
-> ExecuteEnv
-> (Maybe Task, Maybe Task)
-> [Action]
toActions :: forall env.
HasEnvConfig env =>
InstalledMap
-> Maybe (MVar ())
-> (RIO env () -> IO ())
-> ExecuteEnv
-> (Maybe Task, Maybe Task)
-> [Action]
toActions InstalledMap
installedMap Maybe (MVar ())
mtestLock RIO env () -> IO ()
runInBase ExecuteEnv
ee (Maybe Task
mbuild, Maybe Task
mfinal) =
[Action]
abuild forall a. [a] -> [a] -> [a]
++ [Action]
afinal
where
abuild :: [Action]
abuild =
case Maybe Task
mbuild of
Maybe Task
Nothing -> []
Just task :: Task
task@Task {Bool
PackageIdentifier
Map PackageIdentifier GhcPkgId
TaskType
TaskConfigOpts
CachePkgSrc
taskBuildTypeConfig :: Task -> Bool
taskAnyMissing :: Task -> Bool
taskCachePkgSrc :: Task -> CachePkgSrc
taskAllInOne :: Task -> Bool
taskPresent :: Task -> Map PackageIdentifier GhcPkgId
taskBuildHaddock :: Task -> Bool
taskBuildTypeConfig :: Bool
taskAnyMissing :: Bool
taskCachePkgSrc :: CachePkgSrc
taskAllInOne :: Bool
taskPresent :: Map PackageIdentifier GhcPkgId
taskBuildHaddock :: Bool
taskConfigOpts :: TaskConfigOpts
taskType :: TaskType
taskProvides :: PackageIdentifier
taskConfigOpts :: Task -> TaskConfigOpts
taskProvides :: Task -> PackageIdentifier
taskType :: Task -> TaskType
..} ->
[ Action
{ actionId :: ActionId
actionId = PackageIdentifier -> ActionType -> ActionId
ActionId PackageIdentifier
taskProvides ActionType
ATBuild
, actionDeps :: Set ActionId
actionDeps =
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (\PackageIdentifier
ident -> PackageIdentifier -> ActionType -> ActionId
ActionId PackageIdentifier
ident ActionType
ATBuild) (TaskConfigOpts -> Set PackageIdentifier
tcoMissing TaskConfigOpts
taskConfigOpts)
, actionDo :: ActionContext -> IO ()
actionDo = \ActionContext
ac -> RIO env () -> IO ()
runInBase forall a b. (a -> b) -> a -> b
$ forall env.
(HasEnvConfig env, HasRunner env) =>
ActionContext
-> ExecuteEnv -> Task -> InstalledMap -> Bool -> RIO env ()
singleBuild ActionContext
ac ExecuteEnv
ee Task
task InstalledMap
installedMap Bool
False
, actionConcurrency :: Concurrency
actionConcurrency = Concurrency
ConcurrencyAllowed
}
]
afinal :: [Action]
afinal =
case Maybe Task
mfinal of
Maybe Task
Nothing -> []
Just task :: Task
task@Task {Bool
PackageIdentifier
Map PackageIdentifier GhcPkgId
TaskType
TaskConfigOpts
CachePkgSrc
taskBuildTypeConfig :: Bool
taskAnyMissing :: Bool
taskCachePkgSrc :: CachePkgSrc
taskAllInOne :: Bool
taskPresent :: Map PackageIdentifier GhcPkgId
taskBuildHaddock :: Bool
taskConfigOpts :: TaskConfigOpts
taskType :: TaskType
taskProvides :: PackageIdentifier
taskBuildTypeConfig :: Task -> Bool
taskAnyMissing :: Task -> Bool
taskCachePkgSrc :: Task -> CachePkgSrc
taskAllInOne :: Task -> Bool
taskPresent :: Task -> Map PackageIdentifier GhcPkgId
taskBuildHaddock :: Task -> Bool
taskConfigOpts :: Task -> TaskConfigOpts
taskProvides :: Task -> PackageIdentifier
taskType :: Task -> TaskType
..} ->
(if Bool
taskAllInOne then forall a. a -> a
id else (:)
Action
{ actionId :: ActionId
actionId = PackageIdentifier -> ActionType -> ActionId
ActionId PackageIdentifier
taskProvides ActionType
ATBuildFinal
, actionDeps :: Set ActionId
actionDeps = Set ActionId -> Set ActionId
addBuild
(forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (\PackageIdentifier
ident -> PackageIdentifier -> ActionType -> ActionId
ActionId PackageIdentifier
ident ActionType
ATBuild) (TaskConfigOpts -> Set PackageIdentifier
tcoMissing TaskConfigOpts
taskConfigOpts))
, actionDo :: ActionContext -> IO ()
actionDo = \ActionContext
ac -> RIO env () -> IO ()
runInBase forall a b. (a -> b) -> a -> b
$ forall env.
(HasEnvConfig env, HasRunner env) =>
ActionContext
-> ExecuteEnv -> Task -> InstalledMap -> Bool -> RIO env ()
singleBuild ActionContext
ac ExecuteEnv
ee Task
task InstalledMap
installedMap Bool
True
, actionConcurrency :: Concurrency
actionConcurrency = Concurrency
ConcurrencyAllowed
}) forall a b. (a -> b) -> a -> b
$
(if forall a. Set a -> Bool
Set.null Set Text
tests then forall a. a -> a
id else (:)
Action
{ actionId :: ActionId
actionId = PackageIdentifier -> ActionType -> ActionId
ActionId PackageIdentifier
taskProvides ActionType
ATRunTests
, actionDeps :: Set ActionId
actionDeps = Set ActionId
finalDeps
, actionDo :: ActionContext -> IO ()
actionDo = \ActionContext
ac -> forall {m :: * -> *} {b}.
MonadUnliftIO m =>
Maybe (MVar ()) -> m b -> m b
withLock Maybe (MVar ())
mtestLock forall a b. (a -> b) -> a -> b
$ RIO env () -> IO ()
runInBase forall a b. (a -> b) -> a -> b
$ do
forall env.
HasEnvConfig env =>
TestOpts
-> [Text]
-> ActionContext
-> ExecuteEnv
-> Task
-> InstalledMap
-> RIO env ()
singleTest TestOpts
topts (forall a. Set a -> [a]
Set.toList Set Text
tests) ActionContext
ac ExecuteEnv
ee Task
task InstalledMap
installedMap
, actionConcurrency :: Concurrency
actionConcurrency = Concurrency
ConcurrencyAllowed
}) forall a b. (a -> b) -> a -> b
$
(if forall a. Set a -> Bool
Set.null Set Text
benches then forall a. a -> a
id else (:)
Action
{ actionId :: ActionId
actionId = PackageIdentifier -> ActionType -> ActionId
ActionId PackageIdentifier
taskProvides ActionType
ATRunBenchmarks
, actionDeps :: Set ActionId
actionDeps = Set ActionId
finalDeps
, actionDo :: ActionContext -> IO ()
actionDo = \ActionContext
ac -> RIO env () -> IO ()
runInBase forall a b. (a -> b) -> a -> b
$ do
forall env.
HasEnvConfig env =>
BenchmarkOpts
-> [Text]
-> ActionContext
-> ExecuteEnv
-> Task
-> InstalledMap
-> RIO env ()
singleBench BenchmarkOpts
beopts (forall a. Set a -> [a]
Set.toList Set Text
benches) ActionContext
ac ExecuteEnv
ee Task
task InstalledMap
installedMap
, actionConcurrency :: Concurrency
actionConcurrency = Concurrency
ConcurrencyDisallowed
})
[]
where
comps :: Set NamedComponent
comps = Task -> Set NamedComponent
taskComponents Task
task
tests :: Set Text
tests = Set NamedComponent -> Set Text
testComponents Set NamedComponent
comps
benches :: Set Text
benches = Set NamedComponent -> Set Text
benchComponents Set NamedComponent
comps
finalDeps :: Set ActionId
finalDeps =
if Bool
taskAllInOne
then Set ActionId -> Set ActionId
addBuild forall a. Monoid a => a
mempty
else forall a. a -> Set a
Set.singleton (PackageIdentifier -> ActionType -> ActionId
ActionId PackageIdentifier
taskProvides ActionType
ATBuildFinal)
addBuild :: Set ActionId -> Set ActionId
addBuild =
case Maybe Task
mbuild of
Maybe Task
Nothing -> forall a. a -> a
id
Just Task
_ -> forall a. Ord a => a -> Set a -> Set a
Set.insert forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> ActionType -> ActionId
ActionId PackageIdentifier
taskProvides ActionType
ATBuild
withLock :: Maybe (MVar ()) -> m b -> m b
withLock Maybe (MVar ())
Nothing m b
f = m b
f
withLock (Just MVar ()
lock) m b
f = forall (m :: * -> *) a b.
MonadUnliftIO m =>
MVar a -> (a -> m b) -> m b
withMVar MVar ()
lock forall a b. (a -> b) -> a -> b
$ \() -> m b
f
bopts :: BuildOpts
bopts = ExecuteEnv -> BuildOpts
eeBuildOpts ExecuteEnv
ee
topts :: TestOpts
topts = BuildOpts -> TestOpts
boptsTestOpts BuildOpts
bopts
beopts :: BenchmarkOpts
beopts = BuildOpts -> BenchmarkOpts
boptsBenchmarkOpts BuildOpts
bopts
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 {Int
[LocalPackage]
Maybe Int
Maybe (Path Abs File)
MVar ()
Version
Map GhcPkgId DumpPackage
Text
TVar (Map PackageIdentifier Installed)
TVar (Map GhcPkgId DumpPackage)
IORef (Set PackageName)
Path Abs File
Path Abs Dir
TChan (Path Abs Dir, Path Abs File)
BuildOptsCLI
BuildOpts
BaseConfigOpts
eePathEnvVar :: Text
eeLargestPackageName :: Maybe Int
eeCustomBuilt :: IORef (Set PackageName)
eeLogFiles :: TChan (Path Abs Dir, Path Abs File)
eeLocalDumpPkgs :: TVar (Map GhcPkgId DumpPackage)
eeSnapshotDumpPkgs :: TVar (Map GhcPkgId DumpPackage)
eeGlobalDumpPkgs :: Map GhcPkgId DumpPackage
eeGlobalDB :: Path Abs Dir
eeLocals :: [LocalPackage]
eeTotalWanted :: Int
eeCabalPkgVer :: Version
eeSetupExe :: Maybe (Path Abs File)
eeSetupShimHs :: Path Abs File
eeSetupHs :: Path Abs File
eeTempDir :: Path Abs Dir
eeGhcPkgIds :: TVar (Map PackageIdentifier Installed)
eeBaseConfigOpts :: BaseConfigOpts
eeBuildOptsCLI :: BuildOptsCLI
eeBuildOpts :: BuildOpts
eeInstallLock :: MVar ()
eeConfigureLock :: MVar ()
eePathEnvVar :: ExecuteEnv -> Text
eeLargestPackageName :: ExecuteEnv -> Maybe Int
eeCustomBuilt :: ExecuteEnv -> IORef (Set PackageName)
eeLogFiles :: ExecuteEnv -> TChan (Path Abs Dir, Path Abs File)
eeLocalDumpPkgs :: ExecuteEnv -> TVar (Map GhcPkgId DumpPackage)
eeSnapshotDumpPkgs :: ExecuteEnv -> TVar (Map GhcPkgId DumpPackage)
eeGlobalDumpPkgs :: ExecuteEnv -> Map GhcPkgId DumpPackage
eeGlobalDB :: ExecuteEnv -> Path Abs Dir
eeLocals :: ExecuteEnv -> [LocalPackage]
eeTotalWanted :: ExecuteEnv -> Int
eeCabalPkgVer :: ExecuteEnv -> Version
eeSetupExe :: ExecuteEnv -> Maybe (Path Abs File)
eeSetupShimHs :: ExecuteEnv -> Path Abs File
eeSetupHs :: ExecuteEnv -> Path Abs File
eeTempDir :: ExecuteEnv -> Path Abs Dir
eeGhcPkgIds :: ExecuteEnv -> TVar (Map PackageIdentifier Installed)
eeBaseConfigOpts :: ExecuteEnv -> BaseConfigOpts
eeBuildOptsCLI :: ExecuteEnv -> BuildOptsCLI
eeBuildOpts :: ExecuteEnv -> BuildOpts
eeInstallLock :: ExecuteEnv -> MVar ()
eeConfigureLock :: ExecuteEnv -> MVar ()
..} task :: Task
task@Task {Bool
PackageIdentifier
Map PackageIdentifier GhcPkgId
TaskType
TaskConfigOpts
CachePkgSrc
taskBuildTypeConfig :: Bool
taskAnyMissing :: Bool
taskCachePkgSrc :: CachePkgSrc
taskAllInOne :: Bool
taskPresent :: Map PackageIdentifier GhcPkgId
taskBuildHaddock :: Bool
taskConfigOpts :: TaskConfigOpts
taskType :: TaskType
taskProvides :: PackageIdentifier
taskBuildTypeConfig :: Task -> Bool
taskAnyMissing :: Task -> Bool
taskCachePkgSrc :: Task -> CachePkgSrc
taskAllInOne :: Task -> Bool
taskPresent :: Task -> Map PackageIdentifier GhcPkgId
taskBuildHaddock :: Task -> Bool
taskConfigOpts :: Task -> TaskConfigOpts
taskProvides :: Task -> PackageIdentifier
taskType :: Task -> TaskType
..} InstalledMap
installedMap Bool
enableTest Bool
enableBench = do
let extra :: [Text]
extra =
case TaskType
taskType of
TTLocalMutable LocalPackage
_ ->
[ Text
"--enable-tests" | Bool
enableTest] forall a. [a] -> [a] -> [a]
++
[ Text
"--enable-benchmarks" | Bool
enableBench]
TTRemotePackage{} -> []
Map PackageIdentifier Installed
idMap <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar (Map PackageIdentifier Installed)
eeGhcPkgIds
let getMissing :: PackageIdentifier -> Maybe (PackageIdentifier, GhcPkgId)
getMissing PackageIdentifier
ident =
case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageIdentifier
ident Map PackageIdentifier Installed
idMap of
Maybe Installed
Nothing
| BuildOptsCLI -> Bool
boptsCLIInitialBuildSteps BuildOptsCLI
eeBuildOptsCLI Bool -> Bool -> Bool
&& Task -> Bool
taskIsTarget Task
task,
Just (InstallLocation
_, Installed
installed) <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (PackageIdentifier -> PackageName
pkgName PackageIdentifier
ident) InstalledMap
installedMap
-> PackageIdentifier
-> Installed -> Maybe (PackageIdentifier, GhcPkgId)
installedToGhcPkgId PackageIdentifier
ident Installed
installed
Just Installed
installed -> PackageIdentifier
-> Installed -> Maybe (PackageIdentifier, GhcPkgId)
installedToGhcPkgId PackageIdentifier
ident Installed
installed
Maybe Installed
_ -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> BuildException
PackageIdMissingBug PackageIdentifier
ident
installedToGhcPkgId :: PackageIdentifier
-> Installed -> Maybe (PackageIdentifier, GhcPkgId)
installedToGhcPkgId PackageIdentifier
ident (Library PackageIdentifier
ident' GhcPkgId
x Maybe (Either License License)
_) = forall a. (?callStack::CallStack) => Bool -> a -> a
assert (PackageIdentifier
ident forall a. Eq a => a -> a -> Bool
== PackageIdentifier
ident') forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (PackageIdentifier
ident, GhcPkgId
x)
installedToGhcPkgId PackageIdentifier
_ (Executable PackageIdentifier
_) = forall a. Maybe a
Nothing
missing' :: Map PackageIdentifier GhcPkgId
missing' = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe PackageIdentifier -> Maybe (PackageIdentifier, GhcPkgId)
getMissing forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
Set.toList Set PackageIdentifier
missing
TaskConfigOpts Set PackageIdentifier
missing Map PackageIdentifier GhcPkgId -> ConfigureOpts
mkOpts = TaskConfigOpts
taskConfigOpts
opts :: ConfigureOpts
opts = Map PackageIdentifier GhcPkgId -> ConfigureOpts
mkOpts Map PackageIdentifier GhcPkgId
missing'
allDeps :: Set GhcPkgId
allDeps = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [a]
Map.elems Map PackageIdentifier GhcPkgId
missing' forall a. [a] -> [a] -> [a]
++ forall k a. Map k a -> [a]
Map.elems Map PackageIdentifier GhcPkgId
taskPresent
cache :: ConfigCache
cache = ConfigCache
{ configCacheOpts :: ConfigureOpts
configCacheOpts = ConfigureOpts
opts
{ coNoDirs :: [[Char]]
coNoDirs = ConfigureOpts -> [[Char]]
coNoDirs ConfigureOpts
opts forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map Text -> [Char]
T.unpack [Text]
extra
}
, configCacheDeps :: Set GhcPkgId
configCacheDeps = Set GhcPkgId
allDeps
, configCacheComponents :: Set ByteString
configCacheComponents =
case TaskType
taskType of
TTLocalMutable LocalPackage
lp -> forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (Text -> ByteString
encodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamedComponent -> Text
renderComponent) forall a b. (a -> b) -> a -> b
$ LocalPackage -> Set NamedComponent
lpComponents LocalPackage
lp
TTRemotePackage{} -> forall a. Set a
Set.empty
, configCacheHaddock :: Bool
configCacheHaddock = Bool
taskBuildHaddock
, configCachePkgSrc :: CachePkgSrc
configCachePkgSrc = CachePkgSrc
taskCachePkgSrc
, configCachePathEnvVar :: Text
configCachePathEnvVar = Text
eePathEnvVar
}
allDepsMap :: Map PackageIdentifier GhcPkgId
allDepsMap = forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map PackageIdentifier GhcPkgId
missing' Map PackageIdentifier GhcPkgId
taskPresent
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map PackageIdentifier GhcPkgId
allDepsMap, ConfigCache
cache)
ensureConfig :: HasEnvConfig env
=> ConfigCache
-> Path Abs Dir
-> ExecuteEnv
-> RIO env ()
-> (ExcludeTHLoading -> [String] -> RIO env ())
-> Path Abs File
-> Task
-> RIO env Bool
ensureConfig :: forall env.
HasEnvConfig env =>
ConfigCache
-> Path Abs Dir
-> ExecuteEnv
-> RIO env ()
-> (ExcludeTHLoading -> [[Char]] -> RIO env ())
-> Path Abs File
-> Task
-> RIO env Bool
ensureConfig ConfigCache
newConfigCache Path Abs Dir
pkgDir ExecuteEnv {Int
[LocalPackage]
Maybe Int
Maybe (Path Abs File)
MVar ()
Version
Map GhcPkgId DumpPackage
Text
TVar (Map PackageIdentifier Installed)
TVar (Map GhcPkgId DumpPackage)
IORef (Set PackageName)
Path Abs File
Path Abs Dir
TChan (Path Abs Dir, Path Abs File)
BuildOptsCLI
BuildOpts
BaseConfigOpts
eePathEnvVar :: Text
eeLargestPackageName :: Maybe Int
eeCustomBuilt :: IORef (Set PackageName)
eeLogFiles :: TChan (Path Abs Dir, Path Abs File)
eeLocalDumpPkgs :: TVar (Map GhcPkgId DumpPackage)
eeSnapshotDumpPkgs :: TVar (Map GhcPkgId DumpPackage)
eeGlobalDumpPkgs :: Map GhcPkgId DumpPackage
eeGlobalDB :: Path Abs Dir
eeLocals :: [LocalPackage]
eeTotalWanted :: Int
eeCabalPkgVer :: Version
eeSetupExe :: Maybe (Path Abs File)
eeSetupShimHs :: Path Abs File
eeSetupHs :: Path Abs File
eeTempDir :: Path Abs Dir
eeGhcPkgIds :: TVar (Map PackageIdentifier Installed)
eeBaseConfigOpts :: BaseConfigOpts
eeBuildOptsCLI :: BuildOptsCLI
eeBuildOpts :: BuildOpts
eeInstallLock :: MVar ()
eeConfigureLock :: MVar ()
eePathEnvVar :: ExecuteEnv -> Text
eeLargestPackageName :: ExecuteEnv -> Maybe Int
eeCustomBuilt :: ExecuteEnv -> IORef (Set PackageName)
eeLogFiles :: ExecuteEnv -> TChan (Path Abs Dir, Path Abs File)
eeLocalDumpPkgs :: ExecuteEnv -> TVar (Map GhcPkgId DumpPackage)
eeSnapshotDumpPkgs :: ExecuteEnv -> TVar (Map GhcPkgId DumpPackage)
eeGlobalDumpPkgs :: ExecuteEnv -> Map GhcPkgId DumpPackage
eeGlobalDB :: ExecuteEnv -> Path Abs Dir
eeLocals :: ExecuteEnv -> [LocalPackage]
eeTotalWanted :: ExecuteEnv -> Int
eeCabalPkgVer :: ExecuteEnv -> Version
eeSetupExe :: ExecuteEnv -> Maybe (Path Abs File)
eeSetupShimHs :: ExecuteEnv -> Path Abs File
eeSetupHs :: ExecuteEnv -> Path Abs File
eeTempDir :: ExecuteEnv -> Path Abs Dir
eeGhcPkgIds :: ExecuteEnv -> TVar (Map PackageIdentifier Installed)
eeBaseConfigOpts :: ExecuteEnv -> BaseConfigOpts
eeBuildOptsCLI :: ExecuteEnv -> BuildOptsCLI
eeBuildOpts :: ExecuteEnv -> BuildOpts
eeInstallLock :: ExecuteEnv -> MVar ()
eeConfigureLock :: ExecuteEnv -> MVar ()
..} RIO env ()
announce ExcludeTHLoading -> [[Char]] -> RIO env ()
cabal Path Abs File
cabalfp Task
task = do
CTime
newCabalMod <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FileStatus -> CTime
modificationTime forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO FileStatus
getFileStatus (forall b t. Path b t -> [Char]
toFilePath Path Abs File
cabalfp)
Path Abs File
setupConfigfp <- forall (m :: * -> *) env.
(MonadThrow m, MonadReader env m, HasEnvConfig env) =>
Path Abs Dir -> m (Path Abs File)
setupConfigFromDir Path Abs Dir
pkgDir
let getNewSetupConfigMod :: RIO env (Maybe CTime)
getNewSetupConfigMod =
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileStatus -> CTime
modificationTime) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
forall (m :: * -> *) e b a.
(MonadUnliftIO m, Exception e) =>
(e -> Maybe b) -> m a -> m (Either b a)
tryJust (forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOError -> Bool
isDoesNotExistError) ([Char] -> IO FileStatus
getFileStatus (forall b t. Path b t -> [Char]
toFilePath Path Abs File
setupConfigfp))
Maybe CTime
newSetupConfigMod <- RIO env (Maybe CTime)
getNewSetupConfigMod
ByteString
newProjectRoot <- [Char] -> ByteString
S8.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b t. Path b t -> [Char]
toFilePath forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env r. HasBuildConfig env => Getting r env (Path Abs Dir)
projectRootL
Bool
taskAnyMissingHack <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasSourceMap env => SimpleGetter env ActualCompiler
actualCompilerVersionLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to ActualCompiler -> Version
getGhcVersionforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to (forall a. Ord a => a -> a -> Bool
< [Int] -> Version
mkVersion [Int
8, Int
4])
Bool
needConfig <-
if BuildOpts -> Bool
boptsReconfigure BuildOpts
eeBuildOpts Bool -> Bool -> Bool
|| (Task -> Bool
taskAnyMissing Task
task Bool -> Bool -> Bool
&& Bool
taskAnyMissingHack)
then forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
else do
let ignoreComponents :: ConfigCache -> ConfigCache
ignoreComponents ConfigCache
cc = ConfigCache
cc { configCacheComponents :: Set ByteString
configCacheComponents = forall a. Set a
Set.empty }
Maybe ConfigCache
mOldConfigCache <- forall env.
HasEnvConfig env =>
Path Abs Dir -> RIO env (Maybe ConfigCache)
tryGetConfigCache Path Abs Dir
pkgDir
Maybe CTime
mOldCabalMod <- forall env.
HasEnvConfig env =>
Path Abs Dir -> RIO env (Maybe CTime)
tryGetCabalMod Path Abs Dir
pkgDir
Maybe CTime
mOldSetupConfigMod <- forall env.
HasEnvConfig env =>
Path Abs Dir -> RIO env (Maybe CTime)
tryGetSetupConfigMod Path Abs Dir
pkgDir
Maybe ByteString
mOldProjectRoot <- forall env.
HasEnvConfig env =>
Path Abs Dir -> RIO env (Maybe ByteString)
tryGetPackageProjectRoot Path Abs Dir
pkgDir
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ConfigCache -> ConfigCache
ignoreComponents Maybe ConfigCache
mOldConfigCache forall a. Eq a => a -> a -> Bool
/= forall a. a -> Maybe a
Just (ConfigCache -> ConfigCache
ignoreComponents ConfigCache
newConfigCache)
Bool -> Bool -> Bool
|| Maybe CTime
mOldCabalMod forall a. Eq a => a -> a -> Bool
/= forall a. a -> Maybe a
Just CTime
newCabalMod
Bool -> Bool -> Bool
|| Maybe CTime
mOldSetupConfigMod forall a. Eq a => a -> a -> Bool
/= Maybe CTime
newSetupConfigMod
Bool -> Bool -> Bool
|| Maybe ByteString
mOldProjectRoot forall a. Eq a => a -> a -> Bool
/= forall a. a -> Maybe a
Just ByteString
newProjectRoot
let ConfigureOpts [[Char]]
dirs [[Char]]
nodirs = ConfigCache -> ConfigureOpts
configCacheOpts ConfigCache
newConfigCache
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Task -> Bool
taskBuildTypeConfig Task
task) RIO env ()
ensureConfigureScript
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
needConfig forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b.
MonadUnliftIO m =>
MVar a -> (a -> m b) -> m b
withMVar MVar ()
eeConfigureLock forall a b. (a -> b) -> a -> b
$ \()
_ -> do
forall env. HasEnvConfig env => Path Abs Dir -> RIO env ()
deleteCaches Path Abs Dir
pkgDir
RIO env ()
announce
CompilerPaths
cp <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasCompiler env => SimpleGetter env CompilerPaths
compilerPathsL
let (GhcPkgExe Path Abs File
pkgPath) = CompilerPaths -> GhcPkgExe
cpPkg CompilerPaths
cp
let programNames :: [([Char], [Char])]
programNames =
case forall env (m :: * -> *).
(MonadReader env m, HasCompiler env) =>
m WhichCompiler
cpWhich CompilerPaths
cp of
WhichCompiler
Ghc ->
[ ([Char]
"ghc", forall b t. Path b t -> [Char]
toFilePath (CompilerPaths -> Path Abs File
cpCompiler CompilerPaths
cp))
, ([Char]
"ghc-pkg", forall b t. Path b t -> [Char]
toFilePath Path Abs File
pkgPath)
]
[[[Char]]]
exes <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [([Char], [Char])]
programNames forall a b. (a -> b) -> a -> b
$ \([Char]
name, [Char]
file) -> do
Either ProcessException [Char]
mpath <- forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasProcessContext env) =>
[Char] -> m (Either ProcessException [Char])
findExecutable [Char]
file
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case Either ProcessException [Char]
mpath of
Left ProcessException
_ -> []
Right [Char]
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Char]
"--with-", [Char]
name, [Char]
"=", [Char]
x]
ExcludeTHLoading -> [[Char]] -> RIO env ()
cabal ExcludeTHLoading
KeepTHLoading forall a b. (a -> b) -> a -> b
$ [Char]
"configure" forall a. a -> [a] -> [a]
: forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[[Char]]]
exes
, [[Char]]
dirs
, [[Char]]
nodirs
]
case Task -> TaskType
taskType Task
task of
TTLocalMutable{} -> forall env.
HasEnvConfig env =>
Path Abs Dir -> ConfigCache -> RIO env ()
writeConfigCache Path Abs Dir
pkgDir ConfigCache
newConfigCache
TTRemotePackage{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
forall env. HasEnvConfig env => Path Abs Dir -> CTime -> RIO env ()
writeCabalMod Path Abs Dir
pkgDir CTime
newCabalMod
RIO env (Maybe CTime)
getNewSetupConfigMod forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall env.
HasEnvConfig env =>
Path Abs Dir -> Maybe CTime -> RIO env ()
writeSetupConfigMod Path Abs Dir
pkgDir
forall env.
HasEnvConfig env =>
Path Abs Dir -> ByteString -> RIO env ()
writePackageProjectRoot Path Abs Dir
pkgDir ByteString
newProjectRoot
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
needConfig
where
ensureConfigureScript :: RIO env ()
ensureConfigureScript = do
let fp :: Path Abs File
fp = Path Abs Dir
pkgDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFileConfigure
Bool
exists <- forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
fp
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exists forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Trying to generate configure with autoreconf in " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (forall b t. Path b t -> [Char]
toFilePath Path Abs Dir
pkgDir)
let autoreconf :: RIO env ()
autoreconf = if Bool
osIsWindows
then forall env.
(HasProcessContext env, HasLogFunc env, ?callStack::CallStack) =>
[Char] -> [[Char]] -> RIO env ()
readProcessNull [Char]
"sh" [[Char]
"autoreconf", [Char]
"-i"]
else forall env.
(HasProcessContext env, HasLogFunc env, ?callStack::CallStack) =>
[Char] -> [[Char]] -> RIO env ()
readProcessNull [Char]
"autoreconf" [[Char]
"-i"]
fixupOnWindows :: RIO env ()
fixupOnWindows = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
osIsWindows (forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ColorWhen
defaultColorWhen)
forall env (m :: * -> *) a.
(HasProcessContext env, MonadReader env m, MonadIO m) =>
[Char] -> m a -> m a
withWorkingDir (forall b t. Path b t -> [Char]
toFilePath Path Abs Dir
pkgDir) forall a b. (a -> b) -> a -> b
$ RIO env ()
autoreconf forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`catchAny` \SomeException
ex -> do
RIO env ()
fixupOnWindows
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Unable to run autoreconf: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Utf8Builder
displayShow SomeException
ex
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
osIsWindows forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Check that executable perl is on the path in Stack's " forall a. Semigroup a => a -> a -> a
<>
Utf8Builder
"MSYS2 \\usr\\bin folder, and working, and that script file " forall a. Semigroup a => a -> a -> a
<>
Utf8Builder
"autoreconf is on the path in that location. To check that " forall a. Semigroup a => a -> a -> a
<>
Utf8Builder
"perl or autoreconf are on the path in the required location, " forall a. Semigroup a => a -> a -> a
<>
Utf8Builder
"run commands:"
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
""
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
" stack exec where -- perl"
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
" stack exec where -- autoreconf"
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
""
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Utf8Builder
"If perl or autoreconf is not on the path in the " forall a. Semigroup a => a -> a -> a
<>
Utf8Builder
"required location, add them with command (note that the " forall a. Semigroup a => a -> a -> a
<>
Utf8Builder
"relevant package name is 'autoconf' not 'autoreconf'):"
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
""
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
" stack exec pacman -- --sync --refresh autoconf"
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
""
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Some versions of perl from MSYS2 are broken. See " forall a. Semigroup a => a -> a -> a
<>
Utf8Builder
"https://github.com/msys2/MSYS2-packages/issues/1611 and " forall a. Semigroup a => a -> a -> a
<>
Utf8Builder
"https://github.com/commercialhaskell/stack/pull/4781. To " forall a. Semigroup a => a -> a -> a
<>
Utf8Builder
"test if perl in the required location is working, try command:"
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
""
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
" stack exec perl -- --version"
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
""
RIO env ()
fixupOnWindows
packageNamePrefix :: ExecuteEnv -> PackageName -> Utf8Builder
packageNamePrefix :: ExecuteEnv -> PackageName -> Utf8Builder
packageNamePrefix ExecuteEnv
ee PackageName
name' =
let name :: [Char]
name = PackageName -> [Char]
packageNameString PackageName
name'
paddedName :: [Char]
paddedName =
case ExecuteEnv -> Maybe Int
eeLargestPackageName ExecuteEnv
ee of
Maybe Int
Nothing -> [Char]
name
Just Int
len -> forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Int
len forall a. Ord a => a -> a -> Bool
>= forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
name) forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
take Int
len forall a b. (a -> b) -> a -> b
$ [Char]
name forall a. [a] -> [a] -> [a]
++ forall a. a -> [a]
L.repeat Char
' '
in forall a. IsString a => [Char] -> a
fromString [Char]
paddedName forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"> "
announceTask :: HasLogFunc env => ExecuteEnv -> Task -> Utf8Builder -> RIO env ()
announceTask :: forall env.
HasLogFunc env =>
ExecuteEnv -> Task -> Utf8Builder -> RIO env ()
announceTask ExecuteEnv
ee Task
task Utf8Builder
action = forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$
ExecuteEnv -> PackageName -> Utf8Builder
packageNamePrefix ExecuteEnv
ee (PackageIdentifier -> PackageName
pkgName (Task -> PackageIdentifier
taskProvides Task
task)) forall a. Semigroup a => a -> a -> a
<>
Utf8Builder
action
withLockedDistDir ::
HasEnvConfig env
=> (Utf8Builder -> RIO env ())
-> Path Abs Dir
-> RIO env a
-> RIO env a
withLockedDistDir :: forall env a.
HasEnvConfig env =>
(Utf8Builder -> RIO env ())
-> Path Abs Dir -> RIO env a -> RIO env a
withLockedDistDir Utf8Builder -> RIO env ()
announce Path Abs Dir
root RIO env a
inner = do
Path Rel Dir
distDir <- forall (m :: * -> *) env.
(MonadThrow m, MonadReader env m, HasEnvConfig env) =>
m (Path Rel Dir)
distRelativeDir
let lockFP :: Path Abs File
lockFP = Path Abs Dir
root forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
distDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFileBuildLock
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir forall a b. (a -> b) -> a -> b
$ forall b t. Path b t -> Path b Dir
parent Path Abs File
lockFP
Maybe a
mres <-
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO forall a b. (a -> b) -> a -> b
$ \forall a. RIO env a -> IO a
run ->
forall a.
[Char] -> SharedExclusive -> (FileLock -> IO a) -> IO (Maybe a)
withTryFileLock (forall b t. Path b t -> [Char]
toFilePath Path Abs File
lockFP) SharedExclusive
Exclusive forall a b. (a -> b) -> a -> b
$ \FileLock
_lock ->
forall a. RIO env a -> IO a
run RIO env a
inner
case Maybe a
mres of
Just a
res -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
res
Maybe a
Nothing -> do
let complainer :: (Int -> RIO env ()) -> RIO env ()
complainer Int -> RIO env ()
delay = do
Int -> RIO env ()
delay Int
5000000
Utf8Builder -> RIO env ()
announce forall a b. (a -> b) -> a -> b
$ Utf8Builder
"blocking for directory lock on " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (forall b t. Path b t -> [Char]
toFilePath Path Abs File
lockFP)
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ do
Int -> RIO env ()
delay Int
30000000
Utf8Builder -> RIO env ()
announce forall a b. (a -> b) -> a -> b
$ Utf8Builder
"still blocking for directory lock on " forall a. Semigroup a => a -> a -> a
<>
forall a. IsString a => [Char] -> a
fromString (forall b t. Path b t -> [Char]
toFilePath Path Abs File
lockFP) forall a. Semigroup a => a -> a -> a
<>
Utf8Builder
"; maybe another Stack process is running?"
forall (m :: * -> *) a.
MonadUnliftIO m =>
Companion m -> (StopCompanion m -> m a) -> m a
withCompanion (\Delay
x -> (Int -> RIO env ()) -> RIO env ()
complainer Delay
x) forall a b. (a -> b) -> a -> b
$
\RIO env ()
stopComplaining ->
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO forall a b. (a -> b) -> a -> b
$ \forall a. RIO env a -> IO a
run ->
forall a. [Char] -> SharedExclusive -> (FileLock -> IO a) -> IO a
withFileLock (forall b t. Path b t -> [Char]
toFilePath Path Abs File
lockFP) SharedExclusive
Exclusive forall a b. (a -> b) -> a -> b
$ \FileLock
_ ->
forall a. RIO env a -> IO a
run forall a b. (a -> b) -> a -> b
$ RIO env ()
stopComplaining forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> RIO env a
inner
data OutputType
= OTLogFile !(Path Abs File) !Handle
| OTConsole !(Maybe Utf8Builder)
withSingleContext :: forall env a. HasEnvConfig env
=> ActionContext
-> ExecuteEnv
-> Task
-> 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 :: forall env a.
HasEnvConfig env =>
ActionContext
-> ExecuteEnv
-> Task
-> Map PackageIdentifier GhcPkgId
-> Maybe [Char]
-> (Package
-> Path Abs File
-> Path Abs Dir
-> (KeepOutputOpen -> ExcludeTHLoading -> [[Char]] -> RIO env ())
-> (Utf8Builder -> RIO env ())
-> OutputType
-> RIO env a)
-> RIO env a
withSingleContext ActionContext {[Action]
Set ActionId
Concurrency
acConcurrency :: ActionContext -> Concurrency
acDownstream :: ActionContext -> [Action]
acRemaining :: ActionContext -> Set ActionId
acConcurrency :: Concurrency
acDownstream :: [Action]
acRemaining :: Set ActionId
..} ee :: ExecuteEnv
ee@ExecuteEnv {Int
[LocalPackage]
Maybe Int
Maybe (Path Abs File)
MVar ()
Version
Map GhcPkgId DumpPackage
Text
TVar (Map PackageIdentifier Installed)
TVar (Map GhcPkgId DumpPackage)
IORef (Set PackageName)
Path Abs File
Path Abs Dir
TChan (Path Abs Dir, Path Abs File)
BuildOptsCLI
BuildOpts
BaseConfigOpts
eePathEnvVar :: Text
eeLargestPackageName :: Maybe Int
eeCustomBuilt :: IORef (Set PackageName)
eeLogFiles :: TChan (Path Abs Dir, Path Abs File)
eeLocalDumpPkgs :: TVar (Map GhcPkgId DumpPackage)
eeSnapshotDumpPkgs :: TVar (Map GhcPkgId DumpPackage)
eeGlobalDumpPkgs :: Map GhcPkgId DumpPackage
eeGlobalDB :: Path Abs Dir
eeLocals :: [LocalPackage]
eeTotalWanted :: Int
eeCabalPkgVer :: Version
eeSetupExe :: Maybe (Path Abs File)
eeSetupShimHs :: Path Abs File
eeSetupHs :: Path Abs File
eeTempDir :: Path Abs Dir
eeGhcPkgIds :: TVar (Map PackageIdentifier Installed)
eeBaseConfigOpts :: BaseConfigOpts
eeBuildOptsCLI :: BuildOptsCLI
eeBuildOpts :: BuildOpts
eeInstallLock :: MVar ()
eeConfigureLock :: MVar ()
eePathEnvVar :: ExecuteEnv -> Text
eeLargestPackageName :: ExecuteEnv -> Maybe Int
eeCustomBuilt :: ExecuteEnv -> IORef (Set PackageName)
eeLogFiles :: ExecuteEnv -> TChan (Path Abs Dir, Path Abs File)
eeLocalDumpPkgs :: ExecuteEnv -> TVar (Map GhcPkgId DumpPackage)
eeSnapshotDumpPkgs :: ExecuteEnv -> TVar (Map GhcPkgId DumpPackage)
eeGlobalDumpPkgs :: ExecuteEnv -> Map GhcPkgId DumpPackage
eeGlobalDB :: ExecuteEnv -> Path Abs Dir
eeLocals :: ExecuteEnv -> [LocalPackage]
eeTotalWanted :: ExecuteEnv -> Int
eeCabalPkgVer :: ExecuteEnv -> Version
eeSetupExe :: ExecuteEnv -> Maybe (Path Abs File)
eeSetupShimHs :: ExecuteEnv -> Path Abs File
eeSetupHs :: ExecuteEnv -> Path Abs File
eeTempDir :: ExecuteEnv -> Path Abs Dir
eeGhcPkgIds :: ExecuteEnv -> TVar (Map PackageIdentifier Installed)
eeBaseConfigOpts :: ExecuteEnv -> BaseConfigOpts
eeBuildOptsCLI :: ExecuteEnv -> BuildOptsCLI
eeBuildOpts :: ExecuteEnv -> BuildOpts
eeInstallLock :: ExecuteEnv -> MVar ()
eeConfigureLock :: ExecuteEnv -> MVar ()
..} task :: Task
task@Task {Bool
PackageIdentifier
Map PackageIdentifier GhcPkgId
TaskType
TaskConfigOpts
CachePkgSrc
taskBuildTypeConfig :: Bool
taskAnyMissing :: Bool
taskCachePkgSrc :: CachePkgSrc
taskAllInOne :: Bool
taskPresent :: Map PackageIdentifier GhcPkgId
taskBuildHaddock :: Bool
taskConfigOpts :: TaskConfigOpts
taskType :: TaskType
taskProvides :: PackageIdentifier
taskBuildTypeConfig :: Task -> Bool
taskAnyMissing :: Task -> Bool
taskCachePkgSrc :: Task -> CachePkgSrc
taskAllInOne :: Task -> Bool
taskPresent :: Task -> Map PackageIdentifier GhcPkgId
taskBuildHaddock :: Task -> Bool
taskConfigOpts :: Task -> TaskConfigOpts
taskProvides :: Task -> PackageIdentifier
taskType :: Task -> TaskType
..} Map PackageIdentifier GhcPkgId
allDeps Maybe [Char]
msuffix Package
-> Path Abs File
-> Path Abs Dir
-> (KeepOutputOpen -> ExcludeTHLoading -> [[Char]] -> RIO env ())
-> (Utf8Builder -> RIO env ())
-> OutputType
-> RIO env a
inner0 =
(Package -> Path Abs File -> Path Abs Dir -> RIO env a)
-> RIO env a
withPackage forall a b. (a -> b) -> a -> b
$ \Package
package Path Abs File
cabalfp Path Abs Dir
pkgDir ->
Path Abs Dir -> Package -> (OutputType -> RIO env a) -> RIO env a
withOutputType Path Abs Dir
pkgDir Package
package forall a b. (a -> b) -> a -> b
$ \OutputType
outputType ->
Package
-> Path Abs Dir
-> OutputType
-> ((KeepOutputOpen -> ExcludeTHLoading -> [[Char]] -> RIO env ())
-> RIO env a)
-> RIO env a
withCabal Package
package Path Abs Dir
pkgDir OutputType
outputType forall a b. (a -> b) -> a -> b
$ \KeepOutputOpen -> ExcludeTHLoading -> [[Char]] -> RIO env ()
cabal ->
Package
-> Path Abs File
-> Path Abs Dir
-> (KeepOutputOpen -> ExcludeTHLoading -> [[Char]] -> RIO env ())
-> (Utf8Builder -> RIO env ())
-> OutputType
-> RIO env a
inner0 Package
package Path Abs File
cabalfp Path Abs Dir
pkgDir KeepOutputOpen -> ExcludeTHLoading -> [[Char]] -> RIO env ()
cabal Utf8Builder -> RIO env ()
announce OutputType
outputType
where
announce :: Utf8Builder -> RIO env ()
announce = forall env.
HasLogFunc env =>
ExecuteEnv -> Task -> Utf8Builder -> RIO env ()
announceTask ExecuteEnv
ee Task
task
wanted :: Bool
wanted =
case TaskType
taskType of
TTLocalMutable LocalPackage
lp -> LocalPackage -> Bool
lpWanted LocalPackage
lp
TTRemotePackage{} -> Bool
False
console :: Bool
console =
(Bool
wanted Bool -> Bool -> Bool
&&
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\(ActionId PackageIdentifier
ident ActionType
_) -> PackageIdentifier
ident forall a. Eq a => a -> a -> Bool
== PackageIdentifier
taskProvides) (forall a. Set a -> [a]
Set.toList Set ActionId
acRemaining) Bool -> Bool -> Bool
&&
Int
eeTotalWanted forall a. Eq a => a -> a -> Bool
== Int
1
) Bool -> Bool -> Bool
|| (Concurrency
acConcurrency forall a. Eq a => a -> a -> Bool
== Concurrency
ConcurrencyDisallowed)
withPackage :: (Package -> Path Abs File -> Path Abs Dir -> RIO env a)
-> RIO env a
withPackage Package -> Path Abs File -> Path Abs Dir -> RIO env a
inner =
case TaskType
taskType of
TTLocalMutable LocalPackage
lp -> do
let root :: Path Abs Dir
root = forall b t. Path b t -> Path b Dir
parent forall a b. (a -> b) -> a -> b
$ LocalPackage -> Path Abs File
lpCabalFile LocalPackage
lp
forall env a.
HasEnvConfig env =>
(Utf8Builder -> RIO env ())
-> Path Abs Dir -> RIO env a -> RIO env a
withLockedDistDir Utf8Builder -> RIO env ()
announce Path Abs Dir
root forall a b. (a -> b) -> a -> b
$
Package -> Path Abs File -> Path Abs Dir -> RIO env a
inner (LocalPackage -> Package
lpPackage LocalPackage
lp) (LocalPackage -> Path Abs File
lpCabalFile LocalPackage
lp) Path Abs Dir
root
TTRemotePackage IsMutable
_ Package
package PackageLocationImmutable
pkgloc -> do
Path Rel Dir
suffix <- forall (m :: * -> *). MonadThrow m => [Char] -> m (Path Rel Dir)
parseRelDir forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> [Char]
packageIdentifierString forall a b. (a -> b) -> a -> b
$ Package -> PackageIdentifier
packageIdent Package
package
let dir :: Path Abs Dir
dir = Path Abs Dir
eeTempDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
suffix
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Path Abs Dir -> PackageLocationImmutable -> RIO env ()
unpackPackageLocation Path Abs Dir
dir PackageLocationImmutable
pkgloc
Path Rel Dir
distDir <- forall (m :: * -> *) env.
(MonadThrow m, MonadReader env m, HasEnvConfig env) =>
m (Path Rel Dir)
distRelativeDir
let oldDist :: Path Abs Dir
oldDist = Path Abs Dir
dir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirDist
newDist :: Path Abs Dir
newDist = Path Abs Dir
dir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
distDir
Bool
exists <- forall (m :: * -> *) b. MonadIO m => Path b Dir -> m Bool
doesDirExist Path Abs Dir
oldDist
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
exists forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir forall a b. (a -> b) -> a -> b
$ forall b t. Path b t -> Path b Dir
parent Path Abs Dir
newDist
forall (m :: * -> *) b0 b1.
MonadIO m =>
Path b0 Dir -> Path b1 Dir -> m ()
renameDir Path Abs Dir
oldDist Path Abs Dir
newDist
let name :: PackageName
name = PackageIdentifier -> PackageName
pkgName PackageIdentifier
taskProvides
Path Rel File
cabalfpRel <- forall (m :: * -> *). MonadThrow m => [Char] -> m (Path Rel File)
parseRelFile forall a b. (a -> b) -> a -> b
$ PackageName -> [Char]
packageNameString PackageName
name forall a. [a] -> [a] -> [a]
++ [Char]
".cabal"
let cabalfp :: Path Abs File
cabalfp = Path Abs Dir
dir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
cabalfpRel
Package -> Path Abs File -> Path Abs Dir -> RIO env a
inner Package
package Path Abs File
cabalfp Path Abs Dir
dir
withOutputType :: Path Abs Dir -> Package -> (OutputType -> RIO env a) -> RIO env a
withOutputType Path Abs Dir
pkgDir Package
package OutputType -> RIO env a
inner
| Bool
console = OutputType -> RIO env a
inner forall a b. (a -> b) -> a -> b
$ Maybe Utf8Builder -> OutputType
OTConsole forall a. Maybe a
Nothing
| BuildOpts -> Bool
boptsInterleavedOutput BuildOpts
eeBuildOpts =
OutputType -> RIO env a
inner forall a b. (a -> b) -> a -> b
$ Maybe Utf8Builder -> OutputType
OTConsole forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ExecuteEnv -> PackageName -> Utf8Builder
packageNamePrefix ExecuteEnv
ee forall a b. (a -> b) -> a -> b
$ Package -> PackageName
packageName Package
package
| Bool
otherwise = do
Path Abs File
logPath <- forall env (m :: * -> *).
(MonadReader env m, HasBuildConfig env, MonadThrow m) =>
Package -> Maybe [Char] -> m (Path Abs File)
buildLogPath Package
package Maybe [Char]
msuffix
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir (forall b t. Path b t -> Path b Dir
parent Path Abs File
logPath)
let fp :: [Char]
fp = forall b t. Path b t -> [Char]
toFilePath Path Abs File
logPath
case TaskType
taskType of
TTLocalMutable LocalPackage
lp | LocalPackage -> Bool
lpWanted LocalPackage
lp ->
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TChan a -> a -> STM ()
writeTChan TChan (Path Abs Dir, Path Abs File)
eeLogFiles (Path Abs Dir
pkgDir, Path Abs File
logPath)
TaskType
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
[Char] -> IOMode -> (Handle -> m a) -> m a
withBinaryFile [Char]
fp IOMode
WriteMode forall a b. (a -> b) -> a -> b
$ \Handle
h -> OutputType -> RIO env a
inner forall a b. (a -> b) -> a -> b
$ Path Abs File -> Handle -> OutputType
OTLogFile Path Abs File
logPath Handle
h
withCabal ::
Package
-> Path Abs Dir
-> OutputType
-> ((KeepOutputOpen -> ExcludeTHLoading -> [String] -> RIO env ()) -> RIO env a)
-> RIO env a
withCabal :: Package
-> Path Abs Dir
-> OutputType
-> ((KeepOutputOpen -> ExcludeTHLoading -> [[Char]] -> RIO env ())
-> RIO env a)
-> RIO env a
withCabal Package
package Path Abs Dir
pkgDir OutputType
outputType (KeepOutputOpen -> ExcludeTHLoading -> [[Char]] -> RIO env ())
-> RIO env a
inner = do
Config
config <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasConfig env => Lens' env Config
configL
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Config -> Bool
configAllowDifferentUser Config
config) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *). MonadIO m => Path Abs Dir -> m ()
checkOwnership (Path Abs Dir
pkgDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Config -> Path Rel Dir
configWorkDir Config
config)
let envSettings :: EnvSettings
envSettings = EnvSettings
{ esIncludeLocals :: Bool
esIncludeLocals = Task -> InstallLocation
taskLocation Task
task forall a. Eq a => a -> a -> Bool
== InstallLocation
Local
, esIncludeGhcPackagePath :: Bool
esIncludeGhcPackagePath = Bool
False
, esStackExe :: Bool
esStackExe = Bool
False
, esLocaleUtf8 :: Bool
esLocaleUtf8 = Bool
True
, esKeepGhcRts :: Bool
esKeepGhcRts = Bool
False
}
ProcessContext
menv <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Config -> EnvSettings -> IO ProcessContext
configProcessContextSettings Config
config EnvSettings
envSettings
Path Rel Dir
distRelativeDir' <- forall (m :: * -> *) env.
(MonadThrow m, MonadReader env m, HasEnvConfig env) =>
m (Path Rel Dir)
distRelativeDir
Either (Path Abs File) (Path Abs File)
esetupexehs <-
case (Package -> BuildType
packageBuildType Package
package, Maybe (Path Abs File)
eeSetupExe) of
(BuildType
C.Simple, Just Path Abs File
setupExe) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left Path Abs File
setupExe
(BuildType, Maybe (Path Abs File))
_ -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Path Abs Dir -> IO (Path Abs File)
getSetupHs Path Abs Dir
pkgDir
(KeepOutputOpen -> ExcludeTHLoading -> [[Char]] -> RIO env ())
-> RIO env a
inner forall a b. (a -> b) -> a -> b
$ \KeepOutputOpen
keepOutputOpen ExcludeTHLoading
stripTHLoading [[Char]]
args -> do
let cabalPackageArg :: [[Char]]
cabalPackageArg
| Package -> PackageName
packageName Package
package forall a. Eq a => a -> a -> Bool
== [Char] -> PackageName
mkPackageName [Char]
"Cabal" = []
| Bool
otherwise =
[[Char]
"-package=" forall a. [a] -> [a] -> [a]
++ PackageIdentifier -> [Char]
packageIdentifierString
(PackageName -> Version -> PackageIdentifier
PackageIdentifier PackageName
cabalPackageName
Version
eeCabalPkgVer)]
packageDBArgs :: [[Char]]
packageDBArgs =
( [Char]
"-clear-package-db"
forall a. a -> [a] -> [a]
: [Char]
"-global-package-db"
forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (([Char]
"-package-db=" forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall loc. Path loc Dir -> [Char]
toFilePathNoTrailingSep) (BaseConfigOpts -> [Path Abs Dir]
bcoExtraDBs BaseConfigOpts
eeBaseConfigOpts)
) forall a. [a] -> [a] -> [a]
++
( ([Char]
"-package-db=" forall a. [a] -> [a] -> [a]
++ forall loc. Path loc Dir -> [Char]
toFilePathNoTrailingSep (BaseConfigOpts -> Path Abs Dir
bcoSnapDB BaseConfigOpts
eeBaseConfigOpts))
forall a. a -> [a] -> [a]
: ([Char]
"-package-db=" forall a. [a] -> [a] -> [a]
++ forall loc. Path loc Dir -> [Char]
toFilePathNoTrailingSep (BaseConfigOpts -> Path Abs Dir
bcoLocalDB BaseConfigOpts
eeBaseConfigOpts))
forall a. a -> [a] -> [a]
: [[Char]
"-hide-all-packages"]
)
warnCustomNoDeps :: RIO env ()
warnCustomNoDeps :: RIO env ()
warnCustomNoDeps =
case (TaskType
taskType, Package -> BuildType
packageBuildType Package
package) of
(TTLocalMutable LocalPackage
lp, BuildType
C.Custom) | LocalPackage -> Bool
lpWanted LocalPackage
lp -> do
forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
MonadIO m) =>
[StyleDoc] -> m ()
prettyWarnL
[ [Char] -> StyleDoc
flow [Char]
"Package"
, forall a. IsString a => [Char] -> a
fromString forall a b. (a -> b) -> a -> b
$ PackageName -> [Char]
packageNameString forall a b. (a -> b) -> a -> b
$ Package -> PackageName
packageName Package
package
, [Char] -> StyleDoc
flow [Char]
"uses a custom Cabal build, but does not use a custom-setup stanza"
]
(TaskType, BuildType)
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
getPackageArgs :: Path Abs Dir -> RIO env [String]
getPackageArgs :: Path Abs Dir -> RIO env [[Char]]
getPackageArgs Path Abs Dir
setupDir =
case Package -> Maybe (Map PackageName VersionRange)
packageSetupDeps Package
package of
Just Map PackageName VersionRange
customSetupDeps -> do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall k a. Ord k => k -> Map k a -> Bool
Map.member ([Char] -> PackageName
mkPackageName [Char]
"Cabal") Map PackageName VersionRange
customSetupDeps) forall a b. (a -> b) -> a -> b
$
forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
MonadIO m) =>
[StyleDoc] -> m ()
prettyWarnL
[ forall a. IsString a => [Char] -> a
fromString forall a b. (a -> b) -> a -> b
$ PackageName -> [Char]
packageNameString forall a b. (a -> b) -> a -> b
$ Package -> PackageName
packageName Package
package
, StyleDoc
"has a setup-depends field, but it does not mention a Cabal dependency. This is likely to cause build errors."
]
[([Char], Maybe PackageIdentifier)]
matchedDeps <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (forall k a. Map k a -> [(k, a)]
Map.toList Map PackageName VersionRange
customSetupDeps) forall a b. (a -> b) -> a -> b
$ \(PackageName
name, VersionRange
range) -> do
let matches :: PackageIdentifier -> Bool
matches (PackageIdentifier PackageName
name' Version
version) =
PackageName
name forall a. Eq a => a -> a -> Bool
== PackageName
name' Bool -> Bool -> Bool
&&
Version
version Version -> VersionRange -> Bool
`withinRange` VersionRange
range
case forall a. (a -> Bool) -> [a] -> [a]
filter (PackageIdentifier -> Bool
matches forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) (forall k a. Map k a -> [(k, a)]
Map.toList Map PackageIdentifier GhcPkgId
allDeps) of
(PackageIdentifier, GhcPkgId)
x:[(PackageIdentifier, GhcPkgId)]
xs -> do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(PackageIdentifier, GhcPkgId)]
xs)
(forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder
"Found multiple installed packages for custom-setup dep: " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (PackageName -> [Char]
packageNameString PackageName
name)))
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char]
"-package-id=" forall a. [a] -> [a] -> [a]
++ GhcPkgId -> [Char]
ghcPkgIdString (forall a b. (a, b) -> b
snd (PackageIdentifier, GhcPkgId)
x), forall a. a -> Maybe a
Just (forall a b. (a, b) -> a
fst (PackageIdentifier, GhcPkgId)
x))
[] -> do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder
"Could not find custom-setup dep: " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (PackageName -> [Char]
packageNameString PackageName
name))
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char]
"-package=" forall a. [a] -> [a] -> [a]
++ PackageName -> [Char]
packageNameString PackageName
name, forall a. Maybe a
Nothing)
let depsArgs :: [[Char]]
depsArgs = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [([Char], Maybe PackageIdentifier)]
matchedDeps
let macroDeps :: [PackageIdentifier]
macroDeps = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall a b. (a, b) -> b
snd [([Char], Maybe PackageIdentifier)]
matchedDeps
cppMacrosFile :: Path Abs File
cppMacrosFile = Path Abs Dir
setupDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFileSetupMacrosH
cppArgs :: [[Char]]
cppArgs = [[Char]
"-optP-include", [Char]
"-optP" forall a. [a] -> [a] -> [a]
++ forall b t. Path b t -> [Char]
toFilePath Path Abs File
cppMacrosFile]
forall (m :: * -> *) absrel.
MonadIO m =>
Path absrel File -> Builder -> m ()
writeBinaryFileAtomic Path Abs File
cppMacrosFile (Text -> Builder
encodeUtf8Builder ([Char] -> Text
T.pack (Version -> [PackageIdentifier] -> [Char]
C.generatePackageVersionMacros (Package -> Version
packageVersion Package
package) [PackageIdentifier]
macroDeps)))
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([[Char]]
packageDBArgs forall a. [a] -> [a] -> [a]
++ [[Char]]
depsArgs forall a. [a] -> [a] -> [a]
++ [[Char]]
cppArgs)
Maybe (Map PackageName VersionRange)
Nothing -> do
RIO env ()
warnCustomNoDeps
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [[Char]]
cabalPackageArg forall a. [a] -> [a] -> [a]
++
([Char]
"-clear-package-db"
forall a. a -> [a] -> [a]
: [Char]
"-global-package-db"
forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (([Char]
"-package-db=" forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall loc. Path loc Dir -> [Char]
toFilePathNoTrailingSep) (BaseConfigOpts -> [Path Abs Dir]
bcoExtraDBs BaseConfigOpts
eeBaseConfigOpts)
forall a. [a] -> [a] -> [a]
++ [[Char]
"-package-db=" forall a. [a] -> [a] -> [a]
++ forall loc. Path loc Dir -> [Char]
toFilePathNoTrailingSep (BaseConfigOpts -> Path Abs Dir
bcoSnapDB BaseConfigOpts
eeBaseConfigOpts)])
setupArgs :: [[Char]]
setupArgs = ([Char]
"--builddir=" forall a. [a] -> [a] -> [a]
++ forall loc. Path loc Dir -> [Char]
toFilePathNoTrailingSep Path Rel Dir
distRelativeDir') forall a. a -> [a] -> [a]
: [[Char]]
args
runExe :: Path Abs File -> [String] -> RIO env ()
runExe :: Path Abs File -> [[Char]] -> RIO env ()
runExe Path Abs File
exeName [[Char]]
fullArgs = do
ActualCompiler
compilerVer <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasSourceMap env => SimpleGetter env ActualCompiler
actualCompilerVersionL
ActualCompiler -> RIO env ()
runAndOutput ActualCompiler
compilerVer forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \ExitCodeException
ece -> do
(Maybe (Path Abs File)
mlogFile, [Text]
bss) <-
case OutputType
outputType of
OTConsole Maybe Utf8Builder
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Maybe a
Nothing, [])
OTLogFile Path Abs File
logFile Handle
h ->
if KeepOutputOpen
keepOutputOpen forall a. Eq a => a -> a -> Bool
== KeepOutputOpen
KeepOpen
then forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Maybe a
Nothing, [])
else do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadIO m => Handle -> m ()
hClose Handle
h
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> Maybe a
Just Path Abs File
logFile,) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (n :: * -> *) i a.
(MonadUnliftIO m, MonadIO n) =>
[Char] -> (ConduitM i ByteString n () -> m a) -> m a
withSourceFile (forall b t. Path b t -> [Char]
toFilePath Path Abs File
logFile) forall a b. (a -> b) -> a -> b
$ \ConduitM () ByteString (RIO env) ()
src ->
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit
forall a b. (a -> b) -> a -> b
$ ConduitM () ByteString (RIO env) ()
src
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *). Monad m => ConduitT ByteString Text m ()
CT.decodeUtf8Lenient
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *).
MonadIO m =>
ExcludeTHLoading
-> ConvertPathsToAbsolute
-> Path Abs Dir
-> ActualCompiler
-> ConduitM Text Text m ()
mungeBuildOutput ExcludeTHLoading
stripTHLoading ConvertPathsToAbsolute
makeAbsolute Path Abs Dir
pkgDir ActualCompiler
compilerVer
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) a o. Monad m => ConduitT a o m [a]
CL.consume
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ forall e. (Exception e, Pretty e) => e -> PrettyException
PrettyException forall a b. (a -> b) -> a -> b
$ ExitCode
-> PackageIdentifier
-> Path Abs File
-> [[Char]]
-> Maybe (Path Abs File)
-> [Text]
-> BuildPrettyException
CabalExitedUnsuccessfully
(ExitCodeException -> ExitCode
eceExitCode ExitCodeException
ece)
PackageIdentifier
taskProvides
Path Abs File
exeName
[[Char]]
fullArgs
Maybe (Path Abs File)
mlogFile
[Text]
bss
where
runAndOutput :: ActualCompiler -> RIO env ()
runAndOutput :: ActualCompiler -> RIO env ()
runAndOutput ActualCompiler
compilerVer = forall env (m :: * -> *) a.
(HasProcessContext env, MonadReader env m, MonadIO m) =>
[Char] -> m a -> m a
withWorkingDir (forall b t. Path b t -> [Char]
toFilePath Path Abs Dir
pkgDir) forall a b. (a -> b) -> a -> b
$ forall env a.
HasProcessContext env =>
ProcessContext -> RIO env a -> RIO env a
withProcessContext ProcessContext
menv forall a b. (a -> b) -> a -> b
$ case OutputType
outputType of
OTLogFile Path Abs File
_ Handle
h -> do
let prefixWithTimestamps :: PrefixWithTimestamps
prefixWithTimestamps =
if Config -> Bool
configPrefixTimestamps Config
config
then PrefixWithTimestamps
PrefixWithTimestamps
else PrefixWithTimestamps
WithoutTimestamps
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall e o env.
(HasProcessContext env, HasLogFunc env, ?callStack::CallStack) =>
[Char]
-> [[Char]]
-> ConduitM ByteString Void (RIO env) e
-> ConduitM ByteString Void (RIO env) o
-> RIO env (e, o)
sinkProcessStderrStdout (forall b t. Path b t -> [Char]
toFilePath Path Abs File
exeName) [[Char]]
fullArgs
(forall (m :: * -> *).
MonadIO m =>
PrefixWithTimestamps -> Handle -> ConduitT ByteString Void m ()
sinkWithTimestamps PrefixWithTimestamps
prefixWithTimestamps Handle
h)
(forall (m :: * -> *).
MonadIO m =>
PrefixWithTimestamps -> Handle -> ConduitT ByteString Void m ()
sinkWithTimestamps PrefixWithTimestamps
prefixWithTimestamps Handle
h)
OTConsole Maybe Utf8Builder
mprefix ->
let prefix :: Utf8Builder
prefix = forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold Maybe Utf8Builder
mprefix in
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall e o env.
(HasProcessContext env, HasLogFunc env, ?callStack::CallStack) =>
[Char]
-> [[Char]]
-> ConduitM ByteString Void (RIO env) e
-> ConduitM ByteString Void (RIO env) o
-> RIO env (e, o)
sinkProcessStderrStdout (forall b t. Path b t -> [Char]
toFilePath Path Abs File
exeName) [[Char]]
fullArgs
((?callStack::CallStack) =>
ExcludeTHLoading
-> LogLevel
-> ActualCompiler
-> Utf8Builder
-> ConduitM ByteString Void (RIO env) ()
outputSink ExcludeTHLoading
KeepTHLoading LogLevel
LevelWarn ActualCompiler
compilerVer Utf8Builder
prefix)
((?callStack::CallStack) =>
ExcludeTHLoading
-> LogLevel
-> ActualCompiler
-> Utf8Builder
-> ConduitM ByteString Void (RIO env) ()
outputSink ExcludeTHLoading
stripTHLoading LogLevel
LevelInfo ActualCompiler
compilerVer Utf8Builder
prefix)
outputSink ::
HasCallStack
=> ExcludeTHLoading
-> LogLevel
-> ActualCompiler
-> Utf8Builder
-> ConduitM S.ByteString Void (RIO env) ()
outputSink :: (?callStack::CallStack) =>
ExcludeTHLoading
-> LogLevel
-> ActualCompiler
-> Utf8Builder
-> ConduitM ByteString Void (RIO env) ()
outputSink ExcludeTHLoading
excludeTH LogLevel
level ActualCompiler
compilerVer Utf8Builder
prefix =
forall (m :: * -> *). Monad m => ConduitT ByteString Text m ()
CT.decodeUtf8Lenient
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *).
MonadIO m =>
ExcludeTHLoading
-> ConvertPathsToAbsolute
-> Path Abs Dir
-> ActualCompiler
-> ConduitM Text Text m ()
mungeBuildOutput ExcludeTHLoading
excludeTH ConvertPathsToAbsolute
makeAbsolute Path Abs Dir
pkgDir ActualCompiler
compilerVer
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) a o.
Monad m =>
(a -> m ()) -> ConduitT a o m ()
CL.mapM_ (forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Text -> LogLevel -> Utf8Builder -> m ()
logGeneric Text
"" LogLevel
level forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Utf8Builder
prefix forall a. Semigroup a => a -> a -> a
<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Display a => a -> Utf8Builder
display)
makeAbsolute :: ConvertPathsToAbsolute
makeAbsolute :: ConvertPathsToAbsolute
makeAbsolute = case ExcludeTHLoading
stripTHLoading of
ExcludeTHLoading
ExcludeTHLoading -> ConvertPathsToAbsolute
ConvertPathsToAbsolute
ExcludeTHLoading
KeepTHLoading -> ConvertPathsToAbsolute
KeepPathsAsIs
Path Abs File
exeName <- case Either (Path Abs File) (Path Abs File)
esetupexehs of
Left Path Abs File
setupExe -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Path Abs File
setupExe
Right Path Abs File
setuphs -> do
Path Abs Dir
distDir <- forall (m :: * -> *) env.
(MonadThrow m, MonadReader env m, HasEnvConfig env) =>
Path Abs Dir -> m (Path Abs Dir)
distDirFromDir Path Abs Dir
pkgDir
let setupDir :: Path Abs Dir
setupDir = Path Abs Dir
distDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirSetup
outputFile :: Path Abs File
outputFile = Path Abs Dir
setupDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFileSetupLower
Set PackageName
customBuilt <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef (Set PackageName)
eeCustomBuilt
if forall a. Ord a => a -> Set a -> Bool
Set.member (Package -> PackageName
packageName Package
package) Set PackageName
customBuilt
then forall (f :: * -> *) a. Applicative f => a -> f a
pure Path Abs File
outputFile
else do
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir Path Abs Dir
setupDir
Path Abs File
compilerPath <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasCompiler env => SimpleGetter env CompilerPaths
compilerPathsLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to CompilerPaths -> Path Abs File
cpCompiler
[[Char]]
packageArgs <- Path Abs Dir -> RIO env [[Char]]
getPackageArgs Path Abs Dir
setupDir
Path Abs File -> [[Char]] -> RIO env ()
runExe Path Abs File
compilerPath forall a b. (a -> b) -> a -> b
$
[ [Char]
"--make"
, [Char]
"-odir", forall loc. Path loc Dir -> [Char]
toFilePathNoTrailingSep Path Abs Dir
setupDir
, [Char]
"-hidir", forall loc. Path loc Dir -> [Char]
toFilePathNoTrailingSep Path Abs Dir
setupDir
, [Char]
"-i", [Char]
"-i."
] forall a. [a] -> [a] -> [a]
++ [[Char]]
packageArgs forall a. [a] -> [a] -> [a]
++
[ forall b t. Path b t -> [Char]
toFilePath Path Abs File
setuphs
, forall b t. Path b t -> [Char]
toFilePath Path Abs File
eeSetupShimHs
, [Char]
"-main-is"
, [Char]
"StackSetupShim.mainOverride"
, [Char]
"-o", forall b t. Path b t -> [Char]
toFilePath Path Abs File
outputFile
, [Char]
"-threaded"
] forall a. [a] -> [a] -> [a]
++
forall a b. (a -> b) -> [a] -> [b]
map Text -> [Char]
T.unpack (
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] ApplyGhcOptions
AGOEverything (Config -> Map ApplyGhcOptions [Text]
configGhcOptionsByCat Config
config) forall a. [a] -> [a] -> [a]
++
case Config -> ApplyGhcOptions
configApplyGhcOptions Config
config of
ApplyGhcOptions
AGOEverything -> BuildOptsCLI -> [Text]
boptsCLIGhcOptions BuildOptsCLI
eeBuildOptsCLI
ApplyGhcOptions
AGOTargets -> []
ApplyGhcOptions
AGOLocals -> [])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b.
MonadIO m =>
IORef a -> (a -> (a, b)) -> m b
atomicModifyIORef' IORef (Set PackageName)
eeCustomBuilt forall a b. (a -> b) -> a -> b
$
\Set PackageName
oldCustomBuilt -> (forall a. Ord a => a -> Set a -> Set a
Set.insert (Package -> PackageName
packageName Package
package) Set PackageName
oldCustomBuilt, ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure Path Abs File
outputFile
let cabalVerboseArg :: [Char]
cabalVerboseArg =
let CabalVerbosity Verbosity
cv = BuildOpts -> CabalVerbosity
boptsCabalVerbose BuildOpts
eeBuildOpts
in [Char]
"--verbose=" forall a. Semigroup a => a -> a -> a
<> Verbosity -> [Char]
showForCabal Verbosity
cv
Path Abs File -> [[Char]] -> RIO env ()
runExe Path Abs File
exeName forall a b. (a -> b) -> a -> b
$ [Char]
cabalVerboseArgforall a. a -> [a] -> [a]
:[[Char]]
setupArgs
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 ac :: ActionContext
ac@ActionContext {[Action]
Set ActionId
Concurrency
acConcurrency :: Concurrency
acDownstream :: [Action]
acRemaining :: Set ActionId
acConcurrency :: ActionContext -> Concurrency
acDownstream :: ActionContext -> [Action]
acRemaining :: ActionContext -> Set ActionId
..} ee :: ExecuteEnv
ee@ExecuteEnv {Int
[LocalPackage]
Maybe Int
Maybe (Path Abs File)
MVar ()
Version
Map GhcPkgId DumpPackage
Text
TVar (Map PackageIdentifier Installed)
TVar (Map GhcPkgId DumpPackage)
IORef (Set PackageName)
Path Abs File
Path Abs Dir
TChan (Path Abs Dir, Path Abs File)
BuildOptsCLI
BuildOpts
BaseConfigOpts
eePathEnvVar :: Text
eeLargestPackageName :: Maybe Int
eeCustomBuilt :: IORef (Set PackageName)
eeLogFiles :: TChan (Path Abs Dir, Path Abs File)
eeLocalDumpPkgs :: TVar (Map GhcPkgId DumpPackage)
eeSnapshotDumpPkgs :: TVar (Map GhcPkgId DumpPackage)
eeGlobalDumpPkgs :: Map GhcPkgId DumpPackage
eeGlobalDB :: Path Abs Dir
eeLocals :: [LocalPackage]
eeTotalWanted :: Int
eeCabalPkgVer :: Version
eeSetupExe :: Maybe (Path Abs File)
eeSetupShimHs :: Path Abs File
eeSetupHs :: Path Abs File
eeTempDir :: Path Abs Dir
eeGhcPkgIds :: TVar (Map PackageIdentifier Installed)
eeBaseConfigOpts :: BaseConfigOpts
eeBuildOptsCLI :: BuildOptsCLI
eeBuildOpts :: BuildOpts
eeInstallLock :: MVar ()
eeConfigureLock :: MVar ()
eePathEnvVar :: ExecuteEnv -> Text
eeLargestPackageName :: ExecuteEnv -> Maybe Int
eeCustomBuilt :: ExecuteEnv -> IORef (Set PackageName)
eeLogFiles :: ExecuteEnv -> TChan (Path Abs Dir, Path Abs File)
eeLocalDumpPkgs :: ExecuteEnv -> TVar (Map GhcPkgId DumpPackage)
eeSnapshotDumpPkgs :: ExecuteEnv -> TVar (Map GhcPkgId DumpPackage)
eeGlobalDumpPkgs :: ExecuteEnv -> Map GhcPkgId DumpPackage
eeGlobalDB :: ExecuteEnv -> Path Abs Dir
eeLocals :: ExecuteEnv -> [LocalPackage]
eeTotalWanted :: ExecuteEnv -> Int
eeCabalPkgVer :: ExecuteEnv -> Version
eeSetupExe :: ExecuteEnv -> Maybe (Path Abs File)
eeSetupShimHs :: ExecuteEnv -> Path Abs File
eeSetupHs :: ExecuteEnv -> Path Abs File
eeTempDir :: ExecuteEnv -> Path Abs Dir
eeGhcPkgIds :: ExecuteEnv -> TVar (Map PackageIdentifier Installed)
eeBaseConfigOpts :: ExecuteEnv -> BaseConfigOpts
eeBuildOptsCLI :: ExecuteEnv -> BuildOptsCLI
eeBuildOpts :: ExecuteEnv -> BuildOpts
eeInstallLock :: ExecuteEnv -> MVar ()
eeConfigureLock :: ExecuteEnv -> MVar ()
..} task :: Task
task@Task {Bool
PackageIdentifier
Map PackageIdentifier GhcPkgId
TaskType
TaskConfigOpts
CachePkgSrc
taskBuildTypeConfig :: Bool
taskAnyMissing :: Bool
taskCachePkgSrc :: CachePkgSrc
taskAllInOne :: Bool
taskPresent :: Map PackageIdentifier GhcPkgId
taskBuildHaddock :: Bool
taskConfigOpts :: TaskConfigOpts
taskType :: TaskType
taskProvides :: PackageIdentifier
taskBuildTypeConfig :: Task -> Bool
taskAnyMissing :: Task -> Bool
taskCachePkgSrc :: Task -> CachePkgSrc
taskAllInOne :: Task -> Bool
taskPresent :: Task -> Map PackageIdentifier GhcPkgId
taskBuildHaddock :: Task -> Bool
taskConfigOpts :: Task -> TaskConfigOpts
taskProvides :: Task -> PackageIdentifier
taskType :: Task -> TaskType
..} InstalledMap
installedMap Bool
isFinalBuild = do
(Map PackageIdentifier GhcPkgId
allDepsMap, ConfigCache
cache) <- 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
Maybe (PrecompiledCache Abs)
mprecompiled <- ConfigCache -> RIO env (Maybe (PrecompiledCache Abs))
getPrecompiled ConfigCache
cache
Maybe Installed
minstalled <-
case Maybe (PrecompiledCache Abs)
mprecompiled of
Just PrecompiledCache Abs
precompiled -> PrecompiledCache Abs -> RIO env (Maybe Installed)
copyPreCompiled PrecompiledCache Abs
precompiled
Maybe (PrecompiledCache Abs)
Nothing -> do
Maybe Curator
mcurator <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasBuildConfig env => Lens' env BuildConfig
buildConfigLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to BuildConfig -> Maybe Curator
bcCurator
ConfigCache
-> Maybe Curator
-> Map PackageIdentifier GhcPkgId
-> RIO env (Maybe Installed)
realConfigAndBuild ConfigCache
cache Maybe Curator
mcurator Map PackageIdentifier GhcPkgId
allDepsMap
case Maybe Installed
minstalled of
Maybe Installed
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Just Installed
installed -> do
forall env.
HasEnvConfig env =>
Installed -> ConfigCache -> RIO env ()
writeFlagCache Installed
installed ConfigCache
cache
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (Map PackageIdentifier Installed)
eeGhcPkgIds forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert PackageIdentifier
taskProvides Installed
installed
where
pname :: PackageName
pname = PackageIdentifier -> PackageName
pkgName PackageIdentifier
taskProvides
doHaddock :: Maybe Curator -> Package -> Bool
doHaddock Maybe Curator
mcurator Package
package
= Bool
taskBuildHaddock Bool -> Bool -> Bool
&&
Bool -> Bool
not Bool
isFinalBuild Bool -> Bool -> Bool
&&
Package -> Bool
packageHasExposedModules Package
package Bool -> Bool -> Bool
&&
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (forall a. Ord a => a -> Set a -> Bool
Set.notMember PackageName
pname forall b c a. (b -> c) -> (a -> b) -> a -> c
. Curator -> Set PackageName
curatorSkipHaddock) Maybe Curator
mcurator
expectHaddockFailure :: Maybe Curator -> Bool
expectHaddockFailure Maybe Curator
mcurator =
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (forall a. Ord a => a -> Set a -> Bool
Set.member PackageName
pname forall b c a. (b -> c) -> (a -> b) -> a -> c
. Curator -> Set PackageName
curatorExpectHaddockFailure) Maybe Curator
mcurator
fulfillHaddockExpectations :: Maybe Curator -> (KeepOutputOpen -> RIO env ()) -> RIO env ()
fulfillHaddockExpectations Maybe Curator
mcurator KeepOutputOpen -> RIO env ()
action | Maybe Curator -> Bool
expectHaddockFailure Maybe Curator
mcurator = do
Either SomeException ()
eres <- forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny forall a b. (a -> b) -> a -> b
$ KeepOutputOpen -> RIO env ()
action KeepOutputOpen
KeepOpen
case Either SomeException ()
eres of
Right () -> forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$ forall a. IsString a => [Char] -> a
fromString (PackageName -> [Char]
packageNameString PackageName
pname) forall a. Semigroup a => a -> a -> a
<> Utf8Builder
": unexpected Haddock success"
Left SomeException
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
fulfillHaddockExpectations Maybe Curator
_ KeepOutputOpen -> RIO env ()
action = do
KeepOutputOpen -> RIO env ()
action KeepOutputOpen
CloseOnException
buildingFinals :: Bool
buildingFinals = Bool
isFinalBuild Bool -> Bool -> Bool
|| Bool
taskAllInOne
enableTests :: Bool
enableTests = Bool
buildingFinals Bool -> Bool -> 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
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any NamedComponent -> Bool
isCBench (Task -> Set NamedComponent
taskComponents Task
task)
annSuffix :: Map Text ExecutableBuildStatus -> Text
annSuffix Map Text ExecutableBuildStatus
executableBuildStatuses = if Text
result forall a. Eq a => a -> a -> Bool
== Text
"" then Text
"" else Text
" (" forall a. Semigroup a => a -> a -> a
<> Text
result forall a. Semigroup a => a -> a -> a
<> Text
")"
where
result :: Text
result = Text -> [Text] -> Text
T.intercalate Text
" + " forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [Text
"lib" | Bool
taskAllInOne Bool -> Bool -> Bool
&& Bool
hasLib]
, [Text
"internal-lib" | Bool
taskAllInOne Bool -> Bool -> Bool
&& Bool
hasSubLib]
, [Text
"exe" | Bool
taskAllInOne Bool -> Bool -> Bool
&& Bool
hasExe]
, [Text
"test" | Bool
enableTests]
, [Text
"bench" | Bool
enableBenchmarks]
]
(Bool
hasLib, Bool
hasSubLib, Bool
hasExe) = case TaskType
taskType of
TTLocalMutable LocalPackage
lp ->
let package :: Package
package = LocalPackage -> Package
lpPackage LocalPackage
lp
hasLibrary :: Bool
hasLibrary =
case Package -> PackageLibraries
packageLibraries Package
package of
PackageLibraries
NoLibraries -> Bool
False
HasLibraries Set Text
_ -> Bool
True
hasSubLibrary :: Bool
hasSubLibrary = Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> Bool
Set.null forall a b. (a -> b) -> a -> b
$ Package -> Set Text
packageInternalLibraries Package
package
hasExecutables :: Bool
hasExecutables = Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> Bool
Set.null forall a b. (a -> b) -> a -> b
$ Map Text ExecutableBuildStatus -> LocalPackage -> Set Text
exesToBuild Map Text ExecutableBuildStatus
executableBuildStatuses LocalPackage
lp
in (Bool
hasLibrary, Bool
hasSubLibrary, Bool
hasExecutables)
TaskType
_ -> (Bool
False, Bool
False, Bool
False)
getPrecompiled :: ConfigCache -> RIO env (Maybe (PrecompiledCache Abs))
getPrecompiled ConfigCache
cache =
case TaskType
taskType of
TTRemotePackage IsMutable
Immutable Package
_ PackageLocationImmutable
loc -> do
Maybe (PrecompiledCache Abs)
mpc <- forall env.
HasEnvConfig env =>
PackageLocationImmutable
-> ConfigureOpts
-> Bool
-> Set GhcPkgId
-> RIO env (Maybe (PrecompiledCache Abs))
readPrecompiledCache
PackageLocationImmutable
loc
(ConfigCache -> ConfigureOpts
configCacheOpts ConfigCache
cache)
(ConfigCache -> Bool
configCacheHaddock ConfigCache
cache)
(ConfigCache -> Set GhcPkgId
configCacheDeps ConfigCache
cache)
case Maybe (PrecompiledCache Abs)
mpc of
Maybe (PrecompiledCache Abs)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
Just PrecompiledCache Abs
pc | forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False
(BaseConfigOpts -> Path Abs Dir
bcoSnapInstallRoot BaseConfigOpts
eeBaseConfigOpts forall b t. Path b Dir -> Path b t -> Bool
`isProperPrefixOf`)
(forall base. PrecompiledCache base -> Maybe (Path base File)
pcLibrary PrecompiledCache Abs
pc) ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
Just PrecompiledCache Abs
pc -> do
let allM :: (t -> f Bool) -> [t] -> f Bool
allM t -> f Bool
_ [] = 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 forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
Bool
b <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall {f :: * -> *} {t}. Monad f => (t -> f Bool) -> [t] -> f Bool
allM forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (:) (forall base. PrecompiledCache base -> Maybe (Path base File)
pcLibrary PrecompiledCache Abs
pc) forall a b. (a -> b) -> a -> b
$ forall base. PrecompiledCache base -> [Path base File]
pcExes PrecompiledCache Abs
pc
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ if Bool
b then forall a. a -> Maybe a
Just PrecompiledCache Abs
pc else forall a. Maybe a
Nothing
TaskType
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
copyPreCompiled :: PrecompiledCache Abs -> RIO env (Maybe Installed)
copyPreCompiled (PrecompiledCache Maybe (Path Abs File)
mlib [Path Abs File]
sublibs [Path Abs File]
exes) = do
WhichCompiler
wc <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasSourceMap env => SimpleGetter env ActualCompiler
actualCompilerVersionLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall r. Getting r ActualCompiler WhichCompiler
whichCompilerL
forall env.
HasLogFunc env =>
ExecuteEnv -> Task -> Utf8Builder -> RIO env ()
announceTask ExecuteEnv
ee Task
task Utf8Builder
"using precompiled package"
let
subLibNames :: [[Char]]
subLibNames = forall a b. (a -> b) -> [a] -> [b]
map Text -> [Char]
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> [a]
Set.toList forall a b. (a -> b) -> a -> b
$ case TaskType
taskType of
TTLocalMutable LocalPackage
lp -> Package -> Set Text
packageInternalLibraries forall a b. (a -> b) -> a -> b
$ LocalPackage -> Package
lpPackage LocalPackage
lp
TTRemotePackage IsMutable
_ Package
p PackageLocationImmutable
_ -> Package -> Set Text
packageInternalLibraries Package
p
PackageIdentifier PackageName
name Version
version = PackageIdentifier
taskProvides
mainLibName :: [Char]
mainLibName = PackageName -> [Char]
packageNameString PackageName
name
mainLibVersion :: [Char]
mainLibVersion = Version -> [Char]
versionString Version
version
pkgName :: [Char]
pkgName = [Char]
mainLibName forall a. [a] -> [a] -> [a]
++ [Char]
"-" forall a. [a] -> [a] -> [a]
++ [Char]
mainLibVersion
toCabalInternalLibName :: ShowS
toCabalInternalLibName [Char]
n = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Char]
"z-", [Char]
mainLibName, [Char]
"-z-", [Char]
n, [Char]
"-", [Char]
mainLibVersion]
allToUnregister :: [[Char]]
allToUnregister = forall a b. (a -> b) -> [a] -> [b]
map (forall a b. a -> b -> a
const [Char]
pkgName) (forall a. Maybe a -> [a]
maybeToList Maybe (Path Abs File)
mlib) forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map ShowS
toCabalInternalLibName [[Char]]
subLibNames
allToRegister :: [Path Abs File]
allToRegister = forall a. Maybe a -> [a]
maybeToList Maybe (Path Abs File)
mlib forall a. [a] -> [a] -> [a]
++ [Path Abs File]
sublibs
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Path Abs File]
allToRegister) forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *) a b.
MonadUnliftIO m =>
MVar a -> (a -> m b) -> m b
withMVar MVar ()
eeInstallLock forall a b. (a -> b) -> a -> b
$ \() -> do
let modifyEnv :: Map Text Text -> Map Text Text
modifyEnv = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert
(WhichCompiler -> Text
ghcPkgPathEnvVar WhichCompiler
wc)
([Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall loc. Path loc Dir -> [Char]
toFilePathNoTrailingSep forall a b. (a -> b) -> a -> b
$ BaseConfigOpts -> Path Abs Dir
bcoSnapDB BaseConfigOpts
eeBaseConfigOpts)
forall env (m :: * -> *) a.
(HasProcessContext env, MonadReader env m, MonadIO m) =>
(Map Text Text -> Map Text Text) -> m a -> m a
withModifyEnvVars Map Text Text -> Map Text Text
modifyEnv forall a b. (a -> b) -> a -> b
$ do
GhcPkgExe Path Abs File
ghcPkgExe <- forall env. HasCompiler env => RIO env GhcPkgExe
getGhcPkgExe
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [[Char]]
allToUnregister forall a b. (a -> b) -> a -> b
$ \[Char]
packageName -> forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
catchAny
(forall env.
(HasProcessContext env, HasLogFunc env, ?callStack::CallStack) =>
[Char] -> [[Char]] -> RIO env ()
readProcessNull (forall b t. Path b t -> [Char]
toFilePath Path Abs File
ghcPkgExe) [ [Char]
"unregister", [Char]
"--force", [Char]
packageName])
(forall a b. a -> b -> a
const (forall (f :: * -> *) a. Applicative f => a -> f a
pure ()))
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Path Abs File]
allToRegister forall a b. (a -> b) -> a -> b
$ \Path Abs File
libpath ->
forall env (m :: * -> *) a.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
MonadIO m, ?callStack::CallStack) =>
[Char] -> [[Char]] -> (ProcessConfig () () () -> m a) -> m a
proc (forall b t. Path b t -> [Char]
toFilePath Path Abs File
ghcPkgExe) [ [Char]
"register", [Char]
"--force", forall b t. Path b t -> [Char]
toFilePath Path Abs File
libpath] forall (m :: * -> *) stdin stdoutIgnored stderrIgnored.
MonadIO m =>
ProcessConfig stdin stdoutIgnored stderrIgnored
-> m (LByteString, LByteString)
readProcess_
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Path Abs File]
exes forall a b. (a -> b) -> a -> b
$ \Path Abs File
exe -> do
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir Path Abs Dir
bindir
let dst :: Path Abs File
dst = Path Abs Dir
bindir forall b t. Path b Dir -> Path Rel t -> Path b t
</> forall b. Path b File -> Path Rel File
filename Path Abs File
exe
[Char] -> [Char] -> IO ()
createLink (forall b t. Path b t -> [Char]
toFilePath Path Abs File
exe) (forall b t. Path b t -> [Char]
toFilePath Path Abs File
dst) forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (IOError -> m a) -> m a
`catchIO` \IOError
_ -> forall (m :: * -> *) b0 b1.
MonadIO m =>
Path b0 File -> Path b1 File -> m ()
copyFile Path Abs File
exe Path Abs File
dst
case (Maybe (Path Abs File)
mlib, [Path Abs File]
exes) of
(Maybe (Path Abs File)
Nothing, Path Abs File
_:[Path Abs File]
_) -> forall env.
HasEnvConfig env =>
InstallLocation -> PackageIdentifier -> RIO env ()
markExeInstalled (Task -> InstallLocation
taskLocation Task
task) PackageIdentifier
taskProvides
(Maybe (Path Abs File), [Path Abs File])
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
let pkgDbs :: [Path Abs Dir]
pkgDbs = [BaseConfigOpts -> Path Abs Dir
bcoSnapDB BaseConfigOpts
eeBaseConfigOpts]
case Maybe (Path Abs File)
mlib of
Maybe (Path Abs File)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> Installed
Executable PackageIdentifier
taskProvides
Just Path Abs File
_ -> do
Maybe GhcPkgId
mpkgid <- forall {env}.
(HasCompiler env, HasProcessContext env, HasLogFunc env) =>
[Path Abs Dir]
-> TVar (Map GhcPkgId DumpPackage)
-> PackageName
-> RIO env (Maybe GhcPkgId)
loadInstalledPkg [Path Abs Dir]
pkgDbs TVar (Map GhcPkgId DumpPackage)
eeSnapshotDumpPkgs PackageName
pname
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
case Maybe GhcPkgId
mpkgid of
Maybe GhcPkgId
Nothing -> forall a. (?callStack::CallStack) => Bool -> a -> a
assert Bool
False forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> Installed
Executable PackageIdentifier
taskProvides
Just GhcPkgId
pkgid -> PackageIdentifier
-> GhcPkgId -> Maybe (Either License License) -> Installed
Library PackageIdentifier
taskProvides GhcPkgId
pkgid forall a. Maybe a
Nothing
where
bindir :: Path Abs Dir
bindir = BaseConfigOpts -> Path Abs Dir
bcoSnapInstallRoot BaseConfigOpts
eeBaseConfigOpts forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
bindirSuffix
realConfigAndBuild :: ConfigCache
-> Maybe Curator
-> Map PackageIdentifier GhcPkgId
-> RIO env (Maybe Installed)
realConfigAndBuild ConfigCache
cache Maybe Curator
mcurator Map PackageIdentifier GhcPkgId
allDepsMap = forall env a.
HasEnvConfig env =>
ActionContext
-> ExecuteEnv
-> Task
-> Map PackageIdentifier GhcPkgId
-> Maybe [Char]
-> (Package
-> Path Abs File
-> Path Abs Dir
-> (KeepOutputOpen -> ExcludeTHLoading -> [[Char]] -> RIO env ())
-> (Utf8Builder -> RIO env ())
-> OutputType
-> RIO env a)
-> RIO env a
withSingleContext ActionContext
ac ExecuteEnv
ee Task
task Map PackageIdentifier GhcPkgId
allDepsMap forall a. Maybe a
Nothing
forall a b. (a -> b) -> a -> b
$ \Package
package Path Abs File
cabalfp Path Abs Dir
pkgDir KeepOutputOpen -> ExcludeTHLoading -> [[Char]] -> RIO env ()
cabal0 Utf8Builder -> RIO env ()
announce OutputType
_outputType -> do
let cabal :: ExcludeTHLoading -> [[Char]] -> RIO env ()
cabal = KeepOutputOpen -> ExcludeTHLoading -> [[Char]] -> RIO env ()
cabal0 KeepOutputOpen
CloseOnException
Map Text ExecutableBuildStatus
executableBuildStatuses <- forall env.
HasEnvConfig env =>
Package -> Path Abs Dir -> RIO env (Map Text ExecutableBuildStatus)
getExecutableBuildStatuses Package
package Path Abs Dir
pkgDir
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (forall k. Map k ExecutableBuildStatus -> Bool
cabalIsSatisfied Map Text ExecutableBuildStatus
executableBuildStatuses) Bool -> Bool -> Bool
&& Task -> Bool
taskIsTarget Task
task)
(forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logInfo
(Utf8Builder
"Building all executables for `" forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (PackageName -> [Char]
packageNameString (Package -> PackageName
packageName Package
package)) forall a. Semigroup a => a -> a -> a
<>
Utf8Builder
"' once. After a successful build of all of them, only specified executables will be rebuilt."))
Bool
_neededConfig <- forall env.
HasEnvConfig env =>
ConfigCache
-> Path Abs Dir
-> ExecuteEnv
-> RIO env ()
-> (ExcludeTHLoading -> [[Char]] -> RIO env ())
-> Path Abs File
-> Task
-> RIO env Bool
ensureConfig ConfigCache
cache Path Abs Dir
pkgDir ExecuteEnv
ee (Utf8Builder -> RIO env ()
announce (Utf8Builder
"configure" forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display (Map Text ExecutableBuildStatus -> Text
annSuffix Map Text ExecutableBuildStatus
executableBuildStatuses))) ExcludeTHLoading -> [[Char]] -> RIO env ()
cabal Path Abs File
cabalfp Task
task
let installedMapHasThisPkg :: Bool
installedMapHasThisPkg :: Bool
installedMapHasThisPkg =
case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Package -> PackageName
packageName Package
package) InstalledMap
installedMap of
Just (InstallLocation
_, Library PackageIdentifier
ident GhcPkgId
_ Maybe (Either License License)
_) -> PackageIdentifier
ident forall a. Eq a => a -> a -> Bool
== PackageIdentifier
taskProvides
Just (InstallLocation
_, Executable PackageIdentifier
_) -> Bool
True
Maybe (InstallLocation, Installed)
_ -> Bool
False
case ( BuildOptsCLI -> Bool
boptsCLIOnlyConfigure BuildOptsCLI
eeBuildOptsCLI
, BuildOptsCLI -> Bool
boptsCLIInitialBuildSteps BuildOptsCLI
eeBuildOptsCLI Bool -> Bool -> Bool
&& Task -> Bool
taskIsTarget Task
task) of
(Bool
True, Bool
_) | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Action]
acDownstream -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
(Bool
_, Bool
True) | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Action]
acDownstream Bool -> Bool -> Bool
|| Bool
installedMapHasThisPkg -> do
Map Text ExecutableBuildStatus
-> (ExcludeTHLoading -> [[Char]] -> RIO env ())
-> (Utf8Builder -> RIO env ())
-> RIO env ()
initialBuildSteps Map Text ExecutableBuildStatus
executableBuildStatuses ExcludeTHLoading -> [[Char]] -> RIO env ()
cabal Utf8Builder -> RIO env ()
announce
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
(Bool, Bool)
_ -> forall env b.
(HasLogFunc env, ?callStack::CallStack) =>
PackageName
-> Maybe Curator -> Bool -> Bool -> b -> RIO env b -> RIO env b
fulfillCuratorBuildExpectations PackageName
pname Maybe Curator
mcurator Bool
enableTests Bool
enableBenchmarks forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$
forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConfigCache
-> Package
-> Path Abs Dir
-> (KeepOutputOpen -> ExcludeTHLoading -> [[Char]] -> RIO env ())
-> (Utf8Builder -> RIO env ())
-> Map Text ExecutableBuildStatus
-> RIO env Installed
realBuild ConfigCache
cache Package
package Path Abs Dir
pkgDir KeepOutputOpen -> ExcludeTHLoading -> [[Char]] -> RIO env ()
cabal0 Utf8Builder -> RIO env ()
announce Map Text ExecutableBuildStatus
executableBuildStatuses
initialBuildSteps :: Map Text ExecutableBuildStatus
-> (ExcludeTHLoading -> [[Char]] -> RIO env ())
-> (Utf8Builder -> RIO env ())
-> RIO env ()
initialBuildSteps Map Text ExecutableBuildStatus
executableBuildStatuses ExcludeTHLoading -> [[Char]] -> RIO env ()
cabal Utf8Builder -> RIO env ()
announce = do
Utf8Builder -> RIO env ()
announce (Utf8Builder
"initial-build-steps" forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display (Map Text ExecutableBuildStatus -> Text
annSuffix Map Text ExecutableBuildStatus
executableBuildStatuses))
ExcludeTHLoading -> [[Char]] -> RIO env ()
cabal ExcludeTHLoading
KeepTHLoading [[Char]
"repl", [Char]
"stack-initial-build-steps"]
realBuild ::
ConfigCache
-> Package
-> Path Abs Dir
-> (KeepOutputOpen -> ExcludeTHLoading -> [String] -> RIO env ())
-> (Utf8Builder -> RIO env ())
-> Map Text ExecutableBuildStatus
-> RIO env Installed
realBuild :: ConfigCache
-> Package
-> Path Abs Dir
-> (KeepOutputOpen -> ExcludeTHLoading -> [[Char]] -> RIO env ())
-> (Utf8Builder -> RIO env ())
-> Map Text ExecutableBuildStatus
-> RIO env Installed
realBuild ConfigCache
cache Package
package Path Abs Dir
pkgDir KeepOutputOpen -> ExcludeTHLoading -> [[Char]] -> RIO env ()
cabal0 Utf8Builder -> RIO env ()
announce Map Text ExecutableBuildStatus
executableBuildStatuses = do
let cabal :: ExcludeTHLoading -> [[Char]] -> RIO env ()
cabal = KeepOutputOpen -> ExcludeTHLoading -> [[Char]] -> RIO env ()
cabal0 KeepOutputOpen
CloseOnException
WhichCompiler
wc <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasSourceMap env => SimpleGetter env ActualCompiler
actualCompilerVersionLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall r. Getting r ActualCompiler WhichCompiler
whichCompilerL
forall env.
HasEnvConfig env =>
InstallLocation -> PackageIdentifier -> RIO env ()
markExeNotInstalled (Task -> InstallLocation
taskLocation Task
task) PackageIdentifier
taskProvides
case TaskType
taskType of
TTLocalMutable LocalPackage
lp -> do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
enableTests forall a b. (a -> b) -> a -> b
$ forall env.
HasEnvConfig env =>
Path Abs Dir -> TestStatus -> RIO env ()
setTestStatus Path Abs Dir
pkgDir TestStatus
TSUnknown
Map NamedComponent (Map [Char] FileCacheInfo)
caches <- forall env (m :: * -> *) a.
(HasEnvConfig env, MonadReader env m, MonadIO m) =>
MemoizedWith EnvConfig a -> m a
runMemoizedWith forall a b. (a -> b) -> a -> b
$ LocalPackage
-> MemoizedWith
EnvConfig (Map NamedComponent (Map [Char] FileCacheInfo))
lpNewBuildCaches LocalPackage
lp
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (forall env.
HasEnvConfig env =>
Path Abs Dir
-> NamedComponent -> Map [Char] FileCacheInfo -> RIO env ()
writeBuildCache Path Abs Dir
pkgDir))
(forall k a. Map k a -> [(k, a)]
Map.toList Map NamedComponent (Map [Char] FileCacheInfo)
caches)
TTRemotePackage{} -> 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 TaskType
taskType of
TTLocalMutable LocalPackage
lp -> do
[PackageWarning]
warnings <- forall env.
HasEnvConfig env =>
TaskType -> Path Abs Dir -> RIO env [PackageWarning]
checkForUnlistedFiles TaskType
taskType Path Abs Dir
pkgDir
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just (LocalPackage -> Path Abs File
lpCabalFile LocalPackage
lp, [PackageWarning]
warnings))
TaskType
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
let showModuleWarning :: PackageWarning -> StyleDoc
showModuleWarning (UnlistedModulesWarning NamedComponent
comp [ModuleName]
modules) =
StyleDoc
"- In" StyleDoc -> StyleDoc -> StyleDoc
<+>
forall a. IsString a => [Char] -> a
fromString (Text -> [Char]
T.unpack (NamedComponent -> Text
renderComponent NamedComponent
comp)) forall a. Semigroup a => a -> a -> a
<>
StyleDoc
":" forall a. Semigroup a => a -> a -> a
<> StyleDoc
line forall a. Semigroup a => a -> a -> a
<>
Int -> StyleDoc -> StyleDoc
indent Int
4 ( forall a. Monoid a => [a] -> a
mconcat
forall a b. (a -> b) -> a -> b
$ forall a. a -> [a] -> [a]
L.intersperse StyleDoc
line
forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map
(Style -> StyleDoc -> StyleDoc
style Style
Good forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => [Char] -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Pretty a => a -> [Char]
C.display)
[ModuleName]
modules
)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (Path Abs File, [PackageWarning])
mlocalWarnings forall a b. (a -> b) -> a -> b
$ \(Path Abs File
cabalfp, [PackageWarning]
warnings) -> do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PackageWarning]
warnings) forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
MonadIO m) =>
StyleDoc -> m ()
prettyWarn forall a b. (a -> b) -> a -> b
$
[Char] -> StyleDoc
flow [Char]
"The following modules should be added to \
\exposed-modules or other-modules in" StyleDoc -> StyleDoc -> StyleDoc
<+>
forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
cabalfp
forall a. Semigroup a => a -> a -> a
<> StyleDoc
":"
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
forall a. Semigroup a => a -> a -> a
<> Int -> StyleDoc -> StyleDoc
indent Int
4 ( forall a. Monoid a => [a] -> a
mconcat
forall a b. (a -> b) -> a -> b
$ forall a. a -> [a] -> [a]
L.intersperse StyleDoc
line
forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map PackageWarning -> StyleDoc
showModuleWarning [PackageWarning]
warnings
)
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
forall a. Semigroup a => a -> a -> a
<> [Char] -> StyleDoc
flow [Char]
"Missing modules in the Cabal file are likely \
\to cause undefined reference errors from the \
\linker, along with other problems."
() <- Utf8Builder -> RIO env ()
announce (Utf8Builder
"build" forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display (Map Text ExecutableBuildStatus -> Text
annSuffix Map Text ExecutableBuildStatus
executableBuildStatuses))
Config
config <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasConfig env => Lens' env Config
configL
[[Char]]
extraOpts <- forall env.
(HasEnvConfig env, HasRunner env) =>
WhichCompiler -> BuildOpts -> RIO env [[Char]]
extraBuildOptions WhichCompiler
wc BuildOpts
eeBuildOpts
let stripTHLoading :: ExcludeTHLoading
stripTHLoading
| Config -> Bool
configHideTHLoading Config
config = ExcludeTHLoading
ExcludeTHLoading
| Bool
otherwise = ExcludeTHLoading
KeepTHLoading
ExcludeTHLoading -> [[Char]] -> RIO env ()
cabal ExcludeTHLoading
stripTHLoading (([Char]
"build" forall a. a -> [a] -> [a]
:) forall a b. (a -> b) -> a -> b
$ (forall a. [a] -> [a] -> [a]
++ [[Char]]
extraOpts) forall a b. (a -> b) -> a -> b
$
case (TaskType
taskType, Bool
taskAllInOne, Bool
isFinalBuild) of
(TaskType
_, Bool
True, Bool
True) -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM BuildException
AllInOneBuildBug
(TTLocalMutable LocalPackage
lp, Bool
False, Bool
False) -> Map Text ExecutableBuildStatus -> LocalPackage -> [[Char]]
primaryComponentOptions Map Text ExecutableBuildStatus
executableBuildStatuses LocalPackage
lp
(TTLocalMutable LocalPackage
lp, Bool
False, Bool
True) -> LocalPackage -> [[Char]]
finalComponentOptions LocalPackage
lp
(TTLocalMutable LocalPackage
lp, Bool
True, Bool
False) -> Map Text ExecutableBuildStatus -> LocalPackage -> [[Char]]
primaryComponentOptions Map Text ExecutableBuildStatus
executableBuildStatuses LocalPackage
lp forall a. [a] -> [a] -> [a]
++ LocalPackage -> [[Char]]
finalComponentOptions LocalPackage
lp
(TTRemotePackage{}, Bool
_, Bool
_) -> [])
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 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (forall e. (Exception e, Pretty e) => e -> PrettyException
PrettyException BuildPrettyException
ex)
BuildPrettyException
_ -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM BuildPrettyException
ex
Bool -> RIO env ()
postBuildCheck Bool
True
Maybe Curator
mcurator <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasBuildConfig env => Lens' env BuildConfig
buildConfigLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to BuildConfig -> Maybe Curator
bcCurator
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Curator -> Package -> Bool
doHaddock Maybe Curator
mcurator Package
package) forall a b. (a -> b) -> a -> b
$ do
Utf8Builder -> RIO env ()
announce Utf8Builder
"haddock"
[[Char]]
sourceFlag <- if Bool -> Bool
not (BuildOpts -> Bool
boptsHaddockHyperlinkSource BuildOpts
eeBuildOpts) then forall (f :: * -> *) a. Applicative f => a -> f a
pure [] else do
ExitCode
ec
<- forall env (m :: * -> *) a.
(HasProcessContext env, MonadReader env m, MonadIO m) =>
[Char] -> m a -> m a
withWorkingDir (forall b t. Path b t -> [Char]
toFilePath Path Abs Dir
eeTempDir)
forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *) a.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
MonadIO m, ?callStack::CallStack) =>
[Char] -> [[Char]] -> (ProcessConfig () () () -> m a) -> m a
proc [Char]
"haddock" [[Char]
"--hyperlinked-source"]
forall a b. (a -> b) -> a -> b
$ \ProcessConfig () () ()
pc -> forall (m :: * -> *) stdin stdout stderr a.
MonadUnliftIO m =>
ProcessConfig stdin stdout stderr
-> (Process stdin stdout stderr -> m a) -> m a
withProcessWait
(forall stdout stdin stdout0 stderr.
StreamSpec 'STOutput stdout
-> ProcessConfig stdin stdout0 stderr
-> ProcessConfig stdin stdout stderr
setStdout forall (m :: * -> *) i.
MonadIO m =>
StreamSpec 'STOutput (ConduitM i ByteString m ())
createSource forall a b. (a -> b) -> a -> b
$ forall stderr stdin stdout stderr0.
StreamSpec 'STOutput stderr
-> ProcessConfig stdin stdout stderr0
-> ProcessConfig stdin stdout stderr
setStderr forall (m :: * -> *) i.
MonadIO m =>
StreamSpec 'STOutput (ConduitM i ByteString m ())
createSource ProcessConfig () () ()
pc) forall a b. (a -> b) -> a -> b
$ \Process
()
(ConduitM () ByteString (RIO env) ())
(ConduitM () ByteString (RIO env) ())
p ->
forall (m :: * -> *) a. Concurrently m a -> m a
runConcurrently
forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. m a -> Concurrently m a
Concurrently (forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit forall a b. (a -> b) -> a -> b
$ forall stdin stdout stderr. Process stdin stdout stderr -> stdout
getStdout Process
()
(ConduitM () ByteString (RIO env) ())
(ConduitM () ByteString (RIO env) ())
p forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) i o. Monad m => ConduitT i o m ()
CL.sinkNull)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) a. m a -> Concurrently m a
Concurrently (forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit forall a b. (a -> b) -> a -> b
$ forall stdin stdout stderr. Process stdin stdout stderr -> stderr
getStderr Process
()
(ConduitM () ByteString (RIO env) ())
(ConduitM () ByteString (RIO env) ())
p forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) i o. Monad m => ConduitT i o m ()
CL.sinkNull)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) a. m a -> Concurrently m a
Concurrently (forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
Process stdin stdout stderr -> m ExitCode
waitExitCode Process
()
(ConduitM () ByteString (RIO env) ())
(ConduitM () ByteString (RIO env) ())
p)
case ExitCode
ec of
ExitCode
ExitSuccess -> forall (f :: * -> *) a. Applicative f => a -> f a
pure [[Char]
"--haddock-option=--hyperlinked-source"]
ExitFailure Int
_ -> do
Bool
hscolourExists <- forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasProcessContext env) =>
[Char] -> m Bool
doesExecutableExist [Char]
"HsColour"
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
hscolourExists forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logWarn
(Utf8Builder
"Warning: haddock not generating hyperlinked sources because 'HsColour' not\n" forall a. Semigroup a => a -> a -> a
<>
Utf8Builder
"found on PATH (use 'stack install hscolour' to install).")
forall (f :: * -> *) a. Applicative f => a -> f a
pure [[Char]
"--hyperlink-source" | Bool
hscolourExists]
ActualCompiler
actualCompiler <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasSourceMap env => SimpleGetter env ActualCompiler
actualCompilerVersionL
let quickjump :: [[Char]]
quickjump =
case ActualCompiler
actualCompiler of
ACGhc Version
ghcVer
| Version
ghcVer forall a. Ord a => a -> a -> Bool
>= [Int] -> Version
mkVersion [Int
8, Int
4] -> [[Char]
"--haddock-option=--quickjump"]
ActualCompiler
_ -> []
Maybe Curator -> (KeepOutputOpen -> RIO env ()) -> RIO env ()
fulfillHaddockExpectations Maybe Curator
mcurator forall a b. (a -> b) -> a -> b
$ \KeepOutputOpen
keep -> KeepOutputOpen -> ExcludeTHLoading -> [[Char]] -> RIO env ()
cabal0 KeepOutputOpen
keep ExcludeTHLoading
KeepTHLoading forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [[Char]
"haddock", [Char]
"--html", [Char]
"--hoogle", [Char]
"--html-location=../$pkg-$version/"]
, [[Char]]
sourceFlag
, [[Char]
"--internal" | BuildOpts -> Bool
boptsHaddockInternal BuildOpts
eeBuildOpts]
, [ [Char]
"--haddock-option=" forall a. Semigroup a => a -> a -> a
<> [Char]
opt
| [Char]
opt <- HaddockOpts -> [[Char]]
hoAdditionalArgs (BuildOpts -> HaddockOpts
boptsHaddockOpts BuildOpts
eeBuildOpts) ]
, [[Char]]
quickjump
]
let hasLibrary :: Bool
hasLibrary =
case Package -> PackageLibraries
packageLibraries Package
package of
PackageLibraries
NoLibraries -> Bool
False
HasLibraries Set Text
_ -> Bool
True
packageHasComponentSet :: (Package -> Set Text) -> Bool
packageHasComponentSet Package -> Set Text
f = Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall a. Set a -> Bool
Set.null forall a b. (a -> b) -> a -> b
$ Package -> Set Text
f Package
package
hasInternalLibrary :: Bool
hasInternalLibrary = (Package -> Set Text) -> Bool
packageHasComponentSet Package -> Set Text
packageInternalLibraries
hasExecutables :: Bool
hasExecutables = (Package -> Set Text) -> Bool
packageHasComponentSet Package -> Set Text
packageExes
shouldCopy :: Bool
shouldCopy = Bool -> Bool
not Bool
isFinalBuild Bool -> Bool -> Bool
&& (Bool
hasLibrary Bool -> Bool -> Bool
|| Bool
hasInternalLibrary Bool -> Bool -> Bool
|| Bool
hasExecutables)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
shouldCopy forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b.
MonadUnliftIO m =>
MVar a -> (a -> m b) -> m b
withMVar MVar ()
eeInstallLock forall a b. (a -> b) -> a -> b
$ \() -> do
Utf8Builder -> RIO env ()
announce Utf8Builder
"copy/register"
Either BuildPrettyException ()
eres <- forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try forall a b. (a -> b) -> a -> b
$ ExcludeTHLoading -> [[Char]] -> RIO env ()
cabal ExcludeTHLoading
KeepTHLoading [[Char]
"copy"]
case Either BuildPrettyException ()
eres of
Left err :: BuildPrettyException
err@CabalExitedUnsuccessfully{} ->
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ Bool -> [Char] -> BuildException
CabalCopyFailed
(Package -> BuildType
packageBuildType Package
package forall a. Eq a => a -> a -> Bool
== BuildType
C.Simple)
(forall e. Exception e => e -> [Char]
displayException BuildPrettyException
err)
Either BuildPrettyException ()
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
hasLibrary forall a b. (a -> b) -> a -> b
$ ExcludeTHLoading -> [[Char]] -> RIO env ()
cabal ExcludeTHLoading
KeepTHLoading [[Char]
"register"]
case Text -> [Char]
T.unpack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BuildOpts -> Maybe Text
boptsDdumpDir BuildOpts
eeBuildOpts of
Just [Char]
ddumpPath | Bool
buildingFinals Bool -> Bool -> Bool
&& Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
ddumpPath) -> do
Path Rel Dir
distDir <- forall (m :: * -> *) env.
(MonadThrow m, MonadReader env m, HasEnvConfig env) =>
m (Path Rel Dir)
distRelativeDir
Path Rel Dir
ddumpDir <- forall (m :: * -> *). MonadThrow m => [Char] -> m (Path Rel Dir)
parseRelDir [Char]
ddumpPath
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ forall a. IsString a => [Char] -> a
fromString ([Char]
"ddump-dir: " forall a. Semigroup a => a -> a -> a
<> forall b t. Path b t -> [Char]
toFilePath Path Rel Dir
ddumpDir)
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ forall a. IsString a => [Char] -> a
fromString ([Char]
"dist-dir: " forall a. Semigroup a => a -> a -> a
<> forall b t. Path b t -> [Char]
toFilePath Path Rel Dir
distDir)
forall (m :: * -> *) r.
MonadUnliftIO m =>
ConduitT () Void (ResourceT m) r -> m r
runConduitRes
forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) i.
MonadResource m =>
Bool -> [Char] -> ConduitT i [Char] m ()
CF.sourceDirectoryDeep Bool
False (forall b t. Path b t -> [Char]
toFilePath Path Rel Dir
distDir)
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) a. Monad m => (a -> Bool) -> ConduitT a a m ()
CL.filter (forall a. Eq a => [a] -> [a] -> Bool
L.isInfixOf [Char]
".dump-")
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) a o.
Monad m =>
(a -> m ()) -> ConduitT a o m ()
CL.mapM_ (\[Char]
src -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
Path Rel Dir
parentDir <- forall b t. Path b t -> Path b Dir
parent forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadThrow m => [Char] -> m (Path Rel Dir)
parseRelDir [Char]
src
Path Rel Dir
destBaseDir <- (Path Rel Dir
ddumpDir forall b t. Path b Dir -> Path Rel t -> Path b t
</>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Char]
".stack-work" forall a. Eq a => [a] -> [a] -> Bool
`L.isInfixOf` forall b t. Path b t -> [Char]
toFilePath Path Rel Dir
destBaseDir) forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir Path Rel Dir
destBaseDir
Path Rel File
src' <- forall (m :: * -> *). MonadThrow m => [Char] -> m (Path Rel File)
parseRelFile [Char]
src
forall (m :: * -> *) b0 b1.
MonadIO m =>
Path b0 File -> Path b1 File -> m ()
copyFile Path Rel File
src' (Path Rel Dir
destBaseDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> forall b. Path b File -> Path Rel File
filename Path Rel File
src'))
Maybe [Char]
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
let (Path Abs Dir
installedPkgDb, TVar (Map GhcPkgId DumpPackage)
installedDumpPkgsTVar) =
case Task -> InstallLocation
taskLocation Task
task of
InstallLocation
Snap ->
( BaseConfigOpts -> Path Abs Dir
bcoSnapDB BaseConfigOpts
eeBaseConfigOpts
, TVar (Map GhcPkgId DumpPackage)
eeSnapshotDumpPkgs )
InstallLocation
Local ->
( BaseConfigOpts -> Path Abs Dir
bcoLocalDB BaseConfigOpts
eeBaseConfigOpts
, TVar (Map GhcPkgId DumpPackage)
eeLocalDumpPkgs )
let ident :: PackageIdentifier
ident = PackageName -> Version -> PackageIdentifier
PackageIdentifier (Package -> PackageName
packageName Package
package) (Package -> Version
packageVersion Package
package)
(Installed
mpkgid, [GhcPkgId]
sublibsPkgIds) <- case Package -> PackageLibraries
packageLibraries Package
package of
HasLibraries Set Text
_ -> do
[GhcPkgId]
sublibsPkgIds <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (forall a. Set a -> [a]
Set.toList forall a b. (a -> b) -> a -> b
$ Package -> Set Text
packageInternalLibraries Package
package) forall a b. (a -> b) -> a -> b
$ \Text
sublib -> do
let sublibName :: Text
sublibName = [Text] -> Text
T.concat [Text
"z-", [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ PackageName -> [Char]
packageNameString forall a b. (a -> b) -> a -> b
$ Package -> PackageName
packageName Package
package, Text
"-z-", Text
sublib]
case [Char] -> Maybe PackageName
parsePackageName forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
sublibName of
Maybe PackageName
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
Just PackageName
subLibName -> forall {env}.
(HasCompiler env, HasProcessContext env, HasLogFunc env) =>
[Path Abs Dir]
-> TVar (Map GhcPkgId DumpPackage)
-> PackageName
-> RIO env (Maybe GhcPkgId)
loadInstalledPkg [Path Abs Dir
installedPkgDb] TVar (Map GhcPkgId DumpPackage)
installedDumpPkgsTVar PackageName
subLibName
Maybe GhcPkgId
mpkgid <- forall {env}.
(HasCompiler env, HasProcessContext env, HasLogFunc env) =>
[Path Abs Dir]
-> TVar (Map GhcPkgId DumpPackage)
-> PackageName
-> RIO env (Maybe GhcPkgId)
loadInstalledPkg [Path Abs Dir
installedPkgDb] TVar (Map GhcPkgId DumpPackage)
installedDumpPkgsTVar (Package -> PackageName
packageName Package
package)
case Maybe GhcPkgId
mpkgid of
Maybe GhcPkgId
Nothing -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ PackageName -> BuildException
Couldn'tFindPkgId forall a b. (a -> b) -> a -> b
$ Package -> PackageName
packageName Package
package
Just GhcPkgId
pkgid -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (PackageIdentifier
-> GhcPkgId -> Maybe (Either License License) -> Installed
Library PackageIdentifier
ident GhcPkgId
pkgid forall a. Maybe a
Nothing, [GhcPkgId]
sublibsPkgIds)
PackageLibraries
NoLibraries -> do
forall env.
HasEnvConfig env =>
InstallLocation -> PackageIdentifier -> RIO env ()
markExeInstalled (Task -> InstallLocation
taskLocation Task
task) PackageIdentifier
taskProvides
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PackageIdentifier -> Installed
Executable PackageIdentifier
ident, [])
case TaskType
taskType of
TTRemotePackage IsMutable
Immutable Package
_ PackageLocationImmutable
loc ->
forall env.
HasEnvConfig env =>
BaseConfigOpts
-> PackageLocationImmutable
-> ConfigureOpts
-> Bool
-> Set GhcPkgId
-> Installed
-> [GhcPkgId]
-> Set Text
-> RIO env ()
writePrecompiledCache
BaseConfigOpts
eeBaseConfigOpts
PackageLocationImmutable
loc
(ConfigCache -> ConfigureOpts
configCacheOpts ConfigCache
cache)
(ConfigCache -> Bool
configCacheHaddock ConfigCache
cache)
(ConfigCache -> Set GhcPkgId
configCacheDeps ConfigCache
cache)
Installed
mpkgid [GhcPkgId]
sublibsPkgIds (Package -> Set Text
packageExes Package
package)
TaskType
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
case TaskType
taskType of
TTRemotePackage{} -> do
let remaining :: [ActionId]
remaining = forall a. (a -> Bool) -> [a] -> [a]
filter (\(ActionId PackageIdentifier
x ActionType
_) -> PackageIdentifier
x forall a. Eq a => a -> a -> Bool
== PackageIdentifier
taskProvides) (forall a. Set a -> [a]
Set.toList Set ActionId
acRemaining)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ActionId]
remaining) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
removeDirRecur Path Abs Dir
pkgDir
TTLocalMutable{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure Installed
mpkgid
loadInstalledPkg :: [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 <- forall env. HasCompiler env => RIO env GhcPkgExe
getGhcPkgExe
[DumpPackage]
dps <- forall env a.
(HasProcessContext env, HasLogFunc env, HasCompiler env) =>
GhcPkgExe
-> PackageName
-> [Path Abs Dir]
-> ConduitM Text Void (RIO env) a
-> RIO env a
ghcPkgDescribe GhcPkgExe
pkgexe PackageName
name [Path Abs Dir]
pkgDbs forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadThrow m =>
ConduitM Text DumpPackage m ()
conduitDumpPackage forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) a o. Monad m => ConduitT a o m [a]
CL.consume
case [DumpPackage]
dps of
[] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
[DumpPackage
dp] -> do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar (Map GhcPkgId DumpPackage)
tvar (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (DumpPackage -> GhcPkgId
dpGhcPkgId DumpPackage
dp) DumpPackage
dp)
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (DumpPackage -> GhcPkgId
dpGhcPkgId DumpPackage
dp)
[DumpPackage]
_ -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ PackageName -> [DumpPackage] -> BuildException
MulipleResultsBug PackageName
name [DumpPackage]
dps
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 <- forall (m :: * -> *) env.
(MonadThrow m, MonadReader env m, HasEnvConfig env) =>
Path Abs Dir -> m (Path Abs Dir)
distDirFromDir Path Abs Dir
pkgDir
Platform
platform <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasPlatform env => Lens' env Platform
platformL
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
(forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall env b.
HasLogFunc env =>
Platform
-> Path b Dir -> Text -> RIO env (Text, ExecutableBuildStatus)
checkExeStatus Platform
platform Path Abs Dir
distDir) (forall a. Set a -> [a]
Set.toList (Package -> Set Text
packageExes 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 <- forall (m :: * -> *). MonadThrow m => [Char] -> m (Path Rel Dir)
parseRelDir (Text -> [Char]
T.unpack Text
name)
Bool
exists <- Path b Dir -> RIO env Bool
checkPath (Path b Dir
distDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirBuild forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
exename)
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 <- forall (m :: * -> *). MonadThrow m => [Char] -> m (Path Rel File)
parseRelFile ([Char]
file forall a. [a] -> [a] -> [a]
++ [Char]
".exe")
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist (Path b Dir
base forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
fileandext)
Platform
_ -> do
Path Rel File
fileandext <- forall (m :: * -> *). MonadThrow m => [Char] -> m (Path Rel File)
parseRelFile [Char]
file
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist (Path b Dir
base forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
fileandext)
where
file :: [Char]
file = Text -> [Char]
T.unpack Text
name
checkForUnlistedFiles ::
HasEnvConfig env
=> TaskType
-> Path Abs Dir
-> RIO env [PackageWarning]
checkForUnlistedFiles :: forall env.
HasEnvConfig env =>
TaskType -> Path Abs Dir -> RIO env [PackageWarning]
checkForUnlistedFiles (TTLocalMutable LocalPackage
lp) Path Abs Dir
pkgDir = do
Map NamedComponent (Map [Char] FileCacheInfo)
caches <- forall env (m :: * -> *) a.
(HasEnvConfig env, MonadReader env m, MonadIO m) =>
MemoizedWith EnvConfig a -> m a
runMemoizedWith forall a b. (a -> b) -> a -> b
$ LocalPackage
-> MemoizedWith
EnvConfig (Map NamedComponent (Map [Char] FileCacheInfo))
lpNewBuildCaches LocalPackage
lp
(Map NamedComponent [Map [Char] FileCacheInfo]
addBuildCache,[PackageWarning]
warnings) <-
forall env a.
HasEnvConfig env =>
Package
-> Path Abs File
-> Set NamedComponent
-> Map NamedComponent (Map [Char] a)
-> RIO
env
(Map NamedComponent [Map [Char] FileCacheInfo], [PackageWarning])
addUnlistedToBuildCache
(LocalPackage -> Package
lpPackage LocalPackage
lp)
(LocalPackage -> Path Abs File
lpCabalFile LocalPackage
lp)
(LocalPackage -> Set NamedComponent
lpComponents LocalPackage
lp)
Map NamedComponent (Map [Char] FileCacheInfo)
caches
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall k a. Map k a -> [(k, a)]
M.toList Map NamedComponent [Map [Char] FileCacheInfo]
addBuildCache) forall a b. (a -> b) -> a -> b
$ \(NamedComponent
component, [Map [Char] FileCacheInfo]
newToCache) -> do
let cache :: Map [Char] FileCacheInfo
cache = forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault forall k a. Map k a
Map.empty NamedComponent
component Map NamedComponent (Map [Char] FileCacheInfo)
caches
forall env.
HasEnvConfig env =>
Path Abs Dir
-> NamedComponent -> Map [Char] FileCacheInfo -> RIO env ()
writeBuildCache Path Abs Dir
pkgDir NamedComponent
component forall a b. (a -> b) -> a -> b
$
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions (Map [Char] FileCacheInfo
cache forall a. a -> [a] -> [a]
: [Map [Char] FileCacheInfo]
newToCache)
forall (f :: * -> *) a. Applicative f => a -> f a
pure [PackageWarning]
warnings
checkForUnlistedFiles TTRemotePackage{} Path Abs Dir
_ = 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) <- 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 <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasBuildConfig env => Lens' env BuildConfig
buildConfigLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to BuildConfig -> Maybe Curator
bcCurator
let pname :: PackageName
pname = PackageIdentifier -> PackageName
pkgName 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
forall env a.
HasEnvConfig env =>
ActionContext
-> ExecuteEnv
-> Task
-> Map PackageIdentifier GhcPkgId
-> Maybe [Char]
-> (Package
-> Path Abs File
-> Path Abs Dir
-> (KeepOutputOpen -> ExcludeTHLoading -> [[Char]] -> RIO env ())
-> (Utf8Builder -> RIO env ())
-> OutputType
-> RIO env a)
-> RIO env a
withSingleContext ActionContext
ac ExecuteEnv
ee Task
task Map PackageIdentifier GhcPkgId
allDepsMap (forall a. a -> Maybe a
Just [Char]
"test") forall a b. (a -> b) -> a -> b
$ \Package
package Path Abs File
_cabalfp Path Abs Dir
pkgDir KeepOutputOpen -> ExcludeTHLoading -> [[Char]] -> RIO env ()
_cabal Utf8Builder -> RIO env ()
announce OutputType
outputType -> do
Config
config <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasConfig env => Lens' env Config
configL
let needHpc :: Bool
needHpc = TestOpts -> Bool
toCoverage TestOpts
topts
Bool
toRun <-
if TestOpts -> Bool
toDisableRun TestOpts
topts
then do
Utf8Builder -> RIO env ()
announce Utf8Builder
"Test running disabled by --no-run-tests flag."
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
else if TestOpts -> Bool
toRerunTests TestOpts
topts
then forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
else do
TestStatus
status <- forall env. HasEnvConfig env => Path Abs Dir -> RIO env TestStatus
getTestStatus Path Abs Dir
pkgDir
case TestStatus
status of
TestStatus
TSSuccess -> do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
testsToRun) forall a b. (a -> b) -> a -> b
$ Utf8Builder -> RIO env ()
announce Utf8Builder
"skipping already passed test"
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"
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
| Bool
otherwise -> do
Utf8Builder -> RIO env ()
announce Utf8Builder
"rerunning previously failed test"
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
TestStatus
TSUnknown -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
toRun forall a b. (a -> b) -> a -> b
$ do
Path Abs Dir
buildDir <- forall (m :: * -> *) env.
(MonadThrow m, MonadReader env m, HasEnvConfig env) =>
Path Abs Dir -> m (Path Abs Dir)
distDirFromDir Path Abs Dir
pkgDir
Path Abs Dir
hpcDir <- forall (m :: * -> *) env.
(MonadThrow m, MonadReader env m, HasEnvConfig env) =>
Path Abs Dir -> m (Path Abs Dir)
hpcDirFromDir Path Abs Dir
pkgDir
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
needHpc (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 <- forall k a. Map k a -> [(k, a)]
Map.toList forall a b. (a -> b) -> a -> b
$ Package -> Map Text TestSuiteInterface
packageTests Package
package
, let testName :: Text
testName = forall a b. (a, b) -> a
fst (Text, TestSuiteInterface)
testSuitePair
, Text
testName forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
testsToRun
]
Map Text (Maybe ExitCode)
errs <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Text, TestSuiteInterface)]
suitesToRun forall a b. (a -> b) -> a -> b
$ \(Text
testName, TestSuiteInterface
suiteInterface) -> do
let stestName :: [Char]
stestName = Text -> [Char]
T.unpack Text
testName
([Char]
testName', Bool
isTestTypeLib) <-
case TestSuiteInterface
suiteInterface of
C.TestSuiteLibV09{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char]
stestName forall a. [a] -> [a] -> [a]
++ [Char]
"Stub", Bool
True)
C.TestSuiteExeV10{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char]
stestName, Bool
False)
TestSuiteInterface
interface -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (TestSuiteInterface -> BuildException
TestSuiteTypeUnsupported TestSuiteInterface
interface)
let exeName :: [Char]
exeName = [Char]
testName' forall a. [a] -> [a] -> [a]
++
case Config -> Platform
configPlatform Config
config of
Platform Arch
_ OS
Windows -> [Char]
".exe"
Platform
_ -> [Char]
""
Path Abs File
tixPath <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Path Abs Dir
pkgDir forall b t. Path b Dir -> Path Rel t -> Path b t
</>) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadThrow m => [Char] -> m (Path Rel File)
parseRelFile forall a b. (a -> b) -> a -> b
$ [Char]
exeName forall a. [a] -> [a] -> [a]
++ [Char]
".tix"
Path Abs File
exePath <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Path Abs Dir
buildDir forall b t. Path b Dir -> Path Rel t -> Path b t
</>) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadThrow m => [Char] -> m (Path Rel File)
parseRelFile forall a b. (a -> b) -> a -> b
$ [Char]
"build/" forall a. [a] -> [a] -> [a]
++ [Char]
testName' forall a. [a] -> [a] -> [a]
++ [Char]
"/" forall a. [a] -> [a] -> [a]
++ [Char]
exeName
Bool
exists <- forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
exePath
Maybe Installed
installed <- case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
pname InstalledMap
installedMap of
Just (InstallLocation
_, Installed
installed) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Installed
installed
Maybe (InstallLocation, Installed)
Nothing -> do
Map PackageIdentifier Installed
idMap <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO (ExecuteEnv -> TVar (Map PackageIdentifier Installed)
eeGhcPkgIds ExecuteEnv
ee)
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ 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
_ GhcPkgId
ghcPkgId Maybe (Either License License)
_) -> [GhcPkgId
ghcPkgId]
Maybe Installed
_ -> []
GhcPkgId
thGhcId <- case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find ((forall a. Eq a => a -> a -> Bool
== PackageName
"template-haskell") forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageIdentifier -> PackageName
pkgName forall b c a. (b -> c) -> (a -> b) -> a -> c
. DumpPackage -> PackageIdentifier
dpPackageIdentforall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd)
(forall k a. Map k a -> [(k, a)]
Map.toList forall a b. (a -> b) -> a -> b
$ ExecuteEnv -> Map GhcPkgId DumpPackage
eeGlobalDumpPkgs ExecuteEnv
ee) of
Just (GhcPkgId
ghcId, DumpPackage
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure GhcPkgId
ghcId
Maybe (GhcPkgId, DumpPackage)
Nothing -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO BuildException
TemplateHaskellNotFoundBug
let setEnv :: [Char] -> ProcessContext -> IO ProcessContext
setEnv [Char]
f ProcessContext
pc = forall (m :: * -> *).
MonadIO m =>
ProcessContext
-> (Map Text Text -> Map Text Text) -> m ProcessContext
modifyEnvVars ProcessContext
pc forall a b. (a -> b) -> a -> b
$ \Map Text Text
envVars ->
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
"HASKELL_DIST_DIR" ([Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall b t. Path b t -> [Char]
toFilePath Path Abs Dir
buildDir) forall a b. (a -> b) -> a -> b
$
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
"GHC_ENVIRONMENT" ([Char] -> Text
T.pack [Char]
f) Map Text Text
envVars
fp' :: Path Abs File
fp' = ExecuteEnv -> Path Abs Dir
eeTempDir ExecuteEnv
ee forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
testGhcEnvRelFile
Int
randomInt <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a (m :: * -> *). (Random a, MonadIO m) => m a
randomIO :: IO Int)
let randomSuffix :: [Char]
randomSuffix = [Char]
"." forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show (forall a. Num a => a -> a
abs Int
randomInt)
[Char]
fp <- forall b t. Path b t -> [Char]
toFilePath forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) b.
MonadThrow m =>
[Char] -> Path b File -> m (Path b File)
addExtension [Char]
randomSuffix Path Abs File
fp'
let snapDBPath :: [Char]
snapDBPath = forall loc. Path loc Dir -> [Char]
toFilePathNoTrailingSep (BaseConfigOpts -> Path Abs Dir
bcoSnapDB forall a b. (a -> b) -> a -> b
$ ExecuteEnv -> BaseConfigOpts
eeBaseConfigOpts ExecuteEnv
ee)
localDBPath :: [Char]
localDBPath = forall loc. Path loc Dir -> [Char]
toFilePathNoTrailingSep (BaseConfigOpts -> Path Abs Dir
bcoLocalDB forall a b. (a -> b) -> a -> b
$ ExecuteEnv -> BaseConfigOpts
eeBaseConfigOpts ExecuteEnv
ee)
ghcEnv :: Utf8Builder
ghcEnv =
Utf8Builder
"clear-package-db\n" forall a. Semigroup a => a -> a -> a
<>
Utf8Builder
"global-package-db\n" forall a. Semigroup a => a -> a -> a
<>
Utf8Builder
"package-db " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString [Char]
snapDBPath forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"\n" forall a. Semigroup a => a -> a -> a
<>
Utf8Builder
"package-db " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString [Char]
localDBPath forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"\n" forall a. Semigroup a => a -> a -> a
<>
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\GhcPkgId
ghcId -> Utf8Builder
"package-id " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display (GhcPkgId -> Text
unGhcPkgId GhcPkgId
ghcId) forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"\n")
([GhcPkgId]
pkgGhcIdList forall a. [a] -> [a] -> [a]
++ GhcPkgId
thGhcIdforall a. a -> [a] -> [a]
:forall k a. Map k a -> [a]
M.elems Map PackageIdentifier GhcPkgId
allDepsMap)
forall (m :: * -> *). MonadIO m => [Char] -> Utf8Builder -> m ()
writeFileUtf8Builder [Char]
fp Utf8Builder
ghcEnv
ProcessContext
menv <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> ProcessContext -> IO ProcessContext
setEnv [Char]
fp forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Config -> EnvSettings -> IO ProcessContext
configProcessContextSettings Config
config EnvSettings
{ esIncludeLocals :: Bool
esIncludeLocals = Task -> InstallLocation
taskLocation Task
task forall a. Eq a => a -> a -> Bool
== InstallLocation
Local
, esIncludeGhcPackagePath :: Bool
esIncludeGhcPackagePath = Bool
True
, esStackExe :: Bool
esStackExe = Bool
True
, esLocaleUtf8 :: Bool
esLocaleUtf8 = Bool
False
, esKeepGhcRts :: Bool
esKeepGhcRts = Bool
False
}
let emptyResult :: Map Text (Maybe ExitCode)
emptyResult = forall k a. k -> a -> Map k a
Map.singleton Text
testName forall a. Maybe a
Nothing
forall env a.
HasProcessContext env =>
ProcessContext -> RIO env a -> RIO env a
withProcessContext ProcessContext
menv forall a b. (a -> b) -> a -> b
$ if Bool
exists
then do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
needHpc forall a b. (a -> b) -> a -> b
$ do
Bool
tixexists <- forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
tixPath
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
tixexists forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder
"Removing HPC file " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (forall b t. Path b t -> [Char]
toFilePath Path Abs File
tixPath))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. (MonadIO m, MonadCatch m) => m a -> m ()
ignoringAbsence (forall (m :: * -> *) b. MonadIO m => Path b File -> m ()
removeFile Path Abs File
tixPath)
let args :: [[Char]]
args = TestOpts -> [[Char]]
toAdditionalArgs TestOpts
topts
argsDisplay :: Text
argsDisplay = case [[Char]]
args of
[] -> Text
""
[[Char]]
_ -> Text
", args: " forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
" " (forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Text
showProcessArgDebug [[Char]]
args)
Utf8Builder -> RIO env ()
announce forall a b. (a -> b) -> a -> b
$ Utf8Builder
"test (suite: " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Text
testName forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Text
argsDisplay forall a. Semigroup a => a -> a -> a
<> Utf8Builder
")"
case OutputType
outputType of
OTConsole Maybe Utf8Builder
_ -> do
forall (m :: * -> *) env.
(MonadIO m, ?callStack::CallStack, MonadReader env m,
HasLogFunc env) =>
Utf8Builder -> m ()
logStickyDone Utf8Builder
""
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadIO m => Handle -> m ()
hFlush Handle
stdout
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadIO m => Handle -> m ()
hFlush Handle
stderr
OTLogFile Path Abs File
_ Handle
_ -> 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 -> forall a. Maybe a
Nothing forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (anyStreamType :: StreamType). StreamSpec anyStreamType ()
inherit
OTConsole (Just Utf8Builder
prefix) -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
(\ConduitT () ByteString (RIO env) ()
src -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit forall a b. (a -> b) -> a -> b
$ ConduitT () ByteString (RIO env) ()
src forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.|
forall (m :: * -> *). Monad m => ConduitT ByteString Text m ()
CT.decodeUtf8Lenient forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.|
forall (m :: * -> *). Monad m => ConduitT Text Text m ()
CT.lines forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.|
forall (m :: * -> *) a b. Monad m => (a -> b) -> ConduitT a b m ()
CL.map Text -> Text
stripCR forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.|
forall (m :: * -> *) a o.
Monad m =>
(a -> m ()) -> ConduitT a o m ()
CL.mapM_ (\Text
t -> forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Utf8Builder
prefix forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Text
t))
forall (m :: * -> *) i.
MonadIO m =>
StreamSpec 'STOutput (ConduitM i ByteString m ())
createSource
OTLogFile Path Abs File
_ Handle
h -> forall a. Maybe a
Nothing forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ 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 -> Maybe Int
toMaximumTimeSeconds TestOpts
topts, Int
maxSecs forall a. Ord a => a -> a -> Bool
> Int
0 = do
forall (m :: * -> *) a.
MonadUnliftIO m =>
Int -> m a -> m (Maybe a)
timeout (Int
maxSecs forall a. Num a => a -> a -> a
* Int
1000000) RIO env ExitCode
action
| Bool
otherwise = forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RIO env ExitCode
action
Maybe ExitCode
mec <- forall env (m :: * -> *) a.
(HasProcessContext env, MonadReader env m, MonadIO m) =>
[Char] -> m a -> m a
withWorkingDir (forall b t. Path b t -> [Char]
toFilePath Path Abs Dir
pkgDir) forall a b. (a -> b) -> a -> b
$
RIO env ExitCode -> RIO env (Maybe ExitCode)
optionalTimeout forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *) a.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
MonadIO m, ?callStack::CallStack) =>
[Char] -> [[Char]] -> (ProcessConfig () () () -> m a) -> m a
proc (forall b t. Path b t -> [Char]
toFilePath Path Abs File
exePath) [[Char]]
args 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 <- forall env (m :: * -> *).
(MonadReader env m, HasBuildConfig env, MonadThrow m) =>
Package -> Maybe [Char] -> m (Path Abs File)
buildLogPath Package
package (forall a. a -> Maybe a
Just [Char]
stestName)
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir (forall b t. Path b t -> Path b Dir
parent Path Abs File
logPath)
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall stdin stdin0 stdout stderr.
StreamSpec 'STInput stdin
-> ProcessConfig stdin0 stdout stderr
-> ProcessConfig stdin stdout stderr
setStdin
forall a b. (a -> b) -> a -> b
$ LByteString -> StreamSpec 'STInput ()
byteStringInput
forall a b. (a -> b) -> a -> b
$ ByteString -> LByteString
BL.fromStrict
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 forall a b. (a -> b) -> a -> b
$ forall a. IsString a => [Char] -> a
fromString forall a b. (a -> b) -> a -> b
$
forall a. Show a => a -> [Char]
show (Path Abs File
logPath, [Char] -> UnqualComponentName
mkUnqualComponentName (Text -> [Char]
T.unpack Text
testName))
else do
Bool
isTerminal <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasRunner env => Lens' env GlobalOpts
globalOptsLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to GlobalOpts -> Bool
globalTerminal
if TestOpts -> Bool
toAllowStdin TestOpts
topts Bool -> Bool -> Bool
&& Bool
isTerminal
then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. a -> a
id
else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall stdin stdin0 stdout stderr.
StreamSpec 'STInput stdin
-> ProcessConfig stdin0 stdout stderr
-> ProcessConfig stdin stdout stderr
setStdin forall a b. (a -> b) -> a -> b
$ LByteString -> StreamSpec 'STInput ()
byteStringInput 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
forall a b. (a -> b) -> a -> b
$ forall stdout stdin stdout0 stderr.
StreamSpec 'STOutput stdout
-> ProcessConfig stdin stdout0 stderr
-> ProcessConfig stdin stdout stderr
setStdout StreamSpec 'STOutput (Maybe (RIO env ()))
output
forall a b. (a -> b) -> a -> b
$ 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
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 forall a b. (a -> b) -> a -> b
$ \Process () (Maybe (RIO env ())) (Maybe (RIO env ()))
p -> do
case (forall stdin stdout stderr. Process stdin stdout stderr -> stdout
getStdout Process () (Maybe (RIO env ())) (Maybe (RIO env ()))
p, 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) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
(Just RIO env ()
x, Just RIO env ()
y) -> 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) -> forall a. (?callStack::CallStack) => Bool -> a -> a
assert Bool
False forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m ()
concurrently_ (forall a. a -> Maybe a -> a
fromMaybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) Maybe (RIO env ())
x) (forall a. a -> Maybe a -> a
fromMaybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) Maybe (RIO env ())
y)
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 -> forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
""
OutputType
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
needHpc forall a b. (a -> b) -> a -> b
$
forall env.
HasEnvConfig env =>
PackageName -> Path Abs File -> [Char] -> RIO env ()
updateTixFile (Package -> PackageName
packageName Package
package) Path Abs File
tixPath [Char]
testName'
let announceResult :: Utf8Builder -> RIO env ()
announceResult Utf8Builder
result = Utf8Builder -> RIO env ()
announce forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Test suite " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Text
testName forall a. Semigroup a => a -> a -> a
<> 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"
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall k a. Map k a
Map.empty
Maybe ExitCode
Nothing -> do
Utf8Builder -> RIO env ()
announceResult Utf8Builder
"timed out"
if Bool
expectFailure
then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall k a. Map k a
Map.empty
else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall k a. k -> a -> Map k a
Map.singleton Text
testName forall a. Maybe a
Nothing
Just ExitCode
ec -> do
Utf8Builder -> RIO env ()
announceResult Utf8Builder
"failed"
if Bool
expectFailure
then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall k a. Map k a
Map.empty
else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall k a. k -> a -> Map k a
Map.singleton Text
testName (forall a. a -> Maybe a
Just ExitCode
ec)
else do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
expectFailure forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logError forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> Utf8Builder
displayShow forall a b. (a -> b) -> a -> b
$ Bool -> [Char] -> [Char] -> [Char] -> BuildException
TestSuiteExeMissing
(Package -> BuildType
packageBuildType Package
package forall a. Eq a => a -> a -> Bool
== BuildType
C.Simple)
[Char]
exeName
(PackageName -> [Char]
packageNameString (Package -> PackageName
packageName Package
package))
(Text -> [Char]
T.unpack Text
testName)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map Text (Maybe ExitCode)
emptyResult
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
needHpc forall a b. (a -> b) -> a -> b
$ do
let testsToRun' :: [Text]
testsToRun' = forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
f [Text]
testsToRun
f :: Text -> Text
f Text
tName =
case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
tName (Package -> Map Text TestSuiteInterface
packageTests Package
package) of
Just C.TestSuiteLibV09{} -> Text
tName forall a. Semigroup a => a -> a -> a
<> Text
"Stub"
Maybe TestSuiteInterface
_ -> Text
tName
forall env.
HasEnvConfig env =>
Path Abs Dir -> Package -> [Text] -> RIO env ()
generateHpcReport Path Abs Dir
pkgDir Package
package [Text]
testsToRun'
ByteString
bs <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
case OutputType
outputType of
OTConsole Maybe Utf8Builder
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
""
OTLogFile Path Abs File
logFile Handle
h -> do
forall (m :: * -> *). MonadIO m => Handle -> m ()
hClose Handle
h
[Char] -> IO ByteString
S.readFile forall a b. (a -> b) -> a -> b
$ forall b t. Path b t -> [Char]
toFilePath Path Abs File
logFile
let succeeded :: Bool
succeeded = forall k a. Map k a -> Bool
Map.null Map Text (Maybe ExitCode)
errs
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
succeeded Bool -> Bool -> Bool
|| Bool
expectFailure) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM 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
_ -> forall a. a -> Maybe a
Just Path Abs File
fp
OTConsole Maybe Utf8Builder
_ -> forall a. Maybe a
Nothing)
ByteString
bs
forall env.
HasEnvConfig env =>
Path Abs Dir -> TestStatus -> RIO env ()
setTestStatus Path Abs Dir
pkgDir 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) <- 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
forall env a.
HasEnvConfig env =>
ActionContext
-> ExecuteEnv
-> Task
-> Map PackageIdentifier GhcPkgId
-> Maybe [Char]
-> (Package
-> Path Abs File
-> Path Abs Dir
-> (KeepOutputOpen -> ExcludeTHLoading -> [[Char]] -> RIO env ())
-> (Utf8Builder -> RIO env ())
-> OutputType
-> RIO env a)
-> RIO env a
withSingleContext ActionContext
ac ExecuteEnv
ee Task
task Map PackageIdentifier GhcPkgId
allDepsMap (forall a. a -> Maybe a
Just [Char]
"bench") forall a b. (a -> b) -> a -> b
$ \Package
_package Path Abs File
_cabalfp Path Abs Dir
_pkgDir KeepOutputOpen -> ExcludeTHLoading -> [[Char]] -> RIO env ()
cabal Utf8Builder -> RIO env ()
announce OutputType
_outputType -> do
let args :: [[Char]]
args = forall a b. (a -> b) -> [a] -> [b]
map Text -> [Char]
T.unpack [Text]
benchesToRun forall a. Semigroup a => a -> a -> a
<> forall b a. b -> (a -> b) -> Maybe a -> b
maybe []
((forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
"--benchmark-options=" forall a. Semigroup a => a -> a -> a
<>))
(BenchmarkOpts -> Maybe [Char]
beoAdditionalArgs BenchmarkOpts
beopts)
Bool
toRun <-
if BenchmarkOpts -> Bool
beoDisableRun BenchmarkOpts
beopts
then do
Utf8Builder -> RIO env ()
announce Utf8Builder
"Benchmark running disabled by --no-run-benchmarks flag."
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
else do
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
toRun forall a b. (a -> b) -> a -> b
$ do
Utf8Builder -> RIO env ()
announce Utf8Builder
"benchmarks"
KeepOutputOpen -> ExcludeTHLoading -> [[Char]] -> RIO env ()
cabal KeepOutputOpen
CloseOnException ExcludeTHLoading
KeepTHLoading ([Char]
"bench" forall a. a -> [a] -> [a]
: [[Char]]
args)
data ExcludeTHLoading = ExcludeTHLoading | KeepTHLoading
data ConvertPathsToAbsolute = ConvertPathsToAbsolute | KeepPathsAsIs
data KeepOutputOpen = KeepOpen | CloseOnException deriving KeepOutputOpen -> KeepOutputOpen -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: KeepOutputOpen -> KeepOutputOpen -> Bool
$c/= :: KeepOutputOpen -> KeepOutputOpen -> Bool
== :: KeepOutputOpen -> KeepOutputOpen -> Bool
$c== :: KeepOutputOpen -> KeepOutputOpen -> Bool
Eq
mungeBuildOutput :: forall m. MonadIO m
=> ExcludeTHLoading
-> ConvertPathsToAbsolute
-> Path Abs Dir
-> ActualCompiler
-> ConduitM Text Text m ()
mungeBuildOutput :: forall (m :: * -> *).
MonadIO m =>
ExcludeTHLoading
-> ConvertPathsToAbsolute
-> Path Abs Dir
-> ActualCompiler
-> ConduitM Text Text m ()
mungeBuildOutput ExcludeTHLoading
excludeTHLoading ConvertPathsToAbsolute
makeAbsolute Path Abs Dir
pkgDir ActualCompiler
compilerVer = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *). Monad m => ConduitT Text Text m ()
CT.lines
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) a b. Monad m => (a -> b) -> ConduitT a b m ()
CL.map Text -> Text
stripCR
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) a. Monad m => (a -> Bool) -> ConduitT a a m ()
CL.filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
isTHLoading)
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 m ()
filterLinkerWarnings
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 m ()
toAbsolute
where
isTHLoading :: Text -> Bool
isTHLoading :: Text -> Bool
isTHLoading = case ExcludeTHLoading
excludeTHLoading of
ExcludeTHLoading
KeepTHLoading -> forall a b. a -> b -> a
const Bool
False
ExcludeTHLoading
ExcludeTHLoading -> \Text
bs ->
Text
"Loading package " Text -> Text -> Bool
`T.isPrefixOf` Text
bs Bool -> Bool -> Bool
&&
(Text
"done." Text -> Text -> Bool
`T.isSuffixOf` Text
bs Bool -> Bool -> Bool
|| Text
"done.\r" Text -> Text -> Bool
`T.isSuffixOf` Text
bs)
filterLinkerWarnings :: ConduitM Text Text m ()
filterLinkerWarnings :: ConduitT Text Text m ()
filterLinkerWarnings
| ActualCompiler -> Version
getGhcVersion ActualCompiler
compilerVer forall a. Ord a => a -> a -> Bool
>= [Int] -> Version
mkVersion [Int
7, Int
8] = ConduitT Text Text m ()
doNothing
| Bool
otherwise = forall (m :: * -> *) a. Monad m => (a -> Bool) -> ConduitT a a m ()
CL.filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
isLinkerWarning)
isLinkerWarning :: Text -> Bool
isLinkerWarning :: Text -> Bool
isLinkerWarning Text
str =
(Text
"ghc.exe: warning:" Text -> Text -> Bool
`T.isPrefixOf` Text
str Bool -> Bool -> Bool
|| Text
"ghc.EXE: warning:" Text -> Text -> Bool
`T.isPrefixOf` Text
str) Bool -> Bool -> Bool
&&
Text
"is linked instead of __imp_" Text -> Text -> Bool
`T.isInfixOf` Text
str
toAbsolute :: ConduitM Text Text m ()
toAbsolute :: ConduitT Text Text m ()
toAbsolute = case ConvertPathsToAbsolute
makeAbsolute of
ConvertPathsToAbsolute
KeepPathsAsIs -> ConduitT Text Text m ()
doNothing
ConvertPathsToAbsolute
ConvertPathsToAbsolute -> forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ConduitT a b m ()
CL.mapM Text -> m Text
toAbsolutePath
toAbsolutePath :: Text -> m Text
toAbsolutePath :: Text -> m Text
toAbsolutePath Text
bs = do
let (Text
x, Text
y) = (Char -> Bool) -> Text -> (Text, Text)
T.break (forall a. Eq a => a -> a -> Bool
== Char
':') Text
bs
Maybe Text
mabs <-
if Text -> Bool
isValidSuffix Text
y
then forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((Char -> Bool) -> Text -> Text
T.takeWhile Char -> Bool
isSpace Text
x forall a. Semigroup a => a -> a -> a
<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b t. Path b t -> [Char]
toFilePath)) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a.
(MonadIO m, MonadCatch m) =>
m a -> m (Maybe a)
forgivingAbsence (forall (m :: * -> *).
MonadIO m =>
Path Abs Dir -> [Char] -> m (Path Abs File)
resolveFile Path Abs Dir
pkgDir (Text -> [Char]
T.unpack forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> Text
T.dropWhile Char -> Bool
isSpace Text
x)) forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch`
\(PathException
_ :: PathException) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
case Maybe Text
mabs of
Maybe Text
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
bs
Just Text
fp -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text
fp Text -> Text -> Text
`T.append` Text
y
doNothing :: ConduitM Text Text m ()
doNothing :: ConduitT Text Text m ()
doNothing = forall (m :: * -> *) i o r.
Monad m =>
(i -> ConduitT i o m r) -> ConduitT i o m ()
awaitForever forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield
isValidSuffix :: Text -> Bool
isValidSuffix = forall a b. Either a b -> Bool
isRight forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Parser a -> Text -> Either [Char] a
parseOnly Parser Text ()
lineCol
lineCol :: Parser Text ()
lineCol = Char -> Parser Text Char
char Char
':'
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Alternative f => [f a] -> f a
choice
[ Parser Text [Char]
num forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Parser Text Char
char Char
':' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser Text [Char]
num forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Char -> Parser Text Char
char Char
'-' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser Text [Char]
num) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
, Char -> Parser Text Char
char Char
'(' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser Text [Char]
num forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Parser Text Char
char Char
',' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser Text [Char]
num forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Text -> Parser Text Text
P.string Text
")-(" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser Text [Char]
num forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Parser Text Char
char Char
',' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser Text [Char]
num forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Parser Text Char
char Char
')' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Parser Text Char
char Char
':'
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
where num :: Parser Text [Char]
num = forall (f :: * -> *) a. Alternative f => f a -> f [a]
some Parser Text Char
digit
data PrefixWithTimestamps = PrefixWithTimestamps | WithoutTimestamps
sinkWithTimestamps :: MonadIO m => PrefixWithTimestamps -> Handle -> ConduitT ByteString Void m ()
sinkWithTimestamps :: forall (m :: * -> *).
MonadIO m =>
PrefixWithTimestamps -> Handle -> ConduitT ByteString Void m ()
sinkWithTimestamps PrefixWithTimestamps
prefixWithTimestamps Handle
h =
case PrefixWithTimestamps
prefixWithTimestamps of
PrefixWithTimestamps
PrefixWithTimestamps ->
forall (m :: * -> *).
Monad m =>
ConduitT ByteString ByteString m ()
CB.lines forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ConduitT a b m ()
CL.mapM forall {m :: * -> *}. MonadIO m => ByteString -> m ByteString
addTimestamp forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) a b. Monad m => (a -> b) -> ConduitT a b m ()
CL.map (forall a. Semigroup a => a -> a -> a
<> ByteString
"\n") forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) o.
MonadIO m =>
Handle -> ConduitT ByteString o m ()
sinkHandle Handle
h
PrefixWithTimestamps
WithoutTimestamps -> forall (m :: * -> *) o.
MonadIO m =>
Handle -> ConduitT ByteString o m ()
sinkHandle Handle
h
where
addTimestamp :: ByteString -> m ByteString
addTimestamp ByteString
theLine = do
ZonedTime
now <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ZonedTime
getZonedTime
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ZonedTime -> ByteString
formatZonedTimeForLog ZonedTime
now forall a. Semigroup a => a -> a -> a
<> ByteString
" " forall a. Semigroup a => a -> a -> a
<> ByteString
theLine)
formatZonedTimeForLog :: ZonedTime -> ByteString
formatZonedTimeForLog :: ZonedTime -> ByteString
formatZonedTimeForLog = [Char] -> ByteString
S8.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. FormatTime t => TimeLocale -> [Char] -> t -> [Char]
formatTime TimeLocale
defaultTimeLocale [Char]
"%Y-%m-%dT%H:%M:%S%6Q"
getSetupHs :: Path Abs Dir
-> IO (Path Abs File)
getSetupHs :: Path Abs Dir -> IO (Path Abs File)
getSetupHs Path Abs Dir
dir = do
Bool
exists1 <- forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
fp1
if Bool
exists1
then forall (f :: * -> *) a. Applicative f => a -> f a
pure Path Abs File
fp1
else do
Bool
exists2 <- forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
fp2
if Bool
exists2
then forall (f :: * -> *) a. Applicative f => a -> f a
pure Path Abs File
fp2
else forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ Path Abs Dir -> BuildException
NoSetupHsFound Path Abs Dir
dir
where
fp1 :: Path Abs File
fp1 = Path Abs Dir
dir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFileSetupHs
fp2 :: Path Abs File
fp2 = Path Abs Dir
dir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFileSetupLhs
extraBuildOptions :: (HasEnvConfig env, HasRunner env)
=> WhichCompiler -> BuildOpts -> RIO env [String]
WhichCompiler
wc BuildOpts
bopts = do
Maybe [Char]
colorOpt <- forall env.
(HasRunner env, HasEnvConfig env) =>
RIO env (Maybe [Char])
appropriateGhcColorFlag
let optsFlag :: [Char]
optsFlag = WhichCompiler -> [Char]
compilerOptionsCabalFlag WhichCompiler
wc
baseOpts :: [Char]
baseOpts = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"" ([Char]
" " forall a. [a] -> [a] -> [a]
++) Maybe [Char]
colorOpt
if TestOpts -> Bool
toCoverage (BuildOpts -> TestOpts
boptsTestOpts BuildOpts
bopts)
then do
[Char]
hpcIndexDir <- forall loc. Path loc Dir -> [Char]
toFilePathNoTrailingSep forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) env.
(MonadThrow m, MonadReader env m, HasEnvConfig env) =>
m (Path Rel Dir)
hpcRelativeDir
forall (f :: * -> *) a. Applicative f => a -> f a
pure [[Char]
optsFlag, [Char]
"-hpcdir " forall a. [a] -> [a] -> [a]
++ [Char]
hpcIndexDir forall a. [a] -> [a] -> [a]
++ [Char]
baseOpts]
else
forall (f :: * -> *) a. Applicative f => a -> f a
pure [[Char]
optsFlag, [Char]
baseOpts]
primaryComponentOptions :: Map Text ExecutableBuildStatus -> LocalPackage -> [String]
primaryComponentOptions :: Map Text ExecutableBuildStatus -> LocalPackage -> [[Char]]
primaryComponentOptions Map Text ExecutableBuildStatus
executableBuildStatuses LocalPackage
lp =
(case Package -> PackageLibraries
packageLibraries Package
package of
PackageLibraries
NoLibraries -> []
HasLibraries Set Text
names ->
forall a b. (a -> b) -> [a] -> [b]
map Text -> [Char]
T.unpack
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text
T.append Text
"lib:" ([Char] -> Text
T.pack (PackageName -> [Char]
packageNameString (Package -> PackageName
packageName Package
package)))
forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (Text -> Text -> Text
T.append Text
"flib:") (forall a. Set a -> [a]
Set.toList Set Text
names)) forall a. [a] -> [a] -> [a]
++
forall a b. (a -> b) -> [a] -> [b]
map (Text -> [Char]
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text
T.append Text
"lib:") (forall a. Set a -> [a]
Set.toList forall a b. (a -> b) -> a -> b
$ Package -> Set Text
packageInternalLibraries Package
package) forall a. [a] -> [a] -> [a]
++
forall a b. (a -> b) -> [a] -> [b]
map (Text -> [Char]
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text
T.append Text
"exe:") (forall a. Set a -> [a]
Set.toList forall a b. (a -> b) -> a -> b
$ Map Text ExecutableBuildStatus -> LocalPackage -> Set Text
exesToBuild Map Text ExecutableBuildStatus
executableBuildStatuses LocalPackage
lp)
where
package :: Package
package = LocalPackage -> Package
lpPackage LocalPackage
lp
exesToBuild :: Map Text ExecutableBuildStatus -> LocalPackage -> Set Text
exesToBuild :: Map Text ExecutableBuildStatus -> LocalPackage -> Set Text
exesToBuild Map Text ExecutableBuildStatus
executableBuildStatuses LocalPackage
lp =
if forall k. Map k ExecutableBuildStatus -> Bool
cabalIsSatisfied Map Text ExecutableBuildStatus
executableBuildStatuses Bool -> Bool -> Bool
&& LocalPackage -> Bool
lpWanted LocalPackage
lp
then Set NamedComponent -> Set Text
exeComponents (LocalPackage -> Set NamedComponent
lpComponents LocalPackage
lp)
else Package -> Set Text
packageExes (LocalPackage -> Package
lpPackage LocalPackage
lp)
cabalIsSatisfied :: Map k ExecutableBuildStatus -> Bool
cabalIsSatisfied :: forall k. Map k ExecutableBuildStatus -> Bool
cabalIsSatisfied = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall a. Eq a => a -> a -> Bool
== ExecutableBuildStatus
ExecutableBuilt) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [a]
M.elems
finalComponentOptions :: LocalPackage -> [String]
finalComponentOptions :: LocalPackage -> [[Char]]
finalComponentOptions LocalPackage
lp =
forall a b. (a -> b) -> [a] -> [b]
map (Text -> [Char]
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamedComponent -> Text
renderComponent) forall a b. (a -> b) -> a -> b
$
forall a. Set a -> [a]
Set.toList forall a b. (a -> b) -> a -> b
$
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 -> Set NamedComponent
lpComponents LocalPackage
lp)
taskComponents :: Task -> Set NamedComponent
taskComponents :: Task -> Set NamedComponent
taskComponents Task
task =
case Task -> TaskType
taskType Task
task of
TTLocalMutable LocalPackage
lp -> LocalPackage -> Set NamedComponent
lpComponents LocalPackage
lp
TTRemotePackage{} -> forall a. Set a
Set.empty
expectTestFailure :: PackageName -> Maybe Curator -> Bool
expectTestFailure :: PackageName -> Maybe Curator -> Bool
expectTestFailure PackageName
pname Maybe Curator
mcurator =
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (forall a. Ord a => a -> Set a -> Bool
Set.member PackageName
pname forall b c a. (b -> c) -> (a -> b) -> a -> c
. Curator -> Set PackageName
curatorExpectTestFailure) Maybe Curator
mcurator
expectBenchmarkFailure :: PackageName -> Maybe Curator -> Bool
expectBenchmarkFailure :: PackageName -> Maybe Curator -> Bool
expectBenchmarkFailure PackageName
pname Maybe Curator
mcurator =
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (forall a. Ord a => a -> Set a -> Bool
Set.member PackageName
pname forall b c a. (b -> c) -> (a -> b) -> a -> c
. Curator -> Set PackageName
curatorExpectBenchmarkFailure) Maybe Curator
mcurator
fulfillCuratorBuildExpectations ::
(HasLogFunc env, HasCallStack)
=> PackageName
-> Maybe Curator
-> Bool
-> Bool
-> b
-> RIO env b
-> RIO env b
fulfillCuratorBuildExpectations :: forall env b.
(HasLogFunc env, ?callStack::CallStack) =>
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 <- 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
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$ forall a. IsString a => [Char] -> a
fromString (PackageName -> [Char]
packageNameString PackageName
pname) forall a. Semigroup a => a -> a -> a
<> Utf8Builder
": unexpected test build success"
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
res
Left SomeException
_ -> 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 <- 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
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$ forall a. IsString a => [Char] -> a
fromString (PackageName -> [Char]
packageNameString PackageName
pname) forall a. Semigroup a => a -> a -> a
<> Utf8Builder
": unexpected benchmark build success"
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
res
Left SomeException
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure b
defValue
fulfillCuratorBuildExpectations PackageName
_ Maybe Curator
_ Bool
_ Bool
_ b
_ RIO env b
action = do
RIO env b
action