Fix missing newlines

Language/Haskell/GhcMod/CabalHelper.hs

@@ -39,7 +39,7 @@ import Language.Haskell.GhcMod.Monad.Types
 import Language.Haskell.GhcMod.Utils
 import Language.Haskell.GhcMod.PathsAndFiles
 import Language.Haskell.GhcMod.Logging
-import Language.Haskell.GhcMod.Stderr
+import Language.Haskell.GhcMod.Output
 import System.FilePath
 import Prelude hiding ((.))
 
@@ -53,7 +53,9 @@ getGhcMergedPkgOptions = chCached Cached {
   cacheLens = Just (lGmcMergedPkgOptions . lGmCaches),
   cacheFile = mergedPkgOptsCacheFile,
   cachedAction = \ _tcf (progs, rootdir, distdir, _) _ma -> do
-    opts <- withCabal $ runQuery' progs rootdir distdir $ ghcMergedPkgOptions
+    readProc <- gmReadProcess
+    opts <- withCabal $ runQuery'' readProc progs rootdir distdir $
+                ghcMergedPkgOptions
     return ([setupConfigPath], opts)
  }
 
@@ -79,7 +81,8 @@ getPackageDbStack' = chCached Cached {
   cacheLens = Just (lGmcPackageDbStack . lGmCaches),
   cacheFile = pkgDbStackCacheFile,
   cachedAction = \ _tcf (progs, rootdir, distdir, _) _ma -> do
-    dbs <- withCabal $ map chPkgToGhcPkg <$> runQuery' progs rootdir distdir packageDbStack
+    readProc <- gmReadProcess
+    dbs <- withCabal $ map chPkgToGhcPkg <$> runQuery'' readProc progs rootdir distdir packageDbStack
     return ([setupConfigPath, sandboxConfigFile], dbs)
  }
 
