Commit 5027632b authored by Herbert Valerio Riedel's avatar Herbert Valerio Riedel 🕺
Browse files

Refactor `rawSystemStdInOut` to use `IOData` abstraction

This removes the remaining occurences of the weakly typed
`{to,from}UTF8` conversion.
parent 424bb5f7
......@@ -62,6 +62,10 @@ data ProgramInvocation = ProgramInvocation {
data IOEncoding = IOEncodingText -- locale mode text
| IOEncodingUTF8 -- always utf8
encodeToIOData :: IOEncoding -> String -> IOData
encodeToIOData IOEncodingText = IODataText
encodeToIOData IOEncodingUTF8 = IODataBinary . toUTF8LBS
emptyProgramInvocation :: ProgramInvocation
emptyProgramInvocation =
ProgramInvocation {
......@@ -138,15 +142,11 @@ runProgramInvocation verbosity
(_, errors, exitCode) <- rawSystemStdInOut verbosity
path args
mcwd menv
(Just input) True
(Just input) IODataModeBinary
when (exitCode /= ExitSuccess) $
die' verbosity $ "'" ++ path ++ "' exited with an error:\n" ++ errors
where
input = case encoding of
IOEncodingText -> (inputStr, False)
IOEncodingUTF8 -> (toUTF8 inputStr, True) -- use binary mode for
-- utf8
input = encodeToIOData encoding inputStr
getProgramInvocationOutput :: Verbosity -> ProgramInvocation -> IO String
getProgramInvocationOutput verbosity inv = do
......@@ -168,25 +168,21 @@ getProgramInvocationOutputAndErrors verbosity
progInvokeInput = minputStr,
progInvokeOutputEncoding = encoding
} = do
let utf8 = case encoding of IOEncodingUTF8 -> True; _ -> False
decode | utf8 = fromUTF8 . normaliseLineEndings
| otherwise = id
let mode = case encoding of IOEncodingUTF8 -> IODataModeBinary
IOEncodingText -> IODataModeText
decode (IODataBinary b) = normaliseLineEndings (fromUTF8LBS b)
decode (IODataText s) = s
pathOverride <- getExtraPathEnv envOverrides extraPath
menv <- getEffectiveEnvironment (envOverrides ++ pathOverride)
(output, errors, exitCode) <- rawSystemStdInOut verbosity
path args
mcwd menv
input utf8
input mode
return (decode output, errors, exitCode)
where
input =
case minputStr of
Nothing -> Nothing
Just inputStr -> Just $
case encoding of
IOEncodingText -> (inputStr, False)
IOEncodingUTF8 -> (toUTF8 inputStr, True) -- use binary mode for utf8
input = encodeToIOData encoding <$> minputStr
getExtraPathEnv :: [(String, Maybe String)] -> [FilePath] -> NoCallStackIO [(String, Maybe String)]
getExtraPathEnv _ [] = return []
......
......@@ -810,9 +810,9 @@ createProcessWithEnv verbosity path args mcwd menv inp out err = withFrozenCallS
--
rawSystemStdout :: Verbosity -> FilePath -> [String] -> IO String
rawSystemStdout verbosity path args = withFrozenCallStack $ do
(output, errors, exitCode) <- rawSystemStdInOut verbosity path args
(IODataText output, errors, exitCode) <- rawSystemStdInOut verbosity path args
Nothing Nothing
Nothing False
Nothing IODataModeText
when (exitCode /= ExitSuccess) $
die errors
return output
......@@ -883,10 +883,10 @@ rawSystemStdInOut :: Verbosity
-> [String] -- ^ Arguments
-> Maybe FilePath -- ^ New working dir or inherit
-> Maybe [(String, String)] -- ^ New environment or inherit
-> Maybe (String, Bool) -- ^ input text and binary mode
-> Bool -- ^ output in binary mode
-> IO (String, String, ExitCode) -- ^ output, errors, exit
rawSystemStdInOut verbosity path args mcwd menv input outputBinary = withFrozenCallStack $ do
-> Maybe IOData -- ^ input text and binary mode
-> IODataMode -- ^ output in binary mode
-> IO (IOData, String, ExitCode) -- ^ output, errors, exit
rawSystemStdInOut verbosity path args mcwd menv input outputMode = withFrozenCallStack $ do
printRawCommandAndArgs verbosity path args
Exception.bracket
......@@ -895,7 +895,6 @@ rawSystemStdInOut verbosity path args mcwd menv input outputBinary = withFrozenC
$ \(inh,outh,errh,pid) -> do
-- output mode depends on what the caller wants
hSetBinaryMode outh outputBinary
-- but the errors are always assumed to be text (in the current locale)
hSetBinaryMode errh False
......@@ -903,11 +902,12 @@ rawSystemStdInOut verbosity path args mcwd menv input outputBinary = withFrozenC
-- so if the process writes to stderr we do not block.
err <- hGetContents errh
out <- hGetContents outh
out <- ioDataHGetContents outh outputMode
mv <- newEmptyMVar
let force str = do
mberr <- Exception.try (evaluate (length str) >> return ())
mberr <- Exception.try (evaluate (rnf str) >> return ())
putMVar mv (mberr :: Either IOError ())
_ <- forkIO $ force out
_ <- forkIO $ force err
......@@ -915,11 +915,9 @@ rawSystemStdInOut verbosity path args mcwd menv input outputBinary = withFrozenC
-- push all the input, if any
case input of
Nothing -> return ()
Just (inputStr, inputBinary) -> do
-- input mode depends on what the caller wants
hSetBinaryMode inh inputBinary
hPutStr inh inputStr
hClose inh
Just inputData -> do
-- input mode depends on what the caller wants
ioDataHPutContents inh inputData
--TODO: this probably fails if the process refuses to consume
-- or if it closes stdin (eg if it exits)
......@@ -935,8 +933,9 @@ rawSystemStdInOut verbosity path args mcwd menv input outputBinary = withFrozenC
" with error message:\n" ++ err
++ case input of
Nothing -> ""
Just ("", _) -> ""
Just (inp, _) -> "\nstdin input:\n" ++ inp
Just d | ioDataNull d -> ""
Just (IODataText inp) -> "\nstdin input:\n" ++ inp
Just (IODataBinary inp) -> "\nstdin input (binary):\n" ++ show inp
-- Check if we we hit an exception while consuming the output
-- (e.g. a text decoding error)
......
......@@ -66,20 +66,21 @@ rawSystemStdInOutTextDecodingTest
hClose handleExe
-- Compile
compilationResult <- rawSystemStdInOut normal
(IODataText resOutput, resErrors, resExitCode) <- rawSystemStdInOut normal
"ghc" ["-o", filenameExe, filenameHs]
Nothing Nothing Nothing
False
print compilationResult
IODataModeText
print (resOutput, resErrors, resExitCode)
-- Execute
Exception.try $ do
rawSystemStdInOut normal
filenameExe []
Nothing Nothing Nothing
False -- not binary mode output, ie utf8 text mode so try to decode
IODataModeText -- not binary mode output, ie utf8 text mode so try to decode
case res of
Right x -> assertFailure $ "expected IO decoding exception: " ++ show x
Right (IODataText x1, x2, x3) -> assertFailure $ "expected IO decoding exception: " ++ show (x1,x2,x3)
Right (IODataBinary _, _, _) -> assertFailure "internal error"
Left err | isDoesNotExistError err -> Exception.throwIO err -- no ghc!
| otherwise -> return ()
......
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