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

-- 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

  , gmPutStrIO
  , gmErrStrIO

  , gmReadProcess

  , 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 (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, MonadIO(..))
import Language.Haskell.GhcMod.Monad.Types hiding (MonadIO(..))

outputFns :: (GmOut m, MonadIO m')
          => m (String -> m' (), String -> m' ())
outputFns =
  outputFns' `liftM` gmoAsk

outputFns' ::
  MonadIO m => GhcModOut -> (String -> m (), String -> m ())
outputFns' (GhcModOut oopts c)  = let
  OutputOpts {..} = oopts
 in
  case ooptLinePrefix of
    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
  putOut <- gmPutStrIO
  putOut str

gmErrStr str = do
  putErr <- gmErrStrIO
  putErr str

gmPutStrLn = gmPutStr . (++"\n")
gmErrStrLn = gmErrStr . (++"\n")

gmPutStrIO, gmErrStrIO :: (GmOut m, MonadIO mi) => m (String -> mi ())

gmPutStrIO = fst `liftM` outputFns
gmErrStrIO = snd `liftM` outputFns


gmReadProcess :: GmOut m => m (FilePath -> [String] -> String -> IO String)
gmReadProcess = do
  GhcModOut {..} <- gmoAsk
  case ooptLinePrefix gmoOptions of
    Just _ ->
        readProcessStderrChan
    Nothing ->
        return $ readProcess

flushStdoutGateway :: Chan (Either (MVar ()) (GmStream, String)) -> IO ()
flushStdoutGateway c = do
  mv <- newEmptyMVar
  writeChan c $ Left mv
  takeMVar mv

type Line = String

stdoutGateway :: (String, String) -> Chan (Either (MVar ()) (GmStream, String)) -> IO ()
stdoutGateway (outPf, errPf) chan = do
  runEffect $ commandProc >-> evalStateP ("","") seperateStreams
 where
   commandProc :: Producer (Either (MVar ()) (GmStream, String)) IO ()
   commandProc = do
     cmd <- liftIO $ readChan chan
     case cmd of
       Left mv -> do
           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
     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 :: String -> IO ()) <- outputFns
  return $ readProcessStderrChan' e

readProcessStderrChan' ::
    (String -> IO ()) -> FilePath -> [String] -> String -> IO String
readProcessStderrChan' pute = go pute
 where
   go :: (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 ->
           throw $ GMEProcess "readProcessStderrChan" exe args $ Left rv
       ExitSuccess ->
           return output
    where
      ignoreSEx = handle (\(SomeException _) -> return ())
      reader h = ignoreSEx $ do
        putErr . (++"\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