{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
--
-- Misc process handling code for SysTools
--
-- (c) The GHC Team 2017
--
-----------------------------------------------------------------------------
module GHC.SysTools.Process where

import GHC.Prelude

import GHC.Driver.Session

import GHC.Utils.Exception
import GHC.Utils.Error
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Misc
import GHC.Utils.Logger

import GHC.Types.SrcLoc ( SrcLoc, mkSrcLoc, mkSrcSpan )
import GHC.Data.FastString

import Control.Concurrent
import Data.Char

import System.Exit
import System.Environment
import System.FilePath
import System.IO
import System.IO.Error as IO
import System.Process

import GHC.Utils.TmpFs

-- | Enable process jobs support on Windows if it can be expected to work (e.g.
-- @process >= 1.6.9.0@).
enableProcessJobs :: CreateProcess -> CreateProcess
#if defined(MIN_VERSION_process)
enableProcessJobs :: CreateProcess -> CreateProcess
enableProcessJobs CreateProcess
opts = CreateProcess
opts { use_process_jobs = True }
#else
enableProcessJobs opts = opts
#endif

#if !MIN_VERSION_base(4,15,0)
-- TODO: This can be dropped with GHC 8.16
hGetContents' :: Handle -> IO String
hGetContents' hdl = do
  output  <- hGetContents hdl
  _ <- evaluate $ length output
  return output
#endif

-- Similar to System.Process.readCreateProcessWithExitCode, but stderr is
-- inherited from the parent process, and output to stderr is not captured.
readCreateProcessWithExitCode'
    :: CreateProcess
    -> IO (ExitCode, String)    -- ^ stdout
readCreateProcessWithExitCode' :: CreateProcess -> IO (ExitCode, [Char])
readCreateProcessWithExitCode' CreateProcess
proc = do
    (Maybe Handle
_, Just Handle
outh, Maybe Handle
_, ProcessHandle
pid) <-
        CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess (CreateProcess
 -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle))
-> CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
forall a b. (a -> b) -> a -> b
$ CreateProcess -> CreateProcess
enableProcessJobs (CreateProcess -> CreateProcess) -> CreateProcess -> CreateProcess
forall a b. (a -> b) -> a -> b
$ CreateProcess
proc{ std_out = CreatePipe }

    -- fork off a thread to start consuming the output
    MVar (Either SomeException [Char])
outMVar <- IO (MVar (Either SomeException [Char]))
forall a. IO (MVar a)
newEmptyMVar
    let onError :: SomeException -> IO ()
        onError :: SomeException -> IO ()
onError SomeException
exc = MVar (Either SomeException [Char])
-> Either SomeException [Char] -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Either SomeException [Char])
outMVar (SomeException -> Either SomeException [Char]
forall a b. a -> Either a b
Left SomeException
exc)
    ThreadId
_ <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ (SomeException -> IO ()) -> IO () -> IO ()
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle SomeException -> IO ()
onError (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      [Char]
output <- Handle -> IO [Char]
hGetContents' Handle
outh
      MVar (Either SomeException [Char])
-> Either SomeException [Char] -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Either SomeException [Char])
outMVar (Either SomeException [Char] -> IO ())
-> Either SomeException [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Either SomeException [Char]
forall a b. b -> Either a b
Right [Char]
output

    -- wait on the output
    Either SomeException [Char]
result <- MVar (Either SomeException [Char])
-> IO (Either SomeException [Char])
forall a. MVar a -> IO a
takeMVar MVar (Either SomeException [Char])
outMVar
    Handle -> IO ()
hClose Handle
outh
    [Char]
output <- case Either SomeException [Char]
result of
      Left SomeException
exc -> SomeException -> IO [Char]
forall e a. Exception e => e -> IO a
throwIO SomeException
exc
      Right [Char]
output -> [Char] -> IO [Char]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
output

    -- wait on the process
    ExitCode
ex <- ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
pid

    (ExitCode, [Char]) -> IO (ExitCode, [Char])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ExitCode
ex, [Char]
output)

