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

{-|
Module      : Stack.Build.ExecuteEnv
License     : BSD-3-Clause

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 (..)
  , OutputType (..)
  ) where

import           Control.Concurrent.Companion ( Companion, withCompanion )
import           Control.Concurrent.Execute
                   ( ActionContext (..), ActionId (..), Concurrency (..) )
import           Control.Monad.Extra ( whenJust )
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           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 (..)
                   )
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
                   ( WhichCompiler (..), compilerVersionString, 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.Plan
                   ( TaskType (..), taskTypeLocation, taskTypePackageIdentifier
                   )
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 )

-- | Type representing environments in which the @Setup.hs@ commands of Cabal

-- (the library) can be executed.

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
    -- ^ The version of the compiler's Cabal boot package.

  , 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

  }

-- | Type representing setup executable circumstances.

data SetupExe
  = SimpleSetupExe !(Path Abs File)
    -- ^ The build type is Simple and there is a path to an existing setup

    -- executable.

  | OtherSetupHs !(Path Abs File)
    -- ^ Other circumstances with a path to the source code for the setup

    -- executable.


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
  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
  platformDir <- platformGhcRelDir
  config <- view configL
  cabalVersionString <- view $ cabalVersionL . to versionString
  actualCompilerVersionString <-
    view $ actualCompilerVersionL . to compilerVersionString
  platform <- view platformL
  let 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
baseNameS String -> String -> String
forall a. [a] -> [a] -> [a]
++
        case Platform
platform of
          Platform Arch
_ OS
Windows -> String
".exe"
          Platform
_ -> String
""
      outputNameS =
        case WhichCompiler
wc of
            WhichCompiler
Ghc -> String
exeNameS
      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

  exePath <- (setupDir </>) <$> parseRelFile exeNameS

  exists <- liftIO $ D.doesFileExist $ toFilePath exePath

  if exists
    then pure $ Just exePath
    else do
      tmpExePath <- fmap (setupDir </>) $ parseRelFile $ "tmp-" ++ exeNameS
      tmpOutputPath <-
        fmap (setupDir </>) $ parseRelFile $ "tmp-" ++ outputNameS
      ensureDir setupDir
      let args = [String]
buildSetupArgs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
            [ String
"-package"
            , String
"Cabal-" String -> String -> String
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
            ]
      compilerPath <- getCompilerPath
      withWorkingDir (toFilePath tmpdir) $
        proc (toFilePath compilerPath) 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)
            `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 []
      renameFile tmpExePath exePath
      pure $ Just exePath

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

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

  -> [DumpPackage]
     -- ^ snapshot packages

  -> [DumpPackage]
     -- ^ project packages and local extra-deps

  -> 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
      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 ()
      ghcPkgIds <- liftIO $ newTVarIO Map.empty
      config <- view configL
      customBuilt <- newIORef Set.empty
      -- Create files for simple setup and setup shim, if necessary

      let 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
      ensureDir setupSrcDir
      let setupStub = String
"setup-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
simpleSetupHash
      setupFileName <- parseRelFile (setupStub ++ ".hs")
      setupHiName <- parseRelFile (setupStub ++ ".hi")
      setupOName <- parseRelFile (setupStub ++ ".o")
      let 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 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 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
      setupHsExists <- doesFileExist setupHs
      unless setupHsExists $ writeBinaryFileAtomic setupHs simpleSetupCode
      let setupShimStub = String
"setup-shim-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
simpleSetupHash
      setupShimFileName <- parseRelFile (setupShimStub ++ ".hs")
      setupShimHiName <- parseRelFile (setupShimStub ++ ".hi")
      setupShimOName <- parseRelFile (setupShimStub ++ ".o")
      let 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 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 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
      setupShimHsExists <- doesFileExist setupShimHs
      unless setupShimHsExists $
        writeBinaryFileAtomic setupShimHs setupGhciShimCode
      setupExe <- getSetupExe setupHs setupShimHs tempDir
      -- 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.

      ignoringAbsence (removeFile setupHi)
      ignoringAbsence (removeFile setupO)
      ignoringAbsence (removeFile setupShimHi)
      ignoringAbsence (removeFile setupShimO)
      cabalPkgVer <- view cabalVersionL
      globalDB <- view $ compilerPathsL . to (.globalDB)
      let globalDumpPkgs = [DumpPackage] -> Map GhcPkgId DumpPackage
toDumpPackagesByGhcPkgId [DumpPackage]
globalPackages
      snapshotDumpPkgs <-
        liftIO $ newTVarIO (toDumpPackagesByGhcPkgId snapshotPackages)
      localDumpPkgs <-
        liftIO $ newTVarIO (toDumpPackagesByGhcPkgId localPackages)
      logFiles <- liftIO $ atomically newTChan
      let 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
      pathEnvVar <- liftIO $ maybe mempty T.pack <$> lookupEnv "PATH"
      inner ExecuteEnv
        { buildOpts
        , 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.

        , installLock
        , baseConfigOpts
        , ghcPkgIds
        , tempDir
        , setupHs
        , setupShimHs
        , setupExe
        , cabalPkgVer
        , totalWanted
        , locals
        , globalDB
        , globalDumpPkgs
        , snapshotDumpPkgs
        , localDumpPkgs
        , logFiles
        , customBuilt
        , largestPackageName
        , pathEnvVar
        } `finally` dumpLogs logFiles 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
    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 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
        Getting DumpLogs env DumpLogs -> RIO env DumpLogs
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((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)) RIO env DumpLogs -> (DumpLogs -> RIO env ()) -> RIO env ()
forall a b. RIO env a -> (a -> RIO env b) -> RIO env b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          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.

    colors <- shouldForceGhcColorFlag
    when colors $ liftIO $ mapM_ (stripColors . snd) allLogs
   where
    drainChan :: STM [(Path Abs Dir, Path Abs File)]
    drainChan :: STM [(Path Abs Dir, Path Abs File)]
drainChan =
      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 STM (Maybe (Path Abs Dir, Path Abs File))
-> (Maybe (Path Abs Dir, Path Abs File)
    -> STM [(Path Abs Dir, Path Abs File)])
-> STM [(Path Abs Dir, Path Abs File)]
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        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
          xs <- STM [(Path Abs Dir, Path Abs File)]
drainChan
          pure $ x: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
    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
    unless (null firstWarning) $ dumpLog " due to warnings" (pkgDir, 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
    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
-> ConduitT Text Text (RIO env) ()
forall (m :: * -> *).
(MonadIO m, MonadUnliftIO m) =>
ExcludeTHLoading
-> ConvertPathsToAbsolute
-> Path Abs Dir
-> ConduitM Text Text m ()
mungeBuildOutput ExcludeTHLoading
ExcludeTHLoading ConvertPathsToAbsolute
ConvertPathsToAbsolute Path Abs Dir
pkgDir
      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 -> String -> String
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

      mnext <- ConduitT ByteString ByteString IO (Maybe Word8)
forall (m :: * -> *) o.
Monad m =>
ConduitT ByteString o m (Maybe Word8)
CB.head
      whenJust mnext $ \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 -> String -> String
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) (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
len (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char -> String
forall a. a -> [a]
L.repeat Char
' '
  in  String
paddedName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"> "

announceTask ::
     HasLogFunc env
  => ExecuteEnv
  -> TaskType
  -> Utf8Builder
  -> RIO env ()
announceTask :: forall env.
HasLogFunc env =>
ExecuteEnv -> TaskType -> Utf8Builder -> RIO env ()
announceTask ExecuteEnv
ee TaskType
taskType Utf8Builder
action = Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, 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
  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 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
  ensureDir $ parent lockFP

  mres <-
    withRunInIO $ \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 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
        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 = 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
        unpackPackageLocation dir pkgloc

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

        distDir <- distRelativeDir
        let 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
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
        exists <- doesDirExist oldDist
        when exists $ 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

          ensureDir $ parent newDist
          renameDir oldDist newDist

        let name = PackageIdentifier -> PackageName
pkgName PackageIdentifier
pkgId
        cabalfpRel <- parseRelFile $ packageNameString name ++ ".cabal"
        let 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
        inner package cabalFP 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
        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
        ensureDir (parent logPath)
        let 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 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 ()

        withBinaryFile fp WriteMode $ \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 <- 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
    unless config.allowDifferentUser $
      checkOwnership (pkgDir </> config.workDir)
    let envSettings = EnvSettings
          { includeLocals :: Bool
includeLocals = TaskType -> InstallLocation
taskTypeLocation TaskType
taskType InstallLocation -> InstallLocation -> Bool
forall a. Eq a => a -> a -> Bool
== InstallLocation
Local
          , includeGhcPackagePath :: Bool
includeGhcPackagePath = Bool
False
          , stackExe :: Bool
stackExe = Bool
False
          , localeUtf8 :: Bool
localeUtf8 = Bool
True
          , keepGhcRts :: Bool
keepGhcRts = Bool
False
          }
    menv <- liftIO $ config.processContextSettings envSettings
    distRelativeDir' <- distRelativeDir
    setupexehs <-
      -- Avoid broken Setup.hs files causing problems for simple build

      -- types, see:

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

      case (package.buildType, ee.setupExe) of
        (BuildType
C.Simple, Just Path Abs File
setupExe) -> SetupExe -> RIO env SetupExe
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SetupExe -> RIO env SetupExe) -> SetupExe -> RIO env SetupExe
forall a b. (a -> b) -> a -> b
$ Path Abs File -> SetupExe
SimpleSetupExe Path Abs File
setupExe
        (BuildType, Maybe (Path Abs File))
_ -> IO SetupExe -> RIO env SetupExe
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO SetupExe -> RIO env SetupExe)
-> IO SetupExe -> RIO env SetupExe
forall a b. (a -> b) -> a -> b
$ Path Abs File -> SetupExe
OtherSetupHs (Path Abs File -> SetupExe) -> IO (Path Abs File) -> IO SetupExe
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Path Abs Dir -> IO (Path Abs File)
getSetupHs Path Abs Dir
pkgDir
    inner $ \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 -> String -> String
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=" String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String)
-> (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 -> String -> String
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 -> String -> String
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
                cabalPackageArg' <-
                  if 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
                    then [String] -> RIO env [String]
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
                    else do
                      [StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyWarnL
                        [ Style -> StyleDoc -> StyleDoc
style Style
Current (PackageName -> StyleDoc
forall a. IsString a => PackageName -> a
fromPackageName Package
package.name)
                        , String -> StyleDoc
flow String
"has a"
                        , Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"setup-depends"
                        , String -> StyleDoc
flow String
"field, but it does not mention a"
                        , Style -> StyleDoc -> StyleDoc
style Style
Current StyleDoc
"Cabal"
                        , String -> StyleDoc
flow String
"dependency. Stack customizes setup using \
                               \Cabal, so it has added the GHC boot package as \
                               \a dependency."
                        ]
                      [String] -> RIO env [String]
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [String]
cabalPackageArg
                matchedDeps <-
                  forM (Map.toList customSetupDeps) $ \(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 -> String -> String
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 -> String -> String
forall a. [a] -> [a] -> [a]
++ PackageName -> String
packageNameString PackageName
name, Maybe PackageIdentifier
forall a. Maybe a
Nothing)
                let 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 = ((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 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
"-optP-include", String
"-optP" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
cppMacrosFile]
                writeBinaryFileAtomic
                  cppMacrosFile
                  ( encodeUtf8Builder
                      ( T.pack
                          ( C.generatePackageVersionMacros
                              package.version
                              macroDeps
                          )
                      )
                  )
                pure (packageDBArgs ++ depsArgs ++ cabalPackageArg' ++ 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
                let packageDBArgs' :: [String]
packageDBArgs' = case Package
package.buildType of
                      -- The Configure build type is very similar to Simple. As

                      -- such, Stack builds the setup executable in much the

                      -- same way as it would in the case of Simple.

                      BuildType
C.Configure ->
                        [ String
"-hide-all-packages"
                        , String
"-package base"
                        ]
                      -- 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

                      BuildType
_ ->
                           (Path Abs Dir -> String) -> [Path Abs Dir] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map
                             ((String
"-package-db=" String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String)
-> (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. Semigroup a => a -> a -> a
<> [    String
"-package-db="
                             String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Path Abs Dir -> String
forall loc. Path loc Dir -> String
toFilePathNoTrailingSep ExecuteEnv
ee.baseConfigOpts.snapDB
                           ]
                [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
"-clear-package-db"
                     , String
"-global-package-db"
                     ]
                  [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String]
packageDBArgs'
                  [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String]
cabalPackageArg

          setupArgs :: [String]
setupArgs =
            (String
"--builddir=" String -> String -> String
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
            RIO env ()
runAndOutput 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
              (mlogFile, 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
-> ConduitM Text Text (RIO env) ()
forall (m :: * -> *).
(MonadIO m, MonadUnliftIO m) =>
ExcludeTHLoading
-> ConvertPathsToAbsolute
-> Path Abs Dir
-> ConduitM Text Text m ()
mungeBuildOutput ExcludeTHLoading
stripTHLoading ConvertPathsToAbsolute
makeAbsolute Path Abs Dir
pkgDir
                          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
              prettyThrowM $ CabalExitedUnsuccessfully
                (eceExitCode ece) pkgId exeName fullArgs mlogFile bss
           where
            runAndOutput :: RIO env ()
            runAndOutput :: RIO env ()
runAndOutput = 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 -> Utf8Builder -> ConduitM ByteString Void (RIO env) ()
ExcludeTHLoading
-> LogLevel -> Utf8Builder -> ConduitM ByteString Void (RIO env) ()
outputSink ExcludeTHLoading
KeepTHLoading LogLevel
LevelWarn Utf8Builder
prefix)
                        (HasCallStack =>
ExcludeTHLoading
-> LogLevel -> Utf8Builder -> ConduitM ByteString Void (RIO env) ()
ExcludeTHLoading
-> LogLevel -> Utf8Builder -> ConduitM ByteString Void (RIO env) ()
outputSink ExcludeTHLoading
stripTHLoading LogLevel
LevelInfo Utf8Builder
prefix)
            outputSink ::
                 HasCallStack
              => ExcludeTHLoading
              -> LogLevel
              -> Utf8Builder
              -> ConduitM S.ByteString Void (RIO env) ()
            outputSink :: HasCallStack =>
ExcludeTHLoading
-> LogLevel -> Utf8Builder -> ConduitM ByteString Void (RIO env) ()
outputSink ExcludeTHLoading
excludeTH LogLevel
level 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
-> ConduitM Text Text (RIO env) ()
forall (m :: * -> *).
(MonadIO m, MonadUnliftIO m) =>
ExcludeTHLoading
-> ConvertPathsToAbsolute
-> Path Abs Dir
-> ConduitM Text Text m ()
mungeBuildOutput ExcludeTHLoading
excludeTH ConvertPathsToAbsolute
makeAbsolute Path Abs Dir
pkgDir
              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 -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>) (Utf8Builder -> Utf8Builder)
-> (Text -> Utf8Builder) -> Text -> Utf8Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
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

      exeName <- case SetupExe
setupexehs of
        SimpleSetupExe 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
        OtherSetupHs Path Abs File
setuphs -> do
          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
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 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
          customBuilt <- liftIO $ readIORef ee.customBuilt
          if Set.member package.name customBuilt
            then pure outputFile
            else do
              ensureDir setupDir
              compilerPath <- view $ compilerPathsL . to (.compiler)
              packageArgs <- getPackageArgs setupDir
              runExe compilerPath $
                   [ "--make"
                   , "-odir", toFilePathNoTrailingSep setupDir
                   , "-hidir", toFilePathNoTrailingSep setupDir
                   , "-i", "-i."
                   ]
                <> packageArgs
                <> [ toFilePath setuphs
                   , toFilePath ee.setupShimHs
                   , "-main-is"
                   , "StackSetupShim.mainOverride"
                   , "-o", toFilePath outputFile
                   , "-threaded"
                   ]
                -- Apply GHC options

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

                <> map
                     T.unpack
                     (  Map.findWithDefault
                          []
                          AGOEverything
                          config.ghcOptionsByCat
                     <> case config.applyGhcOptions of
                          ApplyGhcOptions
AGOEverything -> ExecuteEnv
ee.buildOptsCLI.ghcOptions
                          ApplyGhcOptions
AGOTargets -> []
                          ApplyGhcOptions
AGOLocals -> []
                     )

              liftIO $ atomicModifyIORef' ee.customBuilt $
                \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, ())
              pure outputFile
      let cabalVerboseArg =
            let CabalVerbosity Verbosity
cv = ExecuteEnv
ee.buildOpts.cabalVerbose
            in  String
"--verbose=" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Verbosity -> String
showForCabal Verbosity
cv
      runExe exeName $ cabalVerboseArg: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

  -> ConduitM Text Text m ()
mungeBuildOutput :: forall (m :: * -> *).
(MonadIO m, MonadUnliftIO m) =>
ExcludeTHLoading
-> ConvertPathsToAbsolute
-> Path Abs Dir
-> ConduitM Text Text m ()
mungeBuildOutput ExcludeTHLoading
excludeTHLoading ConvertPathsToAbsolute
makeAbsolute Path Abs Dir
pkgDir = 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

    ConduitT Text Text m ()
doNothing

  -- | 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
    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 -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text) -> (Path Abs File -> Text) -> Path Abs File -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text)
-> (Path Abs File -> String) -> Path Abs File -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs File -> String
forall b t. Path b t -> String
toFilePath)) (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 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
    now <- IO ZonedTime -> m ZonedTime
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ZonedTime
getZonedTime
    pure (formatZonedTimeForLog now <> " " <> 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
  exists1 <- Path Abs File -> IO Bool
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
fp1
  if exists1
    then pure fp1
    else do
      exists2 <- doesFileExist fp2
      if exists2
        then pure fp2
        else throwM $ NoSetupHsFound 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