diff --git a/lib/unison-prelude/src/Unison/Prelude.hs b/lib/unison-prelude/src/Unison/Prelude.hs index ef48bc2556..74d05439ef 100644 --- a/lib/unison-prelude/src/Unison/Prelude.hs +++ b/lib/unison-prelude/src/Unison/Prelude.hs @@ -5,6 +5,7 @@ module Unison.Prelude safeReadUtf8StdIn, writeUtf8, prependUtf8, + atomicallyReplaceFile, uncurry4, reportBug, tShow, @@ -100,6 +101,8 @@ import Text.Read as X (readMaybe) import UnliftIO as X (MonadUnliftIO (..), askRunInIO, askUnliftIO, try, withUnliftIO) import UnliftIO qualified import UnliftIO.Directory qualified as UnliftIO +import UnliftIO.IO (hClose) +import UnliftIO.Temporary (withSystemTempFile) import Witch as X (From (from), TryFrom (tryFrom), TryFromException (TryFromException), into, tryInto) import Witherable as X (filterA, forMaybe, mapMaybe, wither, witherMap) @@ -251,6 +254,16 @@ writeUtf8 fileName txt = do Handle.hSetEncoding handle IO.utf8 Text.hPutStr handle txt +-- | Atomically replace the contents of a file with some text +-- Unfortunately this _still_ isn't atomic on Windows; but is still +-- less likely to leave an empty file than writing directly to the output file. +atomicallyReplaceFile :: (MonadIO m) => FilePath -> Text -> m () +atomicallyReplaceFile path txt = liftIO $ do + withSystemTempFile "temp" \fp outputHandle -> do + hClose outputHandle + liftIO $ writeUtf8 fp txt + UnliftIO.renameFile fp path + -- | Atomically prepend some text to a file, creating the file if it doesn't already exist prependUtf8 :: FilePath -> Text -> IO () prependUtf8 path txt = do diff --git a/unison-cli/package.yaml b/unison-cli/package.yaml index 6257834e98..f0832c8f77 100644 --- a/unison-cli/package.yaml +++ b/unison-cli/package.yaml @@ -153,7 +153,6 @@ executables: - base - bytestring - code-page - - directory - easytest - filepath - megaparsec diff --git a/unison-cli/transcripts/Transcripts.hs b/unison-cli/transcripts/Transcripts.hs index 28121783e2..74e2bba13c 100644 --- a/unison-cli/transcripts/Transcripts.hs +++ b/unison-cli/transcripts/Transcripts.hs @@ -11,7 +11,6 @@ import Data.List import Data.Text qualified as Text import Data.Text.IO qualified as Text import EasyTest -import System.Directory import System.Environment (getArgs) import System.FilePath ( replaceExtension, @@ -30,6 +29,11 @@ import Unison.Codebase.Transcript.Runner as Transcript import Unison.Codebase.Verbosity qualified as Verbosity import Unison.Prelude import Unison.Util.Timing +import UnliftIO.Directory + ( createDirectoryIfMissing, + listDirectory, + renameDirectory, + ) import UnliftIO.STM qualified as STM data TestConfig = TestConfig @@ -73,7 +77,7 @@ testBuilder expectFailure replaceOriginal recordFailure inputDir outputDir prelu case err of Transcript.PortBindingFailure -> do let errMsg = "Failed to bind codebase server to the default port when running transcripts in " <> filePath - io . writeUtf8 outputFile $ Text.pack errMsg + atomicallyReplaceFile outputFile $ Text.pack errMsg when (not expectFailure) $ do io $ recordFailure (inputDir filePath, Text.pack errMsg) crash errMsg @@ -81,13 +85,13 @@ testBuilder expectFailure replaceOriginal recordFailure inputDir outputDir prelu let bundle = MP.errorBundlePretty errors errMsg = "Error parsing " <> filePath <> ": " <> bundle -- Drop the file name, to avoid POSIX/Windows conflicts - io . writeUtf8 outputFile . Text.dropWhile (/= ':') $ Text.pack bundle + atomicallyReplaceFile outputFile . Text.dropWhile (/= ':') $ Text.pack bundle when (not expectFailure) $ do io $ recordFailure (inputDir filePath, Text.pack errMsg) crash errMsg Transcript.RunFailure errOutput -> do let errText = Transcript.format errOutput - io $ writeUtf8 outputFile errText + atomicallyReplaceFile outputFile errText when (not expectFailure) $ do io $ Text.putStrLn errText io $ recordFailure (inputDir filePath, errText) @@ -95,7 +99,7 @@ testBuilder expectFailure replaceOriginal recordFailure inputDir outputDir prelu (filePath, Right out) -> do let outputFile = outputDir if replaceOriginal then filePath else outputFileForTranscript filePath io . createDirectoryIfMissing True $ takeDirectory outputFile - io . writeUtf8 outputFile $ Transcript.format out + atomicallyReplaceFile outputFile $ Transcript.format out when expectFailure $ do let errMsg = "Expected a failure, but transcript was successful." io $ recordFailure (filePath, Text.pack errMsg) diff --git a/unison-cli/unison-cli.cabal b/unison-cli/unison-cli.cabal index 1de4ab84bb..4c5a92d2aa 100644 --- a/unison-cli/unison-cli.cabal +++ b/unison-cli/unison-cli.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.36.0. +-- This file has been generated from package.yaml by hpack version 0.38.1. -- -- see: https://github.com/sol/hpack @@ -359,7 +359,6 @@ executable transcripts base , bytestring , code-page - , directory , easytest , filepath , megaparsec