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

#include "HsVersions.h"

import Exception
import ErrUtils
import DynFlags
import FastString
import Outputable
import Panic
import GhcPrelude
import Util
import SrcLoc           ( SrcLoc, mkSrcLoc, noSrcSpan, mkSrcSpan )

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 FileCleanup

-- 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' proc :: CreateProcess
proc = do
    (_, Just outh :: Handle
outh, _, pid :: ProcessHandle
pid) <-
        CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess CreateProcess
proc{ std_out :: StdStream
std_out = StdStream
CreatePipe }

    -- fork off a thread to start consuming the output
    String
output  <- Handle -> IO String
hGetContents Handle
outh
    MVar ()
outMVar <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
    ThreadId
_ <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ Int -> IO Int
forall a. a -> IO a
evaluate (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
output) IO Int -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
outMVar ()

    -- wait on the output
    MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
outMVar
    Handle -> IO ()
hClose Handle
outh

    -- 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 (var :: String
var, value :: String
value) env :: [(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 (\(var' :: String
var',_) -> 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 prog :: String
prog args :: [String]
args env_update :: (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) {use_process_jobs :: Bool
use_process_jobs = Bool
True}) {
        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) } ""

-- Don't let gcc localize version info string, #8825
c_locale_env :: (String, String)
c_locale_env :: (String, String)
c_locale_env = ("LANGUAGE", "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 opts :: [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
  (b_dirs :: [String]
b_dirs, _) = (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 ('-':'B':dir :: String
dir)) = String -> Either String Option
forall a b. a -> Either a b
Left String
dir
  get_b_opt other :: 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 :: 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 :: DynFlags -> String -> String -> [Option] -> IO ()
runSomething dflags :: DynFlags
dflags phase_name :: String
phase_name pgm :: String
pgm args :: [Option]
args =
  DynFlags
-> (String -> String)
-> String
-> String
-> [Option]
-> Maybe String
-> Maybe [(String, String)]
-> IO ()
runSomethingFiltered 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://ghc.haskell.org/trac/ghc/ticket/10777
runSomethingResponseFile
  :: DynFlags -> (String->String) -> String -> String -> [Option]
  -> Maybe [(String,String)] -> IO ()

runSomethingResponseFile :: DynFlags
-> (String -> String)
-> String
-> String
-> [Option]
-> Maybe [(String, String)]
-> IO ()
runSomethingResponseFile dflags :: DynFlags
dflags filter_fn :: String -> String
filter_fn phase_name :: String
phase_name pgm :: String
pgm args :: [Option]
args mb_env :: Maybe [(String, String)]
mb_env =
    DynFlags
-> String
-> String
-> [Option]
-> ([String] -> IO (ExitCode, ()))
-> IO ()
forall a.
DynFlags
-> String
-> String
-> [Option]
-> ([String] -> IO (ExitCode, a))
-> IO a
runSomethingWith DynFlags
dflags String
phase_name String
pgm [Option]
args (([String] -> IO (ExitCode, ())) -> IO ())
-> ([String] -> IO (ExitCode, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \real_args :: [String]
real_args -> do
        String
fp <- [String] -> IO String
forall (t :: * -> *). Foldable t => [t Char] -> IO String
getResponseFile [String]
real_args
        let args :: [String]
args = ['@'Char -> String -> String
forall a. a -> [a] -> [a]
:String
fp]
        ExitCode
r <- DynFlags
-> (String -> String)
-> String
-> [String]
-> Maybe String
-> Maybe [(String, String)]
-> IO ExitCode
builderMainLoop 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 :: [t Char] -> IO String
getResponseFile args :: [t Char]
args = do
      String
fp <- DynFlags -> TempFileLifetime -> String -> IO String
newTempName DynFlags
dflags TempFileLifetime
TFL_CurrentModule "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
$ \h :: 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
$ (t Char -> String) -> [t Char] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map t Char -> String
forall (t :: * -> *). Foldable t => t Char -> String
escape [t Char]
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 x :: t Char
x = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ "\""
        , (Char -> String) -> t Char -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
            (\c :: Char
c ->
                case Char
c of
                    '\\' -> "\\\\"
                    '\n' -> "\\n"
                    '\"' -> "\\\""
                    _    -> [Char
c])
            t Char
x
        , "\""
        ]

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

runSomethingFiltered :: DynFlags
-> (String -> String)
-> String
-> String
-> [Option]
-> Maybe String
-> Maybe [(String, String)]
-> IO ()
runSomethingFiltered dflags :: DynFlags
dflags filter_fn :: String -> String
filter_fn phase_name :: String
phase_name pgm :: String
pgm args :: [Option]
args mb_cwd :: Maybe String
mb_cwd mb_env :: Maybe [(String, String)]
mb_env = do
    DynFlags
-> String
-> String
-> [Option]
-> ([String] -> IO (ExitCode, ()))
-> IO ()
forall a.
DynFlags
-> String
-> String
-> [Option]
-> ([String] -> IO (ExitCode, a))
-> IO a
runSomethingWith DynFlags
dflags String
phase_name String
pgm [Option]
args (([String] -> IO (ExitCode, ())) -> IO ())
-> ([String] -> IO (ExitCode, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \real_args :: [String]
real_args -> do
        ExitCode
r <- DynFlags
-> (String -> String)
-> String
-> [String]
-> Maybe String
-> Maybe [(String, String)]
-> IO ExitCode
builderMainLoop 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
  :: DynFlags -> String -> String -> [Option]
  -> ([String] -> IO (ExitCode, a))
  -> IO a

runSomethingWith :: DynFlags
-> String
-> String
-> [Option]
-> ([String] -> IO (ExitCode, a))
-> IO a
runSomethingWith dflags :: DynFlags
dflags phase_name :: String
phase_name pgm :: String
pgm args :: [Option]
args io :: [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 a. [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
  DynFlags -> String -> String -> IO a -> IO a
forall a. DynFlags -> String -> String -> IO a -> IO a
traceCmd 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 :: String -> String -> IO (ExitCode, r) -> IO r
handleProc pgm :: String
pgm phase_name :: String
phase_name proc :: IO (ExitCode, r)
proc = do
    (rc :: ExitCode
rc, r :: r
r) <- IO (ExitCode, r)
proc IO (ExitCode, r)
-> (IOException -> IO (ExitCode, r)) -> IO (ExitCode, r)
forall a. IO a -> (IOException -> IO a) -> IO a
`catchIO` IOException -> IO (ExitCode, r)
forall a. IOException -> IO a
handler
    case ExitCode
rc of
      ExitSuccess{} -> r -> IO r
forall (m :: * -> *) a. Monad m => a -> m a
return r
r
      ExitFailure n :: Int
n -> GhcException -> IO r
forall a. GhcException -> IO a
throwGhcExceptionIO (
            String -> GhcException
ProgramError ("`" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
takeFileName String
pgm String -> String -> String
forall a. [a] -> [a] -> [a]
++ "'" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                          " 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
forall a. [a] -> [a] -> [a]
++
                          " (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]
++ ")"))
  where
    handler :: IOException -> IO a
handler err :: IOException
err =
       if IOException -> Bool
IO.isDoesNotExistError IOException
err
          then IO a
forall a. IO a
does_not_exist
          else GhcException -> IO a
forall a. GhcException -> IO a
throwGhcExceptionIO (String -> GhcException
ProgramError (String -> GhcException) -> String -> GhcException
forall a b. (a -> b) -> a -> b
$ IOException -> String
forall a. Show a => a -> String
show IOException
err)

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


builderMainLoop :: DynFlags -> (String -> String) -> FilePath
                -> [String] -> Maybe FilePath -> Maybe [(String, String)]
                -> IO ExitCode
builderMainLoop :: DynFlags
-> (String -> String)
-> String
-> [String]
-> Maybe String
-> Maybe [(String, String)]
-> IO ExitCode
builderMainLoop dflags :: DynFlags
dflags filter_fn :: String -> String
filter_fn pgm :: String
pgm real_args :: [String]
real_args mb_cwd :: Maybe String
mb_cwd mb_env :: 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 b) -> IO b
safely inner :: ProcessHandle -> IO b
inner = ((forall a. IO a -> IO a) -> IO b) -> IO b
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask (((forall a. IO a -> IO a) -> IO b) -> IO b)
-> ((forall a. IO a -> IO a) -> IO b) -> IO b
forall a b. (a -> b) -> a -> b
$ \restore :: 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 = (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
                                            , use_process_jobs :: Bool
use_process_jobs = Bool
True
                                            , std_in :: StdStream
std_in  = StdStream
CreatePipe
                                            , std_out :: StdStream
std_out = StdStream
CreatePipe
                                            , std_err :: StdStream
std_err = StdStream
CreatePipe
                                            }
        (Just hStdIn :: Handle
hStdIn, Just hStdOut :: Handle
hStdOut, Just hStdErr :: Handle
hStdErr, hProcess :: 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_ "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 b
r <- IO b -> IO (Either SomeException b)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO b -> IO (Either SomeException b))
-> IO b -> IO (Either SomeException b)
forall a b. (a -> b) -> a -> b
$ IO b -> IO b
forall a. IO a -> IO a
restore (IO b -> IO b) -> IO b -> IO b
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 h :: 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 b) -> IO b
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 b) -> IO b) -> (ThreadId -> IO b) -> IO b
forall a b. (a -> b) -> a -> b
$ \_ ->
            IO ThreadId -> (ThreadId -> IO ()) -> (ThreadId -> IO b) -> IO b
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 b) -> IO b) -> (ThreadId -> IO b) -> IO b
forall a b. (a -> b) -> a -> b
$ \_ ->
            ProcessHandle -> IO b
inner ProcessHandle
hProcess
        case Either SomeException b
r of
          -- onException
          Left (SomeException e :: e
e) -> do
            ProcessHandle -> IO ()
terminateProcess ProcessHandle
hProcess
            IO ()
cleanup_handles
            e -> IO b
forall a e. Exception e => e -> a
throw e
e
          -- cleanup when there was no exception
          Right s :: b
s -> do
            IO ()
cleanup_handles
            b -> IO b
forall (m :: * -> *) a. Monad m => a -> m a
return b
s
  (ProcessHandle -> IO ExitCode) -> IO ExitCode
forall b. (ProcessHandle -> IO b) -> IO b
safely ((ProcessHandle -> IO ExitCode) -> IO ExitCode)
-> (ProcessHandle -> IO ExitCode) -> IO ExitCode
forall a b. (a -> b) -> a -> b
$ \h :: ProcessHandle
h -> do
    -- we don't want to finish until 2 streams have been complete
    -- (stdout and stderr)
    Chan BuildMessage -> Integer -> IO ()
forall a. (Eq a, Num a) => Chan BuildMessage -> a -> IO ()
log_loop Chan BuildMessage
chan (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 -> a -> IO ()
log_loop _ 0 = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    log_loop chan :: Chan BuildMessage
chan t :: a
t = do
      BuildMessage
msg <- Chan BuildMessage -> IO BuildMessage
forall a. Chan a -> IO a
readChan Chan BuildMessage
chan
      case BuildMessage
msg of
        BuildMsg msg :: SDoc
msg -> do
          DynFlags
-> WarnReason -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO ()
putLogMsg DynFlags
dflags WarnReason
NoReason Severity
SevInfo SrcSpan
noSrcSpan
              (DynFlags -> PprStyle
defaultUserStyle DynFlags
dflags) SDoc
msg
          Chan BuildMessage -> a -> IO ()
log_loop Chan BuildMessage
chan a
t
        BuildError loc :: SrcLoc
loc msg :: SDoc
msg -> do
          DynFlags
-> WarnReason -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO ()
putLogMsg DynFlags
dflags WarnReason
NoReason Severity
SevError (SrcLoc -> SrcLoc -> SrcSpan
mkSrcSpan SrcLoc
loc SrcLoc
loc)
              (DynFlags -> PprStyle
defaultUserStyle DynFlags
dflags) SDoc
msg
          Chan BuildMessage -> a -> IO ()
log_loop Chan BuildMessage
chan a
t
        EOF ->
          Chan BuildMessage -> a -> IO ()
log_loop Chan BuildMessage
chan  (a
ta -> a -> a
forall a. Num a => a -> a -> a
-1)

readerProc :: Chan BuildMessage -> Handle -> (String -> String) -> IO ()
readerProc :: Chan BuildMessage -> Handle -> (String -> String) -> IO ()
readerProc chan :: Chan BuildMessage
chan hdl :: Handle
hdl filter_fn :: 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 []     Nothing    = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        loop []     (Just err :: BuildMessage
err) = Chan BuildMessage -> BuildMessage -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan BuildMessage
chan BuildMessage
err
        loop (l :: String
l:ls :: [String]
ls) in_err :: Maybe BuildMessage
in_err     =
                case Maybe BuildMessage
in_err of
                  Just err :: BuildMessage
err@(BuildError srcLoc :: SrcLoc
srcLoc msg :: SDoc
msg)
                    | String -> Bool
leading_whitespace String
l -> do
                        [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
                  Nothing -> do
                        String -> [String] -> IO ()
checkError String
l [String]
ls
                  _ -> String -> IO ()
forall a. String -> a
panic "readerProc/loop"

        checkError :: String -> [String] -> IO ()
checkError l :: String
l ls :: [String]
ls
           = case String -> Maybe (String, Int, Int, String)
parseError String
l of
                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 (file :: String
file, lineNum :: Int
lineNum, colNum :: Int
colNum, msg :: 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 (x :: Char
x:_) = Char -> Bool
isSpace Char
x

parseError :: String -> Maybe (String, Int, Int, String)
parseError :: String -> Maybe (String, Int, Int, String)
parseError s0 :: String
s0 = case String -> Maybe (String, String)
breakColon String
s0 of
                Just (filename :: String
filename, s1 :: String
s1) ->
                    case String -> Maybe (Int, String)
breakIntColon String
s1 of
                    Just (lineNum :: Int
lineNum, s2 :: String
s2) ->
                        case String -> Maybe (Int, String)
breakIntColon String
s2 of
                        Just (columnNum :: Int
columnNum, s3 :: 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)
                        Nothing ->
                            (String, Int, Int, String) -> Maybe (String, Int, Int, String)
forall a. a -> Maybe a
Just (String
filename, Int
lineNum, 0, String
s2)
                    Nothing -> Maybe (String, Int, Int, String)
forall a. Maybe a
Nothing
                Nothing -> Maybe (String, Int, Int, String)
forall a. Maybe a
Nothing

breakColon :: String -> Maybe (String, String)
breakColon :: String -> Maybe (String, String)
breakColon xs :: String
xs = case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (':' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==) String
xs of
                    (ys :: String
ys, _:zs :: String
zs) -> (String, String) -> Maybe (String, String)
forall a. a -> Maybe a
Just (String
ys, String
zs)
                    _ -> Maybe (String, String)
forall a. Maybe a
Nothing

breakIntColon :: String -> Maybe (Int, String)
breakIntColon :: String -> Maybe (Int, String)
breakIntColon xs :: String
xs = case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (':' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==) String
xs of
                       (ys :: String
ys, _:zs :: 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)
                       _ -> 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 ls :: 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