Commit b3df9e78 authored by Sylvain Henry's avatar Sylvain Henry Committed by Marge Bot
Browse files

Remove PprStyle param of logging actions

Use `withPprStyle` instead to apply a specific style to a SDoc.
parent f8386c7b
......@@ -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
......
......@@ -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 ***"
......
......@@ -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 }
......
......@@ -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 ()
......
......@@ -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 ()
......
......@@ -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, ())
......
......@@ -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.")
......
......@@ -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
......
......@@ -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 ()
......
......@@ -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.
......
......@@ -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"
......
......@@ -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")
......@@ -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,
......
......@@ -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.")
......
......@@ -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)
......
......@@ -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 }
......
......@@ -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
......
......@@ -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
......
......@@ -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 ()
......
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