Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : sdoc
http://hackage.haskell.org/trac/ghc/changeset/9801de5f7918593d0f95648050567fbb3a024206 >--------------------------------------------------------------- commit 9801de5f7918593d0f95648050567fbb3a024206 Author: Ian Lynagh <[email protected]> Date: Wed May 25 15:11:18 2011 +0100 More DynFlags + SDoc >--------------------------------------------------------------- compiler/ghci/Debugger.hs | 2 +- compiler/main/DynFlags.hs | 6 +++--- compiler/main/ErrUtils.lhs | 6 +++--- compiler/main/SysTools.lhs | 4 ++-- compiler/typecheck/TcRnMonad.lhs | 6 ++++-- compiler/utils/Outputable.lhs | 6 +++--- 6 files changed, 16 insertions(+), 14 deletions(-) diff --git a/compiler/ghci/Debugger.hs b/compiler/ghci/Debugger.hs index 141a513..93e813f 100644 --- a/compiler/ghci/Debugger.hs +++ b/compiler/ghci/Debugger.hs @@ -162,7 +162,7 @@ showTerm term = do -- XXX: this tries to disable logging of errors -- does this still do what it is intended to do -- with the changed error handling and logging? - let noop_log _ _ _ _ = return () + let noop_log _ _ _ _ _ = return () expr = "show " ++ showSDoc (ppr bname) _ <- GHC.setSessionDynFlags dflags{log_action=noop_log} txt_ <- withExtendedLinkEnv [(bname, val)] diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 5acc7bb..c0169b6 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -829,11 +829,11 @@ defaultDynFlags mySettings = log_action = \dflags severity srcSpan style msg -> case severity of SevOutput -> printSDoc dflags msg style - SevInfo -> printErrs msg style - SevFatal -> printErrs msg style + SevInfo -> printErrs dflags msg style + SevFatal -> printErrs dflags msg style _ -> do hPutChar stderr '\n' - printErrs (mkLocMessage srcSpan msg) style + printErrs dflags (mkLocMessage srcSpan msg) style -- careful (#2302): printErrs prints in UTF-8, whereas -- converting to string first and using hPutStr would -- just emit the low 8 bits of each unicode char. diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs index 8cc8e62..878c3e6 100644 --- a/compiler/main/ErrUtils.lhs +++ b/compiler/main/ErrUtils.lhs @@ -69,9 +69,9 @@ mkLocMessage locn msg -- are supposed to be in a standard format, and one without a location -- would look strange. Better to say explicitly "<no location info>". -printError :: SrcSpan -> Message -> IO () -printError span msg = - printErrs (mkLocMessage span msg) defaultErrStyle +printError :: DynFlags -> SrcSpan -> Message -> IO () +printError dflags span msg = + printErrs dflags (mkLocMessage span msg) defaultErrStyle -- ----------------------------------------------------------------------------- diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs index 9c086cc..e0bab19 100644 --- a/compiler/main/SysTools.lhs +++ b/compiler/main/SysTools.lhs @@ -712,10 +712,10 @@ builderMainLoop dflags filter_fn pgm real_args mb_env = do msg <- readChan chan case msg of BuildMsg msg -> do - log_action dflags SevInfo noSrcSpan defaultUserStyle msg + log_action dflags dflags SevInfo noSrcSpan defaultUserStyle msg loop chan hProcess t p exitcode BuildError loc msg -> do - log_action dflags SevError (mkSrcSpan loc loc) defaultUserStyle msg + log_action dflags dflags SevError (mkSrcSpan loc loc) defaultUserStyle msg loop chan hProcess t p exitcode EOF -> loop chan hProcess (t-1) p exitcode diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index 7e7f117..5249b23 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -1149,7 +1149,8 @@ failIfM :: Message -> IfL a failIfM msg = do { env <- getLclEnv ; let full_msg = (if_loc env <> colon) $$ nest 2 msg - ; liftIO (printErrs full_msg defaultErrStyle) + ; dflags <- getDOpts + ; liftIO (printErrs dflags full_msg defaultErrStyle) ; failM } -------------------- @@ -1184,7 +1185,8 @@ forkM_maybe doc thing_inside ; return Nothing } }} where - print_errs sdoc = liftIO (printErrs sdoc defaultErrStyle) + print_errs sdoc = do dflags <- getDOpts + liftIO (printErrs dflags sdoc defaultErrStyle) forkM :: SDoc -> IfL a -> IfL a forkM doc thing_inside diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs index 5dd521a..f825133 100644 --- a/compiler/utils/Outputable.lhs +++ b/compiler/utils/Outputable.lhs @@ -328,9 +328,9 @@ printSDoc dflags d sty = do -- I'm not sure whether the direct-IO approach of Pretty.printDoc -- above is better or worse than the put-big-string approach here -printErrs :: SDoc -> PprStyle -> IO () -printErrs doc sty = do - Pretty.printDoc PageMode stderr (runSDoc doc (initSDocContext sty)) +printErrs :: DynFlags -> SDoc -> PprStyle -> IO () +printErrs dflags doc sty = do + Pretty.printDoc PageMode stderr (runSDoc doc (initSDocContext' dflags sty)) hFlush stderr printOutput :: Doc -> IO () _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
