ww

Author: jasagredo

Cabal-syntax/src/Distribution/Utils/Generic.hs

@@ -100,12 +100,14 @@ import qualified Data.Set as Set
 
 import qualified Control.Exception as Exception
 import System.Directory
-  ( getTemporaryDirectory
+  ( copyFile
+  , getTemporaryDirectory
   , removeFile
   , renameFile
   )
 import System.FilePath
-  ( splitFileName
+  ( takeFileName
+  , takeDrive
   , (<.>)
   )
 import System.IO
@@ -172,15 +174,17 @@ withFileContents name action =
 -- This case will give an IO exception but the atomic property is not affected.
 writeFileAtomic :: FilePath -> LBS.ByteString -> IO ()
 writeFileAtomic targetPath content = do
-  let (_, targetFile) = splitFileName targetPath
+  let targetFile = takeFileName targetPath
   tmpDir <- getTemporaryDirectory
   Exception.bracketOnError
     (openBinaryTempFileWithDefaultPermissions tmpDir $ targetFile <.> "tmp")
     (\(tmpPath, handle) -> hClose handle >> removeFile tmpPath)
     ( \(tmpPath, handle) -> do
         LBS.hPut handle content
         hClose handle
-        renameFile tmpPath targetPath
+        if takeDrive targetPath == takeDrive tmpDir
+          then renameFile tmpPath targetPath
+          else copyFile tmpPath targetPath >> removeFile tmpPath
     )
 
 -- ------------------------------------------------------------

Cabal-tests/tests/UnitTests/Distribution/Simple/Utils.hs

@@ -23,16 +23,14 @@ import Test.Tasty.HUnit
 withTempFileTest :: Assertion
 withTempFileTest = do
   fileName <- newIORef ""
-  tempDir  <- getTemporaryDirectory
-  withTempFile tempDir ".foo" $ \fileName' _handle -> do
+  withTempFile ".foo" $ \fileName' _handle -> do
     writeIORef fileName fileName'
   fileExists <- readIORef fileName >>= doesFileExist
   assertBool "Temporary file not deleted by 'withTempFile'!" (not fileExists)
 
 withTempFileRemovedTest :: Assertion
 withTempFileRemovedTest = do
-  tempDir <- getTemporaryDirectory
-  withTempFile tempDir ".foo" $ \fileName handle -> do
+  withTempFile ".foo" $ \fileName handle -> do
     hClose handle
     removeFile fileName
 
@@ -58,9 +56,8 @@ rawSystemStdInOutTextDecodingTest ghcPath
     -- so skip the test if it's not.
     | show localeEncoding /= "UTF-8" = return ()
     | otherwise = do
-  tempDir  <- getTemporaryDirectory
-  res <- withTempFile tempDir ".hs" $ \filenameHs handleHs -> do
-    withTempFile tempDir ".exe" $ \filenameExe handleExe -> do
+  res <- withTempFile ".hs" $ \filenameHs handleHs -> do
+    withTempFile ".exe" $ \filenameExe handleExe -> do
       -- Small program printing not utf8
       hPutStrLn handleHs "import Data.ByteString"
       hPutStrLn handleHs "main = Data.ByteString.putStr (Data.ByteString.pack [32, 32, 255])"

Cabal/src/Distribution/Simple/Configure.hs

@@ -154,7 +154,6 @@ import System.Directory
   ( canonicalizePath
   , createDirectoryIfMissing
   , doesFileExist
-  , getTemporaryDirectory
   , removeFile
   )
 import System.FilePath
@@ -2674,10 +2673,8 @@ checkForeignDeps pkg lbi verbosity =
 
     builds :: String -> [ProgArg] -> IO Bool
     builds program args =
-      do
-        tempDir <- makeSymbolicPath <$> getTemporaryDirectory
-        withTempFileCwd mbWorkDir tempDir ".c" $ \cName cHnd ->
-          withTempFileCwd mbWorkDir tempDir "" $ \oNname oHnd -> do
+        withTempFileCwd ".c" $ \cName cHnd ->
+          withTempFileCwd "" $ \oNname oHnd -> do
             hPutStrLn cHnd program
             hClose cHnd
             hClose oHnd

Cabal/src/Distribution/Simple/GHC/Internal.hs

@@ -85,7 +85,7 @@ import Distribution.Utils.Path
 import Distribution.Verbosity
 import Distribution.Version (Version)
 import Language.Haskell.Extension
-import System.Directory (getDirectoryContents, getTemporaryDirectory)
+import System.Directory (getDirectoryContents)
 import System.Environment (getEnv)
 import System.FilePath
   ( takeDirectory
@@ -221,9 +221,8 @@ configureToolchain _implInfo ghcProg ghcInfo =
     -- we need to find out if ld supports the -x flag
     configureLd' :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram
     configureLd' verbosity ldProg = do
-      tempDir <- getTemporaryDirectory
-      ldx <- withTempFile tempDir ".c" $ \testcfile testchnd ->
-        withTempFile tempDir ".o" $ \testofile testohnd -> do
+      ldx <- withTempFile ".c" $ \testcfile testchnd ->
+        withTempFile ".o" $ \testofile testohnd -> do
           hPutStrLn testchnd "int foo() { return 0; }"
           hClose testchnd
           hClose testohnd
@@ -236,7 +235,7 @@ configureToolchain _implInfo ghcProg ghcInfo =
             , "-o"
             , testofile
             ]
-          withTempFile tempDir ".o" $ \testofile' testohnd' ->
+          withTempFile ".o" $ \testofile' testohnd' ->
             do
               hClose testohnd'
               _ <-

Cabal/src/Distribution/Simple/Haddock.hs

@@ -1133,8 +1133,6 @@ renderArgs verbosity mbWorkDir tmpFileOpts version comp platform args k = do
                 withResponseFile
                   verbosity
                   tmpFileOpts
-                  mbWorkDir
-                  outputDir
                   "haddock-response.txt"
                   (if haddockSupportsUTF8 then Just utf8 else Nothing)
                   renderedArgs
@@ -1144,7 +1142,7 @@ renderArgs verbosity mbWorkDir tmpFileOpts version comp platform args k = do
     (Flag pfile, _) ->
       withPrologueArgs ["--prologue=" ++ pfile]
     (_, Flag prologueText) ->
-      withTempFileEx tmpFileOpts mbWorkDir outputDir "haddock-prologue.txt" $
+      withTempFileEx tmpFileOpts "haddock-prologue.txt" $
         \prologueFileName h -> do
           when haddockSupportsUTF8 (hSetEncoding h utf8)
           hPutStrLn h prologueText

Cabal/src/Distribution/Simple/PreProcess.hs

@@ -511,8 +511,6 @@ ppHsc2hs bi lbi clbi =
             withResponseFile
               verbosity
               defaultTempFileOptions
-              mbWorkDir
-              (makeSymbolicPath $ takeDirectory outFile)
               "hsc2hs-response.txt"
               Nothing
               pureArgs

Cabal/src/Distribution/Simple/Program/Ar.hs

@@ -154,7 +154,7 @@ createArLibArchive verbosity lbi targetPath files = do
                 (initial, middle, final)
                 (map getSymbolicPath files)
           ]
-      else withResponseFile verbosity defaultTempFileOptions mbWorkDir tmpDir "ar.rsp" Nothing (map getSymbolicPath files) $
+      else withResponseFile verbosity defaultTempFileOptions "ar.rsp" Nothing (map getSymbolicPath files) $
         \path -> runProgramInvocation verbosity $ invokeWithResponseFile path
 
     unless

Cabal/src/Distribution/Simple/Program/Ld.hs

@@ -83,8 +83,6 @@ combineObjectFiles verbosity lbi ldProg target files = do
     middle = ld middleArgs
     final = ld finalArgs
 
-    targetDir = takeDirectorySymbolicPath target
-
     invokeWithResponseFile :: FilePath -> ProgramInvocation
     invokeWithResponseFile atFile =
       ld $ simpleArgs ++ ['@' : atFile]
@@ -106,7 +104,7 @@ combineObjectFiles verbosity lbi ldProg target files = do
 
   if oldVersionManualOverride || responseArgumentsNotSupported
     then run $ multiStageProgramInvocation simple (initial, middle, final) (map getSymbolicPath files)
-    else withResponseFile verbosity defaultTempFileOptions mbWorkDir targetDir "ld.rsp" Nothing (map getSymbolicPath files) $
+    else withResponseFile verbosity defaultTempFileOptions "ld.rsp" Nothing (map getSymbolicPath files) $
       \path -> runProgramInvocation verbosity $ invokeWithResponseFile path
   where
     tmpfile = target <.> "tmp" -- perhaps should use a proper temp file

Cabal/src/Distribution/Simple/Program/ResponseFile.hs

@@ -27,10 +27,6 @@ import Distribution.Verbosity
 withResponseFile
   :: Verbosity
   -> TempFileOptions
-  -> Maybe (SymbolicPath CWD (Dir Pkg))
-  -- ^ Working directory
-  -> SymbolicPath Pkg (Dir Response)
-  -- ^ Directory to create response file in.
   -> String
   -- ^ Template for response file name.
   -> Maybe TextEncoding
@@ -39,8 +35,8 @@ withResponseFile
   -- ^ Arguments to put into response file.
   -> (FilePath -> IO a)
   -> IO a
-withResponseFile verbosity tmpFileOpts mbWorkDir responseDir fileNameTemplate encoding arguments f =
-  withTempFileEx tmpFileOpts mbWorkDir responseDir fileNameTemplate $ \responsePath hf -> do
+withResponseFile verbosity tmpFileOpts fileNameTemplate encoding arguments f =
+  withTempFileEx tmpFileOpts fileNameTemplate $ \responsePath hf -> do
     let responseFileName = getSymbolicPath responsePath
     traverse_ (hSetEncoding hf) encoding
     let responseContents =

Cabal/src/Distribution/Simple/Utils.hs

@@ -1734,23 +1734,17 @@ defaultTempFileOptions = TempFileOptions{optKeepTempFiles = False}
 
 -- | Use a temporary filename that doesn't already exist
 withTempFile
-  :: FilePath
-  -- ^ Temp dir to create the file in
-  -> String
+  :: String
   -- ^ File name template. See 'openTempFile'.
   -> (FilePath -> Handle -> IO a)
   -> IO a
-withTempFile tmpDir template f = withFrozenCallStack $
-  withTempFileCwd Nothing (makeSymbolicPath tmpDir) template $
+withTempFile template f = withFrozenCallStack $
+  withTempFileCwd template $
     \fp h -> f (getSymbolicPath fp) h
 
 -- | Use a temporary filename that doesn't already exist.
 withTempFileCwd
-  :: Maybe (SymbolicPath CWD (Dir Pkg))
-  -- ^ Working directory
-  -> SymbolicPath Pkg (Dir tmpDir)
-  -- ^ Temp dir to create the file in
-  -> String
+  :: String
   -- ^ File name template. See 'openTempFile'.
   -> (SymbolicPath Pkg File -> Handle -> IO a)
   -> IO a
@@ -1759,17 +1753,13 @@ withTempFileCwd = withFrozenCallStack $ withTempFileEx defaultTempFileOptions
 -- | A version of 'withTempFile' that additionally takes a 'TempFileOptions'
 -- argument.
 withTempFileEx
-  :: forall a tmpDir
+  :: forall a
    . TempFileOptions
-  -> Maybe (SymbolicPath CWD (Dir Pkg))
-  -- ^ Working directory
-  -> SymbolicPath Pkg (Dir tmpDir)
-  -- ^ Temp dir to create the file in
   -> String
   -- ^ File name template. See 'openTempFile'.
   -> (SymbolicPath Pkg File -> Handle -> IO a)
   -> IO a
-withTempFileEx opts _mbWorkDir _tmpDir template action = do
+withTempFileEx opts template action = do
   tmp <- getTemporaryDirectory
   withFrozenCallStack $
     Exception.bracket
@@ -1783,7 +1773,6 @@ withTempFileEx opts _mbWorkDir _tmpDir template action = do
       )
       (withLexicalCallStack (\(fn, h) -> action (mkRelToPkg tmp fn) h))
   where
-    -- i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path
     mkRelToPkg :: FilePath -> FilePath -> SymbolicPath Pkg File
     mkRelToPkg tmp fp =
       makeSymbolicPath tmp </> makeRelativePathEx (takeFileName fp)