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

    #include "HsVersions.h"

    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 :: Bool
    use_process_jobs = Bool
    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, String)
    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 :: StdStream
    std_out = StdStream
    CreatePipe }

        -- fork off a thread to start consuming the output
        MVar (Either SomeException String)
    outMVar <- IO (MVar (Either SomeException String))
    forall a. IO (MVar a)
    newEmptyMVar
        let onError :: SomeException -> IO ()
            onError :: SomeException -> IO ()
    onError SomeException
    exc = MVar (Either SomeException String)
    -> Either SomeException String -> IO ()
    forall a. MVar a -> a -> IO ()
    putMVar MVar (Either SomeException String)
    outMVar (SomeException -> Either SomeException String
    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
          String
    output <- Handle -> IO String
    hGetContents' Handle
    outh
          MVar (Either SomeException String)
    -> Either SomeException String -> IO ()
    forall a. MVar a -> a -> IO ()
    putMVar MVar (Either SomeException String)
    outMVar (Either SomeException String -> IO ())
    -> Either SomeException String -> IO ()
    forall a b. (a -> b) -> a -> b
    $ String -> Either SomeException String
    forall a b. b -> Either a b
    Right String
    output

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

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

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

    replaceVar :: (String, String) -> [(String, String)] -> [(String, String)]
    replaceVar :: (String, String) -> [(String, String)] -> [(String, String)]
    replaceVar (String
    var, String
    value) [(String, String)]
    env =
        (String
    var, String
    value) (String, String) -> [(String, String)] -> [(String, String)]
    forall a. a -> [a] -> [a]
    : ((String, String) -> Bool)
    -> [(String, String)] -> [(String, String)]
    forall a. (a -> Bool) -> [a] -> [a]
    filter (\(String
    var',String
    _) -> String
    var String -> String -> Bool
    forall a. Eq a => a -> a -> Bool
    /= String
    var') [(String, String)]
    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 :: String
    -> [String] -> (String, String) -> IO (ExitCode, String, String)
    readProcessEnvWithExitCode String
    prog [String]
    args (String, String)
    env_update = do
        [(String, String)]
    current_env <- IO [(String, String)]
    getEnvironment
        CreateProcess -> String -> IO (ExitCode, String, String)
    readCreateProcessWithExitCode (String -> [String] -> CreateProcess
    proc String
    prog [String]
    args) {
            env :: Maybe [(String, String)]
    env = [(String, String)] -> Maybe [(String, String)]
    forall a. a -> Maybe a
    Just ((String, String) -> [(String, String)] -> [(String, String)]
    replaceVar (String, String)
    env_update [(String, String)]
    current_env) } String
    ""

    -- Don't let gcc localize version info string, #8825
    c_locale_env :: (String, String)
    c_locale_env :: (String, String)
    c_locale_env = (String
    "LANGUAGE", String
    "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 [(String, String)])
    getGccEnv [Option]
    opts =
      if [String] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [String]
    b_dirs
         then Maybe [(String, String)] -> IO (Maybe [(String, String)])
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe [(String, String)]
    forall a. Maybe a
    Nothing
         else do [(String, String)]
    env <- IO [(String, String)]
    getEnvironment
                 Maybe [(String, String)] -> IO (Maybe [(String, String)])
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([(String, String)] -> Maybe [(String, String)]
    forall a. a -> Maybe a
    Just ([(String, String)] -> [(String, String)]
    forall {a}. a -> a
    mangle_paths [(String, String)]
    env))
     where
      ([String]
    b_dirs, [Option]
    _) = (Option -> Either String Option)
    -> [Option] -> ([String], [Option])
    forall a b c. (a -> Either b c) -> [a] -> ([b], [c])
    partitionWith Option -> Either String Option
    get_b_opt [Option]
    opts

      get_b_opt :: Option -> Either String Option
    get_b_opt (Option (Char
    '-':Char
    'B':String
    dir)) = String -> Either String Option
    forall a b. a -> Either a b
    Left String
    dir
      get_b_opt Option
    other = Option -> Either String 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 = map mangle_path
      mangle_path (path,paths) | map toUpper path == "PATH"
            = (path, '\"' : head b_dirs ++ "\";" ++ paths)
      mangle_path other = other
    #else
      mangle_paths :: a -> a
    mangle_paths = a -> a
    forall {a}. a -> a
    id
    #endif

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

    runSomething :: Logger
                 -> DynFlags
                 -> 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 -> DynFlags -> String -> String -> [Option] -> IO ()
    runSomething Logger
    logger DynFlags
    dflags String
    phase_name String
    pgm [Option]
    args =
      Logger
    -> DynFlags
    -> (String -> String)
    -> String
    -> String
    -> [Option]
    -> Maybe String
    -> Maybe [(String, String)]
    -> IO ()
    runSomethingFiltered Logger
    logger DynFlags
    dflags String -> String
    forall {a}. a -> a
    id String
    phase_name String
    pgm [Option]
    args Maybe String
    forall a. Maybe a
    Nothing Maybe [(String, String)]
    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
    -> (String -> String)
    -> String
    -> String
    -> [Option]
    -> Maybe [(String, String)]
    -> IO ()
    runSomethingResponseFile Logger
    logger TmpFs
    tmpfs DynFlags
    dflags String -> String
    filter_fn String
    phase_name String
    pgm [Option]
    args Maybe [(String, String)]
    mb_env =
        Logger
    -> DynFlags
    -> String
    -> String
    -> [Option]
    -> ([String] -> IO (ExitCode, ()))
    -> IO ()
    forall a.
    Logger
    -> DynFlags
    -> String
    -> String
    -> [Option]
    -> ([String] -> IO (ExitCode, a))
    -> IO a
    runSomethingWith Logger
    logger DynFlags
    dflags String
    phase_name String
    pgm [Option]
    args (([String] -> IO (ExitCode, ())) -> IO ())
    -> ([String] -> IO (ExitCode, ())) -> IO ()
    forall a b. (a -> b) -> a -> b
    $ \[String]
    real_args -> do
            String
    fp <- [String] -> IO String
    getResponseFile [String]
    real_args
            let args :: [String]
    args = [Char
    '@'Char -> String -> String
    forall a. a -> [a] -> [a]
    :String
    fp]
            ExitCode
    r <- Logger
    -> DynFlags
    -> (String -> String)
    -> String
    -> [String]
    -> Maybe String
    -> Maybe [(String, String)]
    -> IO ExitCode
    builderMainLoop Logger
    logger DynFlags
    dflags String -> String
    filter_fn String
    pgm [String]
    args Maybe String
    forall a. Maybe a
    Nothing Maybe [(String, String)]
    mb_env
            (ExitCode, ()) -> IO (ExitCode, ())
    forall (m :: * -> *) a. Monad m => a -> m a
    return (ExitCode
    r,())
      where
        getResponseFile :: [String] -> IO String
    getResponseFile [String]
    args = do
          String
    fp <- Logger
    -> TmpFs -> DynFlags -> TempFileLifetime -> String -> IO String
    newTempName Logger
    logger TmpFs
    tmpfs DynFlags
    dflags TempFileLifetime
    TFL_CurrentModule String
    "rsp"
          String -> IOMode -> (Handle -> IO ()) -> IO ()
    forall r. String -> IOMode -> (Handle -> IO r) -> IO r
    withFile String
    fp IOMode
    WriteMode ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
    forall a b. (a -> b) -> a -> b
    $ \Handle
    h -> do
    #if defined(mingw32_HOST_OS)
              hSetEncoding h latin1
    #else
              Handle -> TextEncoding -> IO ()
    hSetEncoding Handle
    h TextEncoding
    utf8
    #endif
              Handle -> String -> IO ()
    hPutStr Handle
    h (String -> IO ()) -> String -> IO ()
    forall a b. (a -> b) -> a -> b
    $ [String] -> String
    unlines ([String] -> String) -> [String] -> String
    forall a b. (a -> b) -> a -> b
    $ (String -> String) -> [String] -> [String]
    forall a b. (a -> b) -> [a] -> [b]
    map String -> String
    forall {t :: * -> *}. Foldable t => t Char -> String
    escape [String]
    args
          String -> IO String
    forall (m :: * -> *) a. Monad m => a -> m a
    return String
    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 -> String
    escape t Char
    x = [String] -> String
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat
            [ String
    "\""
            , (Char -> String) -> t Char -> String
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap
                (\Char
    c ->
                    case Char
    c of
                        Char
    '\\' -> String
    "\\\\"
                        Char
    '\n' -> String
    "\\n"
                        Char
    '\"' -> String
    "\\\""
                        Char
    _    -> [Char
    c])
                t Char
    x
            , String
    "\""
            ]

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

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

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

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

    handleProc :: String -> String -> IO (ExitCode, r) -> IO r
    handleProc :: forall r. String -> String -> IO (ExitCode, r) -> IO r
    handleProc String
    pgm String
    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 (m :: * -> *) a. Monad m => a -> m a
    return r
    r
          ExitFailure Int
    n -> GhcException -> IO r
    forall a. GhcException -> IO a
    throwGhcExceptionIO (
                String -> GhcException
    ProgramError (String
    "`" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String -> String
    takeFileName String
    pgm String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "'" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++
                              String
    " failed in phase `" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    phase_name String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "'." String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++
                              String
    " (Exit code: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Int -> String
    forall a. Show a => a -> String
    show Int
    n String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    ")"))
      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 (String -> GhcException
    ProgramError (String -> GhcException) -> String -> GhcException
    forall a b. (a -> b) -> a -> b
    $ IOError -> String
    forall a. Show a => a -> String
    show IOError
    err)

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

    builderMainLoop :: Logger -> DynFlags -> (String -> String) -> FilePath
                    -> [String] -> Maybe FilePath -> Maybe [(String, String)]
                    -> IO ExitCode
    builderMainLoop :: Logger
    -> DynFlags
    -> (String -> String)
    -> String
    -> [String]
    -> Maybe String
    -> Maybe [(String, String)]
    -> IO ExitCode
    builderMainLoop Logger
    logger DynFlags
    dflags String -> String
    filter_fn String
    pgm [String]
    real_args Maybe String
    mb_cwd Maybe [(String, String)]
    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
    $ (String -> [String] -> CreateProcess
    proc String
    pgm [String]
    real_args) { cwd :: Maybe String
    cwd = Maybe String
    mb_cwd
                                         , env :: Maybe [(String, String)]
    env = Maybe [(String, String)]
    mb_env
                                         , std_in :: StdStream
    std_in  = StdStream
    CreatePipe
                                         , std_out :: StdStream
    std_out = StdStream
    CreatePipe
                                         , std_err :: StdStream
    std_err = StdStream
    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
    $
              String
    -> CreateProcess
    -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
    createProcess_ String
    "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 -> (String -> String) -> IO ()
    readerProc Chan BuildMessage
    chan Handle
    h String -> String
    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 (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 (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 -> DynFlags -> SDoc -> IO ()
    logInfo Logger
    logger DynFlags
    dflags (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 -> LogAction
    putLogMsg Logger
    logger DynFlags
    dflags WarnReason
    NoReason Severity
    SevError (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 -> (String -> String) -> IO ()
    readerProc Chan BuildMessage
    chan Handle
    hdl String -> String
    filter_fn =
        (do String
    str <- Handle -> IO String
    hGetContents Handle
    hdl
            [String] -> Maybe BuildMessage -> IO ()
    loop (String -> [String]
    linesPlatform (String -> String
    filter_fn String
    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 :: [String] -> Maybe BuildMessage -> IO ()
    loop []     Maybe BuildMessage
    Nothing    = () -> IO ()
    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 (String
    l:[String]
    ls) Maybe BuildMessage
    in_err     =
                    case Maybe BuildMessage
    in_err of
                      Just err :: BuildMessage
    err@(BuildError SrcLoc
    srcLoc SDoc
    msg)
                        | String -> Bool
    leading_whitespace String
    l ->
                            [String] -> Maybe BuildMessage -> IO ()
    loop [String]
    ls (BuildMessage -> Maybe BuildMessage
    forall a. a -> Maybe a
    Just (SrcLoc -> SDoc -> BuildMessage
    BuildError SrcLoc
    srcLoc (SDoc
    msg SDoc -> SDoc -> SDoc
    $$ String -> SDoc
    text String
    l)))
                        | Bool
    otherwise -> do
                            Chan BuildMessage -> BuildMessage -> IO ()
    forall a. Chan a -> a -> IO ()
    writeChan Chan BuildMessage
    chan BuildMessage
    err
                            String -> [String] -> IO ()
    checkError String
    l [String]
    ls
                      Maybe BuildMessage
    Nothing ->
                            String -> [String] -> IO ()
    checkError String
    l [String]
    ls
                      Maybe BuildMessage
    _ -> String -> IO ()
    forall a. String -> a
    panic String
    "readerProc/loop"

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

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

    parseError :: String -> Maybe (String, Int, Int, String)
    parseError :: String -> Maybe (String, Int, Int, String)
    parseError String
    s0 = case String -> Maybe (String, String)
    breakColon String
    s0 of
                    Just (String
    filename, String
    s1) ->
                        case String -> Maybe (Int, String)
    breakIntColon String
    s1 of
                        Just (Int
    lineNum, String
    s2) ->
                            case String -> Maybe (Int, String)
    breakIntColon String
    s2 of
                            Just (Int
    columnNum, String
    s3) ->
                                (String, Int, Int, String) -> Maybe (String, Int, Int, String)
    forall a. a -> Maybe a
    Just (String
    filename, Int
    lineNum, Int
    columnNum, String
    s3)
                            Maybe (Int, String)
    Nothing ->
                                (String, Int, Int, String) -> Maybe (String, Int, Int, String)
    forall a. a -> Maybe a
    Just (String
    filename, Int
    lineNum, Int
    0, String
    s2)
                        Maybe (Int, String)
    Nothing -> Maybe (String, Int, Int, String)
    forall a. Maybe a
    Nothing
                    Maybe (String, String)
    Nothing -> Maybe (String, Int, Int, String)
    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 :: String -> Maybe (String, String)
    breakColon = String -> String -> Maybe (String, String)
    go []
      where
        -- Don't break on Windows drive letters (e.g. @C:\@ or @C:/@)
        go :: String -> String -> Maybe (String, String)
    go String
    accum  (Char
    ':':Char
    '\\':String
    rest) = String -> String -> Maybe (String, String)
    go (Char
    '\\'Char -> String -> String
    forall a. a -> [a] -> [a]
    :Char
    ':'Char -> String -> String
    forall a. a -> [a] -> [a]
    :String
    accum) String
    rest
        go String
    accum  (Char
    ':':Char
    '/':String
    rest)  = String -> String -> Maybe (String, String)
    go (Char
    '/'Char -> String -> String
    forall a. a -> [a] -> [a]
    :Char
    ':'Char -> String -> String
    forall a. a -> [a] -> [a]
    :String
    accum) String
    rest
        go String
    accum  (Char
    ':':String
    rest)      = (String, String) -> Maybe (String, String)
    forall a. a -> Maybe a
    Just (String -> String
    forall a. [a] -> [a]
    reverse String
    accum, String
    rest)
        go String
    accum  (Char
    c:String
    rest)        = String -> String -> Maybe (String, String)
    go (Char
    cChar -> String -> String
    forall a. a -> [a] -> [a]
    :String
    accum) String
    rest
        go String
    _accum []              = Maybe (String, String)
    forall a. Maybe a
    Nothing

    breakIntColon :: String -> Maybe (Int, String)
    breakIntColon :: String -> Maybe (Int, String)
    breakIntColon String
    xs = case (Char -> Bool) -> String -> (String, String)
    forall a. (a -> Bool) -> [a] -> ([a], [a])
    break (Char
    ':' Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    ==) String
    xs of
                           (String
    ys, Char
    _:String
    zs)
                            | Bool -> Bool
    not (String -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null String
    ys) Bool -> Bool -> Bool
    && (Char -> Bool) -> String -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    all Char -> Bool
    isAscii String
    ys Bool -> Bool -> Bool
    && (Char -> Bool) -> String -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    all Char -> Bool
    isDigit String
    ys ->
                               (Int, String) -> Maybe (Int, String)
    forall a. a -> Maybe a
    Just (String -> Int
    forall a. Read a => String -> a
    read String
    ys, String
    zs)
                           (String, String)
    _ -> Maybe (Int, String)
    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 :: String -> [String]
    linesPlatform String
    ls = String -> [String]
    lines String
    ls
    #else
    linesPlatform "" = []
    linesPlatform xs =
      case lineBreak xs of
        (as,xs1) -> as : linesPlatform xs1
      where
       lineBreak "" = ("","")
       lineBreak ('\r':'\n':xs) = ([],xs)
       lineBreak ('\n':xs) = ([],xs)
       lineBreak (x:xs) = let (as,bs) = lineBreak xs in (x:as,bs)

    #endif