Commit 027a1344 authored by Gershom's avatar Gershom

resp file generation

parent efb556cc
......@@ -3,9 +3,11 @@ module Common where
import Control.Exception ( bracket_ )
import qualified Control.Exception as Exception
import Control.Monad ( when )
import Data.Char ( isSpace )
import Data.List ( foldl' )
import System.IO
import System.Process ( rawSystem, runProcess, waitForProcess )
import System.Process ( createProcess, proc, runProcess, waitForProcess )
import System.Exit ( ExitCode(..), exitWith )
import System.Directory ( removeFile )
......@@ -22,23 +24,25 @@ default_compiler = "gcc"
writeBinaryFile :: FilePath -> String -> IO ()
writeBinaryFile fp str = withBinaryFile fp WriteMode $ \h -> hPutStr h str
rawSystemL :: String -> Bool -> FilePath -> [String] -> IO ()
rawSystemL action flg prog args = do
rawSystemL :: FilePath -> String -> Bool -> FilePath -> [String] -> IO ()
rawSystemL outDir action flg prog args = withResponseFile outDir "c2hscall.rsp" args $ \rspFile -> do
let cmdLine = prog++" "++unwords args
when flg $ hPutStrLn stderr ("Executing: " ++ cmdLine)
exitStatus <- rawSystem prog args
(_,_,_,ph) <- createProcess (proc prog ['@':rspFile])
exitStatus <- waitForProcess ph
case exitStatus of
ExitFailure exitCode -> die $ action ++ " failed "
++ "(exit code " ++ show exitCode ++ ")\n"
++ "command was: " ++ cmdLine ++ "\n"
_ -> return ()
rawSystemWithStdOutL :: String -> Bool -> FilePath -> [String] -> FilePath -> IO ()
rawSystemWithStdOutL action flg prog args outFile = do
rawSystemWithStdOutL :: FilePath -> String -> Bool -> FilePath -> [String] -> FilePath -> IO ()
rawSystemWithStdOutL outDir action flg prog args outFile = withResponseFile outDir "c2hscall.rsp" args $ \rspFile -> do
let cmdLine = prog++" "++unwords args++" >"++outFile
when flg (hPutStrLn stderr ("Executing: " ++ cmdLine))
hOut <- openFile outFile WriteMode
process <- runProcess prog args Nothing Nothing Nothing (Just hOut) Nothing
process <- runProcess prog ['@':rspFile] Nothing Nothing Nothing (Just hOut) Nothing
exitStatus <- waitForProcess process
hClose hOut
case exitStatus of
......@@ -65,3 +69,46 @@ catchIO = Exception.catch
onlyOne :: String -> IO a
onlyOne what = die ("Only one "++what++" may be specified\n")
-- response file handling borrowed from cabal's at Distribution.Simple.Program.ResponseFile
withTempFile :: FilePath -- ^ Temp dir to create the file in
-> String -- ^ File name template. See 'openTempFile'.
-> (FilePath -> Handle -> IO a) -> IO a
withTempFile tmpDir template action =
Exception.bracket
(openTempFile tmpDir template)
(\(name, handle) -> do hClose handle
removeFile $ name)
(uncurry action)
withResponseFile ::
FilePath -- ^ Working directory to create response file in.
-> FilePath -- ^ Template for response file name.
-> [String] -- ^ Arguments to put into response file.
-> (FilePath -> IO a)
-> IO a
withResponseFile workDir fileNameTemplate arguments f =
withTempFile workDir fileNameTemplate $ \responseFileName hf -> do
let responseContents = unlines $ map escapeResponseFileArg arguments
hPutStr hf responseContents
hClose hf
f responseFileName
-- Support a gcc-like response file syntax. Each separate
-- argument and its possible parameter(s), will be separated in the
-- response file by an actual newline; all other whitespace,
-- single quotes, double quotes, and the character used for escaping
-- (backslash) are escaped. The called program will need to do a similar
-- inverse operation to de-escape and re-constitute the argument list.
escapeResponseFileArg :: String -> String
escapeResponseFileArg = reverse . foldl' escape []
where
escape :: String -> Char -> String
escape cs c =
case c of
'\\' -> c:'\\':cs
'\'' -> c:'\\':cs
'"' -> c:'\\':cs
_ | isSpace c -> c:'\\':cs
| otherwise -> c:cs
......@@ -73,7 +73,7 @@ outputDirect config outName outDir outBase name toks = do
when (cNoCompile config) $ exitWith ExitSuccess
rawSystemL ("compiling " ++ cProgName) beVerbose (cCompiler config)
rawSystemL outDir ("compiling " ++ cProgName) beVerbose (cCompiler config)
( ["-c"]
++ [cProgName]
++ ["-o", oProgName]
......@@ -82,14 +82,14 @@ outputDirect config outName outDir outBase name toks = do
possiblyRemove cProgName $
withUtilsObject config outDir outBase $ \oUtilsName -> do
rawSystemL ("linking " ++ oProgName) beVerbose (cLinker config)
rawSystemL outDir ("linking " ++ oProgName) beVerbose (cLinker config)
( [oProgName, oUtilsName]
++ ["-o", progName]
++ [f | LinkFlag f <- flags]
)
possiblyRemove oProgName $ do
rawSystemWithStdOutL ("running " ++ execProgName) beVerbose execProgName [] outName
rawSystemWithStdOutL outDir ("running " ++ execProgName) beVerbose execProgName [] outName
possiblyRemove progName $ do
when needsH $ writeBinaryFile outHName $
......
......@@ -76,11 +76,10 @@ withUtilsObject config outDir outBase f = do
possiblyRemove oUtilsName $ do
unless (cNoCompile config) $
rawSystemL ("compiling " ++ cUtilsName)
rawSystemL outDir ("compiling " ++ cUtilsName)
beVerbose
(cCompiler config)
(["-c", cUtilsName, "-o", oUtilsName] ++
[cFlag | CompFlag cFlag <- flags])
f oUtilsName
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment