Skip to content

Commit

Permalink
Fix haddock compilation with in-library calls
Browse files Browse the repository at this point in the history
`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.
  • Loading branch information
alt-romes committed Nov 5, 2024
1 parent 8e4fc80 commit 24de4e0
Showing 1 changed file with 34 additions and 29 deletions.
63 changes: 34 additions & 29 deletions Cabal/src/Distribution/Simple/Haddock.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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)

-- ------------------------------------------------------------------------------

Expand Down Expand Up @@ -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
Expand Down

0 comments on commit 24de4e0

Please sign in to comment.