@@ -98,8 +101,9 @@ getComponents :: (Applicative m, IOish m, GmEnv m, GmState m, GmLog m)
 getComponents = chCached Cached {
     cacheLens = Just (lGmcComponents . lGmCaches),
     cacheFile = cabalHelperCacheFile,
-    cachedAction = \ _tcf (progs, rootdir, distdir, _vers) _ma ->
+    cachedAction = \ _tcf (progs, rootdir, distdir, _vers) _ma -> do
-      runQuery' progs rootdir distdir $ do
+      readProc <- gmReadProcess
+      runQuery'' readProc progs rootdir distdir $ do
         q <- join7
                <$> ghcOptions
                <*> ghcPkgOptions
@@ -126,6 +130,7 @@ withCabal :: (IOish m, GmEnv m, GmLog m) => m a -> m a
 withCabal action = do
     crdl <- cradle
     opts <- options
+    readProc <- gmReadProcess
 
     let projdir = cradleRootDir crdl
         distdir = projdir </> "dist"
@@ -138,7 +143,7 @@ withCabal action = do
     pkgDbStackOutOfSync <-
          case mCusPkgDbStack of
            Just cusPkgDbStack -> do
-             pkgDb <- runQuery' (helperProgs opts) projdir distdir $
+             pkgDb <- runQuery'' readProc (helperProgs opts) projdir distdir $
                  map chPkgToGhcPkg <$> packageDbStack
              return $ pkgDb /= cusPkgDbStack
 
@@ -163,9 +168,9 @@ withCabal action = do
                          then [ "--with-ghc-pkg=" ++ T.ghcPkgProgram opts ]
                          else []
                     ++ map pkgDbArg cusPkgStack
-            liftIO $ void $ readProcess (T.cabalProgram opts) ("configure":progOpts) ""
+            liftIO $ void $ readProc (T.cabalProgram opts) ("configure":progOpts) ""
             gmLog GmDebug "" $ strDoc $ "writing Cabal autogen files"
-            liftIO $ writeAutogenFiles readProcess projdir distdir
+            liftIO $ writeAutogenFiles readProc projdir distdir
     action
 
 pkgDbArg :: GhcPkgDb -> String

Language/Haskell/GhcMod/Monad.hs

@@ -35,7 +35,7 @@ import Language.Haskell.GhcMod.Error
 import Language.Haskell.GhcMod.Logging
 import Language.Haskell.GhcMod.Cradle
 import Language.Haskell.GhcMod.Target
-import Language.Haskell.GhcMod.Stderr
+import Language.Haskell.GhcMod.Output
 
 import Control.Arrow (first)
 import Control.Applicative

Language/Haskell/GhcMod/Output.hs

@@ -1,13 +1,38 @@
+-- ghc-mod: Making Haskell development *more* fun
+-- Copyright (C) 2015  Daniel Gröber <dxld ÄT darkboxed DOT org>
+--
+-- This program is free software: you can redistribute it and/or modify
+-- it under the terms of the GNU Affero General Public License as published by
+-- the Free Software Foundation, either version 3 of the License, or
+-- (at your option) any later version.
+--
+-- This program is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of
+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+-- GNU Affero General Public License for more details.
+--
+-- You should have received a copy of the GNU Affero General Public License
+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+-- Derived from process:System.Process
+-- Copyright (c) The University of Glasgow 2004-2008
+
 module Language.Haskell.GhcMod.Output (
     gmPutStr
   , gmErrStr
   , gmPutStrLn
   , gmErrStrLn
+  , gmReadProcess
+  , stdoutGateway
   ) where
 
-import Data.Char
+import Data.List
 import System.IO
+import System.Exit
+import System.Process
 import Control.Monad
+import Control.DeepSeq
+import Control.Exception
 import Control.Concurrent
 
 import Language.Haskell.GhcMod.Types hiding (LineSeparator)
@@ -19,36 +44,139 @@ withLines f s = let
   in
     case s of
       [] -> res
-      _ | generalCategory (last s) /= LineSeparator ->
+      _ | not $ isTerminated s ->
             reverse $ drop 1 $ reverse res
       _ -> res
 
-outputFns :: (GmEnv m, MonadIO m') => m (String -> m' (), String -> m' ())
+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 :: (GmEnv m, MonadIO m') => m (GmLines String -> m' (), GmLines String -> m' ())
 outputFns = do
   GhcModEnv {..} <- gmeAsk
   let Options {..} = gmOptions
 
   let pfx f = withLines f
-  let (outPfx, errPfx) = case linePrefix of
+
-                           Nothing -> ( id, id )
+  let outPfx, errPfx :: GmLines String -> GmLines String
-                           Just (op, ep) -> ( pfx (op++), pfx (ep++) )
+      (outPfx, errPfx) =
+          case linePrefix of
+            Nothing -> ( id, id )
+            Just (op, ep) -> ( fmap $ pfx (op++), fmap $ pfx (ep++) )
 
   return $ case gmOutput of
     GmOutputStdio  ->
-        (liftIO . putStr . outPfx     , liftIO . hPutStr stderr . errPfx)
+        ( liftIO . putStr         . unGmLine . outPfx
+        , liftIO . hPutStr stderr . unGmLine . errPfx)
     GmOutputChan c ->
-        (liftIO . writeChan c . outPfx, liftIO . writeChan c . errPfx)
+        ( liftIO . writeChan c . (,) GmOut . outPfx
+        , liftIO . writeChan c . (,) GmErr .errPfx)
 
 gmPutStr, gmPutStrLn, gmErrStr, gmErrStrLn
     :: (MonadIO m, GmEnv m) => String -> m ()
 
 gmPutStr str = do
   putOut <- fst `liftM` outputFns
-  putOut str
+  putOut $ toGmLines str
 
 gmPutStrLn = gmPutStr . (++"\n")
 gmErrStrLn = gmErrStr . (++"\n")
 
 gmErrStr str = do
   putErr <- snd `liftM` outputFns
-  putErr str
+  putErr $ toGmLines str
+
+gmReadProcess :: GmEnv m => m (FilePath -> [String] -> String -> IO String)
+gmReadProcess = do
+  GhcModEnv {..} <- gmeAsk
+  case gmOutput of
+    GmOutputChan _ ->
+        readProcessStderrChan
+    GmOutputStdio ->
+        return $ readProcess
+
+stdoutGateway :: Chan (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
+             GmOut -> putStr (obuf++l) >> go ("", ebuf)
+             GmErr -> putStr (ebuf++l) >> go (obuf, "")
+       GmPartial -> case reverse $ lines l of
+                      [] -> go buf
+                      [x] -> go (appendBuf stream buf x)
+                      x:xs -> do
+                        putStr $ unlines $ reverse xs
+                        go (appendBuf stream buf x)
+
+   appendBuf GmOut (obuf, ebuf) s = (obuf++s, ebuf)
+   appendBuf GmErr (obuf, ebuf) s = (obuf, ebuf++s)
+
+
+readProcessStderrChan ::
+    GmEnv m => m (FilePath -> [String] -> String -> IO String)
+readProcessStderrChan = do
+  (_, e) <- outputFns
+  return $ go e
+ where
+   go :: (GmLines String -> IO ()) -> FilePath -> [String] -> String -> IO String
+   go putErr exe args input = do
+     let cp = (proc exe args) {
+                std_out = CreatePipe
+              , std_err = CreatePipe
+              , std_in  = CreatePipe
+              }
+     (Just i, Just o, Just e, h) <- createProcess cp
+
+     _ <- forkIO $ reader e
+
+     output  <- hGetContents o
+     withForkWait (evaluate $ rnf output) $ \waitOut -> do
+
+       -- now write any input
+       unless (null input) $
+         ignoreSEx $ hPutStr i input
+       -- hClose performs implicit hFlush, and thus may trigger a SIGPIPE
+       ignoreSEx $ hClose i
+
+       -- wait on the output
+       waitOut
+       hClose o
+
+     res <- waitForProcess h
+     case res of
+       ExitFailure rv ->
+           processFailedException "readProcessStderrChan" exe args rv
+       ExitSuccess ->
+           return output
+    where
+      ignoreSEx = handle (\(SomeException _) -> return ())
+      reader h = ignoreSEx $ do
+        putErr . toGmLines . (++"\n") =<< hGetLine h
+        reader h
+
+withForkWait :: IO () -> (IO () ->  IO a) -> IO a
+withForkWait async body = do
+  waitVar <- newEmptyMVar :: IO (MVar (Either SomeException ()))
+  mask $ \restore -> do
+    tid <- forkIO $ try (restore async) >>= putMVar waitVar
+    let wait = takeMVar waitVar >>= either throwIO return
+    restore (body wait) `onException` killThread tid
+
+processFailedException :: String -> String -> [String] -> Int -> IO a
+processFailedException fn exe args rv =
+      error $ concat [fn, ": ", exe, " "
+                     , intercalate " " (map show args)
+                     , " (exit " ++ show rv ++ ")"]

Language/Haskell/GhcMod/Stderr.hs

@@ -1,88 +0,0 @@
--- ghc-mod: Making Haskell development *more* fun
--- Copyright (C) 2015  Daniel Gröber <dxld ÄT darkboxed DOT org>
---
--- This program is free software: you can redistribute it and/or modify
--- it under the terms of the GNU Affero General Public License as published by
--- the Free Software Foundation, either version 3 of the License, or
--- (at your option) any later version.
---
--- This program is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of
--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
--- GNU Affero General Public License for more details.
---
--- You should have received a copy of the GNU Affero General Public License
--- along with this program.  If not, see <http://www.gnu.org/licenses/>.
-
--- Derived from process:System.Process
--- Copyright (c) The University of Glasgow 2004-2008
-
-module Language.Haskell.GhcMod.Stderr where
-
-import Data.List
-import System.IO
-import System.Exit
-import System.Process
-import Control.Monad
-import Control.DeepSeq
-import Control.Exception
-import Control.Concurrent
-
-stdoutGateway :: Chan String -> IO ()
-stdoutGateway chan = do
-    l <- readChan chan
-    putStrLn l
-    stdoutGateway chan
-
-readProcessStderrChan ::
-    Chan String -> FilePath -> [String] -> String -> IO String
-readProcessStderrChan cout exe args input = do
-  let cp = (proc exe args) {
-             std_out = CreatePipe
-           , std_err = CreatePipe
-           , std_in  = CreatePipe
-           }
-  (Just i, Just o, Just e, h) <- createProcess cp
-
-  _ <- forkIO $ reader e
-
-  output  <- hGetContents o
-  withForkWait (evaluate $ rnf output) $ \waitOut -> do
-
-    -- now write any input
-    unless (null input) $
-      ignoreSEx $ hPutStr i input
-    -- hClose performs implicit hFlush, and thus may trigger a SIGPIPE
-    ignoreSEx $ hClose i
-
-    -- wait on the output
-    waitOut
-    hClose o
-
-  res <- waitForProcess h
-  case res of
-    ExitFailure rv ->
-        processFailedException "readProcessStderrChan" exe args rv
-    ExitSuccess ->
-        return output
-
- where
-   ignoreSEx = handle (\(SomeException _) -> return ())
-   reader h = ignoreSEx $ do
-     l <- hGetLine h
-     writeChan cout l
-     reader h
-
-withForkWait :: IO () -> (IO () ->  IO a) -> IO a
-withForkWait async body = do
-  waitVar <- newEmptyMVar :: IO (MVar (Either SomeException ()))
-  mask $ \restore -> do
-    tid <- forkIO $ try (restore async) >>= putMVar waitVar
-    let wait = takeMVar waitVar >>= either throwIO return
-    restore (body wait) `onException` killThread tid
-
-processFailedException :: String -> String -> [String] -> Int -> IO a
-processFailedException fn exe args rv =
-      error $ concat [fn, ": ", exe, " "
-                     , intercalate " " (map show args)
-                     , " (exit " ++ show rv ++ ")"]

Language/Haskell/GhcMod/Types.hs

@@ -130,8 +130,21 @@ data Cradle = Cradle {
   , cradleCabalFile  :: Maybe FilePath
   } deriving (Eq, Show)
 
+
+data GmStream = GmOut | GmErr
+                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 GmOutput = GmOutputStdio
-              | GmOutputChan (Chan String)
+              | GmOutputChan (Chan (GmStream, GmLines String))
 
 data GhcModEnv = GhcModEnv {
       gmOptions    :: Options

ghc-mod.cabal

@@ -125,7 +125,6 @@ Library
                         Language.Haskell.GhcMod.Pretty
                         Language.Haskell.GhcMod.Read
                         Language.Haskell.GhcMod.SrcUtils
-                        Language.Haskell.GhcMod.Stderr
                         Language.Haskell.GhcMod.Target
                         Language.Haskell.GhcMod.Types
                         Language.Haskell.GhcMod.Utils