{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NoFieldSelectors #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
module Stack.Build.ExecuteEnv
( ExecuteEnv (..)
, withExecuteEnv
, withSingleContext
, ExcludeTHLoading (..)
, KeepOutputOpen (..)
, ExecutableBuildStatus (..)
, OutputType (..)
) where
import Control.Concurrent.Companion ( Companion, withCompanion )
import Control.Concurrent.Execute
( ActionContext (..), ActionId (..), Concurrency (..) )
import Crypto.Hash ( SHA256 (..), hashWith )
import Data.Attoparsec.Text ( char, choice, digit, parseOnly )
import qualified Data.Attoparsec.Text as P ( string )
import qualified Data.ByteArray as Mem ( convert )
import qualified Data.ByteString as S
import qualified Data.ByteString.Base64.URL as B64URL
import qualified Data.ByteString.Builder ( toLazyByteString )
import qualified Data.ByteString.Char8 as S8
import Data.Char ( isSpace )
import Conduit
( ConduitT, awaitForever, sinkHandle, withSinkFile
, withSourceFile, yield
)
import qualified Data.Conduit.Binary as CB
import qualified Data.Conduit.List as CL
import qualified Data.Conduit.Text as CT
import qualified Data.List as L
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified Data.Text as T
import Data.Text.Encoding ( decodeUtf8 )
import Data.Time
( ZonedTime, defaultTimeLocale, formatTime, getZonedTime )
import qualified Distribution.PackageDescription as C
import qualified Distribution.Simple.Build.Macros as C
import Distribution.System ( OS (..), Platform (..) )
import Distribution.Types.PackageName ( mkPackageName )
import Distribution.Verbosity ( showForCabal )
import Distribution.Version ( mkVersion )
import Path
( PathException, (</>), parent, parseRelDir, parseRelFile )
import Path.Extra ( forgivingResolveFile, toFilePathNoTrailingSep )
import Path.IO
( doesDirExist, doesFileExist, ensureDir, ignoringAbsence
, removeFile, renameDir, renameFile
)
import RIO.Process
( eceExitCode, proc, runProcess_, setStdout, useHandleOpen
, withWorkingDir
)
import Stack.Config ( checkOwnership )
import Stack.Constants
( cabalPackageName, relDirDist, relDirSetup
, relDirSetupExeCache, relDirSetupExeSrc, relFileBuildLock
, relFileSetupHs, relFileSetupLhs, relFileSetupLower
, relFileSetupMacrosH, setupGhciShimCode, stackProgName
)
import Stack.Constants.Config ( distDirFromDir, distRelativeDir )
import Stack.Package ( buildLogPath )
import Stack.Prelude
import Stack.Types.ApplyGhcOptions ( ApplyGhcOptions (..) )
import Stack.Types.Build
( ConvertPathsToAbsolute (..), ExcludeTHLoading (..)
, KeepOutputOpen (..), TaskType (..), taskTypeLocation
, taskTypePackageIdentifier
)
import Stack.Types.Build.Exception
( BuildException (..), BuildPrettyException (..) )
import Stack.Types.BuildOpts ( BuildOpts (..) )
import Stack.Types.BuildOptsCLI ( BuildOptsCLI (..) )
import Stack.Types.BuildOptsMonoid ( CabalVerbosity (..) )
import Stack.Types.Compiler
( ActualCompiler (..), WhichCompiler (..)
, compilerVersionString, getGhcVersion, whichCompilerL
)
import Stack.Types.CompilerPaths
( CompilerPaths (..), HasCompiler (..), cabalVersionL
, getCompilerPath
)
import Stack.Types.Config
( Config (..), HasConfig (..), stackRootL )
import Stack.Types.ConfigureOpts ( BaseConfigOpts (..) )
import Stack.Types.Dependency ( DepValue(..) )
import Stack.Types.DumpLogs ( DumpLogs (..) )
import Stack.Types.DumpPackage ( DumpPackage (..) )
import Stack.Types.EnvConfig
( HasEnvConfig (..), actualCompilerVersionL
, platformGhcRelDir, shouldForceGhcColorFlag
)
import Stack.Types.EnvSettings ( EnvSettings (..) )
import Stack.Types.GhcPkgId ( GhcPkgId, ghcPkgIdString )
import Stack.Types.Installed ( InstallLocation (..), Installed (..) )
import Stack.Types.Package
( LocalPackage (..), Package (..), packageIdentifier )
import Stack.Types.Platform ( HasPlatform (..) )
import Stack.Types.Version ( withinRange )
import qualified System.Directory as D
import System.Environment ( lookupEnv )
import System.FileLock
( SharedExclusive (..), withFileLock, withTryFileLock )
data ExecutableBuildStatus
= ExecutableBuilt
| ExecutableNotBuilt
deriving (ExecutableBuildStatus -> ExecutableBuildStatus -> Bool
(ExecutableBuildStatus -> ExecutableBuildStatus -> Bool)
-> (ExecutableBuildStatus -> ExecutableBuildStatus -> Bool)
-> Eq ExecutableBuildStatus
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ExecutableBuildStatus -> ExecutableBuildStatus -> Bool
== :: ExecutableBuildStatus -> ExecutableBuildStatus -> Bool
$c/= :: ExecutableBuildStatus -> ExecutableBuildStatus -> Bool
/= :: 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
$ccompare :: ExecutableBuildStatus -> ExecutableBuildStatus -> Ordering
compare :: ExecutableBuildStatus -> ExecutableBuildStatus -> Ordering
$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
>= :: ExecutableBuildStatus -> ExecutableBuildStatus -> Bool
$cmax :: ExecutableBuildStatus
-> ExecutableBuildStatus -> ExecutableBuildStatus
max :: ExecutableBuildStatus
-> ExecutableBuildStatus -> ExecutableBuildStatus
$cmin :: ExecutableBuildStatus
-> ExecutableBuildStatus -> ExecutableBuildStatus
min :: ExecutableBuildStatus
-> ExecutableBuildStatus -> ExecutableBuildStatus
Ord, 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
$cshowsPrec :: Int -> ExecutableBuildStatus -> ShowS
showsPrec :: Int -> ExecutableBuildStatus -> ShowS
$cshow :: ExecutableBuildStatus -> String
show :: ExecutableBuildStatus -> String
$cshowList :: [ExecutableBuildStatus] -> ShowS
showList :: [ExecutableBuildStatus] -> ShowS
Show)
data ExecuteEnv = ExecuteEnv
{ ExecuteEnv -> MVar ()
installLock :: !(MVar ())
, ExecuteEnv -> BuildOpts
buildOpts :: !BuildOpts
, ExecuteEnv -> BuildOptsCLI
buildOptsCLI :: !BuildOptsCLI
, ExecuteEnv -> BaseConfigOpts
baseConfigOpts :: !BaseConfigOpts
, ExecuteEnv -> TVar (Map PackageIdentifier Installed)
ghcPkgIds :: !(TVar (Map PackageIdentifier Installed))
, ExecuteEnv -> Path Abs Dir
tempDir :: !(Path Abs Dir)
, ExecuteEnv -> Path Abs File
setupHs :: !(Path Abs File)
, ExecuteEnv -> Path Abs File
setupShimHs :: !(Path Abs File)
, ExecuteEnv -> Maybe (Path Abs File)
setupExe :: !(Maybe (Path Abs File))
, ExecuteEnv -> Version
cabalPkgVer :: !Version
, ExecuteEnv -> Int
totalWanted :: !Int
, ExecuteEnv -> [LocalPackage]
locals :: ![LocalPackage]
, ExecuteEnv -> Path Abs Dir
globalDB :: !(Path Abs Dir)
, ExecuteEnv -> Map GhcPkgId DumpPackage
globalDumpPkgs :: !(Map GhcPkgId DumpPackage)
, ExecuteEnv -> TVar (Map GhcPkgId DumpPackage)
snapshotDumpPkgs :: !(TVar (Map GhcPkgId DumpPackage))
, ExecuteEnv -> TVar (Map GhcPkgId DumpPackage)
localDumpPkgs :: !(TVar (Map GhcPkgId DumpPackage))
, ExecuteEnv -> TChan (Path Abs Dir, Path Abs File)
logFiles :: !(TChan (Path Abs Dir, Path Abs File))
, ExecuteEnv -> IORef (Set PackageName)
customBuilt :: !(IORef (Set PackageName))
, ExecuteEnv -> Maybe Int
largestPackageName :: !(Maybe Int)
, ExecuteEnv -> Text
pathEnvVar :: !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 :: forall env.
HasEnvConfig env =>
Path Abs File
-> Path Abs File -> Path Abs Dir -> RIO env (Maybe (Path Abs File))
getSetupExe Path Abs File
setupHs Path Abs File
setupShimHs Path Abs Dir
tmpdir = do
WhichCompiler
wc <- Getting WhichCompiler env WhichCompiler -> RIO env WhichCompiler
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting WhichCompiler env WhichCompiler -> RIO env WhichCompiler)
-> Getting WhichCompiler env WhichCompiler -> RIO env WhichCompiler
forall a b. (a -> b) -> a -> b
$ Getting WhichCompiler env ActualCompiler
forall env. HasSourceMap env => SimpleGetter env ActualCompiler
SimpleGetter env ActualCompiler
actualCompilerVersionL Getting WhichCompiler env ActualCompiler
-> ((WhichCompiler -> Const WhichCompiler WhichCompiler)
-> ActualCompiler -> Const WhichCompiler ActualCompiler)
-> Getting WhichCompiler env WhichCompiler
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WhichCompiler -> Const WhichCompiler WhichCompiler)
-> ActualCompiler -> Const WhichCompiler ActualCompiler
forall r. Getting r ActualCompiler WhichCompiler
whichCompilerL
Path Rel Dir
platformDir <- RIO env (Path Rel Dir)
forall env (m :: * -> *).
(HasEnvConfig env, MonadReader env m, 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
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
SimpleGetter env Version
cabalVersionL Getting 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
SimpleGetter env ActualCompiler
actualCompilerVersionL Getting 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
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)
Lens' Config (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 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 a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> RIO env Bool) -> IO Bool -> RIO env Bool
forall a b. (a -> b) -> a -> b
$ 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 a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 a b. (a -> b) -> RIO env a -> RIO env b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Path Abs Dir
setupDir </>) (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 a b. (a -> b) -> RIO env a -> RIO env b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Path Abs Dir
setupDir </>) (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) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
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 () () ()
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 ->
BuildPrettyException -> RIO env ()
forall e (m :: * -> *) a.
(Exception e, MonadThrow m, Pretty e) =>
e -> m a
prettyThrowM (BuildPrettyException -> RIO env ())
-> BuildPrettyException -> RIO env ()
forall a b. (a -> b) -> a -> b
$ ExitCode
-> Maybe PackageIdentifier
-> Path Abs File
-> [String]
-> Maybe (Path Abs File)
-> [Text]
-> BuildPrettyException
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 a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 :: forall env a.
HasEnvConfig env =>
BuildOpts
-> BuildOptsCLI
-> BaseConfigOpts
-> [LocalPackage]
-> [DumpPackage]
-> [DumpPackage]
-> [DumpPackage]
-> Maybe Int
-> (ExecuteEnv -> RIO env a)
-> RIO env a
withExecuteEnv
BuildOpts
buildOpts
BuildOptsCLI
buildOptsCLI
BaseConfigOpts
baseConfigOpts
[LocalPackage]
locals
[DumpPackage]
globalPackages
[DumpPackage]
snapshotPackages
[DumpPackage]
localPackages
Maybe Int
largestPackageName
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
tempDir -> do
MVar ()
installLock <- IO (MVar ()) -> RIO env (MVar ())
forall a. IO a -> RIO env a
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)
ghcPkgIds <- IO (TVar (Map PackageIdentifier Installed))
-> RIO env (TVar (Map PackageIdentifier Installed))
forall a. IO a -> RIO env a
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
Lens' env Config
configL
IORef (Set PackageName)
customBuilt <- 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)
Lens' Config (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
let setupStub :: String
setupStub = String
"setup-" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
simpleSetupHash
Path Rel File
setupFileName <- String -> RIO env (Path Rel File)
forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile (String
setupStub String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
".hs")
Path Rel File
setupHiName <- String -> RIO env (Path Rel File)
forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile (String
setupStub String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
".hi")
Path Rel File
setupOName <- String -> RIO env (Path Rel File)
forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile (String
setupStub String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
".o")
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
setupHi :: Path Abs File
setupHi = 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
setupHiName
setupO :: Path Abs File
setupO = 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
setupOName
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
RIO env () -> RIO env ()
forall (m :: * -> *) a. (MonadIO m, MonadCatch m) => m a -> m ()
ignoringAbsence (Path Abs File -> RIO env ()
forall (m :: * -> *) b. MonadIO m => Path b File -> m ()
removeFile Path Abs File
setupHi)
RIO env () -> RIO env ()
forall (m :: * -> *) a. (MonadIO m, MonadCatch m) => m a -> m ()
ignoringAbsence (Path Abs File -> RIO env ()
forall (m :: * -> *) b. MonadIO m => Path b File -> m ()
removeFile Path Abs File
setupO)
let setupShimStub :: String
setupShimStub = String
"setup-shim-" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
simpleSetupHash
Path Rel File
setupShimFileName <- String -> RIO env (Path Rel File)
forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile (String
setupShimStub String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
".hs")
Path Rel File
setupShimHiName <- String -> RIO env (Path Rel File)
forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile (String
setupShimStub String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
".hi")
Path Rel File
setupShimOName <- String -> RIO env (Path Rel File)
forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile (String
setupShimStub String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
".o")
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
setupShimHi :: Path Abs File
setupShimHi = 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
setupShimHiName
setupShimO :: Path Abs File
setupShimO = 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
setupShimOName
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
RIO env () -> RIO env ()
forall (m :: * -> *) a. (MonadIO m, MonadCatch m) => m a -> m ()
ignoringAbsence (Path Abs File -> RIO env ()
forall (m :: * -> *) b. MonadIO m => Path b File -> m ()
removeFile Path Abs File
setupShimHi)
RIO env () -> RIO env ()
forall (m :: * -> *) a. (MonadIO m, MonadCatch m) => m a -> m ()
ignoringAbsence (Path Abs File -> RIO env ()
forall (m :: * -> *) b. MonadIO m => Path b File -> m ()
removeFile Path Abs File
setupShimO)
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
tempDir
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
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
SimpleGetter env CompilerPaths
compilerPathsL Getting (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 (.globalDB)
let globalDumpPkgs :: Map GhcPkgId DumpPackage
globalDumpPkgs = [DumpPackage] -> Map GhcPkgId DumpPackage
toDumpPackagesByGhcPkgId [DumpPackage]
globalPackages
TVar (Map GhcPkgId DumpPackage)
snapshotDumpPkgs <-
IO (TVar (Map GhcPkgId DumpPackage))
-> RIO env (TVar (Map GhcPkgId DumpPackage))
forall a. IO a -> RIO env a
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)
localDumpPkgs <-
IO (TVar (Map GhcPkgId DumpPackage))
-> RIO env (TVar (Map GhcPkgId DumpPackage))
forall a. IO a -> RIO env a
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)
logFiles <- IO (TChan (Path Abs Dir, Path Abs File))
-> RIO env (TChan (Path Abs Dir, Path Abs File))
forall a. IO a -> RIO env a
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 a. [a] -> 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 (.wanted) [LocalPackage]
locals
Text
pathEnvVar <- IO Text -> RIO env Text
forall a. IO a -> RIO env a
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
{ BuildOpts
$sel:buildOpts:ExecuteEnv :: BuildOpts
buildOpts :: BuildOpts
buildOpts
, BuildOptsCLI
$sel:buildOptsCLI:ExecuteEnv :: BuildOptsCLI
buildOptsCLI :: BuildOptsCLI
buildOptsCLI
, MVar ()
$sel:installLock:ExecuteEnv :: MVar ()
installLock :: MVar ()
installLock
, BaseConfigOpts
$sel:baseConfigOpts:ExecuteEnv :: BaseConfigOpts
baseConfigOpts :: BaseConfigOpts
baseConfigOpts
, TVar (Map PackageIdentifier Installed)
$sel:ghcPkgIds:ExecuteEnv :: TVar (Map PackageIdentifier Installed)
ghcPkgIds :: TVar (Map PackageIdentifier Installed)
ghcPkgIds
, Path Abs Dir
$sel:tempDir:ExecuteEnv :: Path Abs Dir
tempDir :: Path Abs Dir
tempDir
, Path Abs File
$sel:setupHs:ExecuteEnv :: Path Abs File
setupHs :: Path Abs File
setupHs
, Path Abs File
$sel:setupShimHs:ExecuteEnv :: Path Abs File
setupShimHs :: Path Abs File
setupShimHs
, Maybe (Path Abs File)
$sel:setupExe:ExecuteEnv :: Maybe (Path Abs File)
setupExe :: Maybe (Path Abs File)
setupExe
, Version
$sel:cabalPkgVer:ExecuteEnv :: Version
cabalPkgVer :: Version
cabalPkgVer
, Int
$sel:totalWanted:ExecuteEnv :: Int
totalWanted :: Int
totalWanted
, [LocalPackage]
$sel:locals:ExecuteEnv :: [LocalPackage]
locals :: [LocalPackage]
locals
, Path Abs Dir
$sel:globalDB:ExecuteEnv :: Path Abs Dir
globalDB :: Path Abs Dir
globalDB
, Map GhcPkgId DumpPackage
$sel:globalDumpPkgs:ExecuteEnv :: Map GhcPkgId DumpPackage
globalDumpPkgs :: Map GhcPkgId DumpPackage
globalDumpPkgs
, TVar (Map GhcPkgId DumpPackage)
$sel:snapshotDumpPkgs:ExecuteEnv :: TVar (Map GhcPkgId DumpPackage)
snapshotDumpPkgs :: TVar (Map GhcPkgId DumpPackage)
snapshotDumpPkgs
, TVar (Map GhcPkgId DumpPackage)
$sel:localDumpPkgs:ExecuteEnv :: TVar (Map GhcPkgId DumpPackage)
localDumpPkgs :: TVar (Map GhcPkgId DumpPackage)
localDumpPkgs
, TChan (Path Abs Dir, Path Abs File)
$sel:logFiles:ExecuteEnv :: TChan (Path Abs Dir, Path Abs File)
logFiles :: TChan (Path Abs Dir, Path Abs File)
logFiles
, IORef (Set PackageName)
$sel:customBuilt:ExecuteEnv :: IORef (Set PackageName)
customBuilt :: IORef (Set PackageName)
customBuilt
, Maybe Int
$sel:largestPackageName:ExecuteEnv :: Maybe Int
largestPackageName :: Maybe Int
largestPackageName
, Text
$sel:pathEnvVar:ExecuteEnv :: Text
pathEnvVar :: 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)
logFiles 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
dp.ghcPkgId, DumpPackage
dp))
createTempDirFunction :: String -> (Path Abs Dir -> RIO env a) -> RIO env a
createTempDirFunction
| BuildOpts
buildOpts.keepTmpFiles = 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 a b. (a -> b) -> RIO env a -> RIO env b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(Path Abs Dir, 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 a. IO a -> RIO env a
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 a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
(Path Abs Dir, Path Abs File)
firstLog:[(Path Abs Dir, Path Abs File)]
_ -> do
DumpLogs
toDump <- 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
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 (.dumpLogs)
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 ->
[StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyInfoL
[ String -> StyleDoc
flow String
"Build output has been captured to log files, use"
, Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"--dump-logs"
, String -> StyleDoc
flow String
"to see it on the console."
]
| Bool
otherwise -> () -> RIO env ()
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
[StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyInfoL
[ String -> StyleDoc
flow String
"Log files have been written to:"
, Path Abs Dir -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty (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. (HasEnvConfig env, HasRunner 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 a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO env ()) -> IO () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ ((Path 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 a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
Just (Path Abs Dir, Path Abs File)
x -> do
[(Path Abs Dir, Path Abs File)]
xs <- STM [(Path Abs Dir, Path Abs File)]
drainChan
[(Path Abs Dir, Path Abs File)]
-> STM [(Path Abs Dir, Path Abs File)]
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(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) ()
-> ConduitT ByteString Void (RIO env) [Text]
-> ConduitT () Void (RIO env) [Text]
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT ByteString Text (RIO env) ()
forall (m :: * -> *). Monad m => ConduitT ByteString Text m ()
CT.decodeUtf8Lenient
ConduitT ByteString Text (RIO env) ()
-> ConduitT Text Void (RIO env) [Text]
-> ConduitT ByteString Void (RIO env) [Text]
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT Text Text (RIO env) ()
forall (m :: * -> *). Monad m => ConduitT Text Text m ()
CT.lines
ConduitT Text Text (RIO env) ()
-> ConduitT Text Void (RIO env) [Text]
-> ConduitT Text Void (RIO env) [Text]
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| (Text -> Text) -> ConduitT Text Text (RIO env) ()
forall (m :: * -> *) a b. Monad m => (a -> b) -> ConduitT a b m ()
CL.map Text -> Text
stripCR
ConduitT Text Text (RIO env) ()
-> ConduitT Text Void (RIO env) [Text]
-> ConduitT Text Void (RIO env) [Text]
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT 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) ()
-> ConduitT Text Void (RIO env) [Text]
-> ConduitT Text Void (RIO env) [Text]
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| Int -> ConduitT 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 a. [a] -> 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
StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyNote (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$
[StyleDoc] -> StyleDoc
fillSep
( ( [StyleDoc] -> StyleDoc
fillSep
( String -> StyleDoc
flow String
"Dumping log file"
StyleDoc -> [StyleDoc] -> [StyleDoc]
forall a. a -> [a] -> [a]
: [ String -> StyleDoc
flow String
msgSuffix | Bool -> Bool
not (String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
L.null String
msgSuffix) ]
)
StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
":"
)
StyleDoc -> [StyleDoc] -> [StyleDoc]
forall a. a -> [a] -> [a]
: [ Path Abs File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
filepath StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"." ]
)
StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
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
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) ()
-> ConduitT ByteString Void (RIO env) ()
-> ConduitT () Void (RIO env) ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT ByteString Text (RIO env) ()
forall (m :: * -> *). Monad m => ConduitT ByteString Text m ()
CT.decodeUtf8Lenient
ConduitT ByteString Text (RIO env) ()
-> ConduitT Text Void (RIO env) ()
-> ConduitT ByteString Void (RIO env) ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ExcludeTHLoading
-> ConvertPathsToAbsolute
-> Path Abs Dir
-> ActualCompiler
-> ConduitT Text Text (RIO env) ()
forall (m :: * -> *).
(MonadIO m, MonadUnliftIO 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) ()
-> ConduitT Text Void (RIO env) ()
-> ConduitT Text Void (RIO env) ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| (Text -> RIO env ()) -> ConduitT Text Void (RIO env) ()
forall (m :: * -> *) a o.
Monad m =>
(a -> m ()) -> ConduitT a o m ()
CL.mapM_ (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
display)
StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyNote (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$
[StyleDoc] -> StyleDoc
fillSep
[ String -> StyleDoc
flow String
"End of log file:"
, Path Abs File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
filepath StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
]
StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
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 =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT 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 =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT 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 =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitM ByteString Void IO ()
sink
where
noColors :: ConduitT ByteString ByteString IO ()
noColors = do
(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 a. a -> ConduitT ByteString ByteString IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
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
packageNamePrefix :: ExecuteEnv -> PackageName -> String
packageNamePrefix :: ExecuteEnv -> PackageName -> String
packageNamePrefix ExecuteEnv
ee PackageName
name' =
let name :: String
name = PackageName -> String
packageNameString PackageName
name'
paddedName :: String
paddedName =
case ExecuteEnv
ee.largestPackageName of
Maybe Int
Nothing -> String
name
Just Int
len ->
Bool -> ShowS
forall a. HasCallStack => Bool -> a -> a
assert (Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
name) ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Int -> ShowS
forall a. Int -> [a] -> [a]
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]
L.repeat Char
' '
in String
paddedName String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"> "
announceTask ::
HasLogFunc env
=> ExecuteEnv
-> TaskType
-> Utf8Builder
-> RIO env ()
announceTask :: forall env.
HasLogFunc env =>
ExecuteEnv -> TaskType -> Utf8Builder -> RIO env ()
announceTask ExecuteEnv
ee TaskType
taskType Utf8Builder
action = Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, 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
(ExecuteEnv -> PackageName -> String
packageNamePrefix ExecuteEnv
ee (PackageIdentifier -> PackageName
pkgName (TaskType -> PackageIdentifier
taskTypePackageIdentifier TaskType
taskType)))
Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
action
prettyAnnounceTask ::
HasTerm env
=> ExecuteEnv
-> TaskType
-> StyleDoc
-> RIO env ()
prettyAnnounceTask :: forall env.
HasTerm env =>
ExecuteEnv -> TaskType -> StyleDoc -> RIO env ()
prettyAnnounceTask ExecuteEnv
ee TaskType
taskType StyleDoc
action = StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyInfo (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$
String -> StyleDoc
forall a. IsString a => String -> a
fromString
(ExecuteEnv -> PackageName -> String
packageNamePrefix ExecuteEnv
ee (PackageIdentifier -> PackageName
pkgName (TaskType -> PackageIdentifier
taskTypePackageIdentifier TaskType
taskType)))
StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
action
withLockedDistDir ::
forall env a. HasEnvConfig env
=> (StyleDoc -> RIO env ())
-> Path Abs Dir
-> RIO env a
-> RIO env a
withLockedDistDir :: forall env a.
HasEnvConfig env =>
(StyleDoc -> RIO env ()) -> Path Abs Dir -> RIO env a -> RIO env a
withLockedDistDir StyleDoc -> RIO env ()
announce Path Abs Dir
root RIO env a
inner = do
Path Rel Dir
distDir <- RIO env (Path Rel Dir)
forall env (m :: * -> *).
(HasEnvConfig env, MonadReader env m, MonadThrow m) =>
m (Path Rel Dir)
distRelativeDir
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 b. ((forall a. RIO env a -> IO a) -> IO b) -> RIO env b
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 a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
res
Maybe a
Nothing -> do
let complainer :: Companion (RIO env)
complainer :: Companion (RIO env)
complainer Delay
delay = do
Int -> RIO env ()
Delay
delay Int
5000000
StyleDoc -> RIO env ()
announce (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$ [StyleDoc] -> StyleDoc
fillSep
[ String -> StyleDoc
flow String
"blocking for directory lock on"
, Path Abs File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty 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
delay Int
30000000
StyleDoc -> RIO env ()
announce (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$ [StyleDoc] -> StyleDoc
fillSep
[ String -> StyleDoc
flow String
"still blocking for directory lock on"
, Path Abs File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
lockFP StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
";"
, String -> StyleDoc
flow String
"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 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 b. ((forall a. RIO env a -> IO a) -> IO b) -> RIO env b
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 a b. RIO env a -> RIO env b -> RIO env b
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
-> TaskType
-> Map PackageIdentifier GhcPkgId
-> Maybe String
-> ( Package
-> Path Abs File
-> Path Abs Dir
-> (KeepOutputOpen -> ExcludeTHLoading -> [String] -> RIO env ())
-> (Utf8Builder -> RIO env ())
-> OutputType
-> RIO env a)
-> RIO env a
withSingleContext :: forall env a.
HasEnvConfig env =>
ActionContext
-> ExecuteEnv
-> TaskType
-> Map PackageIdentifier GhcPkgId
-> Maybe String
-> (Package
-> Path Abs File
-> Path Abs Dir
-> (KeepOutputOpen -> ExcludeTHLoading -> [String] -> RIO env ())
-> (Utf8Builder -> RIO env ())
-> OutputType
-> RIO env a)
-> RIO env a
withSingleContext
ActionContext
ac
ExecuteEnv
ee
TaskType
taskType
Map PackageIdentifier GhcPkgId
allDeps
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
pkgId :: PackageIdentifier
pkgId = TaskType -> PackageIdentifier
taskTypePackageIdentifier TaskType
taskType
announce :: Utf8Builder -> RIO env ()
announce = ExecuteEnv -> TaskType -> Utf8Builder -> RIO env ()
forall env.
HasLogFunc env =>
ExecuteEnv -> TaskType -> Utf8Builder -> RIO env ()
announceTask ExecuteEnv
ee TaskType
taskType
prettyAnnounce :: StyleDoc -> RIO env ()
prettyAnnounce = ExecuteEnv -> TaskType -> StyleDoc -> RIO env ()
forall env.
HasTerm env =>
ExecuteEnv -> TaskType -> StyleDoc -> RIO env ()
prettyAnnounceTask ExecuteEnv
ee TaskType
taskType
wanted :: Bool
wanted =
case TaskType
taskType of
TTLocalMutable LocalPackage
lp -> LocalPackage
lp.wanted
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
pkgId)
(Set ActionId -> [ActionId]
forall a. Set a -> [a]
Set.toList ActionContext
ac.remaining)
Bool -> Bool -> Bool
&& ExecuteEnv
ee.totalWanted Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
)
Bool -> Bool -> Bool
|| ActionContext
ac.concurrency 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 LocalPackage
lp.cabalFP
(StyleDoc -> RIO env ()) -> Path Abs Dir -> RIO env a -> RIO env a
forall env a.
HasEnvConfig env =>
(StyleDoc -> RIO env ()) -> Path Abs Dir -> RIO env a -> RIO env a
withLockedDistDir StyleDoc -> RIO env ()
prettyAnnounce 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
lp.package LocalPackage
lp.cabalFP 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
packageIdentifier Package
package
let dir :: Path Abs Dir
dir = ExecuteEnv
ee.tempDir 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 env (m :: * -> *).
(HasEnvConfig env, MonadReader env m, MonadThrow m) =>
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
pkgId
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
| ExecuteEnv
ee.buildOpts.interleavedOutput = 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
$ String -> Utf8Builder
forall a. IsString a => String -> a
fromString (ExecuteEnv -> PackageName -> String
packageNamePrefix ExecuteEnv
ee Package
package.name)
| 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
lp.wanted ->
IO () -> RIO env ()
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO env ()) -> IO () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TChan (Path Abs Dir, Path Abs File)
-> (Path Abs Dir, Path Abs File) -> STM ()
forall a. TChan a -> a -> STM ()
writeTChan ExecuteEnv
ee.logFiles (Path Abs Dir
pkgDir, Path Abs File
logPath)
TaskType
_ -> () -> RIO env ()
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
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
Lens' env Config
configL
Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Config
config.allowDifferentUser (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
config.workDir)
let envSettings :: EnvSettings
envSettings = EnvSettings
{ $sel:includeLocals:EnvSettings :: Bool
includeLocals = TaskType -> InstallLocation
taskTypeLocation TaskType
taskType InstallLocation -> InstallLocation -> Bool
forall a. Eq a => a -> a -> Bool
== InstallLocation
Local
, $sel:includeGhcPackagePath:EnvSettings :: Bool
includeGhcPackagePath = Bool
False
, $sel:stackExe:EnvSettings :: Bool
stackExe = Bool
False
, $sel:localeUtf8:EnvSettings :: Bool
localeUtf8 = Bool
True
, $sel:keepGhcRts:EnvSettings :: Bool
keepGhcRts = Bool
False
}
ProcessContext
menv <- IO ProcessContext -> RIO env ProcessContext
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ProcessContext -> RIO env ProcessContext)
-> IO ProcessContext -> RIO env ProcessContext
forall a b. (a -> b) -> a -> b
$ Config
config.processContextSettings EnvSettings
envSettings
Path Rel Dir
distRelativeDir' <- RIO env (Path Rel Dir)
forall env (m :: * -> *).
(HasEnvConfig env, MonadReader env m, MonadThrow m) =>
m (Path Rel Dir)
distRelativeDir
Either (Path Abs File) (Path Abs File)
esetupexehs <-
case (Package
package.buildType, ExecuteEnv
ee.setupExe) 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 a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 a. IO a -> RIO env a
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
package.name 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
ExecuteEnv
ee.cabalPkgVer)]
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=" ++) 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)
ExecuteEnv
ee.baseConfigOpts.extraDBs
) [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 ExecuteEnv
ee.baseConfigOpts.snapDB
)
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 ExecuteEnv
ee.baseConfigOpts.localDB
)
String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String
"-hide-all-packages"]
)
warnCustomNoDeps :: RIO env ()
warnCustomNoDeps :: RIO env ()
warnCustomNoDeps =
case (TaskType
taskType, Package
package.buildType) of
(TTLocalMutable LocalPackage
lp, BuildType
C.Custom) | LocalPackage
lp.wanted ->
[StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyWarnL
[ String -> StyleDoc
flow String
"Package"
, PackageName -> StyleDoc
forall a. IsString a => PackageName -> a
fromPackageName Package
package.name
, String -> StyleDoc
flow String
"uses a custom Cabal build, but does not use a \
\custom-setup stanza"
]
(TaskType, BuildType)
_ -> () -> RIO env ()
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
getPackageArgs :: Path Abs Dir -> RIO env [String]
getPackageArgs :: Path Abs Dir -> RIO env [String]
getPackageArgs Path Abs Dir
setupDir =
case Package
package.setupDeps of
Just Map PackageName DepValue
customSetupDeps -> do
Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (PackageName -> Map PackageName DepValue -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member (String -> PackageName
mkPackageName String
"Cabal") Map PackageName DepValue
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
[ PackageName -> StyleDoc
forall a. IsString a => PackageName -> a
fromPackageName Package
package.name
, String -> StyleDoc
flow String
"has a setup-depends field, but it does not mention \
\a Cabal dependency. This is likely to cause build \
\errors."
]
[(String, Maybe PackageIdentifier)]
matchedDeps <-
[(PackageName, DepValue)]
-> ((PackageName, DepValue)
-> 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 DepValue -> [(PackageName, DepValue)]
forall k a. Map k a -> [(k, a)]
Map.toList Map PackageName DepValue
customSetupDeps) (((PackageName, DepValue)
-> RIO env (String, Maybe PackageIdentifier))
-> RIO env [(String, Maybe PackageIdentifier)])
-> ((PackageName, DepValue)
-> RIO env (String, Maybe PackageIdentifier))
-> RIO env [(String, Maybe PackageIdentifier)]
forall a b. (a -> b) -> a -> b
$ \(PackageName
name, DepValue
depValue) -> 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` DepValue
depValue.versionRange
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 a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(PackageIdentifier, GhcPkgId)]
xs) (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
flow String
"Found multiple installed packages for \
\custom-setup dep:"
, Style -> StyleDoc -> StyleDoc
style Style
Current (PackageName -> StyleDoc
forall a. IsString a => PackageName -> a
fromPackageName PackageName
name) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
]
(String, Maybe PackageIdentifier)
-> RIO env (String, Maybe PackageIdentifier)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (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
[StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyWarnL
[ String -> StyleDoc
flow String
"Could not find custom-setup dep:"
, Style -> StyleDoc -> StyleDoc
style Style
Current (PackageName -> StyleDoc
forall a. IsString a => PackageName -> a
fromPackageName PackageName
name) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
]
(String, Maybe PackageIdentifier)
-> RIO env (String, Maybe PackageIdentifier)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (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
( Version -> [PackageIdentifier] -> String
C.generatePackageVersionMacros
Package
package.version
[PackageIdentifier]
macroDeps
)
)
)
[String] -> RIO env [String]
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([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 DepValue)
Nothing -> do
RIO env ()
warnCustomNoDeps
[String] -> RIO env [String]
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([String] -> RIO env [String]) -> [String] -> RIO env [String]
forall a b. (a -> b) -> a -> b
$
[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=" ++) 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)
ExecuteEnv
ee.baseConfigOpts.extraDBs
[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 ExecuteEnv
ee.baseConfigOpts.snapDB
]
)
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
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 a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Path Abs File)
forall a. Maybe a
Nothing, [])
else do
IO () -> RIO env ()
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO env ()) -> IO () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ 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 a b. (a -> b) -> RIO env a -> RIO env b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Path Abs 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) ()
-> ConduitT ByteString Void (RIO env) [Text]
-> ConduitT () Void (RIO env) [Text]
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT ByteString Text (RIO env) ()
forall (m :: * -> *). Monad m => ConduitT ByteString Text m ()
CT.decodeUtf8Lenient
ConduitT ByteString Text (RIO env) ()
-> ConduitT Text Void (RIO env) [Text]
-> ConduitT ByteString Void (RIO env) [Text]
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ExcludeTHLoading
-> ConvertPathsToAbsolute
-> Path Abs Dir
-> ActualCompiler
-> ConduitM Text Text (RIO env) ()
forall (m :: * -> *).
(MonadIO m, MonadUnliftIO 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) ()
-> ConduitT Text Void (RIO env) [Text]
-> ConduitT Text Void (RIO env) [Text]
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT Text Void (RIO env) [Text]
forall (m :: * -> *) a o. Monad m => ConduitT a o m [a]
CL.consume
BuildPrettyException -> RIO env ()
forall e (m :: * -> *) a.
(Exception e, MonadThrow m, Pretty e) =>
e -> m a
prettyThrowM (BuildPrettyException -> RIO env ())
-> BuildPrettyException -> RIO env ()
forall a b. (a -> b) -> a -> b
$ ExitCode
-> PackageIdentifier
-> Path Abs File
-> [String]
-> Maybe (Path Abs File)
-> [Text]
-> BuildPrettyException
CabalExitedUnsuccessfully
(ExitCodeException -> ExitCode
eceExitCode ExitCodeException
ece) PackageIdentifier
pkgId 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
config.prefixTimestamps
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 = Utf8Builder -> Maybe Utf8Builder -> Utf8Builder
forall a. a -> Maybe a -> a
fromMaybe Utf8Builder
forall a. Monoid a => a
mempty 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 :: HasCallStack =>
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) ()
-> ConduitT Text Void (RIO env) ()
-> ConduitM ByteString Void (RIO env) ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ExcludeTHLoading
-> ConvertPathsToAbsolute
-> Path Abs Dir
-> ActualCompiler
-> ConduitM Text Text (RIO env) ()
forall (m :: * -> *).
(MonadIO m, MonadUnliftIO 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) ()
-> ConduitT Text Void (RIO env) ()
-> ConduitT Text Void (RIO env) ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| (Text -> RIO env ()) -> ConduitT Text Void (RIO env) ()
forall (m :: * -> *) a o.
Monad m =>
(a -> m ()) -> ConduitT a o m ()
CL.mapM_ (Text -> 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)
-> (Text -> Utf8Builder) -> Text -> Utf8Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display)
makeAbsolute :: ConvertPathsToAbsolute
makeAbsolute :: ConvertPathsToAbsolute
makeAbsolute = case ExcludeTHLoading
stripTHLoading of
ExcludeTHLoading
ExcludeTHLoading -> ConvertPathsToAbsolute
ConvertPathsToAbsolute
ExcludeTHLoading
KeepTHLoading -> ConvertPathsToAbsolute
KeepPathsAsIs
Path Abs File
exeName <- case Either (Path Abs File) (Path Abs File)
esetupexehs of
Left Path Abs File
setupExe -> Path Abs File -> RIO env (Path Abs File)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Path Abs File
setupExe
Right Path Abs File
setuphs -> do
Path Abs Dir
distDir <- Path Abs Dir -> RIO env (Path Abs Dir)
forall env (m :: * -> *).
(HasEnvConfig env, MonadReader env m, MonadThrow m) =>
Path Abs Dir -> m (Path Abs Dir)
distDirFromDir Path Abs Dir
pkgDir
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 a. IO a -> RIO env a
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 ExecuteEnv
ee.customBuilt
if PackageName -> Set PackageName -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Package
package.name Set PackageName
customBuilt
then Path Abs File -> RIO env (Path Abs File)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure 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
SimpleGetter env CompilerPaths
compilerPathsL Getting (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 (.compiler)
[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 ExecuteEnv
ee.setupShimHs
, 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
config.ghcOptionsByCat
[Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ case Config
config.applyGhcOptions of
ApplyGhcOptions
AGOEverything -> ExecuteEnv
ee.buildOptsCLI.ghcOptions
ApplyGhcOptions
AGOTargets -> []
ApplyGhcOptions
AGOLocals -> []
)
IO () -> RIO env ()
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO env ()) -> IO () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ IORef (Set PackageName)
-> (Set PackageName -> (Set PackageName, ())) -> IO ()
forall (m :: * -> *) a b.
MonadIO m =>
IORef a -> (a -> (a, b)) -> m b
atomicModifyIORef' ExecuteEnv
ee.customBuilt ((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
package.name Set PackageName
oldCustomBuilt, ())
Path Abs File -> RIO env (Path Abs File)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Path Abs File
outputFile
let cabalVerboseArg :: String
cabalVerboseArg =
let CabalVerbosity Verbosity
cv = ExecuteEnv
ee.buildOpts.cabalVerbose
in String
"--verbose=" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Verbosity -> String
showForCabal Verbosity
cv
Path Abs File -> [String] -> RIO env ()
runExe Path Abs File
exeName ([String] -> RIO env ()) -> [String] -> RIO env ()
forall a b. (a -> b) -> a -> b
$ String
cabalVerboseArgString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
setupArgs
mungeBuildOutput ::
forall m. (MonadIO m, MonadUnliftIO m)
=> ExcludeTHLoading
-> ConvertPathsToAbsolute
-> Path Abs Dir
-> ActualCompiler
-> ConduitM Text Text m ()
mungeBuildOutput :: forall (m :: * -> *).
(MonadIO m, MonadUnliftIO m) =>
ExcludeTHLoading
-> ConvertPathsToAbsolute
-> Path Abs Dir
-> ActualCompiler
-> ConduitM Text Text m ()
mungeBuildOutput ExcludeTHLoading
excludeTHLoading ConvertPathsToAbsolute
makeAbsolute Path Abs Dir
pkgDir ActualCompiler
compilerVer = ConduitT Text Text m () -> ConduitT Text Text m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ConduitT Text Text m () -> ConduitT Text Text m ())
-> ConduitT Text Text m () -> ConduitT Text Text m ()
forall a b. (a -> b) -> a -> b
$
ConduitT Text Text m ()
forall (m :: * -> *). Monad m => ConduitT Text Text m ()
CT.lines
ConduitT Text Text m ()
-> ConduitT Text Text m () -> ConduitT Text Text m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| (Text -> Text) -> ConduitT Text Text m ()
forall (m :: * -> *) a b. Monad m => (a -> b) -> ConduitT a b m ()
CL.map Text -> Text
stripCR
ConduitT Text Text m ()
-> ConduitT Text Text m () -> ConduitT Text Text m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| (Text -> Bool) -> ConduitT 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)
ConduitT Text Text m ()
-> ConduitT Text Text m () -> ConduitT Text Text m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT Text Text m ()
filterLinkerWarnings
ConduitT Text Text m ()
-> ConduitT Text Text m () -> ConduitT Text Text m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT Text Text m ()
toAbsolute
where
isTHLoading :: Text -> Bool
isTHLoading :: Text -> Bool
isTHLoading = case ExcludeTHLoading
excludeTHLoading of
ExcludeTHLoading
KeepTHLoading -> 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 :: ConduitT 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] = ConduitT Text Text m ()
doNothing
| Bool
otherwise = (Text -> Bool) -> ConduitT 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 :: ConduitT Text Text m ()
toAbsolute = case ConvertPathsToAbsolute
makeAbsolute of
ConvertPathsToAbsolute
KeepPathsAsIs -> ConduitT Text Text m ()
doNothing
ConvertPathsToAbsolute
ConvertPathsToAbsolute -> (Text -> m Text) -> ConduitT 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
(Maybe (Path Abs File) -> Maybe Text)
-> m (Maybe (Path Abs File)) -> m (Maybe Text)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Path Abs File -> Text) -> Maybe (Path Abs File) -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
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) -> (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)) (m (Maybe (Path Abs File)) -> m (Maybe Text))
-> m (Maybe (Path Abs File)) -> m (Maybe Text)
forall a b. (a -> b) -> a -> b
$
Path Abs Dir -> String -> m (Maybe (Path Abs File))
forall (m :: * -> *).
MonadIO m =>
Path Abs Dir -> String -> m (Maybe (Path Abs File))
forgivingResolveFile 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) m (Maybe (Path Abs File))
-> (PathException -> m (Maybe (Path Abs File)))
-> m (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) -> m (Maybe (Path Abs File))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Path Abs File)
forall a. Maybe a
Nothing
else Maybe Text -> m (Maybe Text)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Text
forall a. Maybe a
Nothing
case Maybe Text
mabs of
Maybe Text
Nothing -> Text -> m Text
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
bs
Just Text
fp -> Text -> m Text
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 :: ConduitT Text Text m ()
doNothing = (Text -> ConduitT Text Text m ()) -> ConduitT Text Text m ()
forall (m :: * -> *) i o r.
Monad m =>
(i -> ConduitT i o m r) -> ConduitT i o m ()
awaitForever Text -> ConduitT 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 a b. Parser Text a -> Parser Text b -> Parser Text b
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 a b. Parser Text a -> Parser Text b -> Parser Text b
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 a b. Parser Text a -> Parser Text b -> Parser Text b
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 a b. Parser Text a -> Parser Text b -> Parser Text b
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 a b. Parser Text a -> Parser Text b -> Parser Text b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser Text String
num) Parser Text (Maybe String) -> Parser () -> Parser ()
forall a b. Parser Text a -> Parser Text b -> Parser Text b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> Parser ()
forall a. a -> Parser Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
, Char -> Parser Char
char Char
'(' Parser Char -> Parser Text String -> Parser Text String
forall a b. Parser Text a -> Parser Text b -> Parser Text b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser Text String
num Parser Text String -> Parser Char -> Parser Char
forall a b. Parser Text a -> Parser Text b -> Parser Text b
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 a b. Parser Text a -> Parser Text b -> Parser Text b
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 a b. Parser Text a -> Parser Text b -> Parser Text b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Text -> Parser Text Text
P.string Text
")-(" Parser Text Text -> Parser Text String -> Parser Text String
forall a b. Parser Text a -> Parser Text b -> Parser Text b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser Text String
num Parser Text String -> Parser Char -> Parser Char
forall a b. Parser Text a -> Parser Text b -> Parser Text b
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 a b. Parser Text a -> Parser Text b -> Parser Text b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser Text String
num Parser Text String -> Parser Char -> Parser Char
forall a b. Parser Text a -> Parser Text b -> Parser Text b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Parser Char
char Char
')' Parser Char -> Parser () -> Parser ()
forall a b. Parser Text a -> Parser Text b -> Parser Text b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> Parser ()
forall a. a -> Parser Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
]
Parser () -> Parser Char -> Parser Char
forall a b. Parser Text a -> Parser Text b -> Parser Text b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Parser Char
char Char
':'
Parser Char -> Parser () -> Parser ()
forall a b. Parser Text a -> Parser Text b -> Parser Text b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> Parser ()
forall a. a -> Parser Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
where
num :: Parser Text String
num = Parser Char -> Parser Text String
forall a. Parser Text a -> Parser Text [a]
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 :: forall (m :: * -> *).
MonadIO m =>
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 =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT 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 =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT 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 =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT 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 a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ZonedTime
getZonedTime
ByteString -> m ByteString
forall a. a -> m a
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 a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Path Abs File
fp2
else BuildException -> IO (Path Abs File)
forall e a. (HasCallStack, Exception e) => e -> IO a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (BuildException -> IO (Path Abs File))
-> BuildException -> IO (Path Abs File)
forall a b. (a -> b) -> a -> b
$ Path Abs Dir -> BuildException
NoSetupHsFound Path Abs Dir
dir
where
fp1 :: Path Abs File
fp1 = Path Abs Dir
dir 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