From e566d1385483fbc93bab94973aebd2a1663245df Mon Sep 17 00:00:00 2001
From: Ian Lynagh <igloo@earth.li>
Date: Wed, 25 May 2011 15:45:25 +0100
Subject: [PATCH] More DynFlags + SDoc
---
compiler/ghci/Debugger.hs | 5 +++--
compiler/main/InteractiveEval.hs | 5 +++--
compiler/rename/RnNames.lhs | 3 ++-
compiler/typecheck/TcRnMonad.lhs | 5 +++--
compiler/utils/Outputable.lhs | 6 +++---
compiler/vectorise/Vectorise/Monad/Base.hs | 3 ++-
ghc/GhciMonad.hs | 3 ++-
7 files changed, 18 insertions(+), 12 deletions(-)
diff --git a/compiler/ghci/Debugger.hs b/compiler/ghci/Debugger.hs
index 93e813fa3085..d11f36d7a9ab 100644
--- a/compiler/ghci/Debugger.hs
+++ b/compiler/ghci/Debugger.hs
@@ -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 <- getSessionDynFlags
+ liftIO $ (printForUser dflags stdout unqual . vcat)
(zipWith (\id docterm -> ppr id <+> char '=' <+> docterm)
ids
docterms)
@@ -225,4 +226,4 @@ pprTypeAndContents ids = 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 $ printForUser dflags stderr alwaysQualify doc
diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs
index e0a30b46dca7..8dd4e0146417 100644
--- a/compiler/main/InteractiveEval.hs
+++ b/compiler/main/InteractiveEval.hs
@@ -680,8 +680,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) $
+ printForUser dflags stderr alwaysQualify $
fsep [text "RTTI Improvement for", ppr id, equals, ppr subst]
let ic' = extendInteractiveContext
diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs
index 46058c4677f7..c3aef5d90fc1 100644
--- a/compiler/rename/RnNames.lhs
+++ b/compiler/rename/RnNames.lhs
@@ -1377,9 +1377,10 @@ printMinimalImports :: [ImportDeclUsage] -> RnM ()
printMinimalImports imports_w_usage
= do { imports' <- mapM mk_minimal imports_w_usage
; this_mod <- getModule
+ ; dflags <- getDOpts
; liftIO $
do { h <- openFile (mkFilename this_mod) WriteMode
- ; printForUser h neverQualify (vcat (map ppr imports')) }
+ ; printForUser dflags h neverQualify (vcat (map ppr imports')) }
-- The neverQualify is important. We are printing Names
-- but they are in the context of an 'import' decl, and
-- we never qualify things inside there
diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs
index 5249b238280f..acf6f7ae0a73 100644
--- a/compiler/typecheck/TcRnMonad.lhs
+++ b/compiler/typecheck/TcRnMonad.lhs
@@ -413,7 +413,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 <- getDOpts
+ liftIO (printForUser dflags stderr alwaysQualify doc)
traceOptTcRn :: DynFlag -> SDoc -> TcRn ()
-- Output the message, with current location if opt_PprStyle_Debug
@@ -428,7 +429,7 @@ traceOptTcRn flag doc = ifDOptM flag $ do
dumpTcRn :: SDoc -> TcRn ()
dumpTcRn doc = do { rdr_env <- getGlobalRdrEnv
; dflags <- getDOpts
- ; liftIO (printForUser stderr (mkPrintUnqualified dflags rdr_env) doc) }
+ ; liftIO (printForUser dflags stderr (mkPrintUnqualified dflags rdr_env) doc) }
debugDumpTcRn :: SDoc -> TcRn ()
debugDumpTcRn doc | opt_NoDebugOutput = return ()
diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs
index bd33ddaee364..162c253b6b91 100644
--- a/compiler/utils/Outputable.lhs
+++ b/compiler/utils/Outputable.lhs
@@ -347,10 +347,10 @@ hPrintDump dflags h doc = do
where
better_doc = doc $$ blankLine
-printForUser :: Handle -> PrintUnqualified -> SDoc -> IO ()
-printForUser handle unqual doc
+printForUser :: DynFlags -> Handle -> PrintUnqualified -> SDoc -> IO ()
+printForUser dflags handle unqual doc
= Pretty.printDoc PageMode handle
- (runSDoc doc (initSDocContext (mkUserStyle unqual AllTheWay)))
+ (runSDoc doc (initSDocContext' dflags (mkUserStyle unqual AllTheWay)))
printForUserPartWay :: Handle -> Int -> PrintUnqualified -> SDoc -> IO ()
printForUserPartWay handle d unqual doc
diff --git a/compiler/vectorise/Vectorise/Monad/Base.hs b/compiler/vectorise/Vectorise/Monad/Base.hs
index aa73e25264b5..5bd2a4515f89 100644
--- a/compiler/vectorise/Vectorise/Monad/Base.hs
+++ b/compiler/vectorise/Vectorise/Monad/Base.hs
@@ -122,7 +122,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 getDOptsDs
+ ; liftIO $ printForUser dflags stderr unqual (mkDumpDoc header doc)
}
-- Control --------------------------------------------------------------------
diff --git a/ghc/GhciMonad.hs b/ghc/GhciMonad.hs
index 2aff48385e3d..06ef41126266 100644
--- a/ghc/GhciMonad.hs
+++ b/ghc/GhciMonad.hs
@@ -239,7 +239,8 @@ unsetOption opt
printForUser :: GhcMonad m => SDoc -> m ()
printForUser doc = do
unqual <- GHC.getPrintUnqual
- MonadUtils.liftIO $ Outputable.printForUser stdout unqual doc
+ dflags <- getSessionDynFlags
+ MonadUtils.liftIO $ Outputable.printForUser dflags stdout unqual doc
printForUserPartWay :: SDoc -> GHCi ()
printForUserPartWay doc = do
--
GitLab