Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : sdoc
http://hackage.haskell.org/trac/ghc/changeset/e566d1385483fbc93bab94973aebd2a1663245df >--------------------------------------------------------------- commit e566d1385483fbc93bab94973aebd2a1663245df Author: Ian Lynagh <[email protected]> Date: Wed May 25 15:45:25 2011 +0100 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 93e813f..d11f36d 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 e0a30b4..8dd4e01 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 46058c4..c3aef5d 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 5249b23..acf6f7a 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 bd33dda..162c253 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 aa73e25..5bd2a45 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 2aff483..06ef411 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 _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
