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 + ) -- ---------------------------------------------------------------------