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