From 24de4e034560dcffb7c3b148144364e1ebad1aa0 Mon Sep 17 00:00:00 2001
From: Rodrigo Mesquita <rodrigo.m.mesquita@gmail.com>
Date: Tue, 5 Nov 2024 11:35:00 +0000
Subject: [PATCH] Fix haddock compilation with in-library calls

`reusingGHCCompilationArtifacts` assumed the existence of a build folder
where objects were written (even if empty), but with InLibrary calls
this is no longer necessarily true.

Previously, the build folder ended up always existing because the call
of `configure` through `Setup` created the folder.
However, now that we may call Cabal the library directly, the existence
of this directory is no longer guaranteed.

Easy fix: don't try to copy the build folder if it doesn't exist yet.
---
 Cabal/src/Distribution/Simple/Haddock.hs | 63 +++++++++++++-----------
 1 file changed, 34 insertions(+), 29 deletions(-)

diff --git a/Cabal/src/Distribution/Simple/Haddock.hs b/Cabal/src/Distribution/Simple/Haddock.hs
index d6147186cae..fb095fa500e 100644
--- a/Cabal/src/Distribution/Simple/Haddock.hs
+++ b/Cabal/src/Distribution/Simple/Haddock.hs
@@ -1058,24 +1058,29 @@ reusingGHCCompilationArtifacts
   -> ((SymbolicPath Pkg (Path.Dir Artifacts), SymbolicPath Pkg (Path.Dir Artifacts), SymbolicPath Pkg (Path.Dir Artifacts)) -> IO r)
   -- ^ Continuation
   -> IO r
-reusingGHCCompilationArtifacts verbosity tmpFileOpts mbWorkDir lbi bi clbi version act
-  | version >= mkVersion [2, 28, 0] = do
+reusingGHCCompilationArtifacts verbosity tmpFileOpts mbWorkDir lbi bi clbi version act = do
+  let
+    vanillaOpts = componentGhcOptions normal lbi bi clbi (buildDir lbi)
+    i = interpretSymbolicPath mbWorkDir
+    iopt ghcDir = i $ fromFlag $ ghcDir vanillaOpts
+    copyDir ghcDir tmpDir = copyDirectoryRecursive verbosity (iopt ghcDir) (i tmpDir)
+
+  buildDirsExs <- (&&) <$> doesDirectoryExist (iopt ghcOptObjDir) <*> doesDirectoryExist (iopt ghcOptHiDir)
+
+  if version >= mkVersion [2, 28, 0]
+    && buildDirsExs
+    then do
       withTempDirectoryCwdEx verbosity tmpFileOpts mbWorkDir (distPrefLBI lbi) "haddock-objs" $ \tmpObjDir ->
         withTempDirectoryCwdEx verbosity tmpFileOpts mbWorkDir (distPrefLBI lbi) "haddock-his" $ \tmpHiDir -> do
           -- Re-use ghc's interface and obj files, but first copy them to
           -- somewhere where it is safe if haddock overwrites them
-          let
-            vanillaOpts = componentGhcOptions normal lbi bi clbi (buildDir lbi)
-            i = interpretSymbolicPath mbWorkDir
-            copyDir ghcDir tmpDir = copyDirectoryRecursive verbosity (i $ fromFlag $ ghcDir vanillaOpts) (i tmpDir)
           copyDir ghcOptObjDir tmpObjDir
           copyDir ghcOptHiDir tmpHiDir
           -- copyDir ghcOptStubDir tmpStubDir -- (see W.1 in Note [Hi Haddock Recompilation Avoidance])
 
           act (tmpObjDir, tmpHiDir, fromFlag $ ghcOptHiDir vanillaOpts)
-  | otherwise = do
-      withTempDirectoryCwdEx verbosity tmpFileOpts mbWorkDir (distPrefLBI lbi) "tmp" $
-        \tmpFallback -> act (tmpFallback, tmpFallback, tmpFallback)
+    else withTempDirectoryCwdEx verbosity tmpFileOpts mbWorkDir (distPrefLBI lbi) "tmp" $
+      \tmpFallback -> act (tmpFallback, tmpFallback, tmpFallback)
 
 -- ------------------------------------------------------------------------------
 
@@ -1351,26 +1356,26 @@ haddockPackagePaths ipkgs mkHtmlPath = do
   interfaces <-
     sequenceA
       [ case interfaceAndHtmlPath ipkg of
-        Nothing -> do
-          return (Left (packageId ipkg))
-        Just (interface, html) -> do
-          (html', hypsrc') <-
-            case html of
-              Just htmlPath -> do
-                let hypSrcPath = htmlPath </> defaultHyperlinkedSourceDirectory
-                hypSrcExists <- doesDirectoryExist hypSrcPath
-                return $
-                  ( Just (fixFileUrl htmlPath)
-                  , if hypSrcExists
-                      then Just (fixFileUrl hypSrcPath)
-                      else Nothing
-                  )
-              Nothing -> return (Nothing, Nothing)
-
-          exists <- doesFileExist interface
-          if exists
-            then return (Right (interface, html', hypsrc', Visible))
-            else return (Left pkgid)
+          Nothing -> do
+            return (Left (packageId ipkg))
+          Just (interface, html) -> do
+            (html', hypsrc') <-
+              case html of
+                Just htmlPath -> do
+                  let hypSrcPath = htmlPath </> defaultHyperlinkedSourceDirectory
+                  hypSrcExists <- doesDirectoryExist hypSrcPath
+                  return $
+                    ( Just (fixFileUrl htmlPath)
+                    , if hypSrcExists
+                        then Just (fixFileUrl hypSrcPath)
+                        else Nothing
+                    )
+                Nothing -> return (Nothing, Nothing)
+
+            exists <- doesFileExist interface
+            if exists
+              then return (Right (interface, html', hypsrc', Visible))
+              else return (Left pkgid)
       | ipkg <- ipkgs
       , let pkgid = packageId ipkg
       , pkgName pkgid `notElem` noHaddockWhitelist