GHC在线程存在时包含stdout,但GHCi不包含

时间:2018-11-01 14:05:21

标签: multithreading haskell ghc ghci

我有以下haskell程序

module Main where

import           Control.Concurrent
import           Control.Monad
import           GHC.IO.Handle
import           System.Process

unlessM :: Monad m => m Bool -> m () -> m()
unlessM cond m = do
  c <- cond
  unless c m

main :: IO ()
main = do
  lock <- newMVar ()
  void $ withCreateProcess
    (proc exe args){ std_out = CreatePipe, std_err = CreatePipe }
    $ handleProcess lock
  where
    exe = "/bin/bash"
    args = ["-c", "echo 1; sleep 1; echo 2; sleep 1; echo 3 "]
    handleProcess lock _ (Just outh) (Just errh) hand = do
      _ <- forkIO $ showLines lock outh "STDOUT"
      _ <- forkIO $ showLines lock errh "STDERR"
      waitForProcess hand
    handleProcess _ _ _ _ _ = fail "No output or error handlers"
    showLines :: MVar () -> Handle -> String -> IO ()
    showLines v h str =
      unlessM (hIsClosed h) $
        unlessM (hIsEOF h) $ do
          l <- hGetLine h
          () <- takeMVar v
          putStrLn $ str ++ ": " ++ l
          putMVar v ()
          showLines v h str

使用ghci运行它可以提供预期的输出,但是编译和运行不会产生任何结果

$ ghci
GHCi, version 8.0.2: http://www.haskell.org/ghc/  :? for help
Loaded GHCi configuration from /home/drninjabatman/.ghci
Prelude> :load Main.hs
[1 of 1] Compiling Main             ( Main.hs, interpreted )
Ok, modules loaded: Main.
*Main> main
STDOUT: 1
STDOUT: 2
STDOUT: 3
*Main> 
Leaving GHCi.
$ runhaskell ./Main.hs
STDOUT: 1
STDOUT: 2
STDOUT: 3
$ ghc Main.hs -o test
[1 of 1] Compiling Main             ( Main.hs, Main.o )
Linking test ...
$ ./test
$ # No output 

1 个答案:

答案 0 :(得分:0)

Haskell程序在其主线程暂停时立即终止。

您需要将main修改为退出之前等待生成的线程。

在GHCi中,这不是问题,因为主线程运行REPL,因此不会停止。

未经测试的尝试:

handleProcess lock _ (Just outh) (Just errh) hand = do
      lockOut <- newEmptyMVar
      _ <- forkIO (showLines lock outh "STDOUT" >> putMVar lockOut ())
      lockErr <- newEmptyMVar
      _ <- forkIO (showLines lock errh "STDERR" >> putMVar lockErr ())
      waitForProcess hand
      takeMVar lockOut
      takeMVar lockErr