{-# LANGUAGE NoImplicitPrelude     #-}
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NoFieldSelectors      #-}
{-# LANGUAGE OverloadedRecordDot   #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE TypeFamilies          #-}

-- | Provides all the necessary types and functions for running cabal Setup.hs

-- commands. Only used in the "Execute" and "ExecutePackage" modules

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 )

-- | Has an executable been built or not?

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)
    -- ^ Temporary Setup.hs for simple builds

  , ExecuteEnv -> Path Abs File
setupShimHs    :: !(Path Abs File)
    -- ^ Temporary SetupShim.hs, to provide access to initial-build-steps

  , ExecuteEnv -> Maybe (Path Abs File)
setupExe       :: !(Maybe (Path Abs File))
    -- ^ Compiled version of eeSetupHs

  , 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))
    -- ^ Stores which packages with custom-setup have already had their

    -- Setup.hs built.

  , ExecuteEnv -> Maybe Int
largestPackageName :: !(Maybe Int)
    -- ^ For nicer interleaved output: track the largest package name size

  , ExecuteEnv -> Text
pathEnvVar :: !Text
    -- ^ Value of the PATH environment variable

  }

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

-- | Get a compiled Setup exe

getSetupExe :: HasEnvConfig env
            => Path Abs File -- ^ Setup.hs input file

            -> Path Abs File -- ^ SetupShim.hs input file

            -> Path Abs Dir -- ^ temporary directory

            -> 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

-- | Execute a function that takes an 'ExecuteEnv'.

withExecuteEnv ::
     forall env a. HasEnvConfig env
  => BuildOpts
  -> BuildOptsCLI
  -> BaseConfigOpts
  -> [LocalPackage]
  -> [DumpPackage] -- ^ global packages

  -> [DumpPackage] -- ^ snapshot packages

  -> [DumpPackage] -- ^ local packages

  -> Maybe Int -- ^ largest package name, for nicer interleaved output

  -> (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
      -- Create files for simple setup and setup shim, if necessary

      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
      -- See https://github.com/commercialhaskell/stack/issues/6267. Remove any

      -- historical *.hi or *.o files. This can be dropped when Stack drops

      -- support for the problematic versions of GHC.

      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
      -- See https://github.com/commercialhaskell/stack/issues/6267. Remove any

      -- historical *.hi or *.o files. This can be dropped when Stack drops

      -- support for the problematic versions of GHC.

      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
          -- Uncertain as to why we cannot run configures in parallel. This

          -- appears to be a Cabal library bug. Original issue:

          -- https://github.com/commercialhaskell/stack/issues/84. Ideally

          -- we'd be able to remove this.

        , 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
      -- No log files generated, nothing to dump

      [] -> () -> 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))
          ]

    -- We only strip the colors /after/ we've dumped logs, so that we get pretty

    -- colors in our dump output on the terminal.

    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 -- prior to GHC 8

             Bool -> Bool -> Bool
|| Text
": warning:" Text -> Text -> Bool
`T.isInfixOf` Text
t -- GHC 8 is slightly different

             Bool -> Bool -> Bool
|| Text
"mwarning:" Text -> Text -> Bool
`T.isInfixOf` Text
t -- colorized output


  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) -- ESC

      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
          -- Color sequences always end with an m

          (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) -- m

          Int -> ConduitT ByteString ByteString IO ()
forall (m :: * -> *) o.
Monad m =>
Int -> ConduitT ByteString o m ()
CB.drop Int
1 -- drop the m itself

          ConduitT ByteString ByteString IO ()
noColors

-- | Make a padded prefix for log messages

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

-- | Ensure we're the only action using the directory.  See

-- <https://github.com/commercialhaskell/stack/issues/2730>

withLockedDistDir ::
     forall env a. HasEnvConfig env
  => (StyleDoc -> RIO env ()) -- ^ A pretty announce function

  -> Path Abs Dir -- ^ root directory for package

  -> 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 -- 5 seconds

            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 -- 30 seconds

              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

-- | How we deal with output from GHC, either dumping to a log file or the

-- console (with some prefix).

data OutputType
  = OTLogFile !(Path Abs File) !Handle
  | OTConsole !(Maybe Utf8Builder)

-- | This sets up a context for executing build steps which need to run

-- Cabal (via a compiled Setup.hs).  In particular it does the following:

--

-- * Ensures the package exists in the file system, downloading if necessary.

--

-- * Opens a log file if the built output shouldn't go to stderr.

--

-- * Ensures that either a simple Setup.hs is built, or the package's

--   custom setup is built.

--

-- * Provides the user a function with which run the Cabal process.

withSingleContext ::
     forall env a. HasEnvConfig env
  => ActionContext
  -> ExecuteEnv
  -> TaskType
  -> Map PackageIdentifier GhcPkgId
     -- ^ All dependencies' package ids to provide to Setup.hs.

  -> Maybe String
  -> (  Package        -- Package info

     -> Path Abs File  -- Cabal file path

     -> Path Abs Dir   -- Package root directory file path

        -- Note that the `Path Abs Dir` argument is redundant with the

        -- `Path Abs File` argument, but we provide both to avoid recalculating

        -- `parent` of the `File`.

     -> (KeepOutputOpen -> ExcludeTHLoading -> [String] -> RIO env ())
        -- Function to run Cabal with args

     -> (Utf8Builder -> RIO env ())
        -- An plain 'announce' function, for different build phases

     -> 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

  -- Output to the console if this is the last task, and the user asked to build

  -- it specifically. When the action is a 'ConcurrencyDisallowed' action

  -- (benchmarks), then we can also be sure to have exclusive access to the

  -- console, so output is also sent to the console in this case.

  --

  -- See the discussion on #426 for thoughts on sending output to the console

  --from concurrent tasks.

  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

        -- See: https://github.com/commercialhaskell/stack/issues/157

        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
          -- Previously used takeDirectory, but that got confused

          -- by trailing slashes, see:

          -- https://github.com/commercialhaskell/stack/issues/216

          --

          -- Instead, use Path which is a bit more resilient

          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
    -- Not in interleaved mode. When building a single wanted package, dump

    -- to the console with no prefix.

    | 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

    -- If the user requested interleaved output, dump to the console with a

    -- prefix.

    | 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)

    -- Neither condition applies, dump to a file.

    | 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

        -- We only want to dump logs for local non-dependency packages

        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 <-
      -- Avoid broken Setup.hs files causing problems for simple build

      -- types, see:

      -- https://github.com/commercialhaskell/stack/issues/370

      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
            -- Omit cabal package dependency when building

            -- Cabal. See

            -- https://github.com/commercialhaskell/stack/issues/1356

            | 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
              -- The package is using the Cabal custom-setup

              -- configuration introduced in Cabal 1.24. In

              -- this case, the package is providing an

              -- explicit list of dependencies, and we

              -- should simply use all of them.

              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
                -- Generate setup_macros.h and provide it to ghc

                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)

              -- This branch is usually taken for builds, and is always taken

              -- for `stack sdist`.

              --

              -- This approach is debatable. It adds access to the snapshot

              -- package database for Cabal. There are two possible objections:

              --

              -- 1. This doesn't isolate the build enough; arbitrary other

              -- packages available could cause the build to succeed or fail.

              --

              -- 2. This doesn't provide enough packages: we should also

              -- include the local database when building local packages.

              --

              -- Currently, this branch is only taken via `stack sdist` or when

              -- explicitly requested in the stack.yaml file.

              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
                      -- NOTE: This is different from packageDBArgs above in

                      -- that it does not include the local database and does

                      -- not pass in the -hide-all-packages argument

                  [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, []) -- expected failure build continues further

                    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)
            -- If users want control, we should add a config option for this

            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]
++

                -- Apply GHC options

                -- https://github.com/commercialhaskell/stack/issues/4526

                (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

-- | Strip Template Haskell "Loading package" lines and making paths absolute.

mungeBuildOutput ::
     forall m. (MonadIO m, MonadUnliftIO m)
  => ExcludeTHLoading       -- ^ exclude TH loading?

  -> ConvertPathsToAbsolute -- ^ convert paths to absolute?

  -> Path Abs Dir           -- ^ package's root directory

  -> ActualCompiler         -- ^ compiler we're building with

  -> 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
  -- | Is this line a Template Haskell "Loading package" line

  -- ByteString

  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
    -- Check for ghc 7.8 since it's the only one prone to producing

    -- linker warnings on Windows x64

    | 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

  -- | Convert GHC error lines with file paths to have absolute file paths

  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

  -- | Match the error location format at the end of lines

  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

-- | Whether to prefix log lines with timestamps.

data PrefixWithTimestamps
  = PrefixWithTimestamps
  | WithoutTimestamps

-- | Write stream of lines to handle, but adding timestamps.

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)

-- | Format a time in ISO8601 format. We choose ZonedTime over UTCTime

-- because a user expects to see logs in their local time, and would

-- be confused to see UTC time. Stack's debug logs also use the local

-- time zone.

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"

-- | Find the Setup.hs or Setup.lhs in the given directory. If none exists,

-- throw an exception.

getSetupHs :: Path Abs Dir -- ^ project directory

           -> 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