Make sure stdoutGateway is flushed before exiting.

This commit is contained in:
Daniel Gröber 2015-09-14 09:44:16 +02:00
parent 56902bfe2d
commit 5b02cc1bb0
3 changed files with 48 additions and 23 deletions

View File

@ -47,7 +47,7 @@ import Control.Monad.Reader (runReaderT)
import Control.Monad.State.Strict (runStateT) import Control.Monad.State.Strict (runStateT)
import Control.Monad.Trans.Journal (runJournalT) import Control.Monad.Trans.Journal (runJournalT)
import Exception (ExceptionMonad(..)) import Exception
import System.Directory import System.Directory
import Prelude import Prelude
@ -82,9 +82,9 @@ runGmOutT opts ma = do
runGmOutT' gmo ma runGmOutT' gmo ma
runGmOutT' :: IOish m => GhcModOut -> GmOutT m a -> m a runGmOutT' :: IOish m => GhcModOut -> GmOutT m a -> m a
runGmOutT' gmo ma = do runGmOutT' gmo@(gmoChan -> chan) ma = do
gbracket_ (liftIO $ forkIO $ stdoutGateway $ gmoChan gmo) gbracket_ (liftIO $ forkIO $ stdoutGateway chan)
(liftIO . killThread) (const $ liftIO $ flushStdoutGateway chan)
(flip runReaderT gmo $ unGmOutT ma) (flip runReaderT gmo $ unGmOutT ma)
-- | Run a @GhcModT m@ computation. -- | Run a @GhcModT m@ computation.

View File

@ -32,6 +32,7 @@ module Language.Haskell.GhcMod.Output (
, gmUnsafeErrStr , gmUnsafeErrStr
, stdoutGateway , stdoutGateway
, flushStdoutGateway
) where ) where
import Data.List import Data.List
@ -89,14 +90,14 @@ stdioOutputFns lpfx = let
, liftIO . hPutStr stderr . unGmLine . errPfx) , liftIO . hPutStr stderr . unGmLine . errPfx)
chanOutputFns :: MonadIO m chanOutputFns :: MonadIO m
=> Chan (GmStream, GmLines String) => Chan (Either (MVar ()) (GmStream, GmLines String))
-> Maybe (String, String) -> Maybe (String, String)
-> (GmLines String -> m (), GmLines String -> m ()) -> (GmLines String -> m (), GmLines String -> m ())
chanOutputFns c lpfx = let chanOutputFns c lpfx = let
(outPfx, errPfx) = pfxFns lpfx (outPfx, errPfx) = pfxFns lpfx
in in
( liftIO . writeChan c . (,) GmOutStream . outPfx ( liftIO . writeChan c . Right . (,) GmOutStream . outPfx
, liftIO . writeChan c . (,) GmErrStream . errPfx) , liftIO . writeChan c . Right . (,) GmErrStream . errPfx)
outputFns' :: outputFns' ::
MonadIO m => GhcModOut -> (GmLines String -> m (), GmLines String -> m ()) MonadIO m => GhcModOut -> (GmLines String -> m (), GmLines String -> m ())
@ -142,23 +143,47 @@ gmReadProcess = do
Nothing -> Nothing ->
return $ readProcess return $ readProcess
stdoutGateway :: Chan (GmStream, GmLines String) -> IO () flushStdoutGateway :: Chan (Either (MVar ()) (GmStream, GmLines String)) -> IO ()
flushStdoutGateway c = do
mv <- newEmptyMVar
writeChan c $ Left mv
takeMVar mv
stdoutGateway :: Chan (Either (MVar ()) (GmStream, GmLines String)) -> IO ()
stdoutGateway chan = go ("", "") stdoutGateway chan = go ("", "")
where where
go buf@(obuf, ebuf) = do go :: (String, String) -> IO ()
(stream, GmLines ty l) <- readChan chan go buf = do
case ty of cmd <- readChan chan
case cmd of
Left mv -> do
let flush (obuf, ebuf) = do
-- Add newline to unterminated stderr but not to stdout
-- otherwise emacs will get confused etc
putStr $ ebuf ++ if null ebuf || last ebuf /= '\n'
then "" else "\n"
putStr obuf
work (GmOutStream, GmLines GmPartial "") buf flush
putMVar mv ()
Right l ->
work l buf go
work (stream, GmLines ty l) buf@(obuf, ebuf) cont = case ty of
GmTerminated -> GmTerminated ->
case stream of case stream of
GmOutStream -> putStr (obuf++l) >> hFlush stdout >> go ("", ebuf) GmOutStream ->
GmErrStream -> putStr (ebuf++l) >> hFlush stdout >> go (obuf, "") putStr (obuf++l) >> hFlush stdout >> cont ("", ebuf)
GmPartial -> case reverse $ lines l of GmErrStream ->
[] -> go buf putStr (ebuf++l) >> hFlush stdout >> cont (obuf, "")
[x] -> go (appendBuf stream buf x)
GmPartial ->
case reverse $ lines l of
[] -> cont buf
[x] -> cont (appendBuf stream buf x)
x:xs -> do x:xs -> do
putStr $ unlines $ reverse xs putStr $ unlines $ reverse xs
hFlush stdout hFlush stdout
go (appendBuf stream buf x) cont (appendBuf stream buf x)
appendBuf GmOutStream (obuf, ebuf) s = (obuf++s, ebuf) appendBuf GmOutStream (obuf, ebuf) s = (obuf++s, ebuf)
appendBuf GmErrStream (obuf, ebuf) s = (obuf, ebuf++s) appendBuf GmErrStream (obuf, ebuf) s = (obuf, ebuf++s)

View File

@ -192,7 +192,7 @@ data GhcModEnv = GhcModEnv {
data GhcModOut = GhcModOut { data GhcModOut = GhcModOut {
gmoOptions :: OutputOpts gmoOptions :: OutputOpts
, gmoChan :: Chan (GmStream, GmLines String) , gmoChan :: Chan (Either (MVar ()) (GmStream, GmLines String))
} }
data GhcModLog = GhcModLog { data GhcModLog = GhcModLog {