From b3df9e780fb2f5658412c644849cd0f1e6f50331 Mon Sep 17 00:00:00 2001 From: Sylvain Henry Date: Tue, 17 Mar 2020 17:26:11 +0100 Subject: Remove PprStyle param of logging actions Use `withPprStyle` instead to apply a specific style to a SDoc. --- compiler/GHC.hs | 2 +- compiler/GHC/Core/Lint.hs | 7 +++-- compiler/GHC/Core/Opt/Driver.hs | 2 +- compiler/GHC/Core/Opt/Monad.hs | 2 +- compiler/GHC/Driver/CodeOutput.hs | 3 +- compiler/GHC/Driver/Make.hs | 16 +++++------ compiler/GHC/Driver/Pipeline.hs | 2 +- compiler/GHC/Driver/Session.hs | 39 +++++++++++++------------- compiler/GHC/Iface/Binary.hs | 3 +- compiler/GHC/Iface/Load.hs | 2 +- compiler/GHC/Runtime/Debugger.hs | 2 +- compiler/GHC/Runtime/Linker.hs | 9 +++--- compiler/GHC/Stg/Lint.hs | 2 +- compiler/GHC/SysTools/ExtraObj.hs | 2 +- compiler/GHC/SysTools/Process.hs | 4 +-- compiler/GHC/Tc/Utils/Monad.hs | 5 ++-- compiler/GHC/Utils/Error.hs | 50 ++++++++++++++++++---------------- ghc/GHCi/UI.hs | 4 +-- testsuite/tests/ghc-api/T7478/T7478.hs | 6 ++-- 19 files changed, 80 insertions(+), 82 deletions(-) diff --git a/compiler/GHC.hs b/compiler/GHC.hs index ce14dee795..cd1227d418 100644 --- a/compiler/GHC.hs +++ b/compiler/GHC.hs @@ -611,7 +611,7 @@ setSessionDynFlags dflags = do | otherwise = "" msg = text "Starting " <> text prog tr <- if verbosity dflags >= 3 - then return (logInfo dflags defaultDumpStyle msg) + then return (logInfo dflags $ withPprStyle defaultDumpStyle msg) else return (pure ()) let conf = IServConfig diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs index b72bf0f1c5..b1f0e8eece 100644 --- a/compiler/GHC/Core/Lint.hs +++ b/compiler/GHC/Core/Lint.hs @@ -372,7 +372,7 @@ displayLintResults :: DynFlags -> CoreToDo displayLintResults dflags pass warns errs binds | not (isEmptyBag errs) = do { putLogMsg dflags NoReason Err.SevDump noSrcSpan - defaultDumpStyle + $ withPprStyle defaultDumpStyle (vcat [ lint_banner "errors" (ppr pass), Err.pprMessageBag errs , text "*** Offending Program ***" , pprCoreBindings binds @@ -385,7 +385,7 @@ displayLintResults dflags pass warns errs binds -- If the Core linter encounters an error, output to stderr instead of -- stdout (#13342) = putLogMsg dflags NoReason Err.SevInfo noSrcSpan - defaultDumpStyle + $ withPprStyle defaultDumpStyle (lint_banner "warnings" (ppr pass) $$ Err.pprMessageBag (mapBag ($$ blankLine) warns)) | otherwise = return () @@ -416,7 +416,8 @@ lintInteractiveExpr what hsc_env expr display_lint_err err = do { putLogMsg dflags NoReason Err.SevDump - noSrcSpan defaultDumpStyle + noSrcSpan + $ withPprStyle defaultDumpStyle (vcat [ lint_banner "errors" (text what) , err , text "*** Offending Program ***" diff --git a/compiler/GHC/Core/Opt/Driver.hs b/compiler/GHC/Core/Opt/Driver.hs index 982f13be35..082eb9d326 100644 --- a/compiler/GHC/Core/Opt/Driver.hs +++ b/compiler/GHC/Core/Opt/Driver.hs @@ -495,7 +495,7 @@ ruleCheckPass current_phase pat guts = ; let rule_fn fn = getRules (RuleEnv rb vis_orphs) fn ++ (mg_rules guts) ; liftIO $ putLogMsg dflags NoReason Err.SevDump noSrcSpan - defaultDumpStyle + $ withPprStyle defaultDumpStyle (ruleCheckProgram current_phase pat rule_fn (mg_binds guts)) ; return guts } diff --git a/compiler/GHC/Core/Opt/Monad.hs b/compiler/GHC/Core/Opt/Monad.hs index 0db18b5790..0febfdb787 100644 --- a/compiler/GHC/Core/Opt/Monad.hs +++ b/compiler/GHC/Core/Opt/Monad.hs @@ -781,7 +781,7 @@ msg sev reason doc err_sty = mkErrStyle dflags unqual user_sty = mkUserStyle unqual AllTheWay dump_sty = mkDumpStyle unqual - ; liftIO $ putLogMsg dflags reason sev loc sty doc } + ; liftIO $ putLogMsg dflags reason sev loc (withPprStyle sty doc) } -- | Output a String message to the screen putMsgS :: String -> CoreM () diff --git a/compiler/GHC/Driver/CodeOutput.hs b/compiler/GHC/Driver/CodeOutput.hs index a733638934..0c77ffc477 100644 --- a/compiler/GHC/Driver/CodeOutput.hs +++ b/compiler/GHC/Driver/CodeOutput.hs @@ -86,8 +86,7 @@ codeOutput dflags this_mod filenm location foreign_stubs foreign_fps pkg_deps NoReason SevDump noSrcSpan - defaultDumpStyle - err + $ withPprStyle defaultDumpStyle err ; ghcExit dflags 1 } Nothing -> return () diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs index 874bd2b253..b76874eeab 100644 --- a/compiler/GHC/Driver/Make.hs +++ b/compiler/GHC/Driver/Make.hs @@ -907,7 +907,7 @@ checkStability hpt sccs all_home_mods = -- | Each module is given a unique 'LogQueue' to redirect compilation messages -- to. A 'Nothing' value contains the result of compilation, and denotes the -- end of the message queue. -data LogQueue = LogQueue !(IORef [Maybe (WarnReason, Severity, SrcSpan, PprStyle, MsgDoc)]) +data LogQueue = LogQueue !(IORef [Maybe (WarnReason, Severity, SrcSpan, MsgDoc)]) !(MVar ()) -- | The graph of modules to compile and their corresponding result 'MVar' and @@ -1126,7 +1126,7 @@ parUpsweep n_jobs mHscMessage old_hpt stable_mods cleanup sccs = do return (success_flag,ok_results) where - writeLogQueue :: LogQueue -> Maybe (WarnReason,Severity,SrcSpan,PprStyle,MsgDoc) -> IO () + writeLogQueue :: LogQueue -> Maybe (WarnReason,Severity,SrcSpan,MsgDoc) -> IO () writeLogQueue (LogQueue ref sem) msg = do atomicModifyIORef' ref $ \msgs -> (msg:msgs,()) _ <- tryPutMVar sem () @@ -1135,8 +1135,8 @@ parUpsweep n_jobs mHscMessage old_hpt stable_mods cleanup sccs = do -- The log_action callback that is used to synchronize messages from a -- worker thread. parLogAction :: LogQueue -> LogAction - parLogAction log_queue _dflags !reason !severity !srcSpan !style !msg = do - writeLogQueue log_queue (Just (reason,severity,srcSpan,style,msg)) + parLogAction log_queue _dflags !reason !severity !srcSpan !msg = do + writeLogQueue log_queue (Just (reason,severity,srcSpan,msg)) -- Print each message from the log_queue using the log_action from the -- session's DynFlags. @@ -1149,8 +1149,8 @@ parUpsweep n_jobs mHscMessage old_hpt stable_mods cleanup sccs = do print_loop [] = read_msgs print_loop (x:xs) = case x of - Just (reason,severity,srcSpan,style,msg) -> do - putLogMsg dflags reason severity srcSpan style msg + Just (reason,severity,srcSpan,msg) -> do + putLogMsg dflags reason severity srcSpan msg print_loop xs -- Exit the loop once we encounter the end marker. Nothing -> return () @@ -2653,8 +2653,8 @@ withDeferredDiagnostics f = do errors <- liftIO $ newIORef [] fatals <- liftIO $ newIORef [] - let deferDiagnostics _dflags !reason !severity !srcSpan !style !msg = do - let action = putLogMsg dflags reason severity srcSpan style msg + let deferDiagnostics _dflags !reason !severity !srcSpan !msg = do + let action = putLogMsg dflags reason severity srcSpan msg case severity of SevWarning -> atomicModifyIORef' warnings $ \i -> (action: i, ()) SevError -> atomicModifyIORef' errors $ \i -> (action: i, ()) diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs index 563af47e1f..5d9583fdb9 100644 --- a/compiler/GHC/Driver/Pipeline.hs +++ b/compiler/GHC/Driver/Pipeline.hs @@ -1913,7 +1913,7 @@ linkDynLibCheck dflags o_files dep_packages = do when (haveRtsOptsFlags dflags) $ do putLogMsg dflags NoReason SevInfo noSrcSpan - defaultUserStyle + $ withPprStyle defaultUserStyle (text "Warning: -rtsopts and -with-rtsopts have no effect with -shared." $$ text " Call hs_init_ghc() from your main() function to set these options.") diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs index 474c61b563..09a59eb14b 100644 --- a/compiler/GHC/Driver/Session.hs +++ b/compiler/GHC/Driver/Session.hs @@ -1508,7 +1508,6 @@ type LogAction = DynFlags -> WarnReason -> Severity -> SrcSpan - -> PprStyle -> MsgDoc -> IO () @@ -1519,10 +1518,10 @@ defaultFatalMessager = hPutStrLn stderr -- See Note [JSON Error Messages] -- jsonLogAction :: LogAction -jsonLogAction dflags reason severity srcSpan _style msg +jsonLogAction dflags reason severity srcSpan msg = do - defaultLogActionHPutStrDoc dflags stdout (doc $$ text "") - (mkCodeStyle CStyle) + defaultLogActionHPutStrDoc dflags stdout + (withPprStyle (mkCodeStyle CStyle) (doc $$ text "")) where doc = renderJSON $ JSObject [ ( "span", json srcSpan ) @@ -1533,13 +1532,13 @@ jsonLogAction dflags reason severity srcSpan _style msg defaultLogAction :: LogAction -defaultLogAction dflags reason severity srcSpan style msg +defaultLogAction dflags reason severity srcSpan msg = case severity of - SevOutput -> printOut msg style - SevDump -> printOut (msg $$ blankLine) style - SevInteractive -> putStrSDoc msg style - SevInfo -> printErrs msg style - SevFatal -> printErrs msg style + SevOutput -> printOut msg + SevDump -> printOut (msg $$ blankLine) + SevInteractive -> putStrSDoc msg + SevInfo -> printErrs msg + SevFatal -> printErrs msg SevWarning -> printWarns SevError -> printWarns where @@ -1555,8 +1554,9 @@ defaultLogAction dflags reason severity srcSpan style msg if gopt Opt_DiagnosticsShowCaret dflags then getCaretDiagnostic severity srcSpan else pure empty - printErrs (message $+$ caretDiagnostic) - (setStyleColoured True style) + printErrs $ getPprStyle $ \style -> + withPprStyle (setStyleColoured True style) + (message $+$ caretDiagnostic) -- careful (#2302): printErrs prints in UTF-8, -- whereas converting to string first and using -- hPutStr would just emit the low 8 bits of @@ -1584,16 +1584,16 @@ defaultLogAction dflags reason severity srcSpan style msg | otherwise = "" -- | Like 'defaultLogActionHPutStrDoc' but appends an extra newline. -defaultLogActionHPrintDoc :: DynFlags -> Handle -> SDoc -> PprStyle -> IO () -defaultLogActionHPrintDoc dflags h d sty - = defaultLogActionHPutStrDoc dflags h (d $$ text "") sty +defaultLogActionHPrintDoc :: DynFlags -> Handle -> SDoc -> IO () +defaultLogActionHPrintDoc dflags h d + = defaultLogActionHPutStrDoc dflags h (d $$ text "") -defaultLogActionHPutStrDoc :: DynFlags -> Handle -> SDoc -> PprStyle -> IO () -defaultLogActionHPutStrDoc dflags h d sty +defaultLogActionHPutStrDoc :: DynFlags -> Handle -> SDoc -> IO () +defaultLogActionHPutStrDoc dflags h d -- Don't add a newline at the end, so that successive -- calls to this log-action can output all on the same line = printSDoc ctx Pretty.PageMode h d - where ctx = initSDocContext dflags sty + where ctx = initSDocContext dflags defaultDumpStyle newtype FlushOut = FlushOut (IO ()) @@ -2171,8 +2171,7 @@ parseDynamicFlagsFull activeFlags cmdline dflags0 args = do return (dflags5, leftover, warns' ++ warns) -- | Write an error or warning to the 'LogOutput'. -putLogMsg :: DynFlags -> WarnReason -> Severity -> SrcSpan -> PprStyle - -> MsgDoc -> IO () +putLogMsg :: DynFlags -> WarnReason -> Severity -> SrcSpan -> MsgDoc -> IO () putLogMsg dflags = log_action dflags dflags updateWays :: DynFlags -> DynFlags diff --git a/compiler/GHC/Iface/Binary.hs b/compiler/GHC/Iface/Binary.hs index 49e3b00e50..a14cb17e04 100644 --- a/compiler/GHC/Iface/Binary.hs +++ b/compiler/GHC/Iface/Binary.hs @@ -101,8 +101,7 @@ readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu = do NoReason SevOutput noSrcSpan - defaultDumpStyle - sd + $ withPprStyle defaultDumpStyle sd QuietBinIFaceReading -> \_ -> return () wantedGot :: String -> a -> a -> (a -> SDoc) -> IO () diff --git a/compiler/GHC/Iface/Load.hs b/compiler/GHC/Iface/Load.hs index b66bab1853..80c4505c8e 100644 --- a/compiler/GHC/Iface/Load.hs +++ b/compiler/GHC/Iface/Load.hs @@ -1117,7 +1117,7 @@ showIface hsc_env filename = do neverQualifyModules neverQualifyPackages putLogMsg dflags NoReason SevDump noSrcSpan - (mkDumpStyle print_unqual) (pprModIface iface) + $ withPprStyle (mkDumpStyle print_unqual) (pprModIface iface) -- Show a ModIface but don't display details; suitable for ModIfaces stored in -- the EPT. diff --git a/compiler/GHC/Runtime/Debugger.hs b/compiler/GHC/Runtime/Debugger.hs index 511293ba5c..7ea450067e 100644 --- a/compiler/GHC/Runtime/Debugger.hs +++ b/compiler/GHC/Runtime/Debugger.hs @@ -177,7 +177,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 = "Prelude.return (Prelude.show " ++ showPpr dflags bname ++ ") :: Prelude.IO Prelude.String" diff --git a/compiler/GHC/Runtime/Linker.hs b/compiler/GHC/Runtime/Linker.hs index a5ba2e6ef0..2ac1fc12d2 100644 --- a/compiler/GHC/Runtime/Linker.hs +++ b/compiler/GHC/Runtime/Linker.hs @@ -237,7 +237,7 @@ showLinkerState :: DynLinker -> DynFlags -> IO () showLinkerState dl dflags = do pls <- readPLS dl putLogMsg dflags NoReason SevDump noSrcSpan - defaultDumpStyle + $ withPprStyle defaultDumpStyle (vcat [text "----- Linker state -----", text "Pkgs:" <+> ppr (pkgs_loaded pls), text "Objs:" <+> ppr (objs_loaded pls), @@ -420,7 +420,7 @@ classifyLdInput dflags f | isDynLibFilename platform f = return (Just (DLLPath f)) | otherwise = do putLogMsg dflags NoReason SevInfo noSrcSpan - defaultUserStyle + $ withPprStyle defaultUserStyle (text ("Warning: ignoring unrecognised input `" ++ f ++ "'")) return Nothing where platform = targetPlatform dflags @@ -1414,7 +1414,7 @@ load_dyn hsc_env crash_early dll = do when (wopt Opt_WarnMissedExtraSharedLib dflags) $ putLogMsg dflags (Reason Opt_WarnMissedExtraSharedLib) SevWarning - noSrcSpan defaultUserStyle (note err) + noSrcSpan $ withPprStyle defaultUserStyle (note err) where note err = vcat $ map text [ err @@ -1715,8 +1715,7 @@ maybePutStr dflags s NoReason SevInteractive noSrcSpan - defaultUserStyle - (text s) + $ withPprStyle defaultUserStyle (text s) maybePutStrLn :: DynFlags -> String -> IO () maybePutStrLn dflags s = maybePutStr dflags (s ++ "\n") diff --git a/compiler/GHC/Stg/Lint.hs b/compiler/GHC/Stg/Lint.hs index 80ca8768f3..34fc1a141e 100644 --- a/compiler/GHC/Stg/Lint.hs +++ b/compiler/GHC/Stg/Lint.hs @@ -75,7 +75,7 @@ lintStgTopBindings dflags this_mod unarised whodunnit binds return () Just msg -> do putLogMsg dflags NoReason Err.SevDump noSrcSpan - defaultDumpStyle + $ withPprStyle defaultDumpStyle (vcat [ text "*** Stg Lint ErrMsgs: in" <+> text whodunnit <+> text "***", msg, diff --git a/compiler/GHC/SysTools/ExtraObj.hs b/compiler/GHC/SysTools/ExtraObj.hs index 3d12158b5c..46081df98c 100644 --- a/compiler/GHC/SysTools/ExtraObj.hs +++ b/compiler/GHC/SysTools/ExtraObj.hs @@ -77,7 +77,7 @@ mkExtraObjToLinkIntoBinary :: DynFlags -> IO FilePath mkExtraObjToLinkIntoBinary dflags = do when (gopt Opt_NoHsMain dflags && haveRtsOptsFlags dflags) $ do putLogMsg dflags NoReason SevInfo noSrcSpan - defaultUserStyle + $ withPprStyle defaultUserStyle (text "Warning: -rtsopts and -with-rtsopts have no effect with -no-hs-main." $$ text " Call hs_init_ghc() from your main() function to set these options.") diff --git a/compiler/GHC/SysTools/Process.hs b/compiler/GHC/SysTools/Process.hs index 5482a4ef25..a7649ed534 100644 --- a/compiler/GHC/SysTools/Process.hs +++ b/compiler/GHC/SysTools/Process.hs @@ -282,11 +282,11 @@ builderMainLoop dflags filter_fn pgm real_args mb_cwd mb_env = do case msg of BuildMsg msg -> do putLogMsg dflags NoReason SevInfo noSrcSpan - defaultUserStyle msg + $ withPprStyle defaultUserStyle msg log_loop chan t BuildError loc msg -> do putLogMsg dflags NoReason SevError (mkSrcSpan loc loc) - defaultUserStyle msg + $ withPprStyle defaultUserStyle msg log_loop chan t EOF -> log_loop chan (t-1) diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs index 6e21326f62..12716509f5 100644 --- a/compiler/GHC/Tc/Utils/Monad.hs +++ b/compiler/GHC/Tc/Utils/Monad.hs @@ -1902,7 +1902,7 @@ failIfM msg ; let full_msg = (if_loc env <> colon) $$ nest 2 msg ; dflags <- getDynFlags ; liftIO (putLogMsg dflags NoReason SevFatal - noSrcSpan (defaultErrStyle dflags) full_msg) + noSrcSpan $ withPprStyle (defaultErrStyle dflags) full_msg) ; failM } -------------------- @@ -1938,8 +1938,7 @@ forkM_maybe doc thing_inside NoReason SevFatal noSrcSpan - (defaultErrStyle dflags) - msg + $ withPprStyle (defaultErrStyle dflags) msg ; traceIf (text "} ending fork (badly)" <+> doc) ; return Nothing } diff --git a/compiler/GHC/Utils/Error.hs b/compiler/GHC/Utils/Error.hs index ed12d0104e..96f1e11f3a 100644 --- a/compiler/GHC/Utils/Error.hs +++ b/compiler/GHC/Utils/Error.hs @@ -379,7 +379,7 @@ printBagOfErrors :: DynFlags -> Bag ErrMsg -> IO () printBagOfErrors dflags bag_of_errors = sequence_ [ let style = mkErrStyle dflags unqual ctx = initSDocContext dflags style - in putLogMsg dflags reason sev s style (formatErrDoc ctx doc) + in putLogMsg dflags reason sev s $ withPprStyle style (formatErrDoc ctx doc) | ErrMsg { errMsgSpan = s, errMsgDoc = doc, errMsgSeverity = sev, @@ -441,8 +441,8 @@ dumpIfSet dflags flag hdr doc NoReason SevDump noSrcSpan - defaultDumpStyle - (mkDumpDoc hdr doc) + (withPprStyle defaultDumpStyle + (mkDumpDoc hdr doc)) -- | a wrapper around 'dumpAction'. -- First check whether the dump flag is set @@ -523,14 +523,14 @@ dumpSDocWithStyle sty dflags dumpOpt hdr doc = $$ blankLine $$ doc return $ mkDumpDoc hdr d - defaultLogActionHPrintDoc dflags handle doc' sty + defaultLogActionHPrintDoc dflags handle (withPprStyle sty doc') -- write the dump to stdout writeDump Nothing = do let (doc', severity) | null hdr = (doc, SevOutput) | otherwise = (mkDumpDoc hdr doc, SevDump) - putLogMsg dflags NoReason severity noSrcSpan sty doc' + putLogMsg dflags NoReason severity noSrcSpan (withPprStyle sty doc') -- | Choose where to put a dump file based on DynFlags @@ -610,15 +610,15 @@ ifVerbose dflags val act errorMsg :: DynFlags -> MsgDoc -> IO () errorMsg dflags msg - = putLogMsg dflags NoReason SevError noSrcSpan (defaultErrStyle dflags) msg + = putLogMsg dflags NoReason SevError noSrcSpan $ withPprStyle (defaultErrStyle dflags) msg warningMsg :: DynFlags -> MsgDoc -> IO () warningMsg dflags msg - = putLogMsg dflags NoReason SevWarning noSrcSpan (defaultErrStyle dflags) msg + = putLogMsg dflags NoReason SevWarning noSrcSpan $ withPprStyle (defaultErrStyle dflags) msg fatalErrorMsg :: DynFlags -> MsgDoc -> IO () fatalErrorMsg dflags msg = - putLogMsg dflags NoReason SevFatal noSrcSpan (defaultErrStyle dflags) msg + putLogMsg dflags NoReason SevFatal noSrcSpan $ withPprStyle (defaultErrStyle dflags) msg fatalErrorMsg'' :: FatalMessager -> String -> IO () fatalErrorMsg'' fm msg = fm msg @@ -627,12 +627,12 @@ compilationProgressMsg :: DynFlags -> String -> IO () compilationProgressMsg dflags msg = do traceEventIO $ "GHC progress: " ++ msg ifVerbose dflags 1 $ - logOutput dflags defaultUserStyle (text msg) + logOutput dflags $ withPprStyle defaultUserStyle (text msg) showPass :: DynFlags -> String -> IO () showPass dflags what = ifVerbose dflags 2 $ - logInfo dflags defaultUserStyle (text "***" <+> text what <> colon) + logInfo dflags $ withPprStyle defaultUserStyle (text "***" <+> text what <> colon) data PrintTimings = PrintTimings | DontPrintTimings deriving (Eq, Show) @@ -727,7 +727,7 @@ withTiming' :: MonadIO m withTiming' dflags what force_result prtimings action = do if verbosity dflags >= 2 || dopt Opt_D_dump_timings dflags then do whenPrintTimings $ - logInfo dflags defaultUserStyle $ + logInfo dflags $ withPprStyle defaultUserStyle $ text "***" <+> what <> colon let ctx = initDefaultSDocContext dflags eventBegins ctx what @@ -743,7 +743,7 @@ withTiming' dflags what force_result prtimings action time = realToFrac (end - start) * 1e-9 when (verbosity dflags >= 2 && prtimings == PrintTimings) - $ liftIO $ logInfo dflags defaultUserStyle + $ liftIO $ logInfo dflags $ withPprStyle defaultUserStyle (text "!!!" <+> what <> colon <+> text "finished in" <+> doublePrec 2 time <+> text "milliseconds" @@ -774,27 +774,29 @@ withTiming' dflags what force_result prtimings action eventEndsDoc ctx w = showSDocOneLine ctx $ text "GHC:finished:" <+> w debugTraceMsg :: DynFlags -> Int -> MsgDoc -> IO () -debugTraceMsg dflags val msg = ifVerbose dflags val $ - logInfo dflags defaultDumpStyle msg +debugTraceMsg dflags val msg = + ifVerbose dflags val $ + logInfo dflags (withPprStyle defaultDumpStyle msg) + putMsg :: DynFlags -> MsgDoc -> IO () -putMsg dflags msg = logInfo dflags defaultUserStyle msg +putMsg dflags msg = logInfo dflags (withPprStyle defaultUserStyle msg) printInfoForUser :: DynFlags -> PrintUnqualified -> MsgDoc -> IO () printInfoForUser dflags print_unqual msg - = logInfo dflags (mkUserStyle print_unqual AllTheWay) msg + = logInfo dflags (withUserStyle print_unqual AllTheWay msg) printOutputForUser :: DynFlags -> PrintUnqualified -> MsgDoc -> IO () printOutputForUser dflags print_unqual msg - = logOutput dflags (mkUserStyle print_unqual AllTheWay) msg + = logOutput dflags (withUserStyle print_unqual AllTheWay msg) -logInfo :: DynFlags -> PprStyle -> MsgDoc -> IO () -logInfo dflags sty msg - = putLogMsg dflags NoReason SevInfo noSrcSpan sty msg +logInfo :: DynFlags -> MsgDoc -> IO () +logInfo dflags msg + = putLogMsg dflags NoReason SevInfo noSrcSpan msg -logOutput :: DynFlags -> PprStyle -> MsgDoc -> IO () --- ^ Like 'logInfo' but with 'SevOutput' rather then 'SevInfo' -logOutput dflags sty msg - = putLogMsg dflags NoReason SevOutput noSrcSpan sty msg +-- | Like 'logInfo' but with 'SevOutput' rather then 'SevInfo' +logOutput :: DynFlags -> MsgDoc -> IO () +logOutput dflags msg + = putLogMsg dflags NoReason SevOutput noSrcSpan msg prettyPrintGhcErrors :: ExceptionMonad m => DynFlags -> m a -> m a prettyPrintGhcErrors dflags diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs index 4eafcbd1d1..a7246344e8 100644 --- a/ghc/GHCi/UI.hs +++ b/ghc/GHCi/UI.hs @@ -556,8 +556,8 @@ resetLastErrorLocations = do ghciLogAction :: LogAction -> IORef [(FastString, Int)] -> LogAction ghciLogAction old_log_action lastErrLocations - dflags flag severity srcSpan style msg = do - old_log_action dflags flag severity srcSpan style msg + dflags flag severity srcSpan msg = do + old_log_action dflags flag severity srcSpan msg case severity of SevError -> case srcSpan of RealSrcSpan rsp _ -> modifyIORef lastErrLocations diff --git a/testsuite/tests/ghc-api/T7478/T7478.hs b/testsuite/tests/ghc-api/T7478/T7478.hs index ae8bb82e88..383b1ebd93 100644 --- a/testsuite/tests/ghc-api/T7478/T7478.hs +++ b/testsuite/tests/ghc-api/T7478/T7478.hs @@ -41,9 +41,9 @@ compileInGhc targets handlerOutput = do TargetFile file Nothing -> file _ -> error "fileFromTarget: not a known target" - collectSrcError handlerOutput flags _ SevOutput _srcspan style msg - = handlerOutput $ GHC.showSDocForUser flags (queryQual style) msg - collectSrcError _ _ _ _ _ _ _ + collectSrcError handlerOutput flags _ SevOutput _srcspan msg + = handlerOutput $ GHC.showSDocForUser flags alwaysQualify msg + collectSrcError _ _ _ _ _ _ = return () main :: IO () -- cgit v1.2.1