Question

以下示例需要包：

- text
- string-conversions
- process

代码：

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}

module Example where

import qualified Data.Text as T
import Data.Text (Text)
import Data.Monoid
import Control.Monad.Identity
import System.Process
import GHC.IO.Handle
import Debug.Trace
import Data.String.Conversions

runGhci :: Text -> IO Text
runGhci _ =  do
  let expr = "print \"test\""
  let inputLines = (<> "\n") <$> T.lines expr :: [Text]
  print inputLines
  createProcess ((proc "ghci" ["-v0", "-ignore-dot-ghci"]) {std_in=CreatePipe, std_out=CreatePipe, std_err=CreatePipe}) >>= \case
    (Just pin, Just pout, Just perr, ph) -> do
      output <-
        forM inputLines (\i -> do
          let script = i <> "\n"
          do
            hPutStr pin $ cs $ script
            hFlush pin
            x <- hIsEOF pout >>= \case
              True -> return ""
              False -> hGetLine pout
            y <- hIsEOF perr >>= \case
              True -> return ""
              False -> hGetLine perr
            let output = cs $! x ++ y
            return $ trace "OUTPUT" $ output
        )
      let f i o = "ghci>" <> i <> o
      let final = T.concat ( zipWith f (inputLines :: [Text]) (output :: [Text]) :: [Text])
      print final
      terminateProcess ph
      pure $ T.strip $  final
    _ -> error "Invaild GHCI process"

如果我尝试运行上述内容：

stack ghci src/Example.hs
ghci> :set -XOverloadedStrings
ghci> runGhci ""
["print \"test\"\n"]

根据https://stackoverflow.com/a/26510673/1663462，hIsEOF perr似乎阻止了它，听起来我不应该调用此函数，除非有一些输出＆＃39;准备刷新/读取...但是如何处理在该阶段没有任何输出的情况？我不介意定期检查＆＃39;或者超时。

如何防止上述情况发生？我已经尝试了涉及hGetContents，hGetLine的各种方法，但是在这种情况下它们似乎都会阻塞（或关闭句柄）......

Answer 1

我必须使用额外的线程，MVars以及超时：

runGhci :: Text -> IO Text
runGhci _ =  do
  let expr = "123 <$> 123"
  let inputLines = filter (/= "") (T.lines expr)
  print inputLines
  createProcess ((proc "ghci" ["-v0", "-ignore-dot-ghci"]) {std_in=CreatePipe, std_out=CreatePipe, std_err=CreatePipe}) >>= \case
    (Just pin, Just pout, Just perr, ph) -> do
      output <- do
        forM inputLines
          (\i -> do
              let script = "putStrLn " ++ show magic ++ "\n"
                            ++ cs i ++ "\n"
                            ++ "putStrLn " ++ show magic ++ "\n"
              do
                stdoutMVar <- newEmptyMVar
                stderrMVar <- newMVar ""
                hPutStr pin script
                hFlush pin
                tOutId <- forkIO $ extract' pout >>= putMVar stdoutMVar
                tErrId <- forkIO $ do
                  let f' = hGetLine perr >>= (\l -> modifyMVar_ stderrMVar (return . (++ (l ++ "\n"))))
                  forever f'
                x <- timeout (1 * (10^6)) (takeMVar stdoutMVar) >>= return . fromMaybe "***ghci timed out"
                y <- timeout (1 * (10^6)) (takeMVar stderrMVar) >>= return . fromMaybe "***ghci timed out"
                killThread tOutId
                killThread tErrId
                return $ trace "OUTPUT" $ cs $! x ++ y
          )
      let final = T.concat ( zipWith f (inputLines :: [Text]) (output :: [Text]) :: [Text])
      print final
      terminateProcess ph
      pure $ T.strip $ cs $ final
    _ -> error "Invaild GHCI process"

如何查询进程的stdout / stderrr输出？被isEOF阻止

1 个答案: