Skip to content

Commit

Permalink
Fix 'cabal clean' on Windows for build-type: Custom'.
Browse files Browse the repository at this point in the history
Fixes #1863.
  • Loading branch information
23Skidoo committed Oct 30, 2014
1 parent 3c1728c commit 9261093
Show file tree
Hide file tree
Showing 4 changed files with 76 additions and 10 deletions.
1 change: 1 addition & 0 deletions cabal-install/Distribution/Client/Configure.hs
Original file line number Diff line number Diff line change
Expand Up @@ -127,6 +127,7 @@ configure verbosity packageDBs repos comp platform conf
(configDistPref configFlags),
useLoggingHandle = Nothing,
useWorkingDir = Nothing,
useWin32CleanHack = False,
forceExternalSetupMethod = False,
setupCacheLock = Nothing
}
Expand Down
1 change: 1 addition & 0 deletions cabal-install/Distribution/Client/Install.hs
Original file line number Diff line number Diff line change
Expand Up @@ -1028,6 +1028,7 @@ performInstallations verbosity
useLoggingHandle = Nothing,
useWorkingDir = Nothing,
forceExternalSetupMethod = parallelInstall,
useWin32CleanHack = False,
setupCacheLock = Just lock
}
reportingLevel = fromFlag (installBuildReports installFlags)
Expand Down
68 changes: 60 additions & 8 deletions cabal-install/Distribution/Client/SetupWrapper.hs
Original file line number Diff line number Diff line change
@@ -1,3 +1,4 @@
{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Client.SetupWrapper
Expand Down Expand Up @@ -97,6 +98,16 @@ import Data.Maybe ( fromMaybe, isJust )
import Data.Monoid ( mempty )
import Data.Char ( isSpace )

#ifdef mingw32_HOST_OS
import Distribution.Simple.Utils
( withTempDirectory )

import Control.Exception ( bracket )
import System.FilePath ( equalFilePath, takeDirectory )
import System.Directory ( doesDirectoryExist )
import qualified System.Win32 as Win32
#endif

data SetupScriptOptions = SetupScriptOptions {
useCabalVersion :: VersionRange,
useCompiler :: Maybe Compiler,
Expand All @@ -109,6 +120,12 @@ data SetupScriptOptions = SetupScriptOptions {
useWorkingDir :: Maybe FilePath,
forceExternalSetupMethod :: Bool,

-- On Windows, running './dist/setup/setup clean' doesn't work because the
-- setup script will try to delete itself. So we have to move the setup exe
-- out of the way first and then delete it manually. This applies only to
-- the external setup method.
useWin32CleanHack :: Bool,

-- Used only when calling setupWrapper from parallel code to serialise
-- access to the setup cache; should be Nothing otherwise.
--
Expand All @@ -135,6 +152,7 @@ defaultSetupScriptOptions = SetupScriptOptions {
useDistPref = defaultDistPref,
useLoggingHandle = Nothing,
useWorkingDir = Nothing,
useWin32CleanHack = False,
forceExternalSetupMethod = False,
setupCacheLock = Nothing
}
Expand Down Expand Up @@ -491,12 +509,46 @@ externalSetupMethod verbosity options pkg bt mkargs = do
-- working directory.
path' <- tryCanonicalizePath path

searchpath <- programSearchPathAsPATHVar
(getProgramSearchPath (useProgramConfig options'))
env <- getEffectiveEnvironment [("PATH", Just searchpath)]
#if mingw32_HOST_OS
setupProgFile' <- tryCanonicalizePath setupProgFile
let win32CleanHackNeeded = (useWin32CleanHack options')
-- Skip when a cached setup script is used.
&& setupProgFile' `equalFilePath` path'
if win32CleanHackNeeded then doWin32CleanHack path' else doInvoke path'
#else
doInvoke path'
#endif

process <- runProcess path' args
(useWorkingDir options') env
Nothing (useLoggingHandle options') (useLoggingHandle options')
exitCode <- waitForProcess process
unless (exitCode == ExitSuccess) $ exitWith exitCode
where
doInvoke path' = do
searchpath <- programSearchPathAsPATHVar
(getProgramSearchPath (useProgramConfig options'))
env <- getEffectiveEnvironment [("PATH", Just searchpath)]

process <- runProcess path' args
(useWorkingDir options') env Nothing
(useLoggingHandle options') (useLoggingHandle options')
exitCode <- waitForProcess process
unless (exitCode == ExitSuccess) $ exitWith exitCode

#if mingw32_HOST_OS
doWin32CleanHack path' = do
info verbosity $ "Using the Win32 clean hack."
-- Recursively removes the temp dir on exit.
withTempDirectory verbosity workingDir "cabal-tmp" $ \tmpDir ->
bracket (moveOutOfTheWay tmpDir path')
(maybeRestore path')
doInvoke

moveOutOfTheWay tmpDir path' = do
let newPath = tmpDir </> "setup" <.> exeExtension
Win32.moveFile path' newPath
return newPath

maybeRestore oldPath path' = do
let oldPathDir = takeDirectory oldPath
oldPathDirExists <- doesDirectoryExist oldPathDir
-- 'setup clean' didn't complete, 'dist/setup' still exists.
when oldPathDirExists $
Win32.moveFile path' oldPath
#endif
16 changes: 14 additions & 2 deletions cabal-install/Main.hs
Original file line number Diff line number Diff line change
Expand Up @@ -236,10 +236,9 @@ mainWorker args = topHandler $
,haddockCommand `commandAddAction` haddockAction
,execCommand `commandAddAction` execAction
,userConfigCommand `commandAddAction` userConfigAction
,cleanCommand `commandAddAction` cleanAction
,wrapperAction copyCommand
copyVerbosity copyDistPref
,wrapperAction cleanCommand
cleanVerbosity cleanDistPref
,wrapperAction hscolourCommand
hscolourVerbosity hscolourDistPref
,wrapperAction registerCommand
Expand Down Expand Up @@ -804,6 +803,19 @@ haddockAction haddockFlags extraArgs globalFlags = do
setupWrapper verbosity setupScriptOptions Nothing
haddockCommand (const haddockFlags') extraArgs

cleanAction :: CleanFlags -> [String] -> GlobalFlags -> IO ()
cleanAction cleanFlags extraArgs _globalFlags =
setupWrapper verbosity setupScriptOptions Nothing
cleanCommand (const cleanFlags) extraArgs
where
verbosity = fromFlagOrDefault normal (cleanVerbosity cleanFlags)
setupScriptOptions = defaultSetupScriptOptions {
useDistPref = fromFlagOrDefault
(useDistPref defaultSetupScriptOptions)
(cleanDistPref cleanFlags),
useWin32CleanHack = True
}

listAction :: ListFlags -> [String] -> GlobalFlags -> IO ()
listAction listFlags extraArgs globalFlags = do
let verbosity = fromFlag (listVerbosity listFlags)
Expand Down

0 comments on commit 9261093

Please sign in to comment.