{-# LANGUAGE CPP #-}
module System.IO.Silently (
silence,
hSilence,
capture,
capture_,
hCapture,
hCapture_,
) where
import Prelude
#if __GLASGOW_HASKELL__ >= 612
import GHC.IO.Handle (hDuplicate, hDuplicateTo)
#else
import GHC.Handle (hDuplicate, hDuplicateTo)
#endif
import System.IO
import qualified Control.Exception as E
import Control.DeepSeq
import System.Directory (removeFile,getTemporaryDirectory)
mNullDevice :: Maybe FilePath
#ifdef WINDOWS
mNullDevice = Just "\\\\.\\NUL"
#elif UNIX
mNullDevice = Just "/dev/null"
#else
mNullDevice = Nothing
#endif
silence :: IO a -> IO a
silence = hSilence [stdout]
hSilence :: [Handle] -> IO a -> IO a
hSilence handles action = case mNullDevice of
Just nullDevice -> E.bracket (openFile nullDevice AppendMode)
hClose
prepareAndRun
Nothing -> do
tmpDir <- getTempOrCurrentDirectory
E.bracket (openTempFile tmpDir "silence")
cleanup
(prepareAndRun . snd)
where
cleanup (tmpFile,tmpHandle) = do
hClose tmpHandle
removeFile tmpFile
prepareAndRun tmpHandle = go handles
where
go [] = action
go hs = goBracket go tmpHandle hs
getTempOrCurrentDirectory :: IO String
getTempOrCurrentDirectory = getTemporaryDirectory `catchIOError` (\_ -> return ".")
where
catchIOError :: IO a -> (IOError -> IO a) -> IO a
catchIOError = E.catch
capture :: IO a -> IO (String, a)
capture = hCapture [stdout]
capture_ :: IO a -> IO String
capture_ = fmap fst . capture
hCapture_ :: [Handle] -> IO a -> IO String
hCapture_ handles = fmap fst . hCapture handles
hCapture :: [Handle] -> IO a -> IO (String, a)
hCapture handles action = do
tmpDir <- getTempOrCurrentDirectory
E.bracket (openTempFile tmpDir "capture")
cleanup
(prepareAndRun . snd)
where
cleanup (tmpFile,tmpHandle) = do
hClose tmpHandle
removeFile tmpFile
prepareAndRun tmpHandle = go handles
where
go [] = do
a <- action
mapM_ hFlush handles
hSeek tmpHandle AbsoluteSeek 0
str <- hGetContents tmpHandle
str `deepseq` return (str,a)
go hs = goBracket go tmpHandle hs
goBracket :: ([Handle] -> IO a) -> Handle -> [Handle] -> IO a
goBracket go tmpHandle (h:hs) = do
buffering <- hGetBuffering h
let redirect = do
old <- hDuplicate h
hDuplicateTo tmpHandle h
return old
restore old = do
hDuplicateTo old h
hSetBuffering h buffering
hClose old
E.bracket redirect restore (\_ -> go hs)