From 73fefa5f8d27f42f0f6e2794e7fcdb589fad5758 Mon Sep 17 00:00:00 2001 From: VeryMilkyJoe Date: Mon, 9 Jun 2025 13:54:59 +0200 Subject: [PATCH] Track closed files in the VFS Add data structure which represents a closed file in the VFS. This structure only stores the language kind of the closed file as of now. The VFS now stores VFS entries which can be either open or closed files. --- lsp-test/src/Language/LSP/Test.hs | 4 +- lsp-test/src/Language/LSP/Test/Session.hs | 4 +- lsp/src/Language/LSP/Server/Core.hs | 4 +- lsp/src/Language/LSP/VFS.hs | 60 ++++++++++++++++++++--- 4 files changed, 58 insertions(+), 14 deletions(-) diff --git a/lsp-test/src/Language/LSP/Test.hs b/lsp-test/src/Language/LSP/Test.hs index 0437d77f..41466edd 100644 --- a/lsp-test/src/Language/LSP/Test.hs +++ b/lsp-test/src/Language/LSP/Test.hs @@ -371,7 +371,7 @@ envOverrideConfig cfg = do documentContents :: TextDocumentIdentifier -> Session T.Text documentContents doc = do vfs <- vfs <$> get - let Just file = vfs ^. vfsMap . at (toNormalizedUri (doc ^. L.uri)) + let Just file = vfs ^? vfsMap . ix (toNormalizedUri (doc ^. L.uri)) . _Open return (virtualFileText file) {- | Parses an ApplyEditRequest, checks that it is for the passed document @@ -801,7 +801,7 @@ resolveAndExecuteCodeAction ca = executeCodeAction ca getVersionedDoc :: TextDocumentIdentifier -> Session VersionedTextDocumentIdentifier getVersionedDoc (TextDocumentIdentifier uri) = do vfs <- vfs <$> get - let ver = vfs ^? vfsMap . ix (toNormalizedUri uri) . to virtualFileVersion + let ver = vfs ^? vfsMap . ix (toNormalizedUri uri) . _Open . to virtualFileVersion -- TODO: is this correct? Could return an OptionalVersionedTextDocumentIdentifier, -- but that complicated callers... return (VersionedTextDocumentIdentifier uri (fromMaybe 0 ver)) diff --git a/lsp-test/src/Language/LSP/Test/Session.hs b/lsp-test/src/Language/LSP/Test/Session.hs index 43d525b2..70312011 100644 --- a/lsp-test/src/Language/LSP/Test/Session.hs +++ b/lsp-test/src/Language/LSP/Test/Session.hs @@ -446,7 +446,7 @@ updateState (FromServerMess SMethod_WorkspaceApplyEdit r) = do modify $ \s -> let oldVFS = vfs s update (VirtualFile _ file_ver t _kind) = VirtualFile v (file_ver +1) t _kind - newVFS = oldVFS & vfsMap . ix (toNormalizedUri uri) %~ update + newVFS = oldVFS & vfsMap . ix (toNormalizedUri uri) . _Open %~ update in s { vfs = newVFS } where @@ -486,7 +486,7 @@ updateState (FromServerMess SMethod_WorkspaceApplyEdit r) = do -- where n is the current version textDocumentVersions uri = do vfs <- vfs <$> get - let curVer = fromMaybe 0 $ vfs ^? vfsMap . ix (toNormalizedUri uri) . lsp_version + let curVer = fromMaybe 0 $ vfs ^? vfsMap . ix (toNormalizedUri uri) . _Open . lsp_version pure $ map (VersionedTextDocumentIdentifier uri) [curVer + 1..] textDocumentEdits uri edits = do diff --git a/lsp/src/Language/LSP/Server/Core.hs b/lsp/src/Language/LSP/Server/Core.hs index 14298916..a7e75fc9 100644 --- a/lsp/src/Language/LSP/Server/Core.hs +++ b/lsp/src/Language/LSP/Server/Core.hs @@ -21,7 +21,7 @@ import Colog.Core ( ) import Control.Concurrent.Extra as C import Control.Concurrent.STM -import Control.Lens (at, (^.), (^?), _Just) +import Control.Lens (ix, (^.), (^?), _Just) import Control.Monad import Control.Monad.Catch ( MonadCatch, @@ -433,7 +433,7 @@ sendRequest m params resHandler = do getVirtualFile :: MonadLsp config m => NormalizedUri -> m (Maybe VirtualFile) getVirtualFile uri = do dat <- vfsData <$> getsState resVFS - pure $ dat ^. vfsMap . at uri + pure $ dat ^? vfsMap . ix uri . _Open {-# INLINE getVirtualFile #-} getVirtualFiles :: MonadLsp config m => m VFS diff --git a/lsp/src/Language/LSP/VFS.hs b/lsp/src/Language/LSP/VFS.hs index 560e97c3..ceba38e2 100644 --- a/lsp/src/Language/LSP/VFS.hs +++ b/lsp/src/Language/LSP/VFS.hs @@ -18,12 +18,19 @@ module Language.LSP.VFS ( VFS (..), vfsMap, VirtualFile (..), + ClosedVirtualFile (..), + VirtualFileEntry (..), lsp_version, file_version, file_text, + language_id, + _Open, + _Closed, virtualFileText, virtualFileVersion, virtualFileLanguageKind, + closedVirtualFileLanguageKind, + virtualFileEntryLanguageKind, VfsLog (..), -- * Managing the VFS @@ -102,13 +109,27 @@ data VirtualFile = VirtualFile } deriving (Show) +{- | Represents a closed file in the VFS +We are keeping track of this in order to be able to get information +on virtual files after they were closed. +-} +data ClosedVirtualFile = ClosedVirtualFile + { _language_id :: !(Maybe J.LanguageKind) + -- ^ see 'VirtualFile._language_id' + } + deriving (Show) + +data VirtualFileEntry = Open VirtualFile | Closed ClosedVirtualFile + deriving (Show) + data VFS = VFS - { _vfsMap :: !(Map.Map J.NormalizedUri VirtualFile) + { _vfsMap :: !(Map.Map J.NormalizedUri VirtualFileEntry) } deriving (Show) data VfsLog = SplitInsideCodePoint Utf16.Position Rope + | ApplyChangeToClosedFile J.NormalizedUri | URINotFound J.NormalizedUri | Opening J.NormalizedUri | Closing J.NormalizedUri @@ -120,6 +141,7 @@ data VfsLog instance Pretty VfsLog where pretty (SplitInsideCodePoint pos r) = "VFS: asked to make change inside code point. Position" <+> viaShow pos <+> "in" <+> viaShow r + pretty (ApplyChangeToClosedFile uri) = "VFS: trying to apply a change to a closed file" <+> pretty uri pretty (URINotFound uri) = "VFS: don't know about URI" <+> pretty uri pretty (Opening uri) = "VFS: opening" <+> pretty uri pretty (Closing uri) = "VFS: closing" <+> pretty uri @@ -129,7 +151,9 @@ instance Pretty VfsLog where pretty (DeleteNonExistent uri) = "VFS: asked to delete non-existent file" <+> pretty uri makeFieldsNoPrefix ''VirtualFile +makeFieldsNoPrefix ''ClosedVirtualFile makeFieldsNoPrefix ''VFS +makePrisms ''VirtualFileEntry --- @@ -140,7 +164,20 @@ virtualFileVersion :: VirtualFile -> Int32 virtualFileVersion vf = _lsp_version vf virtualFileLanguageKind :: VirtualFile -> Maybe J.LanguageKind -virtualFileLanguageKind vf = _language_id vf +virtualFileLanguageKind vf = vf ^. language_id + +closedVirtualFileLanguageKind :: ClosedVirtualFile -> Maybe J.LanguageKind +closedVirtualFileLanguageKind vf = vf ^. language_id + +virtualFileEntryLanguageKind :: VirtualFileEntry -> Maybe J.LanguageKind +virtualFileEntryLanguageKind (Open vf) = virtualFileLanguageKind vf +virtualFileEntryLanguageKind (Closed vf) = closedVirtualFileLanguageKind vf + +toClosedVirtualFile :: VirtualFile -> ClosedVirtualFile +toClosedVirtualFile vf = + ClosedVirtualFile + { _language_id = virtualFileLanguageKind vf + } --- @@ -155,7 +192,7 @@ openVFS logger msg = do let J.TextDocumentItem (J.toNormalizedUri -> uri) languageId version text = msg ^. J.params . J.textDocument vfile = VirtualFile version 0 (Rope.fromText text) (Just languageId) logger <& Opening uri `WithSeverity` Debug - vfsMap . at uri .= Just vfile + vfsMap . at uri .= (Just $ Open vfile) -- --------------------------------------------------------------------- @@ -168,9 +205,10 @@ changeFromClientVFS logger msg = do J.VersionedTextDocumentIdentifier (J.toNormalizedUri -> uri) version = vid vfs <- get case vfs ^. vfsMap . at uri of - Just (VirtualFile _ file_ver contents kind) -> do + Just (Open (VirtualFile _ file_ver contents kind)) -> do contents' <- applyChanges logger contents changes - vfsMap . at uri .= Just (VirtualFile version (file_ver + 1) contents' kind) + vfsMap . at uri .= Just (Open (VirtualFile version (file_ver + 1) contents' kind)) + Just (Closed (ClosedVirtualFile _)) -> logger <& ApplyChangeToClosedFile uri `WithSeverity` Warning Nothing -> logger <& URINotFound uri `WithSeverity` Warning -- --------------------------------------------------------------------- @@ -181,7 +219,7 @@ applyCreateFile (J.CreateFile _ann _kind (J.toNormalizedUri -> uri) options) = %= Map.insertWith (\new old -> if shouldOverwrite then new else old) uri - (VirtualFile 0 0 mempty Nothing) + (Open (VirtualFile 0 0 mempty Nothing)) where shouldOverwrite :: Bool shouldOverwrite = case options of @@ -308,7 +346,8 @@ persistFileVFS :: (MonadIO m) => LogAction m (WithSeverity VfsLog) -> FilePath - persistFileVFS logger dir vfs uri = case vfs ^. vfsMap . at uri of Nothing -> Nothing - Just vf -> + (Just (Closed _)) -> Nothing + (Just (Open vf)) -> let tfn = virtualFileName dir uri vf action = do exists <- liftIO $ doesFileExist tfn @@ -329,7 +368,12 @@ closeVFS :: (MonadState VFS m) => LogAction m (WithSeverity VfsLog) -> J.TMessag closeVFS logger msg = do let J.DidCloseTextDocumentParams (J.TextDocumentIdentifier (J.toNormalizedUri -> uri)) = msg ^. J.params logger <& Closing uri `WithSeverity` Debug - vfsMap . at uri .= Nothing + vfsMap . ix uri + %= ( \mf -> + case mf of + Open f -> Closed $ toClosedVirtualFile f + Closed f -> Closed f + ) -- ---------------------------------------------------------------------