Fix stdoutGateway line buffering

Language/Haskell/GhcMod.hs

@@ -62,8 +62,6 @@ module Language.Haskell.GhcMod (
   , gmErrStr
   , gmPutStrLn
   , gmErrStrLn
-  , gmUnsafePutStr
-  , gmUnsafeErrStr
   -- * FileMapping
   , loadMappedFile
   , loadMappedFileSource

Language/Haskell/GhcMod/Output.hs

@@ -28,85 +28,56 @@ module Language.Haskell.GhcMod.Output (
 
   , gmReadProcess
 
-  , gmUnsafePutStr
-  , gmUnsafeErrStr
-
   , stdoutGateway
   , flushStdoutGateway
   ) where
 
 import Data.List
+import qualified Data.Label as L
+import qualified Data.Label.Base as LB
 import System.IO
 import System.Exit
 import System.Process
 import Control.Monad
+import Control.Monad.State.Strict
 import Control.DeepSeq
 import Control.Exception
-import Control.Concurrent
+import Control.Concurrent (forkIO, killThread, myThreadId)
+import Control.Concurrent.MVar
+import Control.Concurrent.Chan
+import Pipes
+import Pipes.Lift
 import Prelude
 
-import Language.Haskell.GhcMod.Types hiding (LineSeparator)
+import Language.Haskell.GhcMod.Types hiding (LineSeparator, MonadIO(..))
-import Language.Haskell.GhcMod.Monad.Types
+import Language.Haskell.GhcMod.Monad.Types hiding (MonadIO(..))
-
-withLines :: (String -> String) -> String -> String
-withLines f s = let
-    res = unlines $ map f $ lines s
-  in
-    case s of
-      [] -> res
-      _ | not $ isTerminated s ->
-            reverse $ drop 1 $ reverse res
-      _ -> res
-
-isTerminated :: String -> Bool
-isTerminated "" = False
-isTerminated s = isNewline (last s)
-
-isNewline :: Char -> Bool
-isNewline c = c == '\n'
-
-toGmLines :: String -> (GmLines String)
-toGmLines "" = GmLines GmPartial ""
-toGmLines s | isNewline (last s) = GmLines GmTerminated s
-toGmLines s = GmLines GmPartial s
 
 outputFns :: (GmOut m, MonadIO m')
-          => m (GmLines String -> m' (), GmLines String -> m' ())
+          => m (String -> m' (), String -> m' ())
 outputFns =
   outputFns' `liftM` gmoAsk
 
-pfxFns :: Maybe (String, String) -> (GmLines String -> GmLines String, GmLines String -> GmLines String)
-pfxFns lpfx = case lpfx of
-    Nothing -> ( id, id )
-    Just (op, ep) -> ( fmap $ pfx (op++), fmap $ pfx (ep++) )
-  where
-    pfx f = withLines f
-
-stdioOutputFns :: MonadIO m => Maybe (String, String) -> (GmLines String -> m (), GmLines String -> m ())
-stdioOutputFns lpfx = let
-    (outPfx, errPfx) = pfxFns lpfx
-  in
-    ( liftIO . putStr         . unGmLine . outPfx
-    , liftIO . hPutStr stderr . unGmLine . errPfx)
-
-chanOutputFns :: MonadIO m
-              => 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 . Right . (,) GmOutStream . outPfx
-    , liftIO . writeChan c . Right . (,) GmErrStream . errPfx)
-
 outputFns' ::
-  MonadIO m => GhcModOut -> (GmLines String -> m (), GmLines String -> m ())
+  MonadIO m => GhcModOut -> (String -> m (), String -> m ())
 outputFns' (GhcModOut oopts c)  = let
   OutputOpts {..} = oopts
  in
   case ooptLinePrefix of
-    Nothing  -> stdioOutputFns ooptLinePrefix
+    Nothing -> stdioOutputFns
-    Just _ -> chanOutputFns c ooptLinePrefix
+    Just _  -> chanOutputFns c
+
+stdioOutputFns :: MonadIO m => (String -> m (), String -> m ())
+stdioOutputFns =
+    ( liftIO . putStr
+    , liftIO . hPutStr stderr
+    )
+
+chanOutputFns :: MonadIO m
+              => Chan (Either (MVar ()) (GmStream, String))
+              -> (String -> m (), String -> m ())
+chanOutputFns c = (write GmOutStream, write GmErrStream)
+ where
+   write stream s = liftIO $ writeChan c $ Right $ (stream,s)
 
 gmPutStr, gmPutStrLn, gmErrStr, gmErrStrLn
     :: (MonadIO m, GmOut m) => String -> m ()
@@ -124,16 +95,10 @@ gmErrStrLn = gmErrStr . (++"\n")
 
 gmPutStrIO, gmErrStrIO :: (GmOut m, MonadIO mi) => m (String -> mi ())
 
-gmPutStrIO = ((. toGmLines) . fst) `liftM` outputFns
+gmPutStrIO = fst `liftM` outputFns
-gmErrStrIO = ((. toGmLines) . snd) `liftM` outputFns
+gmErrStrIO = snd `liftM` outputFns
 
 
--- | Only use these when you're sure there are no other writers on stdout
-gmUnsafePutStr, gmUnsafeErrStr
-    :: MonadIO m => OutputOpts -> String -> m ()
-gmUnsafePutStr oopts = (fst $ stdioOutputFns (ooptLinePrefix oopts)) . toGmLines
-gmUnsafeErrStr oopts = (snd $ stdioOutputFns (ooptLinePrefix oopts)) . toGmLines
-
 gmReadProcess :: GmOut m => m (FilePath -> [String] -> String -> IO String)
 gmReadProcess = do
   GhcModOut {..} <- gmoAsk
@@ -143,64 +108,83 @@ gmReadProcess = do
     Nothing ->
         return $ readProcess
 
-flushStdoutGateway :: Chan (Either (MVar ()) (GmStream, GmLines String)) -> IO ()
+flushStdoutGateway :: Chan (Either (MVar ()) (GmStream, String)) -> IO ()
 flushStdoutGateway c = do
   mv <- newEmptyMVar
   writeChan c $ Left mv
   takeMVar mv
 
-stdoutGateway :: Chan (Either (MVar ()) (GmStream, GmLines String)) -> IO ()
+type Line = String
-stdoutGateway chan = go ("", "")
+
+stdoutGateway :: (String, String) -> Chan (Either (MVar ()) (GmStream, String)) -> IO ()
+stdoutGateway (outPf, errPf) chan = do
+  runEffect $ commandProc >-> evalStateP ("","") seperateStreams
  where
-   go :: (String, String) -> IO ()
+   commandProc :: Producer (Either (MVar ()) (GmStream, String)) IO ()
-   go buf = do
+   commandProc = do
-     cmd <- readChan chan
+     cmd <- liftIO $ readChan chan
      case cmd of
        Left mv -> do
-           let flush (obuf, ebuf) = do
+           yield $ Left mv
-                 -- Add newline to unterminated stderr but not to stdout
+       Right input -> do
-                 -- otherwise emacs will get confused etc
+           yield $ Right input
-                 putStr $ ebuf ++ if null ebuf || last ebuf /= '\n'
+           commandProc
-                                    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
+   seperateStreams :: Consumer (Either (MVar ()) (GmStream, String)) (StateT (String, String) IO) ()
-           GmTerminated ->
+   seperateStreams  = do
-              case stream of
+       ecmd <- await
-                GmOutStream ->
+       case ecmd of
-                    putStr (obuf++l) >> hFlush stdout >> cont ("", ebuf)
+         Left mv -> do
-                GmErrStream ->
+           -- flush buffers
-                    putStr (ebuf++l) >> hFlush stdout >> cont (obuf, "")
+           (\s -> lift $ zoom (streamLens s) $ sGetLine Nothing)
+               `mapM_` [GmOutStream, GmErrStream]
 
-           GmPartial ->
+           liftIO $ putMVar mv ()
-              case reverse $ lines l of
+         Right (stream, str) -> do
-                [] -> cont buf
+           ls <- lift $ zoom (streamLens stream) $ sGetLine (Just str)
-                [x] -> cont (appendBuf stream buf x)
+           case ls of
-                x:xs -> do
+               [] -> return ()
-                  putStr $ unlines $ reverse xs
+               _  -> liftIO $ putStr $ unlines $ map (streamPf stream++) ls
-                  hFlush stdout
-                  cont (appendBuf stream buf x)
 
-   appendBuf GmOutStream (obuf, ebuf) s = (obuf++s, ebuf)
+           liftIO $ hFlush stdout
-   appendBuf GmErrStream (obuf, ebuf) s = (obuf, ebuf++s)
+           seperateStreams
 
+   sGetLine :: (Maybe String) -> StateT String IO [Line]
+   sGetLine mstr' = do
+     buf <- get
+     let mstr = (buf++) <$> mstr'
+     case mstr of
+       Nothing -> put "" >> return [buf]
+       Just "" -> return []
+       Just s | last s == '\n' -> put "" >> return (lines s)
+              | otherwise -> do
+                  let (p:ls') = reverse $ lines s
+                  put p
+                  return $ reverse $ ls'
+
+   streamLens GmOutStream = LB.fst
+   streamLens GmErrStream = LB.snd
+
+   streamPf GmOutStream = outPf
+   streamPf GmErrStream = errPf
+
+zoom :: Monad m => (f L.:-> o) -> StateT o m a -> StateT f m a
+zoom l (StateT a) =
+    StateT $ \f -> do
+      (a, s') <- a $ L.get l f
+      return (a, L.set l s' f)
 
 readProcessStderrChan ::
     GmOut m => m (FilePath -> [String] -> String -> IO String)
 readProcessStderrChan = do
-  (_, e :: GmLines String -> IO ()) <- outputFns
+  (_, e :: String -> IO ()) <- outputFns
   return $ readProcessStderrChan' e
 
 readProcessStderrChan' ::
-     (GmLines String -> IO ())
+    (String -> IO ()) -> FilePath -> [String] -> String -> IO String
-  -> FilePath -> [String] -> String -> IO String
 readProcessStderrChan' pute = go pute
  where
-   go :: (GmLines String -> IO ()) -> FilePath -> [String] -> String -> IO String
+   go :: (String -> IO ()) -> FilePath -> [String] -> String -> IO String
    go putErr exe args input = do
      let cp = (proc exe args) {
                 std_out = CreatePipe
@@ -233,7 +217,7 @@ readProcessStderrChan' pute = go pute
     where
       ignoreSEx = handle (\(SomeException _) -> return ())
       reader h = ignoreSEx $ do
-        putErr . toGmLines . (++"\n") =<< hGetLine h
+        putErr . (++"\n") =<< hGetLine h
         reader h
 
 withForkWait :: IO () -> (IO () ->  IO a) -> IO a

Language/Haskell/GhcMod/Types.hs

@@ -172,19 +172,9 @@ data Cradle = Cradle {
   , cradleDistDir    :: FilePath
   } deriving (Eq, Show)
 
-
 data GmStream = GmOutStream | GmErrStream
                 deriving (Show)
 
-data GmLineType = GmTerminated | GmPartial
-                deriving (Show)
-
-data GmLines a = GmLines GmLineType a
-              deriving (Show, Functor)
-
-unGmLine :: GmLines a -> a
-unGmLine (GmLines _ s) = s
-
 data GhcModEnv = GhcModEnv {
       gmOptions    :: Options
     , gmCradle     :: Cradle
@@ -192,7 +182,7 @@ data GhcModEnv = GhcModEnv {
 
 data GhcModOut = GhcModOut {
       gmoOptions :: OutputOpts
-    , gmoChan    :: Chan (Either (MVar ()) (GmStream, GmLines String))
+    , gmoChan    :: Chan (Either (MVar ()) (GmStream, String))
     }
 
 data GhcModLog = GhcModLog {

ghc-mod.cabal

@@ -174,6 +174,7 @@ Library
                       , djinn-ghc >= 0.0.2.2
                       , fclabels == 2.0.*
                       , extra == 1.4.*
+                      , pipes == 4.1.*
   if impl(ghc < 7.8)
     Build-Depends:      convertible
   if impl(ghc < 7.5)

src/GHCMod.hs

@@ -399,7 +399,7 @@ main = do
       Left e -> throw e
       Right res@(globalOptions,_) -> catches (progMain res) [
             Handler $ \(e :: GhcModError) ->
-              exitError' globalOptions $ renderStyle ghcModStyle (gmeDoc e)
+              runGmOutT globalOptions $ exitError $ renderStyle ghcModStyle (gmeDoc e)
           ]
 
 progMain :: (Options,[String]) -> IO ()
@@ -575,11 +575,6 @@ instance Exception InvalidCommandLine
 exitError :: (MonadIO m, GmOut m) => String -> m a
 exitError msg = gmErrStrLn (dropWhileEnd (=='\n') msg) >> liftIO exitFailure
 
-exitError' :: Options -> String -> IO a
-exitError' opts msg = do
-    gmUnsafeErrStr (optOutput opts) $ dropWhileEnd (=='\n') msg ++ "\n"
-    liftIO exitFailure
-
 fatalError :: String -> a
 fatalError s = throw $ FatalError $ "ghc-mod: " ++ s