Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Fix Setup.hs if c_tmpdir already exists but is invalid #537

Merged
merged 1 commit into from
Oct 9, 2023
Merged
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
29 changes: 24 additions & 5 deletions Setup.hs
Original file line number Diff line number Diff line change
@@ -1,4 +1,4 @@

{-# LANGUAGE MultiWayIf #-}
module Main where

import Distribution.Extra.Doctest
Expand Down Expand Up @@ -74,9 +74,21 @@ postBuildHook args build_flags pkg_desc lbi = do

setupMessage verbosity (printf "Building executable '%s' for" hs_exe) (package pkg_desc)

-- symlink the C build directory into the HS build directories
exists <- doesDirectoryExist c_tmpdir
unless exists $ createDirectoryLink ("../../../../.." </> hs_tmpdir) c_tmpdir
-- Symlink the C build directory into the HS build directories.
-- We need to take care here: the symlink might already exist but point
-- to a nonexistent path, in which case doesDirectoryExist returns False
-- but it is still a symlink.
whenM (pathIsSymbolicLinkSafe c_tmpdir) $ removeFile c_tmpdir
objExists <- doesPathExist c_tmpdir
objExistsDir <- doesDirectoryExist c_tmpdir
createdObjSymlink <-
if | objExists && not objExistsDir ->
dieNoVerbosity $ c_tmpdir ++ " is a file; remove this to continue compiling accelerate."
| objExistsDir ->
return False
| otherwise -> do
createDirectoryLink ("../../../../.." </> hs_tmpdir) c_tmpdir
return True

-- prevent having to re-link every time we build the library
executable <- doesFileExist (hs_builddir </> hs_exe)
Expand All @@ -89,7 +101,14 @@ postBuildHook args build_flags pkg_desc lbi = do
renameFile (c_builddir </> c_exe) (hs_builddir </> hs_exe)

-- clean up after ourselves
unless exists $ removeDirectoryLink c_tmpdir
when createdObjSymlink $ removeDirectoryLink c_tmpdir

postBuild simpleUserHooks args build_flags pkg_desc lbi

-- | Returns True if there is a symbolic link at the given path, False otherwise.
pathIsSymbolicLinkSafe :: FilePath -> IO Bool
pathIsSymbolicLinkSafe fp =
handleDoesNotExist False $ pathIsSymbolicLink fp

whenM :: IO Bool -> IO () -> IO ()
whenM mcond action = mcond >>= \cond -> when cond action
Loading