replaceVar :: (String, String) -> [(String, String)] -> [(String, String)]
replaceVar :: ([Char], [Char]) -> [([Char], [Char])] -> [([Char], [Char])]
replaceVar ([Char]
var, [Char]
value) [([Char], [Char])]
env =
    ([Char]
var, [Char]
value) ([Char], [Char]) -> [([Char], [Char])] -> [([Char], [Char])]
forall a. a -> [a] -> [a]
: (([Char], [Char]) -> Bool)
-> [([Char], [Char])] -> [([Char], [Char])]
forall a. (a -> Bool) -> [a] -> [a]
filter (\([Char]
var',[Char]
_) -> [Char]
var [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
/= [Char]
var') [([Char], [Char])]
env

-- | Version of @System.Process.readProcessWithExitCode@ that takes a
-- key-value tuple to insert into the environment.
readProcessEnvWithExitCode
    :: String -- ^ program path
    -> [String] -- ^ program args
    -> (String, String) -- ^ addition to the environment
    -> IO (ExitCode, String, String) -- ^ (exit_code, stdout, stderr)
readProcessEnvWithExitCode :: [Char]
-> [[Char]] -> ([Char], [Char]) -> IO (ExitCode, [Char], [Char])
readProcessEnvWithExitCode [Char]
prog [[Char]]
args ([Char], [Char])
env_update = do
    [([Char], [Char])]
current_env <- IO [([Char], [Char])]
getEnvironment
    CreateProcess -> [Char] -> IO (ExitCode, [Char], [Char])
readCreateProcessWithExitCode ([Char] -> [[Char]] -> CreateProcess
proc [Char]
prog [[Char]]
args) {
        env = Just (replaceVar env_update current_env) } [Char]
""

-- Don't let gcc localize version info string, #8825
c_locale_env :: (String, String)
c_locale_env :: ([Char], [Char])
c_locale_env = ([Char]
"LANGUAGE", [Char]
"C")

-- If the -B<dir> option is set, add <dir> to PATH.  This works around
-- a bug in gcc on Windows Vista where it can't find its auxiliary
-- binaries (see bug #1110).
getGccEnv :: [Option] -> IO (Maybe [(String,String)])
getGccEnv :: [Option] -> IO (Maybe [([Char], [Char])])
getGccEnv [Option]
opts =
  if [[Char]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
b_dirs
     then Maybe [([Char], [Char])] -> IO (Maybe [([Char], [Char])])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [([Char], [Char])]
forall a. Maybe a
Nothing
     else do [([Char], [Char])]
env <- IO [([Char], [Char])]
getEnvironment
             Maybe [([Char], [Char])] -> IO (Maybe [([Char], [Char])])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([([Char], [Char])] -> Maybe [([Char], [Char])]
forall a. a -> Maybe a
Just ([([Char], [Char])] -> [([Char], [Char])]
mangle_paths [([Char], [Char])]
env))
 where
  ([[Char]]
b_dirs, [Option]
_) = (Option -> Either [Char] Option)
-> [Option] -> ([[Char]], [Option])
forall a b c. (a -> Either b c) -> [a] -> ([b], [c])
partitionWith Option -> Either [Char] Option
get_b_opt [Option]
opts

  get_b_opt :: Option -> Either [Char] Option
get_b_opt (Option (Char
'-':Char
'B':[Char]
dir)) = [Char] -> Either [Char] Option
forall a b. a -> Either a b
Left [Char]
dir
  get_b_opt Option
other = Option -> Either [Char] Option
forall a b. b -> Either a b
Right Option
other

  -- Work around #1110 on Windows only (lest we stumble into #17266).
#if defined(mingw32_HOST_OS)
  mangle_paths :: [([Char], [Char])] -> [([Char], [Char])]
mangle_paths = (([Char], [Char]) -> ([Char], [Char]))
-> [([Char], [Char])] -> [([Char], [Char])]
forall a b. (a -> b) -> [a] -> [b]
map ([Char], [Char]) -> ([Char], [Char])
mangle_path
  mangle_path :: ([Char], [Char]) -> ([Char], [Char])
mangle_path ([Char]
path,[Char]
paths) | (Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper [Char]
path [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"PATH"
        = ([Char]
path, Char
'\"' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [[Char]] -> [Char]
forall a. HasCallStack => [a] -> a
head [[Char]]
b_dirs [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\";" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
paths)
  mangle_path ([Char], [Char])
other = ([Char], [Char])
other
#else
  mangle_paths = id
#endif


-----------------------------------------------------------------------------
-- Running an external program

runSomething :: Logger
             -> String          -- For -v message
             -> String          -- Command name (possibly a full path)
                                --      assumed already dos-ified
             -> [Option]        -- Arguments
                                --      runSomething will dos-ify them
             -> IO ()

runSomething :: Logger -> [Char] -> [Char] -> [Option] -> IO ()
runSomething Logger
logger [Char]
phase_name [Char]
pgm [Option]
args =
  Logger
-> ([Char] -> [Char])
-> [Char]
-> [Char]
-> [Option]
-> Maybe [Char]
-> Maybe [([Char], [Char])]
-> IO ()
runSomethingFiltered Logger
logger [Char] -> [Char]
forall a. a -> a
id [Char]
phase_name [Char]
pgm [Option]
args Maybe [Char]
forall a. Maybe a
Nothing Maybe [([Char], [Char])]
forall a. Maybe a
Nothing

-- | Run a command, placing the arguments in an external response file.
--
-- This command is used in order to avoid overlong command line arguments on
-- Windows. The command line arguments are first written to an external,
-- temporary response file, and then passed to the linker via @filepath.
-- response files for passing them in. See:
--
--     https://gcc.gnu.org/wiki/Response_Files
--     https://gitlab.haskell.org/ghc/ghc/issues/10777
runSomethingResponseFile
  :: Logger
  -> TmpFs
  -> DynFlags
  -> (String->String)
  -> String
  -> String
  -> [Option]
  -> Maybe [(String,String)]
  -> IO ()
runSomethingResponseFile :: Logger
-> TmpFs
-> DynFlags
-> ([Char] -> [Char])
-> [Char]
-> [Char]
-> [Option]
-> Maybe [([Char], [Char])]
-> IO ()
runSomethingResponseFile Logger
logger TmpFs
tmpfs DynFlags
dflags [Char] -> [Char]
filter_fn [Char]
phase_name [Char]
pgm [Option]
args Maybe [([Char], [Char])]
mb_env =
    Logger
-> [Char]
-> [Char]
-> [Option]
-> ([[Char]] -> IO (ExitCode, ()))
-> IO ()
forall a.
Logger
-> [Char]
-> [Char]
-> [Option]
-> ([[Char]] -> IO (ExitCode, a))
-> IO a
runSomethingWith Logger
logger [Char]
phase_name [Char]
pgm [Option]
args (([[Char]] -> IO (ExitCode, ())) -> IO ())
-> ([[Char]] -> IO (ExitCode, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[[Char]]
real_args -> do
        [Char]
fp <- [[Char]] -> IO [Char]
getResponseFile [[Char]]
real_args
        let args :: [[Char]]
args = [Char
'@'Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:[Char]
fp]
        ExitCode
r <- Logger
-> ([Char] -> [Char])
-> [Char]
-> [[Char]]
-> Maybe [Char]
-> Maybe [([Char], [Char])]
-> IO ExitCode
builderMainLoop Logger
logger [Char] -> [Char]
filter_fn [Char]
pgm [[Char]]
args Maybe [Char]
forall a. Maybe a
Nothing Maybe [([Char], [Char])]
mb_env
        (ExitCode, ()) -> IO (ExitCode, ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ExitCode
r,())
  where
    getResponseFile :: [[Char]] -> IO [Char]
getResponseFile [[Char]]
args = do
      [Char]
fp <- Logger
-> TmpFs -> TempDir -> TempFileLifetime -> [Char] -> IO [Char]
newTempName Logger
logger TmpFs
tmpfs (DynFlags -> TempDir
tmpDir DynFlags
dflags) TempFileLifetime
TFL_CurrentModule [Char]
"rsp"
      [Char] -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. [Char] -> IOMode -> (Handle -> IO r) -> IO r
withFile [Char]
fp IOMode
WriteMode ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
          Handle -> TextEncoding -> IO ()
hSetEncoding Handle
h TextEncoding
utf8
          Handle -> [Char] -> IO ()
hPutStr Handle
h ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unlines ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ ([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> [Char]
forall {t :: * -> *}. Foldable t => t Char -> [Char]
escape [[Char]]
args
      [Char] -> IO [Char]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
fp

    -- Note: Response files have backslash-escaping, double quoting, and are
    -- whitespace separated (some implementations use newline, others any
    -- whitespace character). Therefore, escape any backslashes, newlines, and
    -- double quotes in the argument, and surround the content with double
    -- quotes.
    --
    -- Another possibility that could be considered would be to convert
    -- backslashes in the argument to forward slashes. This would generally do
    -- the right thing, since backslashes in general only appear in arguments
    -- as part of file paths on Windows, and the forward slash is accepted for
    -- those. However, escaping is more reliable, in case somehow a backslash
    -- appears in a non-file.
    escape :: t Char -> [Char]
escape t Char
x = [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ [Char]
"\""
        , (Char -> [Char]) -> t Char -> [Char]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
            (\Char
c ->
                case Char
c of
                    Char
'\\' -> [Char]
"\\\\"
                    Char
'\n' -> [Char]
"\\n"
                    Char
'\"' -> [Char]
"\\\""
                    Char
_    -> [Char
c])
            t Char
x
        , [Char]
"\""
        ]

runSomethingFiltered
  :: Logger -> (String->String) -> String -> String -> [Option]
  -> Maybe FilePath -> Maybe [(String,String)] -> IO ()

runSomethingFiltered :: Logger
-> ([Char] -> [Char])
-> [Char]
-> [Char]
-> [Option]
-> Maybe [Char]
-> Maybe [([Char], [Char])]
-> IO ()
runSomethingFiltered Logger
logger [Char] -> [Char]
filter_fn [Char]
phase_name [Char]
pgm [Option]
args Maybe [Char]
mb_cwd Maybe [([Char], [Char])]
mb_env =
    Logger
-> [Char]
-> [Char]
-> [Option]
-> ([[Char]] -> IO (ExitCode, ()))
-> IO ()
forall a.
Logger
-> [Char]
-> [Char]
-> [Option]
-> ([[Char]] -> IO (ExitCode, a))
-> IO a
runSomethingWith Logger
logger [Char]
phase_name [Char]
pgm [Option]
args (([[Char]] -> IO (ExitCode, ())) -> IO ())
-> ([[Char]] -> IO (ExitCode, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[[Char]]
real_args -> do
        ExitCode
r <- Logger
-> ([Char] -> [Char])
-> [Char]
-> [[Char]]
-> Maybe [Char]
-> Maybe [([Char], [Char])]
-> IO ExitCode
builderMainLoop Logger
logger [Char] -> [Char]
filter_fn [Char]
pgm [[Char]]
real_args Maybe [Char]
mb_cwd Maybe [([Char], [Char])]
mb_env
        (ExitCode, ()) -> IO (ExitCode, ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ExitCode
r,())

runSomethingWith
  :: Logger -> String -> String -> [Option]
  -> ([String] -> IO (ExitCode, a))
  -> IO a

runSomethingWith :: forall a.
Logger
-> [Char]
-> [Char]
-> [Option]
-> ([[Char]] -> IO (ExitCode, a))
-> IO a
runSomethingWith Logger
logger [Char]
phase_name [Char]
pgm [Option]
args [[Char]] -> IO (ExitCode, a)
io = do
  let real_args :: [[Char]]
real_args = ([Char] -> Bool) -> [[Char]] -> [[Char]]
forall a. (a -> Bool) -> [a] -> [a]
filter [Char] -> Bool
forall (f :: * -> *) a. Foldable f => f a -> Bool
notNull ((Option -> [Char]) -> [Option] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Option -> [Char]
showOpt [Option]
args)
      cmdLine :: [Char]
cmdLine = [Char] -> [[Char]] -> [Char]
showCommandForUser [Char]
pgm [[Char]]
real_args
  Logger -> [Char] -> [Char] -> IO a -> IO a
forall a. Logger -> [Char] -> [Char] -> IO a -> IO a
traceCmd Logger
logger [Char]
phase_name [Char]
cmdLine (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO (ExitCode, a) -> IO a
forall r. [Char] -> [Char] -> IO (ExitCode, r) -> IO r
handleProc [Char]
pgm [Char]
phase_name (IO (ExitCode, a) -> IO a) -> IO (ExitCode, a) -> IO a
forall a b. (a -> b) -> a -> b
$ [[Char]] -> IO (ExitCode, a)
io [[Char]]
real_args

handleProc :: String -> String -> IO (ExitCode, r) -> IO r
handleProc :: forall r. [Char] -> [Char] -> IO (ExitCode, r) -> IO r
handleProc [Char]
pgm [Char]
phase_name IO (ExitCode, r)
proc = do
    (ExitCode
rc, r
r) <- IO (ExitCode, r)
proc IO (ExitCode, r)
-> (IOError -> IO (ExitCode, r)) -> IO (ExitCode, r)
forall a. IO a -> (IOError -> IO a) -> IO a
`catchIO` IOError -> IO (ExitCode, r)
handler
    case ExitCode
rc of
      ExitSuccess{} -> r -> IO r
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return r
r
      ExitFailure Int
n -> GhcException -> IO r
forall a. GhcException -> IO a
throwGhcExceptionIO (
            [Char] -> GhcException
ProgramError ([Char]
"`" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
takeFileName [Char]
pgm [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"'" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                          [Char]
" failed in phase `" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
phase_name [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"'." [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                          [Char]
" (Exit code: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"))
  where
    handler :: IOError -> IO (ExitCode, r)
handler IOError
err =
       if IOError -> Bool
IO.isDoesNotExistError IOError
err
          then IO (ExitCode, r)
does_not_exist
          else GhcException -> IO (ExitCode, r)
forall a. GhcException -> IO a
throwGhcExceptionIO ([Char] -> GhcException
ProgramError ([Char] -> GhcException) -> [Char] -> GhcException
forall a b. (a -> b) -> a -> b
$ IOError -> [Char]
forall a. Show a => a -> [Char]
show IOError
err)

    does_not_exist :: IO (ExitCode, r)
does_not_exist = GhcException -> IO (ExitCode, r)
forall a. GhcException -> IO a
throwGhcExceptionIO ([Char] -> GhcException
InstallationError ([Char]
"could not execute: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
pgm))


builderMainLoop :: Logger -> (String -> String) -> FilePath
                -> [String] -> Maybe FilePath -> Maybe [(String, String)]
                -> IO ExitCode
builderMainLoop :: Logger
-> ([Char] -> [Char])
-> [Char]
-> [[Char]]
-> Maybe [Char]
-> Maybe [([Char], [Char])]
-> IO ExitCode
builderMainLoop Logger
logger [Char] -> [Char]
filter_fn [Char]
pgm [[Char]]
real_args Maybe [Char]
mb_cwd Maybe [([Char], [Char])]
mb_env = do
  Chan BuildMessage
chan <- IO (Chan BuildMessage)
forall a. IO (Chan a)
newChan

  -- We use a mask here rather than a bracket because we want
  -- to distinguish between cleaning up with and without an
  -- exception. This is to avoid calling terminateProcess
  -- unless an exception was raised.
  let safely :: (ProcessHandle -> IO ExitCode) -> IO ExitCode
safely ProcessHandle -> IO ExitCode
inner = ((forall a. IO a -> IO a) -> IO ExitCode) -> IO ExitCode
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask (((forall a. IO a -> IO a) -> IO ExitCode) -> IO ExitCode)
-> ((forall a. IO a -> IO a) -> IO ExitCode) -> IO ExitCode
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> do
        -- acquire
        -- On Windows due to how exec is emulated the old process will exit and
        -- a new process will be created. This means waiting for termination of
        -- the parent process will get you in a race condition as the child may
        -- not have finished yet.  This caused #16450.  To fix this use a
        -- process job to track all child processes and wait for each one to
        -- finish.
        let procdata :: CreateProcess
procdata =
              CreateProcess -> CreateProcess
enableProcessJobs
              (CreateProcess -> CreateProcess) -> CreateProcess -> CreateProcess
forall a b. (a -> b) -> a -> b
$ ([Char] -> [[Char]] -> CreateProcess
proc [Char]
pgm [[Char]]
real_args) { cwd = mb_cwd
                                     , env = mb_env
                                     , std_in  = CreatePipe
                                     , std_out = CreatePipe
                                     , std_err = CreatePipe
                                     }
        (Just Handle
hStdIn, Just Handle
hStdOut, Just Handle
hStdErr, ProcessHandle
hProcess) <- IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
forall a. IO a -> IO a
restore (IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
 -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle))
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
forall a b. (a -> b) -> a -> b
$
          [Char]
-> CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess_ [Char]
"builderMainLoop" CreateProcess
procdata
        let cleanup_handles :: IO ()
cleanup_handles = do
              Handle -> IO ()
hClose Handle
hStdIn
              Handle -> IO ()
hClose Handle
hStdOut
              Handle -> IO ()
hClose Handle
hStdErr
        Either SomeException ExitCode
r <- IO ExitCode -> IO (Either SomeException ExitCode)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO ExitCode -> IO (Either SomeException ExitCode))
-> IO ExitCode -> IO (Either SomeException ExitCode)
forall a b. (a -> b) -> a -> b
$ IO ExitCode -> IO ExitCode
forall a. IO a -> IO a
restore (IO ExitCode -> IO ExitCode) -> IO ExitCode -> IO ExitCode
forall a b. (a -> b) -> a -> b
$ do
          Handle -> BufferMode -> IO ()
hSetBuffering Handle
hStdOut BufferMode
LineBuffering
          Handle -> BufferMode -> IO ()
hSetBuffering Handle
hStdErr BufferMode
LineBuffering
          let make_reader_proc :: Handle -> IO ThreadId
make_reader_proc Handle
h = IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ Chan BuildMessage -> Handle -> ([Char] -> [Char]) -> IO ()
readerProc Chan BuildMessage
chan Handle
h [Char] -> [Char]
filter_fn
          IO ThreadId
-> (ThreadId -> IO ()) -> (ThreadId -> IO ExitCode) -> IO ExitCode
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracketOnError (Handle -> IO ThreadId
make_reader_proc Handle
hStdOut) ThreadId -> IO ()
killThread ((ThreadId -> IO ExitCode) -> IO ExitCode)
-> (ThreadId -> IO ExitCode) -> IO ExitCode
forall a b. (a -> b) -> a -> b
$ \ThreadId
_ ->
            IO ThreadId
-> (ThreadId -> IO ()) -> (ThreadId -> IO ExitCode) -> IO ExitCode
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracketOnError (Handle -> IO ThreadId
make_reader_proc Handle
hStdErr) ThreadId -> IO ()
killThread ((ThreadId -> IO ExitCode) -> IO ExitCode)
-> (ThreadId -> IO ExitCode) -> IO ExitCode
forall a b. (a -> b) -> a -> b
$ \ThreadId
_ ->
            ProcessHandle -> IO ExitCode
inner ProcessHandle
hProcess
        case Either SomeException ExitCode
r of
          -- onException
          Left (SomeException e
e) -> do
            ProcessHandle -> IO ()
terminateProcess ProcessHandle
hProcess
            IO ()
cleanup_handles
            e -> IO ExitCode
forall a e. Exception e => e -> a
throw e
e
          -- cleanup when there was no exception
          Right ExitCode
s -> do
            IO ()
cleanup_handles
            ExitCode -> IO ExitCode
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ExitCode
s
  (ProcessHandle -> IO ExitCode) -> IO ExitCode
safely ((ProcessHandle -> IO ExitCode) -> IO ExitCode)
-> (ProcessHandle -> IO ExitCode) -> IO ExitCode
forall a b. (a -> b) -> a -> b
$ \ProcessHandle
h -> do
    -- we don't want to finish until 2 streams have been complete
    -- (stdout and stderr)
    Chan BuildMessage -> Integer -> IO ()
log_loop Chan BuildMessage
chan (Integer
2 :: Integer)
    -- after that, we wait for the process to finish and return the exit code.
    ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
h
  where
    -- t starts at the number of streams we're listening to (2) decrements each
    -- time a reader process sends EOF. We are safe from looping forever if a
    -- reader thread dies, because they send EOF in a finally handler.
    log_loop :: Chan BuildMessage -> Integer -> IO ()
log_loop Chan BuildMessage
_ Integer
0 = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    log_loop Chan BuildMessage
chan Integer
t = do
      BuildMessage
msg <- Chan BuildMessage -> IO BuildMessage
forall a. Chan a -> IO a
readChan Chan BuildMessage
chan
      case BuildMessage
msg of
        BuildMsg SDoc
msg -> do
          Logger -> SDoc -> IO ()
logInfo Logger
logger (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ PprStyle -> SDoc -> SDoc
withPprStyle PprStyle
defaultUserStyle SDoc
msg
          Chan BuildMessage -> Integer -> IO ()
log_loop Chan BuildMessage
chan Integer
t
        BuildError SrcLoc
loc SDoc
msg -> do
          Logger -> MessageClass -> SrcSpan -> SDoc -> IO ()
logMsg Logger
logger MessageClass
errorDiagnostic (SrcLoc -> SrcLoc -> SrcSpan
mkSrcSpan SrcLoc
loc SrcLoc
loc)
              (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ PprStyle -> SDoc -> SDoc
withPprStyle PprStyle
defaultUserStyle SDoc
msg
          Chan BuildMessage -> Integer -> IO ()
log_loop Chan BuildMessage
chan Integer
t
        BuildMessage
EOF ->
          Chan BuildMessage -> Integer -> IO ()
log_loop Chan BuildMessage
chan  (Integer
tInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
1)

readerProc :: Chan BuildMessage -> Handle -> (String -> String) -> IO ()
readerProc :: Chan BuildMessage -> Handle -> ([Char] -> [Char]) -> IO ()
readerProc Chan BuildMessage
chan Handle
hdl [Char] -> [Char]
filter_fn =
    (do [Char]
str <- Handle -> IO [Char]
hGetContents Handle
hdl
        [[Char]] -> Maybe BuildMessage -> IO ()
loop ([Char] -> [[Char]]
linesPlatform ([Char] -> [Char]
filter_fn [Char]
str)) Maybe BuildMessage
forall a. Maybe a
Nothing)
    IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`finally`
       Chan BuildMessage -> BuildMessage -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan BuildMessage
chan BuildMessage
EOF
        -- ToDo: check errors more carefully
        -- ToDo: in the future, the filter should be implemented as
        -- a stream transformer.
    where
        loop :: [[Char]] -> Maybe BuildMessage -> IO ()
loop []     Maybe BuildMessage
Nothing    = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        loop []     (Just BuildMessage
err) = Chan BuildMessage -> BuildMessage -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan BuildMessage
chan BuildMessage
err
        loop ([Char]
l:[[Char]]
ls) Maybe BuildMessage
in_err     =
                case Maybe BuildMessage
in_err of
                  Just err :: BuildMessage
err@(BuildError SrcLoc
srcLoc SDoc
msg)
                    | [Char] -> Bool
leading_whitespace [Char]
l ->
                        [[Char]] -> Maybe BuildMessage -> IO ()
loop [[Char]]
ls (BuildMessage -> Maybe BuildMessage
forall a. a -> Maybe a
Just (SrcLoc -> SDoc -> BuildMessage
BuildError SrcLoc
srcLoc (SDoc
msg SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
l)))
                    | Bool
otherwise -> do
                        Chan BuildMessage -> BuildMessage -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan BuildMessage
chan BuildMessage
err
                        [Char] -> [[Char]] -> IO ()
checkError [Char]
l [[Char]]
ls
                  Maybe BuildMessage
Nothing ->
                        [Char] -> [[Char]] -> IO ()
checkError [Char]
l [[Char]]
ls
                  Maybe BuildMessage
_ -> [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
panic [Char]
"readerProc/loop"

        checkError :: [Char] -> [[Char]] -> IO ()
checkError [Char]
l [[Char]]
ls
           = case [Char] -> Maybe ([Char], Int, Int, [Char])
parseError [Char]
l of
                Maybe ([Char], Int, Int, [Char])
Nothing -> do
                    Chan BuildMessage -> BuildMessage -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan BuildMessage
chan (SDoc -> BuildMessage
BuildMsg ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
l))
                    [[Char]] -> Maybe BuildMessage -> IO ()
loop [[Char]]
ls Maybe BuildMessage
forall a. Maybe a
Nothing
                Just ([Char]
file, Int
lineNum, Int
colNum, [Char]
msg) -> do
                    let srcLoc :: SrcLoc
srcLoc = FastString -> Int -> Int -> SrcLoc
mkSrcLoc ([Char] -> FastString
mkFastString [Char]
file) Int
lineNum Int
colNum
                    [[Char]] -> Maybe BuildMessage -> IO ()
loop [[Char]]
ls (BuildMessage -> Maybe BuildMessage
forall a. a -> Maybe a
Just (SrcLoc -> SDoc -> BuildMessage
BuildError SrcLoc
srcLoc ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
msg)))

        leading_whitespace :: [Char] -> Bool
leading_whitespace []    = Bool
False
        leading_whitespace (Char
x:[Char]
_) = Char -> Bool
isSpace Char
x

parseError :: String -> Maybe (String, Int, Int, String)
parseError :: [Char] -> Maybe ([Char], Int, Int, [Char])
parseError [Char]
s0 = case [Char] -> Maybe ([Char], [Char])
breakColon [Char]
s0 of
                Just ([Char]
filename, [Char]
s1) ->
                    case [Char] -> Maybe (Int, [Char])
breakIntColon [Char]
s1 of
                    Just (Int
lineNum, [Char]
s2) ->
                        case [Char] -> Maybe (Int, [Char])
breakIntColon [Char]
s2 of
                        Just (Int
columnNum, [Char]
s3) ->
                            ([Char], Int, Int, [Char]) -> Maybe ([Char], Int, Int, [Char])
forall a. a -> Maybe a
Just ([Char]
filename, Int
lineNum, Int
columnNum, [Char]
s3)
                        Maybe (Int, [Char])
Nothing ->
                            ([Char], Int, Int, [Char]) -> Maybe ([Char], Int, Int, [Char])
forall a. a -> Maybe a
Just ([Char]
filename, Int
lineNum, Int
0, [Char]
s2)
                    Maybe (Int, [Char])
Nothing -> Maybe ([Char], Int, Int, [Char])
forall a. Maybe a
Nothing
                Maybe ([Char], [Char])
Nothing -> Maybe ([Char], Int, Int, [Char])
forall a. Maybe a
Nothing

-- | Break a line of an error message into a filename and the rest of the line,
-- taking care to ignore colons in Windows drive letters (as noted in #17786).
-- For instance,
--
-- * @"hi.c: ABCD"@ is mapped to @Just ("hi.c", \"ABCD\")@
-- * @"C:\\hi.c: ABCD"@ is mapped to @Just ("C:\\hi.c", \"ABCD\")@
breakColon :: String -> Maybe (String, String)
breakColon :: [Char] -> Maybe ([Char], [Char])
breakColon = [Char] -> [Char] -> Maybe ([Char], [Char])
go []
  where
    -- Don't break on Windows drive letters (e.g. @C:\@ or @C:/@)
    go :: [Char] -> [Char] -> Maybe ([Char], [Char])
go [Char]
accum  (Char
':':Char
'\\':[Char]
rest) = [Char] -> [Char] -> Maybe ([Char], [Char])
go (Char
'\\'Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:Char
':'Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:[Char]
accum) [Char]
rest
    go [Char]
accum  (Char
':':Char
'/':[Char]
rest)  = [Char] -> [Char] -> Maybe ([Char], [Char])
go (Char
'/'Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:Char
':'Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:[Char]
accum) [Char]
rest
    go [Char]
accum  (Char
':':[Char]
rest)      = ([Char], [Char]) -> Maybe ([Char], [Char])
forall a. a -> Maybe a
Just ([Char] -> [Char]
forall a. [a] -> [a]
reverse [Char]
accum, [Char]
rest)
    go [Char]
accum  (Char
c:[Char]
rest)        = [Char] -> [Char] -> Maybe ([Char], [Char])
go (Char
cChar -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:[Char]
accum) [Char]
rest
    go [Char]
_accum []              = Maybe ([Char], [Char])
forall a. Maybe a
Nothing

breakIntColon :: String -> Maybe (Int, String)
breakIntColon :: [Char] -> Maybe (Int, [Char])
breakIntColon [Char]
xs = case (Char -> Bool) -> [Char] -> ([Char], [Char])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char
':' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==) [Char]
xs of
                       ([Char]
ys, Char
_:[Char]
zs)
                        | Bool -> Bool
not ([Char] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
ys) Bool -> Bool -> Bool
&& (Char -> Bool) -> [Char] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isAscii [Char]
ys Bool -> Bool -> Bool
&& (Char -> Bool) -> [Char] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isDigit [Char]
ys ->
                           (Int, [Char]) -> Maybe (Int, [Char])
forall a. a -> Maybe a
Just ([Char] -> Int
forall a. Read a => [Char] -> a
read [Char]
ys, [Char]
zs)
                       ([Char], [Char])
_ -> Maybe (Int, [Char])
forall a. Maybe a
Nothing

data BuildMessage
  = BuildMsg   !SDoc
  | BuildError !SrcLoc !SDoc
  | EOF

-- Divvy up text stream into lines, taking platform dependent
-- line termination into account.
linesPlatform :: String -> [String]
#if !defined(mingw32_HOST_OS)
linesPlatform ls = lines ls
#else
linesPlatform :: [Char] -> [[Char]]
linesPlatform [Char]
"" = []
linesPlatform [Char]
xs =
  case [Char] -> ([Char], [Char])
lineBreak [Char]
xs of
    ([Char]
as,[Char]
xs1) -> [Char]
as [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [Char] -> [[Char]]
linesPlatform [Char]
xs1
  where
   lineBreak :: [Char] -> ([Char], [Char])
lineBreak [Char]
"" = ([Char]
"",[Char]
"")
   lineBreak (Char
'\r':Char
'\n':[Char]
xs) = ([],[Char]
xs)
   lineBreak (Char
'\n':[Char]
xs) = ([],[Char]
xs)
   lineBreak (Char
x:[Char]
xs) = let ([Char]
as,[Char]
bs) = [Char] -> ([Char], [Char])
lineBreak [Char]
xs in (Char
xChar -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:[Char]
as,[Char]
bs)

#endif