Fix missing newlines

This commit is contained in:
Daniel Gröber 2015-08-13 09:01:58 +02:00
parent 2806f702d9
commit 09c3c5603c
6 changed files with 166 additions and 109 deletions

View File

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

View File

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

View File

@ -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 ( module Language.Haskell.GhcMod.Output (
gmPutStr gmPutStr
, gmErrStr , gmErrStr
, gmPutStrLn , gmPutStrLn
, gmErrStrLn , gmErrStrLn
, gmReadProcess
, stdoutGateway
) where ) where
import Data.Char import Data.List
import System.IO import System.IO
import System.Exit
import System.Process
import Control.Monad import Control.Monad
import Control.DeepSeq
import Control.Exception
import Control.Concurrent import Control.Concurrent
import Language.Haskell.GhcMod.Types hiding (LineSeparator) import Language.Haskell.GhcMod.Types hiding (LineSeparator)
@ -19,36 +44,139 @@ withLines f s = let
in in
case s of case s of
[] -> res [] -> res
_ | generalCategory (last s) /= LineSeparator -> _ | not $ isTerminated s ->
reverse $ drop 1 $ reverse res reverse $ drop 1 $ reverse res
_ -> 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 outputFns = do
GhcModEnv {..} <- gmeAsk GhcModEnv {..} <- gmeAsk
let Options {..} = gmOptions let Options {..} = gmOptions
let pfx f = withLines f let pfx f = withLines f
let (outPfx, errPfx) = case linePrefix of
let outPfx, errPfx :: GmLines String -> GmLines String
(outPfx, errPfx) =
case linePrefix of
Nothing -> ( id, id ) Nothing -> ( id, id )
Just (op, ep) -> ( pfx (op++), pfx (ep++) ) Just (op, ep) -> ( fmap $ pfx (op++), fmap $ pfx (ep++) )
return $ case gmOutput of return $ case gmOutput of
GmOutputStdio -> GmOutputStdio ->
(liftIO . putStr . outPfx , liftIO . hPutStr stderr . errPfx) ( liftIO . putStr . unGmLine . outPfx
, liftIO . hPutStr stderr . unGmLine . errPfx)
GmOutputChan c -> GmOutputChan c ->
(liftIO . writeChan c . outPfx, liftIO . writeChan c . errPfx) ( liftIO . writeChan c . (,) GmOut . outPfx
, liftIO . writeChan c . (,) GmErr .errPfx)
gmPutStr, gmPutStrLn, gmErrStr, gmErrStrLn gmPutStr, gmPutStrLn, gmErrStr, gmErrStrLn
:: (MonadIO m, GmEnv m) => String -> m () :: (MonadIO m, GmEnv m) => String -> m ()
gmPutStr str = do gmPutStr str = do
putOut <- fst `liftM` outputFns putOut <- fst `liftM` outputFns
putOut str putOut $ toGmLines str
gmPutStrLn = gmPutStr . (++"\n") gmPutStrLn = gmPutStr . (++"\n")
gmErrStrLn = gmErrStr . (++"\n") gmErrStrLn = gmErrStr . (++"\n")
gmErrStr str = do gmErrStr str = do
putErr <- snd `liftM` outputFns 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 ++ ")"]

View File

@ -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 ++ ")"]

View File

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

View File

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