Introduce putLogMsg
authorBen Gamari <bgamari.foss@gmail.com>
Wed, 15 Mar 2017 13:29:24 +0000 (09:29 -0400)
committerBen Gamari <ben@smart-cactus.org>
Wed, 15 Mar 2017 19:23:34 +0000 (15:23 -0400)
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

15 files changed:
compiler/coreSyn/CoreLint.hs
compiler/deSugar/Coverage.hs
compiler/ghci/Linker.hs
compiler/iface/BinIface.hs
compiler/iface/LoadIface.hs
compiler/main/DriverPipeline.hs
compiler/main/DynFlags.hs
compiler/main/ErrUtils.hs
compiler/main/GhcMake.hs
compiler/main/SysTools.hs
compiler/main/TidyPgm.hs
compiler/simplCore/CoreMonad.hs
compiler/simplCore/SimplCore.hs
compiler/simplStg/SimplStg.hs
compiler/typecheck/TcRnMonad.hs

index fb86242..40386e4 100644 (file)
@@ -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
index d42b6b0..f4fb42c 100644 (file)
@@ -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)
index 390d914..c9b0eff 100644 (file)
@@ -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")
index 60f0447..f658d7f 100644 (file)
@@ -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 =
index a3f7761..b1a3ef1 100644 (file)
@@ -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
index 1549722..c4918cc 100644 (file)
@@ -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.")
index 0ef6d5d..f80f9a7 100644 (file)
@@ -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
index 8e71847..a9310c6 100644 (file)
@@ -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
index b518518..3912ac5 100644 (file)
@@ -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 ()
index 9a9f899..1b567e9 100644 (file)
@@ -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 ->
index 26cee48..21d0208 100644 (file)
@@ -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
index 209d0f8..c689eea 100644 (file)
@@ -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 ()
index 34f49ad..72e2795 100644 (file)
@@ -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))
index ed04327..4943f52 100644 (file)
@@ -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
index 0e5e07d..3404ce7 100644 (file)
@@ -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 }