diff --git a/Language/Haskell/GhcMod/Monad.hs b/Language/Haskell/GhcMod/Monad.hs index 51b90a8..b29f8b7 100644 --- a/Language/Haskell/GhcMod/Monad.hs +++ b/Language/Haskell/GhcMod/Monad.hs @@ -47,7 +47,7 @@ import Control.Monad.Reader (runReaderT) import Control.Monad.State.Strict (runStateT) import Control.Monad.Trans.Journal (runJournalT) -import Exception (ExceptionMonad(..)) +import Exception import System.Directory import Prelude @@ -82,9 +82,9 @@ runGmOutT opts ma = do runGmOutT' gmo ma runGmOutT' :: IOish m => GhcModOut -> GmOutT m a -> m a -runGmOutT' gmo ma = do - gbracket_ (liftIO $ forkIO $ stdoutGateway $ gmoChan gmo) - (liftIO . killThread) +runGmOutT' gmo@(gmoChan -> chan) ma = do + gbracket_ (liftIO $ forkIO $ stdoutGateway chan) + (const $ liftIO $ flushStdoutGateway chan) (flip runReaderT gmo $ unGmOutT ma) -- | Run a @GhcModT m@ computation. diff --git a/Language/Haskell/GhcMod/Output.hs b/Language/Haskell/GhcMod/Output.hs index 8503861..21f7ea7 100644 --- a/Language/Haskell/GhcMod/Output.hs +++ b/Language/Haskell/GhcMod/Output.hs @@ -32,6 +32,7 @@ module Language.Haskell.GhcMod.Output ( , gmUnsafeErrStr , stdoutGateway + , flushStdoutGateway ) where import Data.List @@ -89,14 +90,14 @@ stdioOutputFns lpfx = let , liftIO . hPutStr stderr . unGmLine . errPfx) chanOutputFns :: MonadIO m - => Chan (GmStream, GmLines String) + => Chan (Either (MVar ()) (GmStream, GmLines String)) -> Maybe (String, String) -> (GmLines String -> m (), GmLines String -> m ()) chanOutputFns c lpfx = let (outPfx, errPfx) = pfxFns lpfx in - ( liftIO . writeChan c . (,) GmOutStream . outPfx - , liftIO . writeChan c . (,) GmErrStream . errPfx) + ( liftIO . writeChan c . Right . (,) GmOutStream . outPfx + , liftIO . writeChan c . Right . (,) GmErrStream . errPfx) outputFns' :: MonadIO m => GhcModOut -> (GmLines String -> m (), GmLines String -> m ()) @@ -142,23 +143,47 @@ gmReadProcess = do Nothing -> 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 ("", "") where - go buf@(obuf, ebuf) = do - (stream, GmLines ty l) <- readChan chan - case ty of - GmTerminated -> - case stream of - GmOutStream -> putStr (obuf++l) >> hFlush stdout >> go ("", ebuf) - GmErrStream -> putStr (ebuf++l) >> hFlush stdout >> go (obuf, "") - GmPartial -> case reverse $ lines l of - [] -> go buf - [x] -> go (appendBuf stream buf x) - x:xs -> do - putStr $ unlines $ reverse xs - hFlush stdout - go (appendBuf stream buf x) + go :: (String, String) -> IO () + go buf = do + 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 -> + case stream of + GmOutStream -> + putStr (obuf++l) >> hFlush stdout >> cont ("", ebuf) + GmErrStream -> + putStr (ebuf++l) >> hFlush stdout >> cont (obuf, "") + + GmPartial -> + case reverse $ lines l of + [] -> cont buf + [x] -> cont (appendBuf stream buf x) + x:xs -> do + putStr $ unlines $ reverse xs + hFlush stdout + cont (appendBuf stream buf x) appendBuf GmOutStream (obuf, ebuf) s = (obuf++s, ebuf) appendBuf GmErrStream (obuf, ebuf) s = (obuf, ebuf++s) diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs index 88cc6e5..15ca68a 100644 --- a/Language/Haskell/GhcMod/Types.hs +++ b/Language/Haskell/GhcMod/Types.hs @@ -192,7 +192,7 @@ data GhcModEnv = GhcModEnv { data GhcModOut = GhcModOut { gmoOptions :: OutputOpts - , gmoChan :: Chan (GmStream, GmLines String) + , gmoChan :: Chan (Either (MVar ()) (GmStream, GmLines String)) } data GhcModLog = GhcModLog {