ghc-mod/Language/Haskell/GhcMod/Output.hs

243 lines
7.1 KiB
Haskell
Raw Normal View History

2015-08-13 07:01:58 +00:00
-- 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
{-# LANGUAGE FlexibleInstances #-}
module Language.Haskell.GhcMod.Output (
gmPutStr
, gmErrStr
, gmPutStrLn
, gmErrStrLn
2015-09-08 04:44:02 +00:00
, gmPutStrIO
, gmErrStrIO
, gmReadProcess
, gmReadProcess'
2015-09-08 04:44:02 +00:00
2015-08-13 07:01:58 +00:00
, stdoutGateway
, flushStdoutGateway
) where
2015-08-13 07:01:58 +00:00
import Data.List
import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy as BS
2015-09-16 03:08:16 +00:00
import qualified Data.Label as L
import qualified Data.Label.Base as LB
import System.IO
2015-08-13 07:01:58 +00:00
import System.Exit
import System.Process
import Control.Monad
2015-09-16 03:08:16 +00:00
import Control.Monad.State.Strict
2015-08-13 07:01:58 +00:00
import Control.DeepSeq
import Control.Exception
2015-09-16 03:18:44 +00:00
import Control.Concurrent (forkIO, killThread)
2015-09-16 03:08:16 +00:00
import Control.Concurrent.MVar
import Control.Concurrent.Chan
import Pipes
import Pipes.Lift
import Prelude
2015-09-16 03:08:16 +00:00
import Language.Haskell.GhcMod.Types hiding (LineSeparator, MonadIO(..))
import Language.Haskell.GhcMod.Monad.Types hiding (MonadIO(..))
2015-08-13 07:01:58 +00:00
class ProcessOutput a where
hGetContents' :: Handle -> IO a
instance ProcessOutput String where
hGetContents' = hGetContents
instance ProcessOutput ByteString where
hGetContents' = BS.hGetContents
outputFns :: (GmOut m, MonadIO m')
2015-09-16 03:08:16 +00:00
=> m (String -> m' (), String -> m' ())
outputFns =
2015-09-01 08:45:15 +00:00
outputFns' `liftM` gmoAsk
outputFns' ::
2015-09-16 03:08:16 +00:00
MonadIO m => GhcModOut -> (String -> m (), String -> m ())
outputFns' (GhcModOut oopts c) = let
OutputOpts {..} = oopts
2015-08-14 03:57:33 +00:00
in
case ooptLinePrefix of
2015-09-16 03:08:16 +00:00
Nothing -> stdioOutputFns
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 ()
gmPutStr str = do
2015-09-08 04:44:02 +00:00
putOut <- gmPutStrIO
putOut str
gmErrStr str = do
putErr <- gmErrStrIO
putErr str
gmPutStrLn = gmPutStr . (++"\n")
gmErrStrLn = gmErrStr . (++"\n")
2015-09-08 04:44:02 +00:00
gmPutStrIO, gmErrStrIO :: (GmOut m, MonadIO mi) => m (String -> mi ())
2015-09-16 03:08:16 +00:00
gmPutStrIO = fst `liftM` outputFns
gmErrStrIO = snd `liftM` outputFns
2015-08-13 07:01:58 +00:00
2015-08-14 03:57:33 +00:00
gmReadProcess :: GmOut m => m (FilePath -> [String] -> String -> IO String)
2015-08-13 07:01:58 +00:00
gmReadProcess = do
GhcModOut {..} <- gmoAsk
case ooptLinePrefix gmoOptions of
Just _ ->
2015-08-13 07:01:58 +00:00
readProcessStderrChan
Nothing ->
2015-08-13 07:01:58 +00:00
return $ readProcess
gmReadProcess' :: GmOut m => m (FilePath -> [String] -> String -> IO ByteString)
gmReadProcess' = readProcessStderrChan
2015-09-16 03:08:16 +00:00
flushStdoutGateway :: Chan (Either (MVar ()) (GmStream, String)) -> IO ()
flushStdoutGateway c = do
mv <- newEmptyMVar
writeChan c $ Left mv
takeMVar mv
2015-09-16 03:08:16 +00:00
type Line = String
stdoutGateway :: (String, String) -> Chan (Either (MVar ()) (GmStream, String)) -> IO ()
stdoutGateway (outPf, errPf) chan = do
runEffect $ commandProc >-> evalStateP ("","") seperateStreams
2015-08-13 07:01:58 +00:00
where
2015-09-16 03:08:16 +00:00
commandProc :: Producer (Either (MVar ()) (GmStream, String)) IO ()
commandProc = do
cmd <- liftIO $ readChan chan
case cmd of
Left mv -> do
2015-09-16 03:08:16 +00:00
yield $ Left mv
Right input -> do
yield $ Right input
commandProc
seperateStreams :: Consumer (Either (MVar ()) (GmStream, String)) (StateT (String, String) IO) ()
seperateStreams = do
ecmd <- await
case ecmd of
Left mv -> do
-- flush buffers
(\s -> lift $ zoom (streamLens s) $ sGetLine Nothing)
`mapM_` [GmOutStream, GmErrStream]
liftIO $ putMVar mv ()
Right (stream, str) -> do
ls <- lift $ zoom (streamLens stream) $ sGetLine (Just str)
case ls of
[] -> return ()
_ -> liftIO $ putStr $ unlines $ map (streamPf stream++) ls
liftIO $ hFlush stdout
seperateStreams
sGetLine :: (Maybe String) -> StateT String IO [Line]
sGetLine mstr' = do
buf <- get
2015-09-16 03:40:53 +00:00
let mstr = (buf++) `liftM` mstr'
2015-09-16 03:08:16 +00:00
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
2015-09-16 03:18:44 +00:00
(a', s') <- a $ L.get l f
return (a', L.set l s' f)
2015-08-13 07:01:58 +00:00
readProcessStderrChan ::
(GmOut m, ProcessOutput a, NFData a) => m (FilePath -> [String] -> String -> IO a)
2015-08-13 07:01:58 +00:00
readProcessStderrChan = do
2015-09-16 03:08:16 +00:00
(_, e :: String -> IO ()) <- outputFns
return $ readProcessStderrChan' e
readProcessStderrChan' :: (ProcessOutput a, NFData a) =>
(String -> IO ()) -> FilePath -> [String] -> String -> IO a
readProcessStderrChan' putErr exe args input = do
2015-08-13 07:01:58 +00:00
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
2015-08-13 07:01:58 +00:00
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 ->
2015-08-31 06:55:49 +00:00
throw $ GMEProcess "readProcessStderrChan" exe args $ Left rv
2015-08-13 07:01:58 +00:00
ExitSuccess ->
return output
where
ignoreSEx = handle (\(SomeException _) -> return ())
reader h = ignoreSEx $ do
2015-09-16 03:08:16 +00:00
putErr . (++"\n") =<< hGetLine h
2015-08-13 07:01:58 +00:00
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