Replace writeFile with atomicFileWrite in ghcide-tests

ghcide-test/exe/CradleTests.hs

@@ -29,6 +29,7 @@ import           Language.LSP.Protocol.Types     hiding
 import           Language.LSP.Test
 import           System.FilePath
 import           System.IO.Extra                 hiding (withTempDir)
+import           Test.Hls.FileSystem
 import           Test.Hls.Util                   (EnvSpec (..), OS (..),
                                                   ignoreInEnv)
 import           Test.Tasty
@@ -53,7 +54,7 @@ loadCradleOnlyonce = testGroup "load cradle only once"
     ]
     where
         direct dir = do
-            liftIO $ writeFileUTF8 (dir </> "hie.yaml")
+            liftIO $ atomicFileWriteStringUTF8 (dir </> "hie.yaml")
                 "cradle: {direct: {arguments: []}}"
             test dir
         implicit dir = test dir
@@ -73,15 +74,15 @@ retryFailedCradle = testWithDummyPluginEmpty' "retry failed" $ \dir -> do
   -- The false cradle always fails
   let hieContents = "cradle: {bios: {shell: \"false\"}}"
       hiePath = dir </> "hie.yaml"
-  liftIO $ writeFile hiePath hieContents
+  liftIO $ atomicFileWriteString hiePath hieContents
   let aPath = dir </> "A.hs"
   doc <- createDoc aPath "haskell" "main = return ()"
   WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc
   liftIO $ "Test assumption failed: cradle should error out" `assertBool` not ideResultSuccess
 
   -- Fix the cradle and typecheck again
   let validCradle = "cradle: {bios: {shell: \"echo A.hs\"}}"
-  liftIO $ writeFileUTF8 hiePath $ T.unpack validCradle
+  liftIO $ atomicFileWriteStringUTF8 hiePath $ T.unpack validCradle
   sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams
          [FileEvent (filePathToUri $ dir </> "hie.yaml") FileChangeType_Changed ]
 
@@ -214,7 +215,7 @@ sessionDepsArePickedUp = testWithDummyPluginEmpty'
   "session-deps-are-picked-up"
   $ \dir -> do
     liftIO $
-      writeFileUTF8
+      atomicFileWriteStringUTF8
         (dir </> "hie.yaml")
         "cradle: {direct: {arguments: []}}"
     -- Open without OverloadedStrings and expect an error.
@@ -223,7 +224,7 @@ sessionDepsArePickedUp = testWithDummyPluginEmpty'
 
     -- Update hie.yaml to enable OverloadedStrings.
     liftIO $
-      writeFileUTF8
+      atomicFileWriteStringUTF8
         (dir </> "hie.yaml")
         "cradle: {direct: {arguments: [-XOverloadedStrings]}}"
     sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams

ghcide-test/exe/DependentFileTest.hs

@@ -15,6 +15,7 @@ import           Language.LSP.Protocol.Types    hiding
                                                  mkRange)
 import           Language.LSP.Test
 import           Test.Hls
+import           Test.Hls.FileSystem
 
 
 tests :: TestTree
@@ -31,7 +32,7 @@ tests = testGroup "addDependentFile"
         -- If the file contains B then no type error
         -- otherwise type error
         let depFilePath = "dep-file.txt"
