Add -fkeep-going to make compiler continue despite errors (#15424)

Add a new optional failure handling for upsweep which continues
the compilation on other modules if any of them has errors.

15 files changed, 103 insertions, 3 deletions

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index c2d0322cd9..5bd8cb819f 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -653,6 +653,7 @@ data GeneralFlag
    -- response file and as such breaking apart.
    | Opt_SingleLibFolder
    | Opt_KeepCAFs
+   | Opt_KeepGoing
 
    -- output style opts
    | Opt_ErrorSpans -- Include full span info in error messages,
@@ -4206,6 +4207,7 @@ fFlagsDeps = [
   flagSpec "ignore-interface-pragmas"         Opt_IgnoreInterfacePragmas,
   flagGhciSpec "implicit-import-qualified"    Opt_ImplicitImportQualified,
   flagSpec "irrefutable-tuples"               Opt_IrrefutableTuples,
+  flagSpec "keep-going"                       Opt_KeepGoing,
   flagSpec "kill-absence"                     Opt_KillAbsence,
   flagSpec "kill-one-shot"                    Opt_KillOneShot,
   flagSpec "late-dmd-anal"                    Opt_LateDmdAnal,
diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs
index 81311c1e0c..6e44a86f28 100644
--- a/compiler/main/GhcMake.hs
+++ b/compiler/main/GhcMake.hs
@@ -1357,6 +1357,25 @@ upsweep mHscMessage old_hpt stable_mods cleanup sccs = do
  where
   done_holes = emptyUniqSet
 
+  keep_going this_mods old_hpt done mods mod_index nmods uids_to_check done_holes = do
+    let sum_deps ms (AcyclicSCC mod) =
+          if any (flip elem . map (unLoc . snd) $ ms_imps mod) ms
+            then ms_mod_name mod:ms
+            else ms
+        sum_deps ms _ = ms
+        dep_closure = foldl' sum_deps this_mods mods
+        dropped_ms = drop (length this_mods) (reverse dep_closure)
+        prunable (AcyclicSCC mod) = elem (ms_mod_name mod) dep_closure
+        prunable _ = False
+        mods' = filter (not . prunable) mods
+        nmods' = nmods - length dropped_ms
+
+    when (not $ null dropped_ms) $ do
+        dflags <- getSessionDynFlags
+        liftIO $ fatalErrorMsg dflags (keepGoingPruneErr dropped_ms)
+    (_, done') <- upsweep' old_hpt done mods' (mod_index+1) nmods' uids_to_check done_holes
+    return (Failed, done')
+
   upsweep'
     :: GhcMonad m
     => HomePackageTable
@@ -1374,10 +1393,13 @@ upsweep mHscMessage old_hpt stable_mods cleanup sccs = do
         return (Succeeded, done)
 
   upsweep' _old_hpt done
-     (CyclicSCC ms:_) _ _ _ _
+     (CyclicSCC ms:mods) mod_index nmods uids_to_check done_holes
    = do dflags <- getSessionDynFlags
         liftIO $ fatalErrorMsg dflags (cyclicModuleErr ms)
-        return (Failed, done)
+        if gopt Opt_KeepGoing dflags
+          then keep_going (map ms_mod_name ms) old_hpt done mods mod_index nmods
+                          uids_to_check done_holes
+          else return (Failed, done)
 
   upsweep' old_hpt done
      (AcyclicSCC mod:mods) mod_index nmods uids_to_check done_holes
@@ -1426,7 +1448,12 @@ upsweep mHscMessage old_hpt stable_mods cleanup sccs = do
                  return (Just mod_info)
 
         case mb_mod_info of
-          Nothing -> return (Failed, done)
+          Nothing -> do
+                dflags <- getSessionDynFlags
+                if gopt Opt_KeepGoing dflags
+                  then keep_going [ms_mod_name mod] old_hpt done mods mod_index nmods
+                                  uids_to_check done_holes
+                  else return (Failed, done)
           Just mod_info -> do
                 let this_mod = ms_mod_name mod
 
@@ -2652,6 +2679,12 @@ multiRootsErr dflags summs@(summ1:_)
     mod = ms_mod summ1
     files = map (expectJust "checkDup" . ml_hs_file . ms_location) summs
 
+keepGoingPruneErr :: [ModuleName] -> SDoc
+keepGoingPruneErr ms
+  = vcat (( text "-fkeep-going in use, removing the following" <+>
+            text "dependencies and continuing:"):
+          map (nest 6 . ppr) ms )
+
 cyclicModuleErr :: [ModSummary] -> SDoc
 -- From a strongly connected component we find
 -- a single cycle to report
diff --git a/docs/users_guide/8.10.1-notes.rst b/docs/users_guide/8.10.1-notes.rst
index 8d70c7b34c..2ca9ce5c08 100644
--- a/docs/users_guide/8.10.1-notes.rst
+++ b/docs/users_guide/8.10.1-notes.rst
@@ -119,6 +119,9 @@ Compiler
   the sample start event contains a timestamp of when the census occurred.
   The retainer profiling events are emitted using the standard events.
 
+- Add new flag :ghc-flag:`-fkeep-going` which makes the compiler
+  continue as far as it can despite errors.
+
 GHCi
 ~~~~
 
diff --git a/docs/users_guide/using.rst b/docs/users_guide/using.rst
index d1c453898f..8462a87cd8 100644
--- a/docs/users_guide/using.rst
+++ b/docs/users_guide/using.rst
@@ -1041,6 +1041,18 @@ messages and in GHCi:
     start at zero. This choice was made to follow existing convention
     (i.e. this is how Emacs does it).
 
+.. ghc-flag:: -fkeep-going
+    :shortdesc: Continue compilation as far as possible on errors
+    :type: dynamic
+    :category: verbosity
+
+    :since: 8.10.1
+
+    Causes GHC to continue the compilation if a module has an error.
+    Any reverse dependencies are pruned immediately and the whole
+    compilation is still flagged as an error.  This option has no
+    effect if parallel compilation (:ghc-flag:`-j[⟨n⟩]`) is in use.
+
 .. ghc-flag:: -freverse-errors
     :shortdesc: Output errors in reverse order
     :type: dynamic
diff --git a/testsuite/tests/ghci/prog019/A.hs b/testsuite/tests/ghci/prog019/A.hs
new file mode 100644
index 0000000000..4126fd03c3
--- /dev/null
+++ b/testsuite/tests/ghci/prog019/A.hs
@@ -0,0 +1,8 @@
+-- Test for #15424
+
+module A where
+
+import B
+import C
+import D
+import E
diff --git a/testsuite/tests/ghci/prog019/B.hs b/testsuite/tests/ghci/prog019/B.hs
new file mode 100644
index 0000000000..96a9cd4009
--- /dev/null
+++ b/testsuite/tests/ghci/prog019/B.hs
@@ -0,0 +1,3 @@
+module B where
+
+import B1
diff --git a/testsuite/tests/ghci/prog019/B1.hs b/testsuite/tests/ghci/prog019/B1.hs
new file mode 100644
index 0000000000..093c3b3ab0
--- /dev/null
+++ b/testsuite/tests/ghci/prog019/B1.hs
@@ -0,0 +1,3 @@
+module B1 where
+
+import B2
diff --git a/testsuite/tests/ghci/prog019/B2.hs b/testsuite/tests/ghci/prog019/B2.hs
new file mode 100644
index 0000000000..ad504c35ee
--- /dev/null
+++ b/testsuite/tests/ghci/prog019/B2.hs
@@ -0,0 +1,3 @@
+module B2 where
+
+asdf
diff --git a/testsuite/tests/ghci/prog019/C.hs b/testsuite/tests/ghci/prog019/C.hs
new file mode 100644
index 0000000000..695cb14e18
--- /dev/null
+++ b/testsuite/tests/ghci/prog019/C.hs
@@ -0,0 +1,4 @@
+module C where
+
+foo :: Int
+foo = 1
diff --git a/testsuite/tests/ghci/prog019/D.hs b/testsuite/tests/ghci/prog019/D.hs
new file mode 100644
index 0000000000..4edf1e1f97
--- /dev/null
+++ b/testsuite/tests/ghci/prog019/D.hs
@@ -0,0 +1,3 @@
+module D where
+
+roses are red
diff --git a/testsuite/tests/ghci/prog019/E.hs b/testsuite/tests/ghci/prog019/E.hs
new file mode 100644
index 0000000000..114aeb9831
--- /dev/null
+++ b/testsuite/tests/ghci/prog019/E.hs
@@ -0,0 +1,4 @@
+module E where
+
+bar :: String
+bar = "abc"
diff --git a/testsuite/tests/ghci/prog019/prog019.T b/testsuite/tests/ghci/prog019/prog019.T
new file mode 100644
index 0000000000..e5bc51f6ad
--- /dev/null
+++ b/testsuite/tests/ghci/prog019/prog019.T
@@ -0,0 +1,4 @@
+test('prog019',
+     [extra_hc_opts('-fkeep-going'),
+      extra_files(['A.hs', 'B.hs', 'B1.hs', 'B2.hs', 'C.hs', 'D.hs', 'E.hs'])],
+     ghci_script, ['prog019.script'])
diff --git a/testsuite/tests/ghci/prog019/prog019.script b/testsuite/tests/ghci/prog019/prog019.script
new file mode 100644
index 0000000000..e4fcd34d4a
--- /dev/null
+++ b/testsuite/tests/ghci/prog019/prog019.script
@@ -0,0 +1,4 @@
+:load A
+bar
+:module C
+foo
diff --git a/testsuite/tests/ghci/prog019/prog019.stderr b/testsuite/tests/ghci/prog019/prog019.stderr
new file mode 100644
index 0000000000..b915e3d049
--- /dev/null
+++ b/testsuite/tests/ghci/prog019/prog019.stderr
@@ -0,0 +1,12 @@
+
+B2.hs:3:1: error:
+    Parse error: module header, import declaration
+    or top-level declaration expected.
+-fkeep-going in use, removing the following dependencies and continuing:
+      B1
+      B
+      A
+
+D.hs:3:1: error:
+    Parse error: module header, import declaration
+    or top-level declaration expected.
diff --git a/testsuite/tests/ghci/prog019/prog019.stdout b/testsuite/tests/ghci/prog019/prog019.stdout
new file mode 100644
index 0000000000..64d63622e0
--- /dev/null
+++ b/testsuite/tests/ghci/prog019/prog019.stdout
@@ -0,0 +1,2 @@
+"abc"
+1