Don't swallow ghc's verbose output

This commit is contained in:
Daniel Gröber 2015-09-08 06:44:02 +02:00
parent dbf215a35b
commit 6ad71af001
4 changed files with 27 additions and 11 deletions

View File

@ -3,18 +3,19 @@
module Language.Haskell.GhcMod.DynFlags where module Language.Haskell.GhcMod.DynFlags where
import Control.Applicative import Control.Applicative
import Control.Monad (void) import Control.Monad
import GHC (DynFlags(..), GhcMode(..), GhcLink(..), HscTarget(..)) import GHC
import qualified GHC as G import qualified GHC as G
import GHC.Paths (libdir) import GHC.Paths (libdir)
import GhcMonad
import qualified Language.Haskell.GhcMod.Gap as Gap import qualified Language.Haskell.GhcMod.Gap as Gap
import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.DebugLogger
import System.IO.Unsafe (unsafePerformIO) import System.IO.Unsafe (unsafePerformIO)
import Prelude import Prelude
setEmptyLogger :: DynFlags -> DynFlags setDebugLogger :: (String -> IO ()) -> DynFlags -> DynFlags
setEmptyLogger df = Gap.setLogAction df $ \_ _ _ _ _ -> return () setDebugLogger put df = do
Gap.setLogAction df (debugLogAction put)
-- * Fast -- * Fast
-- * Friendly to foreign export -- * Friendly to foreign export

View File

@ -22,9 +22,15 @@ module Language.Haskell.GhcMod.Output (
, gmErrStr , gmErrStr
, gmPutStrLn , gmPutStrLn
, gmErrStrLn , gmErrStrLn
, gmPutStrIO
, gmErrStrIO
, gmReadProcess , gmReadProcess
, gmUnsafePutStr , gmUnsafePutStr
, gmUnsafeErrStr , gmUnsafeErrStr
, stdoutGateway , stdoutGateway
) where ) where
@ -105,15 +111,21 @@ gmPutStr, gmPutStrLn, gmErrStr, gmErrStrLn
:: (MonadIO m, GmOut m) => String -> m () :: (MonadIO m, GmOut m) => String -> m ()
gmPutStr str = do gmPutStr str = do
putOut <- fst `liftM` outputFns putOut <- gmPutStrIO
putOut $ toGmLines str putOut str
gmErrStr str = do
putErr <- gmErrStrIO
putErr str
gmPutStrLn = gmPutStr . (++"\n") gmPutStrLn = gmPutStr . (++"\n")
gmErrStrLn = gmErrStr . (++"\n") gmErrStrLn = gmErrStr . (++"\n")
gmErrStr str = do gmPutStrIO, gmErrStrIO :: (GmOut m, MonadIO mi) => m (String -> mi ())
putErr <- snd `liftM` outputFns
putErr $ toGmLines str gmPutStrIO = ((. toGmLines) . fst) `liftM` outputFns
gmErrStrIO = ((. toGmLines) . snd) `liftM` outputFns
-- | Only use these when you're sure there are no other writers on stdout -- | Only use these when you're sure there are no other writers on stdout
gmUnsafePutStr, gmUnsafeErrStr gmUnsafePutStr, gmUnsafeErrStr

View File

@ -38,6 +38,7 @@ import Language.Haskell.GhcMod.Utils as U
import Language.Haskell.GhcMod.FileMapping import Language.Haskell.GhcMod.FileMapping
import Language.Haskell.GhcMod.LightGhc import Language.Haskell.GhcMod.LightGhc
import Language.Haskell.GhcMod.CustomPackageDb import Language.Haskell.GhcMod.CustomPackageDb
import Language.Haskell.GhcMod.Output
import Data.Maybe import Data.Maybe
import Data.Monoid as Monoid import Data.Monoid as Monoid
@ -131,8 +132,9 @@ runGmlTWith efnmns' mdf wrapper action = do
(text "Initializing GHC session with following options") (text "Initializing GHC session with following options")
(intercalate " " $ map (("\""++) . (++"\"")) opts') (intercalate " " $ map (("\""++) . (++"\"")) opts')
putErr <- gmErrStrIO
initSession opts' $ initSession opts' $
setModeSimple >>> setEmptyLogger >>> mdf setModeSimple >>> setDebugLogger putErr >>> mdf
mappedStrs <- getMMappedFilePaths mappedStrs <- getMMappedFilePaths
let targetStrs = mappedStrs ++ map moduleNameString mns ++ cfns let targetStrs = mappedStrs ++ map moduleNameString mns ++ cfns

View File

@ -112,6 +112,7 @@ Library
Language.Haskell.GhcMod.Cradle Language.Haskell.GhcMod.Cradle
Language.Haskell.GhcMod.CustomPackageDb Language.Haskell.GhcMod.CustomPackageDb
Language.Haskell.GhcMod.Debug Language.Haskell.GhcMod.Debug
Language.Haskell.GhcMod.DebugLogger
Language.Haskell.GhcMod.Doc Language.Haskell.GhcMod.Doc
Language.Haskell.GhcMod.DynFlags Language.Haskell.GhcMod.DynFlags
Language.Haskell.GhcMod.Error Language.Haskell.GhcMod.Error