-        liftIO $ writeFile depFilePath "A"
+        liftIO $ atomicFileWriteString depFilePath "A"
         let fooContent = T.unlines
               [ "{-# LANGUAGE TemplateHaskell #-}"
               , "module Foo where"
@@ -48,7 +49,7 @@ tests = testGroup "addDependentFile"
         expectDiagnostics
             [("Foo.hs", [(DiagnosticSeverity_Error, (4,11), "Couldn't match type", Just "GHC-83865")])]
         -- Now modify the dependent file
-        liftIO $ writeFile depFilePath "B"
+        liftIO $ atomicFileWriteString depFilePath "B"
         sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams
             [FileEvent (filePathToUri depFilePath) FileChangeType_Changed ]
 

ghcide-test/exe/DiagnosticTests.hs

@@ -39,7 +39,7 @@ import           System.Time.Extra
 import           Test.Hls                        (TestConfig (testConfigCaps, testDirLocation, testDisableKick, testPluginDescriptor),
                                                   runSessionWithTestConfig,
                                                   waitForProgressBegin)
-import           Test.Hls.FileSystem             (directCradle, file, text)
+import           Test.Hls.FileSystem
 import           Test.Tasty
 import           Test.Tasty.HUnit
 
@@ -381,7 +381,7 @@ tests = testGroup "diagnostics"
               let (drive, suffix) = splitDrive pathB
               in filePathToUri (joinDrive (lower drive) suffix)
           liftIO $ createDirectoryIfMissing True (takeDirectory pathB)
-          liftIO $ writeFileUTF8 pathB $ T.unpack bContent
+          liftIO $ atomicFileWriteStringUTF8 pathB $ T.unpack bContent
           uriA <- getDocUri "A/A.hs"
           Just pathA <- pure $ uriToFilePath uriA
           uriA <- pure $

ghcide-test/exe/GarbageCollectionTests.hs

@@ -12,6 +12,7 @@ import           Language.LSP.Protocol.Types hiding (SemanticTokenAbsolute (..),
                                               SemanticTokensEdit (..), mkRange)
 import           Language.LSP.Test
 import           System.FilePath
+import           Test.Hls.FileSystem
 import           Test.Tasty
 import           Test.Tasty.HUnit
 import           Text.Printf                 (printf)
@@ -20,14 +21,14 @@ tests :: TestTree
 tests = testGroup "garbage collection"
   [ testGroup "dirty keys"
         [ testWithDummyPluginEmpty' "are collected" $ \dir -> do
-            liftIO $ writeFile (dir </> "hie.yaml") "cradle: {direct: {arguments: [A]}}"
+            liftIO $ atomicFileWriteString (dir </> "hie.yaml") "cradle: {direct: {arguments: [A]}}"
             doc <- generateGarbage "A" dir
             closeDoc doc
             garbage <- waitForGC
             liftIO $ assertBool "no garbage was found" $ not $ null garbage
 
         , testWithDummyPluginEmpty' "are deleted from the state" $ \dir -> do
-            liftIO $ writeFile (dir </> "hie.yaml") "cradle: {direct: {arguments: [A]}}"
+            liftIO $ atomicFileWriteString (dir </> "hie.yaml") "cradle: {direct: {arguments: [A]}}"
             docA <- generateGarbage "A" dir
             keys0 <- getStoredKeys
             closeDoc docA
@@ -37,7 +38,7 @@ tests = testGroup "garbage collection"
             liftIO $ assertBool "keys were not deleted from the state" (length keys1 < length keys0)
 
         , testWithDummyPluginEmpty' "are not regenerated unless needed" $ \dir -> do
-            liftIO $ writeFile (dir </> "hie.yaml") "cradle: {direct: {arguments: [A.hs, B.hs]}}"
+            liftIO $ atomicFileWriteString (dir </> "hie.yaml") "cradle: {direct: {arguments: [A.hs, B.hs]}}"
             docA <- generateGarbage "A" dir
             _docB <- generateGarbage "B" dir
 
@@ -58,7 +59,7 @@ tests = testGroup "garbage collection"
             liftIO $ regeneratedKeys @?= mempty
 
         , testWithDummyPluginEmpty' "regenerate successfully" $ \dir -> do
-            liftIO $ writeFile (dir </> "hie.yaml") "cradle: {direct: {arguments: [A]}}"
+            liftIO $ atomicFileWriteString (dir </> "hie.yaml") "cradle: {direct: {arguments: [A]}}"
             docA <- generateGarbage "A" dir
             closeDoc docA
             garbage <- waitForGC
@@ -83,7 +84,7 @@ tests = testGroup "garbage collection"
         let fp = modName <> ".hs"
             body = printf "module %s where" modName
         doc <- createDoc fp "haskell" (T.pack body)
-        liftIO $ writeFile (dir </> fp) body
+        liftIO $ atomicFileWriteString (dir </> fp) body
         builds <- waitForTypecheck doc
         liftIO $ assertBool "something is wrong with this test" builds
         return doc

ghcide-test/exe/IfaceTests.hs

@@ -18,6 +18,7 @@ import           Language.LSP.Test
 import           System.Directory
 import           System.FilePath
 import           System.IO.Extra               hiding (withTempDir)
+import           Test.Hls.FileSystem
 import           Test.Tasty
 import           Test.Tasty.HUnit
 
@@ -45,7 +46,7 @@ ifaceTHTest = testWithExtraFiles "iface-th-test" "TH" $ \dir -> do
     cdoc <- createDoc cPath "haskell" cSource
 
     -- Change [TH]a from () to Bool
-    liftIO $ writeFileUTF8 aPath (unlines $ init (lines $ T.unpack aSource) ++ ["th_a = [d| a = False|]"])
+    liftIO $ atomicFileWriteStringUTF8 aPath (unlines $ init (lines $ T.unpack aSource) ++ ["th_a = [d| a = False|]"])
 
     -- Check that the change propagates to C
     changeDoc cdoc [TextDocumentContentChangeEvent . InR $ TextDocumentContentChangeWholeDocument cSource]

ghcide-test/exe/PluginSimpleTests.hs

@@ -9,6 +9,7 @@ import           Language.LSP.Protocol.Types hiding (SemanticTokenAbsolute (..),
                                               SemanticTokensEdit (..), mkRange)
 import           Language.LSP.Test
 import           System.FilePath
+import           Test.Hls.FileSystem
 import           Test.Tasty
 
 tests :: TestTree
@@ -36,7 +37,7 @@ tests =
   -- required by plugin-1.0.0). See the build log above for details.
   testWithExtraFiles "simple plugin"  "plugin-knownnat" $ \dir -> do
     _ <- openDoc (dir </> "KnownNat.hs") "haskell"
-    liftIO $ writeFile (dir</>"hie.yaml")
+    liftIO $ atomicFileWriteString (dir</>"hie.yaml")
       "cradle: {cabal: [{path: '.', component: 'lib:plugin'}]}"
 
     expectDiagnostics

ghcide-test/exe/UnitTests.hs

@@ -31,6 +31,7 @@ import           System.Mem                        (performGC)
 import           Test.Hls                          (IdeState, def,
                                                     runSessionWithServerInTmpDir,
                                                     waitForProgressDone)
+import           Test.Hls.FileSystem
 import           Test.Tasty
 import           Test.Tasty.ExpectedFailure
 import           Test.Tasty.HUnit
@@ -104,9 +105,9 @@ findResolution_us :: Int -> IO Int
 findResolution_us delay_us | delay_us >= 1000000 = error "Unable to compute timestamp resolution"
 findResolution_us delay_us = withTempFile $ \f -> withTempFile $ \f' -> do
     performGC
-    writeFile f ""
+    atomicFileWriteString f ""
     threadDelay delay_us
-    writeFile f' ""
+    atomicFileWriteString f' ""
     t <- getModTime f
     t' <- getModTime f'
     if t /= t' then return delay_us else findResolution_us (delay_us * 10)

ghcide-test/exe/WatchedFileTests.hs

@@ -29,7 +29,7 @@ tests :: TestTree
 tests = testGroup "watched files"
   [ testGroup "Subscriptions"
     [ testWithDummyPluginEmpty' "workspace files" $ \sessionDir -> do
-        liftIO $ writeFile (sessionDir </> "hie.yaml") "cradle: {direct: {arguments: [\"-isrc\", \"A\", \"WatchedFilesMissingModule\"]}}"
+        liftIO $ atomicFileWriteString (sessionDir </> "hie.yaml") "cradle: {direct: {arguments: [\"-isrc\", \"A\", \"WatchedFilesMissingModule\"]}}"
         _doc <- createDoc "A.hs" "haskell" "{-#LANGUAGE NoImplicitPrelude #-}\nmodule A where\nimport WatchedFilesMissingModule"
         setIgnoringRegistrationRequests False
         watchedFileRegs <- getWatchedFilesSubscriptionsUntil SMethod_TextDocumentPublishDiagnostics
@@ -40,7 +40,7 @@ tests = testGroup "watched files"
     , testWithDummyPluginEmpty' "non workspace file" $ \sessionDir -> do
         tmpDir <- liftIO getTemporaryDirectory
         let yaml = "cradle: {direct: {arguments: [\"-i" <> tail(init(show tmpDir)) <> "\", \"A\", \"WatchedFilesMissingModule\"]}}"
-        liftIO $ writeFile (sessionDir </> "hie.yaml") yaml
+        liftIO $ atomicFileWriteString (sessionDir </> "hie.yaml") yaml
         _doc <- createDoc "A.hs" "haskell" "{-# LANGUAGE NoImplicitPrelude#-}\nmodule A where\nimport WatchedFilesMissingModule"
         setIgnoringRegistrationRequests False
         watchedFileRegs <- getWatchedFilesSubscriptionsUntil SMethod_TextDocumentPublishDiagnostics
@@ -53,8 +53,8 @@ tests = testGroup "watched files"
   , testGroup "Changes"
     [
       testWithDummyPluginEmpty' "workspace files" $ \sessionDir -> do
-        liftIO $ writeFile (sessionDir </> "hie.yaml") "cradle: {direct: {arguments: [\"-isrc\", \"A\", \"B\"]}}"
-        liftIO $ writeFile (sessionDir </> "B.hs") $ unlines
+        liftIO $ atomicFileWriteString (sessionDir </> "hie.yaml") "cradle: {direct: {arguments: [\"-isrc\", \"A\", \"B\"]}}"
+        liftIO $ atomicFileWriteString (sessionDir </> "B.hs") $ unlines
           ["module B where"
           ,"b :: Bool"
           ,"b = False"]
@@ -66,7 +66,7 @@ tests = testGroup "watched files"
           ]
         expectDiagnostics [("A.hs", [(DiagnosticSeverity_Error, (3, 4), "Couldn't match expected type '()' with actual type 'Bool'", Just "GHC-83865")])]
         -- modify B off editor
-        liftIO $ writeFile (sessionDir </> "B.hs") $ unlines
+        liftIO $ atomicFileWriteString (sessionDir </> "B.hs") $ unlines
           ["module B where"
           ,"b :: Int"
           ,"b = 0"]
@@ -80,7 +80,7 @@ tests = testGroup "watched files"
           let cabalFile = "reload.cabal"
           cabalContent <- liftIO $ T.readFile cabalFile
           let fix = T.replace "build-depends:    base" "build-depends:    base, split"
-          liftIO $ T.writeFile cabalFile (fix cabalContent)
+          liftIO $ atomicFileWriteText cabalFile (fix cabalContent)
           sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams
             [ FileEvent (filePathToUri $ sessionDir </> cabalFile) FileChangeType_Changed ]
           expectDiagnostics [(hsFile, [])]

hls-test-utils/src/Test/Hls/FileSystem.hs

@@ -29,15 +29,20 @@ module Test.Hls.FileSystem
   , directProjectMulti
   , simpleCabalProject
   , simpleCabalProject'
+  , atomicFileWriteString
+  , atomicFileWriteStringUTF8
+  , atomicFileWriteText
   ) where
 
+import           Control.Exception           (onException)
 import           Data.Foldable               (traverse_)
 import qualified Data.Text                   as T
 import qualified Data.Text.IO                as T
 import           Development.IDE             (NormalizedFilePath)
 import           Language.LSP.Protocol.Types (toNormalizedFilePath)
 import           System.Directory
 import           System.FilePath             as FP
+import           System.IO.Extra             (newTempFileWithin, writeFileUTF8)
 import           System.Process.Extra        (readProcess)
 
 -- ----------------------------------------------------------------------------
@@ -244,3 +249,25 @@ simpleCabalProject' :: [FileTree] -> [FileTree]
 simpleCabalProject' fps =
   [ simpleCabalCradle
   ] <> fps
+
+
+atomicFileWrite :: FilePath -> (FilePath -> IO a) -> IO a
+atomicFileWrite targetPath write = do
+  let dir = takeDirectory targetPath
+  createDirectoryIfMissing True dir
+  (tempFilePath, cleanUp) <- newTempFileWithin dir
+  (write tempFilePath >>= \x -> renameFile tempFilePath targetPath >> pure x)
+    `onException` cleanUp
+
+
+atomicFileWriteString :: FilePath -> String -> IO ()
+atomicFileWriteString targetPath content =
+  atomicFileWrite targetPath (flip writeFile content)
+
+atomicFileWriteStringUTF8 :: FilePath -> String -> IO ()
+atomicFileWriteStringUTF8 targetPath content =
+  atomicFileWrite targetPath (flip writeFileUTF8 content)
+
+atomicFileWriteText :: FilePath -> T.Text -> IO ()
+atomicFileWriteText targetPath content =
+    atomicFileWrite targetPath (flip T.writeFile content)