diff --git a/Language/Haskell/GhcMod/CabalHelper.hs b/Language/Haskell/GhcMod/CabalHelper.hs index 9193ba8..36c82a1 100644 --- a/Language/Haskell/GhcMod/CabalHelper.hs +++ b/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 -> - runQuery' progs rootdir distdir $ do + cachedAction = \ _tcf (progs, rootdir, distdir, _vers) _ma -> 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 diff --git a/Language/Haskell/GhcMod/Monad.hs b/Language/Haskell/GhcMod/Monad.hs index 0b392c9..adc7114 100644 --- a/Language/Haskell/GhcMod/Monad.hs +++ b/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 diff --git a/Language/Haskell/GhcMod/Output.hs b/Language/Haskell/GhcMod/Output.hs index 1ca9ee7..fffb1c2 100644 --- a/Language/Haskell/GhcMod/Output.hs +++ b/Language/Haskell/GhcMod/Output.hs @@ -1,13 +1,38 @@ +-- ghc-mod: Making Haskell development *more* fun +-- Copyright (C) 2015 Daniel Gröber +-- +-- 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 . + +-- 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 ) - Just (op, ep) -> ( pfx (op++), pfx (ep++) ) + + let outPfx, errPfx :: GmLines String -> GmLines String + (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 ++ ")"] diff --git a/Language/Haskell/GhcMod/Stderr.hs b/Language/Haskell/GhcMod/Stderr.hs deleted file mode 100644 index 198f062..0000000 --- a/Language/Haskell/GhcMod/Stderr.hs +++ /dev/null @@ -1,88 +0,0 @@ --- ghc-mod: Making Haskell development *more* fun --- Copyright (C) 2015 Daniel Gröber --- --- 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 . - --- 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 ++ ")"] diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs index 934d148..859086c 100644 --- a/Language/Haskell/GhcMod/Types.hs +++ b/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 diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 381cee0..15dda31 100644 --- a/ghc-mod.cabal +++ b/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