Commit 28b8ea72 authored by Mikhail Glushenkov's avatar Mikhail Glushenkov
Browse files

Merge pull request #1388 from 23Skidoo/with-temp-file-ex

Don't change the types of 'withTemp[File,Directory]' in 1.18.
parents a20fa9da 553c72b0
......@@ -1036,8 +1036,8 @@ checkForeignDeps pkg lbi verbosity = do
builds program args = do
tempDir <- getTemporaryDirectory
withTempFile False tempDir ".c" $ \cName cHnd ->
withTempFile False tempDir "" $ \oNname oHnd -> do
withTempFile tempDir ".c" $ \cName cHnd ->
withTempFile tempDir "" $ \oNname oHnd -> do
hPutStrLn cHnd program
hClose cHnd
hClose oHnd
......
......@@ -362,13 +362,13 @@ configureToolchain ghcProg ghcInfo =
configureLd' :: Verbosity -> ConfiguredProgram -> IO [ProgArg]
configureLd' verbosity ldProg = do
tempDir <- getTemporaryDirectory
ldx <- withTempFile False tempDir ".c" $ \testcfile testchnd ->
withTempFile False tempDir ".o" $ \testofile testohnd -> do
ldx <- withTempFile tempDir ".c" $ \testcfile testchnd ->
withTempFile tempDir ".o" $ \testofile testohnd -> do
hPutStrLn testchnd "int foo() { return 0; }"
hClose testchnd; hClose testohnd
rawSystemProgram verbosity ghcProg ["-c", testcfile,
"-o", testofile]
withTempFile False tempDir ".o" $ \testofile' testohnd' ->
withTempFile tempDir ".o" $ \testofile' testohnd' ->
do
hClose testohnd'
_ <- rawSystemProgramStdout verbosity ldProg
......
......@@ -94,8 +94,10 @@ import Distribution.InstalledPackageInfo
( InstalledPackageInfo )
import Distribution.Simple.Utils
( die, copyFileTo, warn, notice, intercalate, setupMessage
, createDirectoryIfMissingVerbose, withTempFile, copyFileVerbose
, withTempDirectory, matchFileGlob
, createDirectoryIfMissingVerbose
, TempFileOptions(..), defaultTempFileOptions
, withTempFileEx, copyFileVerbose
, withTempDirectoryEx, matchFileGlob
, findFileWithExtension, findFile )
import Distribution.Text
( display, simpleParse )
......@@ -212,24 +214,24 @@ haddock pkg_descr lbi suffixes flags = do
let
doExe com = case (compToExe com) of
Just exe -> do
withTempDirectory verbosity keepTempFiles (buildDir lbi) "tmp" $ \tmp -> do
withTempDirectoryEx verbosity tmpFileOpts (buildDir lbi) "tmp" $ \tmp -> do
let bi = buildInfo exe
exeArgs <- fromExecutable verbosity tmp lbi exe clbi htmlTemplate
exeArgs' <- prepareSources verbosity tmp
lbi isVersion2 bi (commonArgs `mappend` exeArgs)
runHaddock verbosity keepTempFiles confHaddock exeArgs'
runHaddock verbosity tmpFileOpts confHaddock exeArgs'
Nothing -> do
warn (fromFlag $ haddockVerbosity flags)
"Unsupported component, skipping..."
return ()
case comp of
CLib lib -> do
withTempDirectory verbosity keepTempFiles (buildDir lbi) "tmp" $ \tmp -> do
withTempDirectoryEx verbosity tmpFileOpts (buildDir lbi) "tmp" $ \tmp -> do
let bi = libBuildInfo lib
libArgs <- fromLibrary verbosity tmp lbi lib clbi htmlTemplate
libArgs' <- prepareSources verbosity tmp
lbi isVersion2 bi (commonArgs `mappend` libArgs)
runHaddock verbosity keepTempFiles confHaddock libArgs'
runHaddock verbosity tmpFileOpts confHaddock libArgs'
CExe _ -> when (flag haddockExecutables) $ doExe comp
CTest _ -> when (flag haddockTestSuites) $ doExe comp
CBench _ -> when (flag haddockBenchmarks) $ doExe comp
......@@ -240,6 +242,7 @@ haddock pkg_descr lbi suffixes flags = do
where
verbosity = flag haddockVerbosity
keepTempFiles = flag haddockKeepTempFiles
tmpFileOpts = defaultTempFileOptions { optKeepTempFiles = keepTempFiles }
flag f = fromFlag $ f flags
htmlTemplate = fmap toPathTemplate . flagToMaybe . haddockHtmlLocation $ flags
......@@ -439,11 +442,15 @@ getGhcLibDir verbosity lbi isVersion2
----------------------------------------------------------------------------------------------
-- | Call haddock with the specified arguments.
runHaddock :: Verbosity -> Bool -> ConfiguredProgram -> HaddockArgs -> IO ()
runHaddock verbosity keepTempFiles confHaddock args = do
runHaddock :: Verbosity
-> TempFileOptions
-> ConfiguredProgram
-> HaddockArgs
-> IO ()
runHaddock verbosity tmpFileOpts confHaddock args = do
let haddockVersion = fromMaybe (error "unable to determine haddock version")
(programVersion confHaddock)
renderArgs verbosity keepTempFiles haddockVersion args $ \(flags,result)-> do
renderArgs verbosity tmpFileOpts haddockVersion args $ \(flags,result)-> do
rawSystemProgram verbosity confHaddock flags
......@@ -451,14 +458,14 @@ runHaddock verbosity keepTempFiles confHaddock args = do
renderArgs :: Verbosity
-> Bool
-> TempFileOptions
-> Version
-> HaddockArgs
-> (([String], FilePath) -> IO a)
-> IO a
renderArgs verbosity keepTempFiles version args k = do
renderArgs verbosity tmpFileOpts version args k = do
createDirectoryIfMissingVerbose verbosity True outputDir
withTempFile keepTempFiles outputDir "haddock-prolog.txt" $ \prologFileName h -> do
withTempFileEx tmpFileOpts outputDir "haddock-prolog.txt" $ \prologFileName h -> do
do
hPutStrLn h $ fromFlag $ argPrologue args
hClose h
......
......@@ -204,13 +204,13 @@ configureToolchain lhcProg =
configureLd :: Verbosity -> ConfiguredProgram -> IO [ProgArg]
configureLd verbosity ldProg = do
tempDir <- getTemporaryDirectory
ldx <- withTempFile False tempDir ".c" $ \testcfile testchnd ->
withTempFile False tempDir ".o" $ \testofile testohnd -> do
ldx <- withTempFile tempDir ".c" $ \testcfile testchnd ->
withTempFile tempDir ".o" $ \testofile testohnd -> do
hPutStrLn testchnd "int foo() { return 0; }"
hClose testchnd; hClose testohnd
rawSystemProgram verbosity lhcProg ["-c", testcfile,
"-o", testofile]
withTempFile False tempDir ".o" $ \testofile' testohnd' ->
withTempFile tempDir ".o" $ \testofile' testohnd' ->
do
hClose testohnd'
_ <- rawSystemProgramStdout verbosity ldProg
......
......@@ -147,7 +147,7 @@ sdist pkg mb_lbi flags mkTmpDir pps =
Nothing -> do
createDirectoryIfMissingVerbose verbosity True tmpTargetDir
withTempDirectory verbosity False tmpTargetDir "sdist." $ \tmpDir -> do
withTempDirectory verbosity tmpTargetDir "sdist." $ \tmpDir -> do
let targetDir = tmpDir </> tarBallName pkg'
generateSourceDir targetDir pkg'
targzFile <- createArchive verbosity pkg' mb_lbi tmpDir targetPref
......
......@@ -109,8 +109,9 @@ module Distribution.Simple.Utils (
FileGlob(..),
-- * temp files and dirs
withTempFile,
withTempDirectory,
TempFileOptions(..), defaultTempFileOptions,
withTempFile, withTempFileEx,
withTempDirectory, withTempDirectoryEx,
-- * .cabal and .buildinfo files
defaultPackageDesc,
......@@ -906,17 +907,33 @@ copyDirectoryRecursiveVerbose verbosity srcDir destDir = do
---------------------------
-- Temporary files and dirs
-- | Advanced options for 'withTempFile' and 'withTempDirectory'.
data TempFileOptions = TempFileOptions {
optKeepTempFiles :: Bool -- ^ Keep temporary files?
}
defaultTempFileOptions :: TempFileOptions
defaultTempFileOptions = TempFileOptions { optKeepTempFiles = False }
-- | Use a temporary filename that doesn't already exist.
--
withTempFile :: Bool -- ^ Keep temporary files?
-> FilePath -- ^ Temp dir to create the file in
-> String -- ^ File name template. See 'openTempFile'.
-> (FilePath -> Handle -> IO a) -> IO a
withTempFile keepTempFiles tmpDir template action =
withTempFile :: FilePath -- ^ Temp dir to create the file in
-> String -- ^ File name template. See 'openTempFile'.
-> (FilePath -> Handle -> IO a) -> IO a
withTempFile tmpDir template action =
withTempFileEx defaultTempFileOptions tmpDir template action
-- | A version of 'withTempFile' that additionally takes a 'TempFileOptions'
-- argument.
withTempFileEx :: TempFileOptions
-> FilePath -- ^ Temp dir to create the file in
-> String -- ^ File name template. See 'openTempFile'.
-> (FilePath -> Handle -> IO a) -> IO a
withTempFileEx opts tmpDir template action =
Exception.bracket
(openTempFile tmpDir template)
(\(name, handle) -> do hClose handle
unless keepTempFiles $ removeFile name)
unless (optKeepTempFiles opts) $ removeFile name)
(uncurry action)
-- | Create and use a temporary directory.
......@@ -930,12 +947,19 @@ withTempFile keepTempFiles tmpDir template action =
-- @src/sdist.342@.
--
withTempDirectory :: Verbosity
-> Bool -- ^ Keep temporary files?
-> FilePath -> String -> (FilePath -> IO a) -> IO a
withTempDirectory _verbosity keepTempFiles targetDir template =
-> FilePath -> String -> (FilePath -> IO a) -> IO a
withTempDirectory verbosity targetDir template =
withTempDirectoryEx verbosity defaultTempFileOptions targetDir template
-- | A version of 'withTempDirectory' that additionally takes a
-- 'TempFileOptions' argument.
withTempDirectoryEx :: Verbosity
-> TempFileOptions
-> FilePath -> String -> (FilePath -> IO a) -> IO a
withTempDirectoryEx _verbosity opts targetDir template =
Exception.bracket
(createTempDirectory targetDir template)
(unless keepTempFiles . removeDirectoryRecursive)
(unless (optKeepTempFiles opts) . removeDirectoryRecursive)
-----------------------------------
-- Safely reading and writing files
......
......@@ -51,7 +51,7 @@ regenerateHaddockIndex verbosity pkgs conf index = do
createDirectoryIfMissing True destDir
withTempDirectory verbosity False destDir "tmphaddock" $ \tempDir -> do
withTempDirectory verbosity destDir "tmphaddock" $ \tempDir -> do
let flags = [ "--gen-contents"
, "--gen-index"
......
......@@ -1112,7 +1112,7 @@ installLocalTarballPackage
-> IO BuildResult
installLocalTarballPackage verbosity jobLimit pkgid tarballPath installPkg = do
tmp <- getTemporaryDirectory
withTempDirectory verbosity False tmp (display pkgid) $ \tmpDirPath ->
withTempDirectory verbosity tmp (display pkgid) $ \tmpDirPath ->
onFailure UnpackFailed $ do
let relUnpackedPath = display pkgid
absUnpackedPath = tmpDirPath </> relUnpackedPath
......
......@@ -45,7 +45,7 @@ sdist flags exflags = do
=<< readPackageDescription verbosity
=<< defaultPackageDesc verbosity
let withDir = if not needMakeArchive then (\f -> f tmpTargetDir)
else withTempDirectory verbosity False tmpTargetDir "sdist."
else withTempDirectory verbosity tmpTargetDir "sdist."
-- 'withTempDir' fails if we don't create 'tmpTargetDir'...
when needMakeArchive $
createDirectoryIfMissingVerbose verbosity True tmpTargetDir
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment