Track the languageId in Virtual File (#610)

The languageKind is received when a TextDocument is opened,
we add this information to the VirtualFile to keep track of it.

Note that the `_language_id` is defined as a Maybe to be compatible
with lsp-test's use of the virtual file system.

Co-authored-by: Michael Peyton Jones <me@michaelpj.com>

Author: VeryMilkyJoe

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

@@ -445,7 +445,7 @@ updateState (FromServerMess SMethod_WorkspaceApplyEdit r) = do
   forM_ latestVersions $ \(VersionedTextDocumentIdentifier uri v) ->
     modify $ \s ->
       let oldVFS = vfs s
-          update (VirtualFile _ file_ver t) = VirtualFile v (file_ver +1) t
+          update (VirtualFile _ file_ver t _kind) = VirtualFile v (file_ver +1) t _kind
           newVFS = oldVFS & vfsMap . ix (toNormalizedUri uri) %~ update
       in s { vfs = newVFS }
 

lsp/example/Reactor.hs

@@ -246,7 +246,7 @@ handle logger =
         logger <& ("Processing DidChangeTextDocument for: " <> T.pack (show doc)) `WithSeverity` Info
         mdoc <- getVirtualFile doc
         case mdoc of
-          Just (VirtualFile _version str _) -> do
+          Just (VirtualFile _version str _ _) -> do
             logger <& ("Found the virtual file: " <> T.pack (show str)) `WithSeverity` Info
           Nothing -> do
             logger <& ("Didn't find anything in the VFS for: " <> T.pack (show doc)) `WithSeverity` Info

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

@@ -471,7 +471,7 @@ getVersionedTextDoc doc = do
   let uri = doc ^. L.uri
   mvf <- getVirtualFile (toNormalizedUri uri)
   let ver = case mvf of
-        Just (VirtualFile lspver _ _) -> lspver
+        Just (VirtualFile lspver _ _ _) -> lspver
         Nothing -> 0
   return (VersionedTextDocumentIdentifier uri ver)
 {-# INLINE getVersionedTextDoc #-}

lsp/src/Language/LSP/VFS.hs

@@ -23,6 +23,7 @@ module Language.LSP.VFS (
   file_text,
   virtualFileText,
   virtualFileVersion,
+  virtualFileLanguageKind,
   VfsLog (..),
 
   -- * Managing the VFS
@@ -92,6 +93,12 @@ data VirtualFile = VirtualFile
   -- remains in the map.
   , _file_text :: !Rope
   -- ^ The full contents of the document
+  , _language_id :: !(Maybe J.LanguageKind)
+  -- ^ The text document's language identifier
+  -- This is a Maybe, since when we use the VFS as a client
+  -- we don't have this information, since server sends WorkspaceEdit
+  -- notifications without a language kind.
+  -- When using the VFS in a server, this should always be Just.
   }
   deriving (Show)
 
@@ -132,6 +139,9 @@ virtualFileText vf = Rope.toText (_file_text vf)
 virtualFileVersion :: VirtualFile -> Int32
 virtualFileVersion vf = _lsp_version vf
 
+virtualFileLanguageKind :: VirtualFile -> Maybe J.LanguageKind
+virtualFileLanguageKind vf = _language_id vf
+
 ---
 
 emptyVFS :: VFS
@@ -142,8 +152,8 @@ emptyVFS = VFS mempty
 -- | Applies the changes from a 'J.DidOpenTextDocument' to the 'VFS'
 openVFS :: (MonadState VFS m) => LogAction m (WithSeverity VfsLog) -> J.TMessage 'J.Method_TextDocumentDidOpen -> m ()
 openVFS logger msg = do
-  let J.TextDocumentItem (J.toNormalizedUri -> uri) _ version text = msg ^. J.params . J.textDocument
-      vfile = VirtualFile version 0 (Rope.fromText text)
+  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
 
@@ -158,9 +168,9 @@ changeFromClientVFS logger msg = do
     J.VersionedTextDocumentIdentifier (J.toNormalizedUri -> uri) version = vid
   vfs <- get
   case vfs ^. vfsMap . at uri of
-    Just (VirtualFile _ file_ver contents) -> do
+    Just (VirtualFile _ file_ver contents kind) -> do
       contents' <- applyChanges logger contents changes
-      vfsMap . at uri .= Just (VirtualFile version (file_ver + 1) contents')
+      vfsMap . at uri .= Just (VirtualFile version (file_ver + 1) contents' kind)
     Nothing -> logger <& URINotFound uri `WithSeverity` Warning
 
 -- ---------------------------------------------------------------------
@@ -171,7 +181,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)
+      (VirtualFile 0 0 mempty Nothing)
  where
   shouldOverwrite :: Bool
   shouldOverwrite = case options of
@@ -281,7 +291,7 @@ changeFromServerVFS logger msg = do
 
 -- ---------------------------------------------------------------------
 virtualFileName :: FilePath -> J.NormalizedUri -> VirtualFile -> FilePath
-virtualFileName prefix uri (VirtualFile _ file_ver _) =
+virtualFileName prefix uri (VirtualFile _ file_ver _ _) =
   let uri_raw = J.fromNormalizedUri uri
       basename = maybe "" takeFileName (J.uriToFilePath uri_raw)
       -- Given a length and a version number, pad the version number to
@@ -463,7 +473,7 @@ rangeToCodePointRange vFile (J.Range b e) =
   CodePointRange <$> positionToCodePointPosition vFile b <*> positionToCodePointPosition vFile e
 
 rangeLinesFromVfs :: VirtualFile -> J.Range -> T.Text
-rangeLinesFromVfs (VirtualFile _ _ ropetext) (J.Range (J.Position lf _cf) (J.Position lt _ct)) = r
+rangeLinesFromVfs (VirtualFile _ _ ropetext _) (J.Range (J.Position lf _cf) (J.Position lt _ct)) = r
  where
   (_, s1) = Rope.splitAtLine (fromIntegral lf) ropetext
   (s2, _) = Rope.splitAtLine (fromIntegral (lt - lf)) s1

lsp/test/VspSpec.hs

@@ -29,7 +29,7 @@ spec = describe "VSP functions" vspSpec
 -- ---------------------------------------------------------------------
 
 vfsFromText :: T.Text -> VirtualFile
-vfsFromText text = VirtualFile 0 0 (Rope.fromText text)
+vfsFromText text = VirtualFile 0 0 (Rope.fromText text) $ Just J.LanguageKind_Haskell
 
 -- ---------------------------------------------------------------------
 
@@ -243,7 +243,7 @@ vspSpec = do
             [ "a𐐀b"
             , "a𐐀b"
             ]
-        vfile = VirtualFile 0 0 (fromString orig)
+        vfile = VirtualFile 0 0 (fromString orig) $ Just J.LanguageKind_Haskell
 
       positionToCodePointPosition vfile (J.Position 1 0) `shouldBe` Just (CodePointPosition 1 0)
       positionToCodePointPosition vfile (J.Position 1 1) `shouldBe` Just (CodePointPosition 1 1)
@@ -265,7 +265,7 @@ vspSpec = do
             [ "a𐐀b"
             , "a𐐀b"
             ]
-        vfile = VirtualFile 0 0 (fromString orig)
+        vfile = VirtualFile 0 0 (fromString orig) $ Just J.LanguageKind_Haskell
 
       codePointPositionToPosition vfile (CodePointPosition 1 0) `shouldBe` Just (J.Position 1 0)
       codePointPositionToPosition vfile (CodePointPosition 1 1) `shouldBe` Just (J.Position 1 1)