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
readCreateProcessWithExitCode'
:: CreateProcess
-> IO (ExitCode, String)
readCreateProcessWithExitCode' proc = do
(_, Just outh, _, pid) <-
createProcess proc{ std_out = CreatePipe }
output <- hGetContents outh
outMVar <- newEmptyMVar
_ <- forkIO $ evaluate (length output) >> putMVar outMVar ()
takeMVar outMVar
hClose outh
ex <- waitForProcess pid
return (ex, output)
replaceVar :: (String, String) -> [(String, String)] -> [(String, String)]
replaceVar (var, value) env =
(var, value) : filter (\(var',_) -> var /= var') env
readProcessEnvWithExitCode
:: String
-> [String]
-> (String, String)
-> IO (ExitCode, String, String)
readProcessEnvWithExitCode prog args env_update = do
current_env <- getEnvironment
readCreateProcessWithExitCode (proc prog args) {
env = Just (replaceVar env_update current_env) } ""
c_locale_env :: (String, String)
c_locale_env = ("LANGUAGE", "C")
getGccEnv :: [Option] -> IO (Maybe [(String,String)])
getGccEnv opts =
if null b_dirs
then return Nothing
else do env <- getEnvironment
return (Just (map mangle_path env))
where
(b_dirs, _) = partitionWith get_b_opt opts
get_b_opt (Option ('-':'B':dir)) = Left dir
get_b_opt other = Right other
mangle_path (path,paths) | map toUpper path == "PATH"
= (path, '\"' : head b_dirs ++ "\";" ++ paths)
mangle_path other = other
runSomething :: DynFlags
-> String
-> String
-> [Option]
-> IO ()
runSomething dflags phase_name pgm args =
runSomethingFiltered dflags id phase_name pgm args Nothing Nothing
runSomethingResponseFile
:: DynFlags -> (String->String) -> String -> String -> [Option]
-> Maybe [(String,String)] -> IO ()
runSomethingResponseFile dflags filter_fn phase_name pgm args mb_env =
runSomethingWith dflags phase_name pgm args $ \real_args -> do
fp <- getResponseFile real_args
let args = ['@':fp]
r <- builderMainLoop dflags filter_fn pgm args Nothing mb_env
return (r,())
where
getResponseFile args = do
fp <- newTempName dflags TFL_CurrentModule "rsp"
withFile fp WriteMode $ \h -> do
#if defined(mingw32_HOST_OS)
hSetEncoding h latin1
#else
hSetEncoding h utf8
#endif
hPutStr h $ unlines $ map escape args
return fp
escape x = concat
[ "\""
, concatMap
(\c ->
case c of
'\\' -> "\\\\"
'\n' -> "\\n"
'\"' -> "\\\""
_ -> [c])
x
, "\""
]
runSomethingFiltered
:: DynFlags -> (String->String) -> String -> String -> [Option]
-> Maybe FilePath -> Maybe [(String,String)] -> IO ()
runSomethingFiltered dflags filter_fn phase_name pgm args mb_cwd mb_env = do
runSomethingWith dflags phase_name pgm args $ \real_args -> do
r <- builderMainLoop dflags filter_fn pgm real_args mb_cwd mb_env
return (r,())
runSomethingWith
:: DynFlags -> String -> String -> [Option]
-> ([String] -> IO (ExitCode, a))
-> IO a
runSomethingWith dflags phase_name pgm args io = do
let real_args = filter notNull (map showOpt args)
cmdLine = showCommandForUser pgm real_args
traceCmd dflags phase_name cmdLine $ handleProc pgm phase_name $ io real_args
handleProc :: String -> String -> IO (ExitCode, r) -> IO r
handleProc pgm phase_name proc = do
(rc, r) <- proc `catchIO` handler
case rc of
ExitSuccess{} -> return r
ExitFailure n -> throwGhcExceptionIO (
ProgramError ("`" ++ takeFileName pgm ++ "'" ++
" failed in phase `" ++ phase_name ++ "'." ++
" (Exit code: " ++ show n ++ ")"))
where
handler err =
if IO.isDoesNotExistError err
then does_not_exist
else throwGhcExceptionIO (ProgramError $ show err)
does_not_exist = throwGhcExceptionIO (InstallationError ("could not execute: " ++ pgm))
builderMainLoop :: DynFlags -> (String -> String) -> FilePath
-> [String] -> Maybe FilePath -> Maybe [(String, String)]
-> IO ExitCode
builderMainLoop dflags filter_fn pgm real_args mb_cwd mb_env = do
chan <- newChan
let safely inner = mask $ \restore -> do
(hStdIn, hStdOut, hStdErr, hProcess) <- restore $
runInteractiveProcess pgm real_args mb_cwd mb_env
let cleanup_handles = do
hClose hStdIn
hClose hStdOut
hClose hStdErr
r <- try $ restore $ do
hSetBuffering hStdOut LineBuffering
hSetBuffering hStdErr LineBuffering
let make_reader_proc h = forkIO $ readerProc chan h filter_fn
bracketOnError (make_reader_proc hStdOut) killThread $ \_ ->
bracketOnError (make_reader_proc hStdErr) killThread $ \_ ->
inner hProcess
case r of
Left (SomeException e) -> do
terminateProcess hProcess
cleanup_handles
throw e
Right s -> do
cleanup_handles
return s
safely $ \h -> do
log_loop chan (2 :: Integer)
waitForProcess h
where
log_loop _ 0 = return ()
log_loop chan t = do
msg <- readChan chan
case msg of
BuildMsg msg -> do
putLogMsg dflags NoReason SevInfo noSrcSpan
(defaultUserStyle dflags) msg
log_loop chan t
BuildError loc msg -> do
putLogMsg dflags NoReason SevError (mkSrcSpan loc loc)
(defaultUserStyle dflags) msg
log_loop chan t
EOF ->
log_loop chan (t1)
readerProc :: Chan BuildMessage -> Handle -> (String -> String) -> IO ()
readerProc chan hdl filter_fn =
(do str <- hGetContents hdl
loop (linesPlatform (filter_fn str)) Nothing)
`finally`
writeChan chan EOF
where
loop [] Nothing = return ()
loop [] (Just err) = writeChan chan err
loop (l:ls) in_err =
case in_err of
Just err@(BuildError srcLoc msg)
| leading_whitespace l -> do
loop ls (Just (BuildError srcLoc (msg $$ text l)))
| otherwise -> do
writeChan chan err
checkError l ls
Nothing -> do
checkError l ls
_ -> panic "readerProc/loop"
checkError l ls
= case parseError l of
Nothing -> do
writeChan chan (BuildMsg (text l))
loop ls Nothing
Just (file, lineNum, colNum, msg) -> do
let srcLoc = mkSrcLoc (mkFastString file) lineNum colNum
loop ls (Just (BuildError srcLoc (text msg)))
leading_whitespace [] = False
leading_whitespace (x:_) = isSpace x
parseError :: String -> Maybe (String, Int, Int, String)
parseError s0 = case breakColon s0 of
Just (filename, s1) ->
case breakIntColon s1 of
Just (lineNum, s2) ->
case breakIntColon s2 of
Just (columnNum, s3) ->
Just (filename, lineNum, columnNum, s3)
Nothing ->
Just (filename, lineNum, 0, s2)
Nothing -> Nothing
Nothing -> Nothing
breakColon :: String -> Maybe (String, String)
breakColon xs = case break (':' ==) xs of
(ys, _:zs) -> Just (ys, zs)
_ -> Nothing
breakIntColon :: String -> Maybe (Int, String)
breakIntColon xs = case break (':' ==) xs of
(ys, _:zs)
| not (null ys) && all isAscii ys && all isDigit ys ->
Just (read ys, zs)
_ -> Nothing
data BuildMessage
= BuildMsg !SDoc
| BuildError !SrcLoc !SDoc
| EOF
linesPlatform :: String -> [String]
#if !defined(mingw32_HOST_OS)
linesPlatform ls = lines 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