Merge pull request #523 from haskell/mpj/no-io-vfs

Remove pointless IO from VFS

Author: michaelpj

lsp-test/src/Language/LSP/Test/Session.hs

@@ -282,8 +282,8 @@ runSession' serverIn serverOut mServerProc serverHandler config caps rootDir exi
   mainThreadId <- myThreadId
 
   let context = SessionContext serverIn absRootDir messageChan timeoutIdVar reqMap initRsp config caps
-      initState vfs = SessionState 0 vfs mempty False Nothing mempty (lspConfig config) mempty (ignoreLogNotifications config) (ignoreConfigurationRequests config)
-      runSession' ses = initVFS $ \vfs -> runSessionMonad context (initState vfs) ses
+      initState = SessionState 0 emptyVFS mempty False Nothing mempty (lspConfig config) mempty (ignoreLogNotifications config) (ignoreConfigurationRequests config)
+      runSession' = runSessionMonad context initState
 
       errorHandler = throwTo mainThreadId :: SessionException -> IO ()
       serverListenerLauncher =
@@ -306,7 +306,7 @@ runSession' serverIn serverOut mServerProc serverHandler config caps rootDir exi
 
   (result, _) <- bracket serverListenerLauncher
                          serverAndListenerFinalizer
-                         (const $ initVFS $ \vfs -> runSessionMonad context (initState vfs) session)
+                         (const $ runSessionMonad context initState session)
   return result
 
 updateStateC :: ConduitM FromServerMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) ()

lsp/ChangeLog.md

@@ -3,6 +3,8 @@
 ## Unreleased
 
 - Fix inference of server capabilities for newer methods (except notebook methods).
+- VFS no longer requires IO to initialize, functions that wrote to a temporary directory
+  now take the directory as an argument.
 
 ## 2.2.0.0
 

lsp/lsp.cabal

@@ -72,7 +72,6 @@ library
     , row-types
     , sorted-list           ^>=0.2.1
     , stm                   ^>=2.5
-    , temporary
     , text
     , text-rope
     , transformers          >=0.5.6   && <0.7

lsp/src/Language/LSP/Server/Control.hs

@@ -142,8 +142,7 @@ runServerWith ioLogger logger clientIn clientOut serverDefinition = do
 
   let sendMsg msg = atomically $ writeTChan cout $ J.toJSON msg
 
-  initVFS $ \vfs -> do
-    ioLoop ioLogger logger clientIn serverDefinition vfs sendMsg
+  ioLoop ioLogger logger clientIn serverDefinition emptyVFS sendMsg
 
   return 1
 

lsp/src/Language/LSP/Server/Core.hs

@@ -453,13 +453,13 @@ snapshotVirtualFiles :: LanguageContextEnv c -> STM VFS
 snapshotVirtualFiles env = vfsData <$> readTVar (resVFS $ resState env)
 {-# INLINE snapshotVirtualFiles #-}
 
-{- | Dump the current text for a given VFS file to a temporary file,
- and return the path to the file.
+{- | Dump the current text for a given VFS file to a file
+ in the given directory and return the path to the file.
 -}
-persistVirtualFile :: MonadLsp config m => LogAction m (WithSeverity VfsLog) -> NormalizedUri -> m (Maybe FilePath)
-persistVirtualFile logger uri = do
+persistVirtualFile :: MonadLsp config m => LogAction m (WithSeverity VfsLog) -> FilePath -> NormalizedUri -> m (Maybe FilePath)
+persistVirtualFile logger dir uri = do
   join $ stateState resVFS $ \vfs ->
-    case persistFileVFS logger (vfsData vfs) uri of
+    case persistFileVFS logger dir (vfsData vfs) uri of
       Nothing -> (return Nothing, vfs)
       Just (fn, write) ->
         let !revMap = case uriToFilePath (fromNormalizedUri uri) of

lsp/src/Language/LSP/VFS.hs

@@ -26,7 +26,6 @@ files in the client workspace by operating on the "VFS" in "LspFuncs".
 module Language.LSP.VFS (
   VFS (..),
   vfsMap,
-  vfsTempDir,
   VirtualFile (..),
   lsp_version,
   file_version,
@@ -36,7 +35,7 @@ module Language.LSP.VFS (
   VfsLog (..),
 
   -- * Managing the VFS
-  initVFS,
+  emptyVFS,
   openVFS,
   changeFromClientVFS,
   changeFromServerVFS,
@@ -92,7 +91,6 @@ import Language.LSP.Protocol.Types qualified as J
 import System.Directory
 import System.FilePath
 import System.IO
-import System.IO.Temp
 
 -- ---------------------------------------------------------------------
 {-# ANN module ("hlint: ignore Eta reduce" :: String) #-}
@@ -113,8 +111,6 @@ data VirtualFile = VirtualFile
 
 data VFS = VFS
   { _vfsMap :: !(Map.Map J.NormalizedUri VirtualFile)
-  , _vfsTempDir :: !FilePath
-  -- ^ This is where all the temporary files will be written to
   }
   deriving (Show)
 
@@ -152,8 +148,8 @@ virtualFileVersion vf = _lsp_version vf
 
 ---
 
-initVFS :: (VFS -> IO r) -> IO r
-initVFS k = withSystemTempDirectory "haskell-lsp" $ \temp_dir -> k (VFS mempty temp_dir)
+emptyVFS :: VFS
+emptyVFS = VFS mempty
 
 -- ---------------------------------------------------------------------
 
@@ -311,13 +307,13 @@ virtualFileName prefix uri (VirtualFile _ file_ver _) =
          in replicate (n - length numString) '0' ++ numString
    in prefix </> basename ++ "-" ++ padLeft 5 file_ver ++ "-" ++ show (hash uri_raw) <.> takeExtensions basename
 
--- | Write a virtual file to a temporary file if it exists in the VFS.
-persistFileVFS :: (MonadIO m) => LogAction m (WithSeverity VfsLog) -> VFS -> J.NormalizedUri -> Maybe (FilePath, m ())
-persistFileVFS logger vfs uri =
+-- | Write a virtual file to a file in the given directory if it exists in the VFS.
+persistFileVFS :: (MonadIO m) => LogAction m (WithSeverity VfsLog) -> FilePath -> VFS -> J.NormalizedUri -> Maybe (FilePath, m ())
+persistFileVFS logger dir vfs uri =
   case vfs ^. vfsMap . at uri of
     Nothing -> Nothing
     Just vf ->
-      let tfn = virtualFileName (vfs ^. vfsTempDir) uri vf
+      let tfn = virtualFileName dir uri vf
           action = do
             exists <- liftIO $ doesFileExist tfn
             unless exists $ do