Commit 93abcfa5 authored by Ian Lynagh's avatar Ian Lynagh
Browse files

Remove more uses of stdout and stderr

parent 78252479
......@@ -27,6 +27,7 @@ import GHC
import Outputable
import PprTyThing
import MonadUtils
import DynFlags
import Exception
import Control.Monad
......@@ -34,7 +35,6 @@ import Data.List
import Data.Maybe
import Data.IORef
import System.IO
import GHC.Exts
-------------------------------------
......@@ -58,7 +58,8 @@ pprintClosureCommand bindThings force str = do
-- Finally, print the Terms
unqual <- GHC.getPrintUnqual
docterms <- mapM showTerm terms
liftIO $ (printForUser stdout unqual . vcat)
dflags <- getDynFlags
liftIO $ (printOutputForUser dflags unqual . vcat)
(zipWith (\id docterm -> ppr id <+> char '=' <+> docterm)
ids
docterms)
......@@ -226,4 +227,4 @@ pprTypeAndContents id = do
traceOptIf :: GhcMonad m => DynFlag -> SDoc -> m ()
traceOptIf flag doc = do
dflags <- GHC.getSessionDynFlags
when (dopt flag dflags) $ liftIO $ printForUser stderr alwaysQualify doc
when (dopt flag dflags) $ liftIO $ printInfoForUser dflags alwaysQualify doc
......@@ -44,6 +44,8 @@ module DynFlags (
fFlags, fWarningFlags, fLangFlags, xFlags,
wayNames, dynFlagDependencies,
printOutputForUser, printInfoForUser,
-- ** Safe Haskell
SafeHaskellMode(..),
safeHaskellOn, safeImportsOn, safeLanguageOn, safeInferOn,
......@@ -995,6 +997,16 @@ newtype FlushErr = FlushErr (IO ())
defaultFlushErr :: FlushErr
defaultFlushErr = FlushErr $ hFlush stderr
printOutputForUser :: DynFlags -> PrintUnqualified -> SDoc -> IO ()
printOutputForUser = printSevForUser SevOutput
printInfoForUser :: DynFlags -> PrintUnqualified -> SDoc -> IO ()
printInfoForUser = printSevForUser SevInfo
printSevForUser :: Severity -> DynFlags -> PrintUnqualified -> SDoc -> IO ()
printSevForUser sev dflags unqual doc
= log_action dflags sev noSrcSpan (mkUserStyle unqual AllTheWay) doc
{-
Note [Verbosity levels]
~~~~~~~~~~~~~~~~~~~~~~~
......
......@@ -84,7 +84,6 @@ import GHC.Exts
import Data.Array
import Exception
import Control.Concurrent
import System.IO
import System.IO.Unsafe
-- -----------------------------------------------------------------------------
......@@ -707,8 +706,9 @@ rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do
WARN(True, text (":print failed to calculate the "
++ "improvement for a type")) hsc_env
Just subst -> do
when (dopt Opt_D_dump_rtti (hsc_dflags hsc_env)) $
printForUser stderr alwaysQualify $
let dflags = hsc_dflags hsc_env
when (dopt Opt_D_dump_rtti dflags) $
printInfoForUser dflags alwaysQualify $
fsep [text "RTTI Improvement for", ppr id, equals, ppr subst]
let ic' = extendInteractiveContext
......
......@@ -49,7 +49,6 @@ import FastString
import Panic
import Util
import System.IO
import Data.IORef
import qualified Data.Set as Set
import Control.Monad
......@@ -444,7 +443,8 @@ traceHiDiffs = traceOptIf Opt_D_dump_hi_diffs
traceOptIf :: DynFlag -> SDoc -> TcRnIf m n () -- No RdrEnv available, so qualify everything
traceOptIf flag doc = ifDOptM flag $
liftIO (printForUser stderr alwaysQualify doc)
do dflags <- getDynFlags
liftIO (printInfoForUser dflags alwaysQualify doc)
traceOptTcRn :: DynFlag -> SDoc -> TcRn ()
-- Output the message, with current location if opt_PprStyle_Debug
......@@ -459,7 +459,7 @@ traceOptTcRn flag doc = ifDOptM flag $ do
dumpTcRn :: SDoc -> TcRn ()
dumpTcRn doc = do { rdr_env <- getGlobalRdrEnv
; dflags <- getDynFlags
; liftIO (printForUser stderr (mkPrintUnqualified dflags rdr_env) doc) }
; liftIO (printInfoForUser dflags (mkPrintUnqualified dflags rdr_env) doc) }
debugDumpTcRn :: SDoc -> TcRn ()
debugDumpTcRn doc | opt_NoDebugOutput = return ()
......
......@@ -43,8 +43,6 @@ import Name
import ErrUtils
import Outputable
import System.IO
-- |Run a vectorisation computation.
--
......@@ -69,7 +67,9 @@ initV hsc_env guts info thing_inside
; return res
}
where
dumpIfVtTrace = dumpIfSet_dyn (hsc_dflags hsc_env) Opt_D_dump_vt_trace
dflags = hsc_dflags hsc_env
dumpIfVtTrace = dumpIfSet_dyn dflags Opt_D_dump_vt_trace
bindsToIds (NonRec v _) = [v]
bindsToIds (Rec binds) = map fst binds
......@@ -100,7 +100,7 @@ initV hsc_env guts info thing_inside
Yes genv _ x -> return $ Just (new_info genv, x)
No reason -> do { unqual <- mkPrintUnqualifiedDs
; liftIO $
printForUser stderr unqual $
printInfoForUser dflags unqual $
mkDumpDoc "Warning: vectorisation failure:" reason
; return Nothing
}
......
......@@ -37,7 +37,6 @@ import DynFlags
import StaticFlags
import Control.Monad
import System.IO (stderr)
-- The Vectorisation Monad ----------------------------------------------------
......@@ -112,8 +111,9 @@ maybeCantVectoriseM s d p
--
emitVt :: String -> SDoc -> VM ()
emitVt herald doc
= liftDs $
liftIO . printForUser stderr alwaysQualify $
= liftDs $ do
dflags <- getDynFlags
liftIO . printInfoForUser dflags alwaysQualify $
hang (text herald) 2 doc
-- |Output a trace message if -ddump-vt-trace is active.
......@@ -140,7 +140,8 @@ dumpOptVt flag header doc
dumpVt :: String -> SDoc -> VM ()
dumpVt header doc
= do { unqual <- liftDs mkPrintUnqualifiedDs
; liftIO $ printForUser stderr unqual (mkDumpDoc header doc)
; dflags <- liftDs getDynFlags
; liftIO $ printInfoForUser dflags unqual (mkDumpDoc header doc)
}
......@@ -185,8 +186,9 @@ tryErrV (VM p) = VM $ \bi genv lenv ->
case r of
Yes genv' lenv' x -> return (Yes genv' lenv' (Just x))
No reason -> do { unqual <- mkPrintUnqualifiedDs
; dflags <- getDynFlags
; liftIO $
printForUser stderr unqual $
printInfoForUser dflags unqual $
text "Warning: vectorisation failure:" <+> reason
; return (Yes genv lenv Nothing)
}
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment