From a9f2c3b20cf6f42b6efe23d31b5d1d7ced6786d8 Mon Sep 17 00:00:00 2001
From: Rodrigo Mesquita <rodrigo.m.mesquita@gmail.com>
Date: Wed, 12 Jun 2024 11:51:12 +0100
Subject: [PATCH] Fix recomp bug by invalidating cache on build exception

Be sure to invalidate the cache if building throws an exception!
If not, we'll abort execution with a stale recompilation cache.
See ghc#24926 for an example of how this can go wrong.
---
 .../Client/ProjectBuilding/UnpackedPackage.hs |  6 +++-
 .../Recompilation/GHC24926/Repro.hs           |  6 ++++
 .../Recompilation/GHC24926/cabal.test.hs      | 36 +++++++++++++++++++
 .../Recompilation/GHC24926/repro.cabal        | 19 ++++++++++
 .../Recompilation/GHC24926/src/Process.hs     |  7 ++++
 5 files changed, 73 insertions(+), 1 deletion(-)
 create mode 100644 cabal-testsuite/PackageTests/Recompilation/GHC24926/Repro.hs
 create mode 100644 cabal-testsuite/PackageTests/Recompilation/GHC24926/cabal.test.hs
 create mode 100644 cabal-testsuite/PackageTests/Recompilation/GHC24926/repro.cabal
 create mode 100644 cabal-testsuite/PackageTests/Recompilation/GHC24926/src/Process.hs

diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs
index 7d9f34a8e8b..23dff3ff3ab 100644
--- a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs
+++ b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs
@@ -99,7 +99,7 @@ import qualified Data.ByteString.Lazy as LBS
 import qualified Data.ByteString.Lazy.Char8 as LBS.Char8
 import qualified Data.List.NonEmpty as NE
 
-import Control.Exception (ErrorCall, Handler (..), SomeAsyncException, assert, catches)
+import Control.Exception (ErrorCall, Handler (..), SomeAsyncException, assert, catches, onException)
 import System.Directory (canonicalizePath, createDirectoryIfMissing, doesDirectoryExist, doesFileExist, removeFile)
 import System.FilePath (dropDrive, normalise, takeDirectory, (<.>), (</>))
 import System.IO (Handle, IOMode (AppendMode), withFile)
@@ -480,6 +480,10 @@ buildInplaceUnpackedPackage
           whenRebuild $ do
             timestamp <- beginUpdateFileMonitor
             runBuild
+              -- Be sure to invalidate the cache if building throws an exception!
+              -- If not, we'll abort execution with a stale recompilation cache.
+              -- See ghc#24926 for an example of how this can go wrong.
+              `onException` invalidatePackageRegFileMonitor packageFileMonitor
 
             let listSimple =
                   execRebuild (getSymbolicPath srcdir) (needElaboratedConfiguredPackage pkg)
diff --git a/cabal-testsuite/PackageTests/Recompilation/GHC24926/Repro.hs b/cabal-testsuite/PackageTests/Recompilation/GHC24926/Repro.hs
new file mode 100644
index 00000000000..204872538ea
--- /dev/null
+++ b/cabal-testsuite/PackageTests/Recompilation/GHC24926/Repro.hs
@@ -0,0 +1,6 @@
+import Process (a)
+import Internal (Unused)
+
+main :: IO ()
+main = a
+
diff --git a/cabal-testsuite/PackageTests/Recompilation/GHC24926/cabal.test.hs b/cabal-testsuite/PackageTests/Recompilation/GHC24926/cabal.test.hs
new file mode 100644
index 00000000000..607426f381c
--- /dev/null
+++ b/cabal-testsuite/PackageTests/Recompilation/GHC24926/cabal.test.hs
@@ -0,0 +1,36 @@
+import Test.Cabal.Prelude
+
+-- See ghc#24926
+main = cabalTest $ do
+  recordMode DoNotRecord $ do
+
+    root <- testTmpDir <$> getTestEnv
+
+    writeInternalOrig root
+    cabal "test" []
+
+    liftIO $ writeFile (root ++ "/src/Internal.hs")
+      " module Internal where;\
+
+      \ data Unused = Unused;"
+    fails $ cabal "test" [] -- broken module on purpose
+
+    writeInternalOrig root
+    out <- cabal' "test" [] -- shouldn't fail!
+
+    assertOutputDoesNotContain
+      "<no location info>: error:" out
+    assertOutputDoesNotContain
+      "Cannot continue after interface file error" out
+
+  where
+
+    writeInternalOrig r = liftIO $ do
+      writeFile (r ++ "/src/Internal.hs")
+        " module Internal where;\
+
+        \ data Unused = Unused;\
+
+        \ b :: IO (); \
+        \ b = pure ();"
+
diff --git a/cabal-testsuite/PackageTests/Recompilation/GHC24926/repro.cabal b/cabal-testsuite/PackageTests/Recompilation/GHC24926/repro.cabal
new file mode 100644
index 00000000000..30ad3d92d13
--- /dev/null
+++ b/cabal-testsuite/PackageTests/Recompilation/GHC24926/repro.cabal
@@ -0,0 +1,19 @@
+cabal-version:      3.0
+name:               repro
+version:            0.1.0.0
+build-type:         Simple
+
+library
+  default-language: Haskell2010
+  exposed-modules:
+    Internal
+    Process
+  build-depends: base
+  hs-source-dirs: src
+
+test-suite repro
+  default-language: Haskell2010
+  type:          exitcode-stdio-1.0
+  main-is:       Repro.hs
+  build-depends: base, repro
+
diff --git a/cabal-testsuite/PackageTests/Recompilation/GHC24926/src/Process.hs b/cabal-testsuite/PackageTests/Recompilation/GHC24926/src/Process.hs
new file mode 100644
index 00000000000..919c5d46df5
--- /dev/null
+++ b/cabal-testsuite/PackageTests/Recompilation/GHC24926/src/Process.hs
@@ -0,0 +1,7 @@
+module Process where
+
+import Internal
+
+a :: IO ()
+a = b
+