Add -fdefer-diagnostics to defer and group diagnostic messages in make-mode

When loading many modules in parallel there can a lot of warnings and
errors get mixed up with regular output. When the compilation fails,
the relevant error message can be thousands of lines backward and is
hard to find. When the compilation successes, warning message is likely
to be ignored as it is not seen. We can address this by deferring the
warning and error message after the compilation. We also put errors
after warnings so it is more visible.

This idea was originally proposed by Bartosz Nitka in
https://phabricator.haskell.org/D4219.

10 files changed, 105 insertions, 2 deletions

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 78be688ec3..28d8bf8eed 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -582,6 +582,7 @@ data GeneralFlag
    -- output style opts
    | Opt_ErrorSpans -- Include full span info in error messages,
                     -- instead of just the start position.
+   | Opt_DeferDiagnostics
    | Opt_DiagnosticsShowCaret -- Show snippets of offending code
    | Opt_PprCaseAsLet
    | Opt_PprShowTicks
@@ -4101,6 +4102,7 @@ fFlagsDeps = [
   flagSpec "stg-cse"                          Opt_StgCSE,
   flagSpec "stg-lift-lams"                    Opt_StgLiftLams,
   flagSpec "cpr-anal"                         Opt_CprAnal,
+  flagSpec "defer-diagnostics"                Opt_DeferDiagnostics,
   flagSpec "defer-type-errors"                Opt_DeferTypeErrors,
   flagSpec "defer-typed-holes"                Opt_DeferTypedHoles,
   flagSpec "defer-out-of-scope-variables"     Opt_DeferOutOfScopeVariables,
diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs
index ae27d4e7fe..85925b3ef9 100644
--- a/compiler/main/GhcMake.hs
+++ b/compiler/main/GhcMake.hs
@@ -395,8 +395,8 @@ load' how_much mHscMessage mod_graph = do
                    | otherwise  = upsweep
 
     setSession hsc_env{ hsc_HPT = emptyHomePackageTable }
-    (upsweep_ok, modsUpswept)
-       <- upsweep_fn mHscMessage pruned_hpt stable_mods cleanup mg
+    (upsweep_ok, modsUpswept) <- withDeferredDiagnostics $
+      upsweep_fn mHscMessage pruned_hpt stable_mods cleanup mg
 
     -- Make modsDone be the summaries for each home module now
     -- available; this should equal the domain of hpt3.
@@ -2457,6 +2457,41 @@ preprocessFile hsc_env src_fn mb_phase (Just (buf, _time))
 --                      Error messages
 -----------------------------------------------------------------------------
 
+-- Defer and group warning, error and fatal messages so they will not get lost
+-- in the regular output.
+withDeferredDiagnostics :: GhcMonad m => m a -> m a
+withDeferredDiagnostics f = do
+  dflags <- getDynFlags
+  if not $ gopt Opt_DeferDiagnostics dflags
+  then f
+  else do
+    warnings <- liftIO $ newIORef []
+    errors <- liftIO $ newIORef []
+    fatals <- liftIO $ newIORef []
+
+    let deferDiagnostics _dflags !reason !severity !srcSpan !style !msg = do
+          let action = putLogMsg dflags reason severity srcSpan style msg
+          case severity of
+            SevWarning -> atomicModifyIORef' warnings $ \i -> (action: i, ())
+            SevError -> atomicModifyIORef' errors $ \i -> (action: i, ())
+            SevFatal -> atomicModifyIORef' fatals $ \i -> (action: i, ())
+            _ -> action
+
+        printDeferredDiagnostics = liftIO $
+          forM_ [warnings, errors, fatals] $ \ref -> do
+            -- This IORef can leak when the dflags leaks, so let us always
+            -- reset the content.
+            actions <- atomicModifyIORef' ref $ \i -> ([], i)
+            sequence_ $ reverse actions
+
+        setLogAction action = modifySession $ \hsc_env ->
+          hsc_env{ hsc_dflags = (hsc_dflags hsc_env){ log_action = action } }
+
+    gbracket
+      (setLogAction deferDiagnostics)
+      (\_ -> setLogAction (log_action dflags) >> printDeferredDiagnostics)
+      (\_ -> f)
+
 noModError :: DynFlags -> SrcSpan -> ModuleName -> FindResult -> ErrMsg
 -- ToDo: we don't have a proper line number for this error
 noModError dflags loc wanted_mod err
diff --git a/docs/users_guide/using.rst b/docs/users_guide/using.rst
index 83eeb51eed..d11dedfb9a 100644
--- a/docs/users_guide/using.rst
+++ b/docs/users_guide/using.rst
@@ -931,6 +931,18 @@ messages and in GHCi:
                   in a’
         or by using the flag -fno-warn-unused-do-bind
 
+.. ghc-flag:: -fdefer-diagnostics
+    :shortdesc: Defer and group diagnostic messages by severity
+    :type: dynamic
+    :category: verbosity
+
+    Causes GHC to group diagnostic messages by severity and output them after
+    other messages when building a multi-module Haskell program. This flag can
+    make diagnostic messages more visible when used in conjunction with
+    :ghc-flag:`--make` and :ghc-flag:`-j[⟨n⟩]`. Otherwise, it can be hard to
+    find the relevant errors or likely to ignore the warnings when they are
+    mixed with many other messages.
+
 .. ghc-flag:: -fdiagnostics-color=⟨always|auto|never⟩
     :shortdesc: Use colors in error messages
     :type: dynamic
diff --git a/testsuite/tests/ghci/prog018/A.hs b/testsuite/tests/ghci/prog018/A.hs
new file mode 100644
index 0000000000..aebfa35614
--- /dev/null
+++ b/testsuite/tests/ghci/prog018/A.hs
@@ -0,0 +1,8 @@
+{-# OPTIONS_GHC -Wincomplete-patterns -Wunused-matches #-}
+module A where
+
+incompletePattern :: Int -> Int
+incompletePattern 0 = 0
+
+unusedMatches :: Int -> Int
+unusedMatches x = 0
diff --git a/testsuite/tests/ghci/prog018/B.hs b/testsuite/tests/ghci/prog018/B.hs
new file mode 100644
index 0000000000..ebfdd6d733
--- /dev/null
+++ b/testsuite/tests/ghci/prog018/B.hs
@@ -0,0 +1,7 @@
+{-# OPTIONS_GHC -Wunused-imports #-}
+module B
+  ( module A
+  ) where
+
+import A
+import Data.List
diff --git a/testsuite/tests/ghci/prog018/C.hs b/testsuite/tests/ghci/prog018/C.hs
new file mode 100644
index 0000000000..c722f9554c
--- /dev/null
+++ b/testsuite/tests/ghci/prog018/C.hs
@@ -0,0 +1,6 @@
+module C where
+
+import B
+
+foo :: ()
+foo = variableNotInScope
diff --git a/testsuite/tests/ghci/prog018/Makefile b/testsuite/tests/ghci/prog018/Makefile
new file mode 100644
index 0000000000..9101fbd40a
--- /dev/null
+++ b/testsuite/tests/ghci/prog018/Makefile
@@ -0,0 +1,3 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
diff --git a/testsuite/tests/ghci/prog018/prog018.T b/testsuite/tests/ghci/prog018/prog018.T
new file mode 100644
index 0000000000..0d9e7813a6
--- /dev/null
+++ b/testsuite/tests/ghci/prog018/prog018.T
@@ -0,0 +1,3 @@
+# testcase for warning and error messages from :load
+test('prog018', [combined_output, extra_files(['A.hs', 'B.hs', 'C.hs'])],
+    ghci_script, ['prog018.script'])
diff --git a/testsuite/tests/ghci/prog018/prog018.script b/testsuite/tests/ghci/prog018/prog018.script
new file mode 100644
index 0000000000..108a84de04
--- /dev/null
+++ b/testsuite/tests/ghci/prog018/prog018.script
@@ -0,0 +1,4 @@
+:set -fdefer-diagnostics
+:set -v1
+:load C.hs
+:reload
diff --git a/testsuite/tests/ghci/prog018/prog018.stdout b/testsuite/tests/ghci/prog018/prog018.stdout
new file mode 100644
index 0000000000..daa722e436
--- /dev/null
+++ b/testsuite/tests/ghci/prog018/prog018.stdout
@@ -0,0 +1,23 @@
+[1 of 3] Compiling A                ( A.hs, interpreted )
+[2 of 3] Compiling B                ( B.hs, interpreted )
+[3 of 3] Compiling C                ( C.hs, interpreted )
+
+A.hs:5:1: warning: [-Wincomplete-patterns (in -Wextra)]
+    Pattern match(es) are non-exhaustive
+    In an equation for ‘incompletePattern’:
+        Patterns not matched: p where p is not one of {0}
+
+A.hs:8:15: warning: [-Wunused-matches (in -Wextra)]
+    Defined but not used: ‘x’
+
+B.hs:7:1: warning: [-Wunused-imports (in -Wextra)]
+    The import of ‘Data.List’ is redundant
+      except perhaps to import instances from ‘Data.List’
+    To import instances alone, use: import Data.List()
+
+C.hs:6:7: error: Variable not in scope: variableNotInScope :: ()
+Failed, two modules loaded.
+[3 of 3] Compiling C                ( C.hs, interpreted )
+
+C.hs:6:7: error: Variable not in scope: variableNotInScope :: ()
+Failed, two modules loaded.