implementing suppressStdout/err.

This commit is contained in:
Kazu Yamamoto 2014-04-18 15:41:32 +09:00
parent 5006d836e1
commit aecb9bc1e4
4 changed files with 46 additions and 18 deletions

View File

@ -18,6 +18,7 @@ import Data.Char (isSpace,isAlphaNum)
import Data.List (isPrefixOf, intercalate) import Data.List (isPrefixOf, intercalate)
import Data.Maybe (listToMaybe, maybeToList) import Data.Maybe (listToMaybe, maybeToList)
import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Utils
import System.FilePath ((</>)) import System.FilePath ((</>))
import System.Process (readProcess) import System.Process (readProcess)
import Text.ParserCombinators.ReadP import Text.ParserCombinators.ReadP
@ -65,8 +66,7 @@ ghcPkgList dbs = map fst3 <$> ghcPkgListEx dbs
ghcPkgListEx :: [GhcPkgDb] -> IO [Package] ghcPkgListEx :: [GhcPkgDb] -> IO [Package]
ghcPkgListEx dbs = do ghcPkgListEx dbs = do
output <- readProcess "ghc-pkg" opts "" output <- suppressStderr $ readProcess "ghc-pkg" opts ""
-- hPutStrLn stderr output
return $ parseGhcPkgOutput $ lines output return $ parseGhcPkgOutput $ lines output
where where
opts = ["list", "-v"] ++ ghcPkgDbStackOpts dbs opts = ["list", "-v"] ++ ghcPkgDbStackOpts dbs

View File

@ -1,13 +1,10 @@
module Language.Haskell.GhcMod.Lint where module Language.Haskell.GhcMod.Lint where
import Control.Applicative ((<$>)) import Control.Applicative ((<$>))
import Control.Exception (finally)
import Data.List (intercalate) import Data.List (intercalate)
import GHC.IO.Handle (hDuplicate, hDuplicateTo)
import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Utils
import Language.Haskell.HLint (hlint) import Language.Haskell.HLint (hlint)
import System.Directory (getTemporaryDirectory, removeFile)
import System.IO (hClose, openTempFile, stdout)
-- | Checking syntax of a target file using hlint. -- | Checking syntax of a target file using hlint.
-- Warnings and errors are returned. -- Warnings and errors are returned.
@ -26,14 +23,3 @@ lint :: [String]
-> FilePath -- ^ A target file. -> FilePath -- ^ A target file.
-> IO [String] -> IO [String]
lint hopts file = map show <$> suppressStdout (hlint (file : hopts)) lint hopts file = map show <$> suppressStdout (hlint (file : hopts))
suppressStdout :: IO a -> IO a
suppressStdout f = do
tmpdir <- getTemporaryDirectory
(path, handle) <- openTempFile tmpdir "ghc-mod-hlint"
dup <- hDuplicate stdout
hDuplicateTo handle stdout
hClose handle
f `finally` do
hDuplicateTo dup stdout
removeFile path

View File

@ -0,0 +1,41 @@
{-# LANGUAGE CPP #-}
module Language.Haskell.GhcMod.Utils (
suppressStdout
, suppressStderr
) where
import Control.Exception (finally)
import GHC.IO.Handle (hDuplicate, hDuplicateTo)
import GHC.IO.Handle.Types (Handle)
import System.IO (hClose, stdout, stderr)
#ifdef WINDOWS
import System.Directory (getTemporaryDirectory, removeFile)
import System.IO (openTempFile)
#else
import System.IO (openFile, IOMode(..))
#endif
suppressStdout :: IO a -> IO a
suppressStdout = suppress stdout
suppressStderr :: IO a -> IO a
suppressStderr = suppress stderr
suppress :: GHC.IO.Handle.Types.Handle -> IO a -> IO a
suppress std f = do
#ifdef WINDOWS
tmpdir <- getTemporaryDirectory
(path, handle) <- openTempFile tmpdir "ghc-mod"
#else
handle <- openFile "/dev/null" WriteMode
#endif
dup <- hDuplicate std
hDuplicateTo handle std
hClose handle
f `finally` do
hDuplicateTo dup std
#ifdef WINDOWS
removeFile path
#endif

View File

@ -56,14 +56,15 @@ Library
Language.Haskell.GhcMod.ErrMsg Language.Haskell.GhcMod.ErrMsg
Language.Haskell.GhcMod.Flag Language.Haskell.GhcMod.Flag
Language.Haskell.GhcMod.GHCApi Language.Haskell.GhcMod.GHCApi
Language.Haskell.GhcMod.GhcPkg
Language.Haskell.GhcMod.GHCChoice Language.Haskell.GhcMod.GHCChoice
Language.Haskell.GhcMod.Gap Language.Haskell.GhcMod.Gap
Language.Haskell.GhcMod.GhcPkg
Language.Haskell.GhcMod.Info Language.Haskell.GhcMod.Info
Language.Haskell.GhcMod.Lang Language.Haskell.GhcMod.Lang
Language.Haskell.GhcMod.Lint Language.Haskell.GhcMod.Lint
Language.Haskell.GhcMod.List Language.Haskell.GhcMod.List
Language.Haskell.GhcMod.PkgDoc Language.Haskell.GhcMod.PkgDoc
Language.Haskell.GhcMod.Utils
Language.Haskell.GhcMod.Types Language.Haskell.GhcMod.Types
Build-Depends: base >= 4.0 && < 5 Build-Depends: base >= 4.0 && < 5
, containers , containers