Commit 086b514b authored by Ben Gamari's avatar Ben Gamari Committed by Ben Gamari

Introduce putLogMsg

This factors out the repetition of (log_action dflags dflags) and will
hopefully allow us to someday better abstract log output.

Test Plan: Validate

Reviewers: austin, hvr, goldfire

Subscribers: rwbarton, thomie

Differential Revision: https://phabricator.haskell.org/D3334
parent cc9d574a
......@@ -307,7 +307,7 @@ displayLintResults :: DynFlags -> CoreToDo
-> IO ()
displayLintResults dflags pass warns errs binds
| not (isEmptyBag errs)
= do { log_action dflags dflags NoReason Err.SevDump noSrcSpan
= do { putLogMsg dflags NoReason Err.SevDump noSrcSpan
(defaultDumpStyle dflags)
(vcat [ lint_banner "errors" (ppr pass), Err.pprMessageBag errs
, text "*** Offending Program ***"
......@@ -320,7 +320,7 @@ displayLintResults dflags pass warns errs binds
, showLintWarnings pass
-- If the Core linter encounters an error, output to stderr instead of
-- stdout (#13342)
= log_action dflags dflags NoReason Err.SevInfo noSrcSpan
= putLogMsg dflags NoReason Err.SevInfo noSrcSpan
(defaultDumpStyle dflags)
(lint_banner "warnings" (ppr pass) $$ Err.pprMessageBag (mapBag ($$ blankLine) warns))
......@@ -351,7 +351,7 @@ lintInteractiveExpr what hsc_env expr
dflags = hsc_dflags hsc_env
display_lint_err err
= do { log_action dflags dflags NoReason Err.SevDump
= do { putLogMsg dflags NoReason Err.SevDump
noSrcSpan (defaultDumpStyle dflags)
(vcat [ lint_banner "errors" (text what)
, err
......
......@@ -111,7 +111,7 @@ addTicksToBinds hsc_env mod mod_loc exports tyCons binds
modBreaks <- mkModBreaks hsc_env mod tickCount entries
when (dopt Opt_D_dump_ticked dflags) $
log_action dflags dflags NoReason SevDump noSrcSpan
putLogMsg dflags NoReason SevDump noSrcSpan
(defaultDumpStyle dflags) (pprLHsBinds binds1)
return (binds1, HpcInfo tickCount hashNo, Just modBreaks)
......
......@@ -243,7 +243,7 @@ withExtendedLinkEnv new_env action
showLinkerState :: DynFlags -> IO ()
showLinkerState dflags
= do pls <- readIORef v_PersistentLinkerState >>= readMVar
log_action dflags dflags NoReason SevDump noSrcSpan
putLogMsg dflags NoReason SevDump noSrcSpan
(defaultDumpStyle dflags)
(vcat [text "----- Linker state -----",
text "Pkgs:" <+> ppr (pkgs_loaded pls),
......@@ -397,7 +397,7 @@ classifyLdInput dflags f
| isObjectFilename platform f = return (Just (Object f))
| isDynLibFilename platform f = return (Just (DLLPath f))
| otherwise = do
log_action dflags dflags NoReason SevInfo noSrcSpan
putLogMsg dflags NoReason SevInfo noSrcSpan
(defaultUserStyle dflags)
(text ("Warning: ignoring unrecognised input `" ++ f ++ "'"))
return Nothing
......@@ -1464,13 +1464,12 @@ loadFramework hsc_env extraPaths rootname
maybePutStr :: DynFlags -> String -> IO ()
maybePutStr dflags s
= when (verbosity dflags > 1) $
do let act = log_action dflags
act dflags
NoReason
SevInteractive
noSrcSpan
(defaultUserStyle dflags)
(text s)
putLogMsg dflags
NoReason
SevInteractive
noSrcSpan
(defaultUserStyle dflags)
(text s)
maybePutStrLn :: DynFlags -> String -> IO ()
maybePutStrLn dflags s = maybePutStr dflags (s ++ "\n")
......@@ -76,13 +76,12 @@ readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu = do
let printer :: SDoc -> IO ()
printer = case traceBinIFaceReading of
TraceBinIFaceReading -> \sd ->
log_action dflags
dflags
NoReason
SevOutput
noSrcSpan
(defaultDumpStyle dflags)
sd
putLogMsg dflags
NoReason
SevOutput
noSrcSpan
(defaultDumpStyle dflags)
sd
QuietBinIFaceReading -> \_ -> return ()
wantedGot :: Outputable a => String -> a -> a -> IO ()
wantedGot what wanted got =
......
......@@ -996,7 +996,7 @@ showIface hsc_env filename = do
iface <- initTcRnIf 's' hsc_env () () $
readBinIface IgnoreHiWay TraceBinIFaceReading filename
let dflags = hsc_dflags hsc_env
log_action dflags dflags NoReason SevDump noSrcSpan
putLogMsg dflags NoReason SevDump noSrcSpan
(defaultDumpStyle dflags) (pprModIface iface)
-- Show a ModIface but don't display details; suitable for ModIfaces stored in
......
......@@ -1642,7 +1642,7 @@ mkExtraObj dflags extn xs
mkExtraObjToLinkIntoBinary :: DynFlags -> IO FilePath
mkExtraObjToLinkIntoBinary dflags = do
when (gopt Opt_NoHsMain dflags && haveRtsOptsFlags dflags) $ do
log_action dflags dflags NoReason SevInfo noSrcSpan
putLogMsg dflags NoReason SevInfo noSrcSpan
(defaultUserStyle dflags)
(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.")
......@@ -2057,7 +2057,7 @@ linkDynLibCheck :: DynFlags -> [String] -> [InstalledUnitId] -> IO ()
linkDynLibCheck dflags o_files dep_packages
= do
when (haveRtsOptsFlags dflags) $ do
log_action dflags dflags NoReason SevInfo noSrcSpan
putLogMsg dflags NoReason SevInfo noSrcSpan
(defaultUserStyle dflags)
(text "Warning: -rtsopts and -with-rtsopts have no effect with -shared." $$
text " Call hs_init_ghc() from your main() function to set these options.")
......
......@@ -64,6 +64,9 @@ module DynFlags (
thisPackage, thisComponentId, thisUnitIdInsts,
-- ** Log output
putLogMsg,
-- ** Safe Haskell
SafeHaskellMode(..),
safeHaskellOn, safeImportsOn, safeLanguageOn, safeInferOn,
......@@ -2406,6 +2409,10 @@ setLogAction dflags = do
})
mlogger
-- | Write an error or warning to the 'LogOutput'.
putLogMsg :: DynFlags -> WarnReason -> Severity -> SrcSpan -> PprStyle
-> MsgDoc -> IO ()
putLogMsg dflags = log_action dflags dflags
updateWays :: DynFlags -> DynFlags
updateWays dflags
......
......@@ -46,7 +46,7 @@ module ErrUtils (
putMsg, printInfoForUser, printOutputForUser,
logInfo, logOutput,
errorMsg, warningMsg,
fatalErrorMsg, fatalErrorMsg', fatalErrorMsg'',
fatalErrorMsg, fatalErrorMsg'',
compilationProgressMsg,
showPass, withTiming,
debugTraceMsg,
......@@ -347,7 +347,7 @@ errorsFound _dflags (_warns, errs) = not (isEmptyBag errs)
printBagOfErrors :: DynFlags -> Bag ErrMsg -> IO ()
printBagOfErrors dflags bag_of_errors
= sequence_ [ let style = mkErrStyle dflags unqual
in log_action dflags dflags reason sev s style (formatErrDoc dflags doc)
in putLogMsg dflags reason sev s style (formatErrDoc dflags doc)
| ErrMsg { errMsgSpan = s,
errMsgDoc = doc,
errMsgSeverity = sev,
......@@ -408,8 +408,7 @@ doIfSet_dyn dflags flag action | gopt flag dflags = action
dumpIfSet :: DynFlags -> Bool -> String -> SDoc -> IO ()
dumpIfSet dflags flag hdr doc
| not flag = return ()
| otherwise = log_action dflags
dflags
| otherwise = putLogMsg dflags
NoReason
SevDump
noSrcSpan
......@@ -490,7 +489,7 @@ dumpSDoc dflags print_unqual flag hdr doc
let (doc', severity)
| null hdr = (doc, SevOutput)
| otherwise = (mkDumpDoc hdr doc, SevDump)
log_action dflags dflags NoReason severity noSrcSpan dump_style doc'
putLogMsg dflags NoReason severity noSrcSpan dump_style doc'
-- | Choose where to put a dump file based on DynFlags
......@@ -547,18 +546,15 @@ ifVerbose dflags val act
errorMsg :: DynFlags -> MsgDoc -> IO ()
errorMsg dflags msg
= log_action dflags dflags NoReason SevError noSrcSpan (defaultErrStyle dflags) msg
= putLogMsg dflags NoReason SevError noSrcSpan (defaultErrStyle dflags) msg
warningMsg :: DynFlags -> MsgDoc -> IO ()
warningMsg dflags msg
= log_action dflags dflags NoReason SevWarning noSrcSpan (defaultErrStyle dflags) msg
= putLogMsg dflags NoReason SevWarning noSrcSpan (defaultErrStyle dflags) msg
fatalErrorMsg :: DynFlags -> MsgDoc -> IO ()
fatalErrorMsg dflags msg = fatalErrorMsg' (log_action dflags) dflags msg
fatalErrorMsg' :: LogAction -> DynFlags -> MsgDoc -> IO ()
fatalErrorMsg' la dflags msg =
la dflags NoReason SevFatal noSrcSpan (defaultErrStyle dflags) msg
fatalErrorMsg dflags msg =
putLogMsg dflags NoReason SevFatal noSrcSpan (defaultErrStyle dflags) msg
fatalErrorMsg'' :: FatalMessager -> String -> IO ()
fatalErrorMsg'' fm msg = fm msg
......@@ -642,12 +638,12 @@ printOutputForUser dflags print_unqual msg
logInfo :: DynFlags -> PprStyle -> MsgDoc -> IO ()
logInfo dflags sty msg
= log_action dflags dflags NoReason SevInfo noSrcSpan sty msg
= putLogMsg dflags NoReason SevInfo noSrcSpan sty msg
logOutput :: DynFlags -> PprStyle -> MsgDoc -> IO ()
-- ^ Like 'logInfo' but with 'SevOutput' rather then 'SevInfo'
logOutput dflags sty msg
= log_action dflags dflags NoReason SevOutput noSrcSpan sty msg
= putLogMsg dflags NoReason SevOutput noSrcSpan sty msg
prettyPrintGhcErrors :: ExceptionMonad m => DynFlags -> m a -> m a
prettyPrintGhcErrors dflags
......
......@@ -973,7 +973,7 @@ 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
log_action dflags dflags reason severity srcSpan style msg
putLogMsg dflags reason severity srcSpan style msg
print_loop xs
-- Exit the loop once we encounter the end marker.
Nothing -> return ()
......
......@@ -1353,11 +1353,11 @@ builderMainLoop dflags filter_fn pgm real_args mb_env = do
msg <- readChan chan
case msg of
BuildMsg msg -> do
log_action dflags dflags NoReason SevInfo noSrcSpan
putLogMsg dflags NoReason SevInfo noSrcSpan
(defaultUserStyle dflags) msg
loop chan hProcess t p exitcode
BuildError loc msg -> do
log_action dflags dflags NoReason SevError (mkSrcSpan loc loc)
putLogMsg dflags NoReason SevError (mkSrcSpan loc loc)
(defaultUserStyle dflags) msg
loop chan hProcess t p exitcode
EOF ->
......
......@@ -416,7 +416,7 @@ tidyProgram hsc_env (ModGuts { mg_module = mod
-- Print one-line size info
; let cs = coreBindsStats tidy_binds
; when (dopt Opt_D_dump_core_stats dflags)
(log_action dflags dflags NoReason SevDump noSrcSpan
(putLogMsg dflags NoReason SevDump noSrcSpan
(defaultDumpStyle dflags)
(text "Tidy size (terms,types,coercions)"
<+> ppr (moduleName mod) <> colon
......
......@@ -736,8 +736,7 @@ msg sev doc
err_sty = mkErrStyle dflags unqual
user_sty = mkUserStyle dflags unqual AllTheWay
dump_sty = mkDumpStyle dflags unqual
; liftIO $
(log_action dflags) dflags NoReason sev loc sty doc }
; liftIO $ putLogMsg dflags NoReason sev loc sty doc }
-- | Output a String message to the screen
putMsgS :: String -> CoreM ()
......
......@@ -519,7 +519,7 @@ ruleCheckPass current_phase pat guts =
{ rb <- getRuleBase
; dflags <- getDynFlags
; vis_orphs <- getVisibleOrphanMods
; liftIO $ log_action dflags dflags NoReason Err.SevDump noSrcSpan
; liftIO $ putLogMsg dflags NoReason Err.SevDump noSrcSpan
(defaultDumpStyle dflags)
(ruleCheckProgram current_phase pat
(RuleEnv rb vis_orphs) (mg_binds guts))
......
......@@ -38,7 +38,7 @@ stg2stg dflags module_name binds
; us <- mkSplitUniqSupply 'g'
; when (dopt Opt_D_verbose_stg2stg dflags)
(log_action dflags dflags NoReason SevDump noSrcSpan
(putLogMsg dflags NoReason SevDump noSrcSpan
(defaultDumpStyle dflags) (text "VERBOSE STG-TO-STG:"))
; (binds', us', ccs) <- end_pass us "Stg2Stg" ([],[],[]) binds
......
......@@ -1774,7 +1774,7 @@ failIfM msg
= do { env <- getLclEnv
; let full_msg = (if_loc env <> colon) $$ nest 2 msg
; dflags <- getDynFlags
; liftIO (log_action dflags dflags NoReason SevFatal
; liftIO (putLogMsg dflags NoReason SevFatal
noSrcSpan (defaultErrStyle dflags) full_msg)
; failM }
......@@ -1811,13 +1811,12 @@ forkM_maybe doc thing_inside
dflags <- getDynFlags
let msg = hang (text "forkM failed:" <+> doc)
2 (text (show exn))
liftIO $ log_action dflags
dflags
NoReason
SevFatal
noSrcSpan
(defaultErrStyle dflags)
msg
liftIO $ putLogMsg dflags
NoReason
SevFatal
noSrcSpan
(defaultErrStyle dflags)
msg
; traceIf (text "} ending fork (badly)" <+> doc)
; return Nothing }
......
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