Change tracking of file types to language kinds

cabal.project

@@ -7,6 +7,17 @@ packages:
          ./hls-plugin-api
          ./hls-test-utils
 
+source-repository-package
+    type: git
+    location: https://github.com/VeryMilkyJoe/lsp.git
+    subdir: lsp
+    tag: 33673596e1b2eb619ca38244e001adda880c3657
+
+source-repository-package
+    type: git
+    location: https://github.com/VeryMilkyJoe/lsp.git
+    subdir: lsp-test
+    tag: 33673596e1b2eb619ca38244e001adda880c3657
 
 index-state: 2025-06-07T14:57:40Z
 

ghcide/src/Development/IDE/Core/FileStore.hs

@@ -226,8 +226,8 @@ getVersionedTextDoc doc = do
     maybe (pure Nothing) getVirtualFile $
         uriToNormalizedFilePath $ toNormalizedUri uri
   let ver = case mvf of
-        Just (VirtualFile lspver _ _) -> lspver
-        Nothing                       -> 0
+        Just (VirtualFile lspver _ _ _) -> lspver
+        Nothing                         -> 0
   return (VersionedTextDocumentIdentifier uri ver)
 
 fileStoreRules :: Recorder (WithPriority Log) -> (NormalizedFilePath -> Action Bool) -> Rules ()

ghcide/src/Development/IDE/Core/Rules.hs

@@ -158,7 +158,7 @@
                                                                useProperty,
                                                                usePropertyByPath)
 import           Ide.Types                                    (DynFlagsModifications (dynFlagsModifyGlobal, dynFlagsModifyParser),
-                                                               PluginId)
+                                                               PluginId, getVirtualFileFromVFS)
 import qualified Language.LSP.Protocol.Lens                   as JL
 import           Language.LSP.Protocol.Message                (SMethod (SMethod_CustomMethod, SMethod_WindowShowMessage))
 import           Language.LSP.Protocol.Types                  (MessageType (MessageType_Info),
@@ -509,7 +509,7 @@
   res <- readHieFileForSrcFromDisk recorder file
   vfsRef <- asks vfsVar
   vfsData <- liftIO $ _vfsMap <$> readTVarIO vfsRef
-  (currentSource, ver) <- liftIO $ case M.lookup (filePathToUri' file) vfsData of
+  (currentSource, ver) <- liftIO $ case getVirtualFileFromVFS (VFS vfsData) (filePathToUri' file) of
     Nothing -> (,Nothing) . T.decodeUtf8 <$> BS.readFile (fromNormalizedFilePath file)
     Just vf -> pure (virtualFileText vf, Just $ virtualFileVersion vf)
   let refmap = Compat.generateReferencesMap . Compat.getAsts . Compat.hie_asts $ res
@@ -802,7 +802,7 @@
             { source_version = ver
             , old_value = m_old
             , get_file_version = use GetModificationTime_{missingFileDiagnostics = False}
             , get_linkable_hashes = \fs -> map (snd . fromJust . hirCoreFp) <$> uses_ GetModIface fs
             , get_module_graph = useWithSeparateFingerprintRule_ GetModuleGraphTransDepsFingerprints GetModuleGraph f
             , regenerate = regenerateHiFile session f ms
             }

ghcide/src/Development/IDE/Core/Shake.hs

@@ -129,6 +129,7 @@ import           Development.IDE.Core.RuleTypes
 import           Development.IDE.Types.Options          as Options
 import qualified Language.LSP.Protocol.Message          as LSP
 import qualified Language.LSP.Server                    as LSP
+import qualified Language.LSP.VFS                       as VFS
 
 import           Development.IDE.Core.Tracing
 import           Development.IDE.Core.WorkerThread
@@ -394,7 +395,8 @@ class Typeable a => IsIdeGlobal a where
 getVirtualFile :: NormalizedFilePath -> Action (Maybe VirtualFile)
 getVirtualFile nf = do
   vfs <- fmap _vfsMap . liftIO . readTVarIO . vfsVar =<< getShakeExtras
-  pure $! Map.lookup (filePathToUri' nf) vfs -- Don't leak a reference to the entire map
+  pure $!  -- Don't leak a reference to the entire map
+    getVirtualFileFromVFS (VFS vfs) $ filePathToUri' nf
 
 -- Take a snapshot of the current LSP VFS
 vfsSnapshot :: Maybe (LSP.LanguageContextEnv a) -> IO VFS

ghcide/src/Development/IDE/Plugin/Completions/Logic.hs

@@ -854,7 +854,7 @@ mergeListsBy cmp all_lists = merge_lists all_lists
 
 -- |From the given cursor position, gets the prefix module or record for autocompletion
 getCompletionPrefix :: Position -> VFS.VirtualFile -> PosPrefixInfo
-getCompletionPrefix pos (VFS.VirtualFile _ _ ropetext) = getCompletionPrefixFromRope pos ropetext
+getCompletionPrefix pos (VFS.VirtualFile _ _ ropetext _) = getCompletionPrefixFromRope pos ropetext
 
 getCompletionPrefixFromRope :: Position -> Rope.Rope -> PosPrefixInfo
 getCompletionPrefixFromRope pos@(Position l c) ropetext =

ghcide/src/Development/IDE/Plugin/HLS.hs

@@ -49,7 +49,8 @@ import qualified Language.LSP.Server           as LSP
 import           Language.LSP.VFS
 import           Prettyprinter.Render.String   (renderString)
 import           Text.Regex.TDFA.Text          ()
-import           UnliftIO                      (MonadUnliftIO, liftIO)
+import           UnliftIO                      (MonadUnliftIO, liftIO,
+                                                readTVarIO)
 import           UnliftIO.Async                (forConcurrently)
 import           UnliftIO.Exception            (catchAny)
 
@@ -251,11 +252,12 @@ extensiblePlugins recorder plugins = mempty { P.pluginHandlers = handlers }
     handlers = mconcat $ do
       (IdeMethod m :=> IdeHandler fs') <- DMap.assocs handlers'
       pure $ requestHandler m $ \ide params -> do
+        vfs <- readTVarIO $ vfsVar $ shakeExtras ide
         config <- Ide.PluginUtils.getClientConfig
         -- Only run plugins that are allowed to run on this request, save the
         -- list of disabled plugins incase that's all we have
-        let (fs, dfs) = List.partition (\(_, desc, _) -> handlesRequest m params desc config == HandlesRequest) fs'
-        let disabledPluginsReason = (\(x, desc, _) -> (x, handlesRequest m params desc config)) <$> dfs
+        let (fs, dfs) = List.partition (\(_, desc, _) -> handlesRequest vfs m params desc config == HandlesRequest) fs'
+        let disabledPluginsReason = (\(x, desc, _) -> (x, handlesRequest vfs m params desc config)) <$> dfs
         -- Clients generally don't display ResponseErrors so instead we log any that we come across
         -- However, some clients do display ResponseErrors! See for example the issues:
         -- https://github.com/haskell/haskell-language-server/issues/4467
@@ -370,7 +372,7 @@ extensibleNotificationPlugins recorder xs = mempty { P.pluginHandlers = handlers
       pure $ notificationHandler m $ \ide vfs params -> do
         config <- Ide.PluginUtils.getClientConfig
         -- Only run plugins that are enabled for this request
-        let fs = filter (\(_, desc, _) -> handlesRequest m params desc config == HandlesRequest) fs'
+        let fs = filter (\(_, desc, _) -> handlesRequest vfs m params desc config == HandlesRequest) fs'
         case nonEmpty fs of
           Nothing -> do
             logWith recorder Warning (LogNoPluginForMethod $ Some m)

hls-plugin-api/src/Ide/Types.hs

@@ -39,6 +39,7 @@ module Ide.Types
 , PluginNotificationHandlers(..)
 , PluginRequestMethod(..)
 , getProcessID, getPid
+, getVirtualFileFromVFS
 , installSigUsr1Handler
 , lookupCommandProvider
 , ResolveFunction
@@ -94,13 +95,13 @@ import           Ide.Plugin.Properties
 import qualified Language.LSP.Protocol.Lens    as L
 import           Language.LSP.Protocol.Message
 import           Language.LSP.Protocol.Types
+import qualified Language.LSP.Protocol.Types   as J
 import           Language.LSP.Server
 import           Language.LSP.VFS
 import           Numeric.Natural
 import           OpenTelemetry.Eventlog
 import           Options.Applicative           (ParserInfo)
 import           Prettyprinter                 as PP
-import           System.FilePath
 import           System.IO.Unsafe
 import           Text.Regex.TDFA.Text          ()
 import           UnliftIO                      (MonadUnliftIO)
@@ -323,7 +324,7 @@ data PluginDescriptor (ideState :: Type) =
                    , pluginNotificationHandlers :: PluginNotificationHandlers ideState
                    , pluginModifyDynflags :: DynFlagsModifications
                    , pluginCli            :: Maybe (ParserInfo (IdeCommand ideState))
-                   , pluginFileType       :: [T.Text]
+                   , pluginLanguageIds    :: [J.LanguageKind]
                    -- ^ File extension of the files the plugin is responsible for.
                    --   The plugin is only allowed to handle files with these extensions.
                    --   When writing handlers, etc. for this plugin it can be assumed that all handled files are of this type.
@@ -416,14 +417,18 @@ pluginResolverResponsible _ _ = DoesNotHandleRequest $ NotResolveOwner "(unable
 -- We are passing the msgParams here even though we only need the URI URI here.
 -- If in the future we need to be able to provide only an URI it can be
 -- separated again.
-pluginSupportsFileType :: (L.HasTextDocument m doc, L.HasUri doc Uri) => m -> PluginDescriptor c -> HandleRequestResult
-pluginSupportsFileType msgParams pluginDesc =
-  case mfp of
-    Just fp | T.pack (takeExtension fp) `elem` pluginFileType pluginDesc -> HandlesRequest
-    _ -> DoesNotHandleRequest $ DoesNotSupportFileType (maybe "(unable to determine file type)" (T.pack . takeExtension) mfp)
+pluginSupportsFileType :: (L.HasTextDocument m doc, L.HasUri doc Uri) => VFS -> m -> PluginDescriptor c -> HandleRequestResult
+pluginSupportsFileType (VFS vfs) msgParams pluginDesc =
+  case languageKindM of
+    Just languageKind | languageKind `elem` pluginLanguageIds pluginDesc -> HandlesRequest
+    _ -> DoesNotHandleRequest $ DoesNotSupportFileType (maybe "(unable to determine file type)" (T.pack . show) languageKindM)
     where
-      mfp = uriToFilePath uri
-      uri = msgParams ^. L.textDocument . L.uri
+      mVFE = getVirtualFileFromVFSIncludingClosed (VFS vfs) uri
+      uri = toNormalizedUri $ msgParams ^. L.textDocument . L.uri
+      languageKindM =
+        case mVFE of
+          Just x -> virtualFileEntryLanguageKind x
+          _      -> Nothing
 
 -- | Methods that can be handled by plugins.
 -- 'ExtraParams' captures any extra data the IDE passes to the handlers for this method
@@ -452,7 +457,9 @@ class HasTracing (MessageParams m) => PluginMethod (k :: MessageKind) (m :: Meth
   --
   -- But there is no use to split it up into two different methods for now.
   handlesRequest
-    :: SMethod m
+    :: VFS
+    -- ^ The virtual file system, contains the language kind of the file.
+    -> SMethod m
     -- ^ Method type.
     -> MessageParams m
     -- ^ Whether a plugin is enabled might depend on the message parameters
@@ -468,24 +475,24 @@ class HasTracing (MessageParams m) => PluginMethod (k :: MessageKind) (m :: Meth
     -- with the given parameters?
 
   default handlesRequest :: (L.HasTextDocument (MessageParams m) doc, L.HasUri doc Uri)
-                              => SMethod m -> MessageParams m -> PluginDescriptor c -> Config -> HandleRequestResult
-  handlesRequest _ params desc conf =
-    pluginEnabledGlobally desc conf <> pluginSupportsFileType params desc
+                              => VFS -> SMethod m -> MessageParams m -> PluginDescriptor c -> Config -> HandleRequestResult
+  handlesRequest vfs _ params desc conf =
+    pluginEnabledGlobally desc conf <> pluginSupportsFileType vfs params desc
 
 -- | Check if a plugin is enabled, if one of it's specific config's is enabled,
 -- and if it supports the file
 pluginEnabledWithFeature :: (L.HasTextDocument (MessageParams m) doc, L.HasUri doc Uri)
-                              => (PluginConfig -> Bool) -> SMethod m -> MessageParams m
+                              => (PluginConfig -> Bool) -> VFS -> SMethod m -> MessageParams m
                               -> PluginDescriptor c -> Config -> HandleRequestResult
-pluginEnabledWithFeature feature _ msgParams pluginDesc config =
+pluginEnabledWithFeature feature vfs _ msgParams pluginDesc config =
   pluginEnabledGlobally pluginDesc config
   <> pluginFeatureEnabled feature pluginDesc config
-  <> pluginSupportsFileType msgParams pluginDesc
+  <> pluginSupportsFileType vfs msgParams pluginDesc
 
 -- | Check if a plugin is enabled, if one of it's specific configs is enabled,
 -- and if it's the plugin responsible for a resolve request.
-pluginEnabledResolve :: L.HasData_ s (Maybe Value) => (PluginConfig -> Bool) -> p -> s -> PluginDescriptor c -> Config -> HandleRequestResult
-pluginEnabledResolve feature _ msgParams pluginDesc config =
+pluginEnabledResolve :: L.HasData_ s (Maybe Value) => (PluginConfig -> Bool) -> VFS -> p -> s -> PluginDescriptor c -> Config -> HandleRequestResult
+pluginEnabledResolve feature _ _ msgParams pluginDesc config =
     pluginEnabledGlobally pluginDesc config
     <> pluginFeatureEnabled feature pluginDesc config
     <> pluginResolverResponsible msgParams pluginDesc
@@ -498,23 +505,23 @@ instance PluginMethod Request Method_CodeActionResolve where
   handlesRequest = pluginEnabledResolve plcCodeActionsOn
 
 instance PluginMethod Request Method_TextDocumentDefinition where
-  handlesRequest _ msgParams pluginDesc _ = pluginSupportsFileType msgParams pluginDesc
+  handlesRequest vfs _ msgParams pluginDesc _ = pluginSupportsFileType vfs msgParams pluginDesc
 
 instance PluginMethod Request Method_TextDocumentTypeDefinition where
-  handlesRequest _ msgParams pluginDesc _ = pluginSupportsFileType msgParams pluginDesc
+  handlesRequest vfs _ msgParams pluginDesc _ = pluginSupportsFileType vfs msgParams pluginDesc
 
 instance PluginMethod Request Method_TextDocumentImplementation where
-  handlesRequest _ msgParams pluginDesc _ = pluginSupportsFileType msgParams pluginDesc
+  handlesRequest vfs _ msgParams pluginDesc _ = pluginSupportsFileType vfs msgParams pluginDesc
 
 instance PluginMethod Request Method_TextDocumentDocumentHighlight where
-  handlesRequest _ msgParams pluginDesc _ = pluginSupportsFileType msgParams pluginDesc
+  handlesRequest vfs _ msgParams pluginDesc _ = pluginSupportsFileType vfs msgParams pluginDesc
 
 instance PluginMethod Request Method_TextDocumentReferences where
-  handlesRequest _ msgParams pluginDesc _ = pluginSupportsFileType msgParams pluginDesc
+  handlesRequest vfs _ msgParams pluginDesc _ = pluginSupportsFileType vfs msgParams pluginDesc
 
 instance PluginMethod Request Method_WorkspaceSymbol where
   -- Unconditionally enabled, but should it really be?
-  handlesRequest _ _ _ _ = HandlesRequest
+  handlesRequest _ _ _ _ _ = HandlesRequest
 
 instance PluginMethod Request Method_TextDocumentInlayHint where
   handlesRequest = pluginEnabledWithFeature plcInlayHintsOn
@@ -549,22 +556,22 @@ instance PluginMethod Request Method_TextDocumentCompletion where
   handlesRequest = pluginEnabledWithFeature plcCompletionOn
 
 instance PluginMethod Request Method_TextDocumentFormatting where
-  handlesRequest _ msgParams pluginDesc conf =
+  handlesRequest vfs _ msgParams pluginDesc conf =
     (if PluginId (formattingProvider conf) == pid
           || PluginId (cabalFormattingProvider conf) == pid
         then HandlesRequest
         else DoesNotHandleRequest (NotFormattingProvider (formattingProvider conf)) )
-    <> pluginSupportsFileType msgParams pluginDesc
+    <> pluginSupportsFileType vfs msgParams pluginDesc
     where
       pid = pluginId pluginDesc
 
 instance PluginMethod Request Method_TextDocumentRangeFormatting where
-  handlesRequest _ msgParams pluginDesc conf =
+  handlesRequest vfs _ msgParams pluginDesc conf =
     (if PluginId (formattingProvider conf) == pid
           || PluginId (cabalFormattingProvider conf) == pid
         then HandlesRequest
         else DoesNotHandleRequest (NotFormattingProvider (formattingProvider conf)))
-    <> pluginSupportsFileType msgParams pluginDesc
+    <> pluginSupportsFileType vfs msgParams pluginDesc
     where
       pid = pluginId pluginDesc
 
@@ -585,21 +592,21 @@ instance PluginMethod Request Method_TextDocumentFoldingRange where
 
 instance PluginMethod Request Method_CallHierarchyIncomingCalls where
   -- This method has no URI parameter, thus no call to 'pluginResponsible'
-  handlesRequest _ _ pluginDesc conf =
+  handlesRequest _ _ _ pluginDesc conf =
       pluginEnabledGlobally pluginDesc conf
     <> pluginFeatureEnabled plcCallHierarchyOn pluginDesc conf
 
 instance PluginMethod Request Method_CallHierarchyOutgoingCalls where
   -- This method has no URI parameter, thus no call to 'pluginResponsible'
-  handlesRequest _ _ pluginDesc conf =
+  handlesRequest _ _ _ pluginDesc conf =
       pluginEnabledGlobally pluginDesc conf
     <> pluginFeatureEnabled plcCallHierarchyOn pluginDesc conf
 
 instance PluginMethod Request Method_WorkspaceExecuteCommand where
-  handlesRequest _ _ _ _= HandlesRequest
+  handlesRequest _ _ _ _ _ = HandlesRequest
 
 instance PluginMethod Request (Method_CustomMethod m) where
-  handlesRequest _ _ _ _ = HandlesRequest
+  handlesRequest _ _ _ _ _ = HandlesRequest
 
 -- Plugin Notifications
 
@@ -613,19 +620,19 @@ instance PluginMethod Notification Method_TextDocumentDidClose where
 
 instance PluginMethod Notification Method_WorkspaceDidChangeWatchedFiles where
   -- This method has no URI parameter, thus no call to 'pluginResponsible'.
-  handlesRequest _ _ desc conf = pluginEnabledGlobally desc conf
+  handlesRequest _ _ _ desc conf = pluginEnabledGlobally desc conf
 
 instance PluginMethod Notification Method_WorkspaceDidChangeWorkspaceFolders where
   -- This method has no URI parameter, thus no call to 'pluginResponsible'.
-  handlesRequest _ _ desc conf = pluginEnabledGlobally desc conf
+  handlesRequest _ _ _ desc conf = pluginEnabledGlobally desc conf
 
 instance PluginMethod Notification Method_WorkspaceDidChangeConfiguration where
   -- This method has no URI parameter, thus no call to 'pluginResponsible'.
-  handlesRequest _ _ desc conf = pluginEnabledGlobally desc conf
+  handlesRequest _ _ _ desc conf = pluginEnabledGlobally desc conf
 
 instance PluginMethod Notification Method_Initialized where
   -- This method has no URI parameter, thus no call to 'pluginResponsible'.
-  handlesRequest _ _ desc conf = pluginEnabledGlobally desc conf
+  handlesRequest _ _ _ desc conf = pluginEnabledGlobally desc conf
 
 
 -- ---------------------------------------------------------------------
@@ -1054,7 +1061,7 @@ defaultPluginDescriptor plId desc =
     mempty
     mempty
     Nothing
-    [".hs", ".lhs", ".hs-boot"]
+    [J.LanguageKind_Haskell, J.LanguageKind_Custom "literate haskell"]
 
 -- | Set up a plugin descriptor, initialized with default values.
 -- This plugin descriptor is prepared for @.cabal@ files and as such,
@@ -1075,7 +1082,7 @@ defaultCabalPluginDescriptor plId desc =
     mempty
     mempty
     Nothing
-    [".cabal"]
+    [J.LanguageKind_Custom "cabal"]
 
 newtype CommandId = CommandId T.Text
   deriving (Show, Read, Eq, Ord)
@@ -1251,6 +1258,20 @@ mkLspCmdId pid (PluginId plid) (CommandId cid)
 getPid :: IO T.Text
 getPid = T.pack . show <$> getProcessID
 
+getVirtualFileFromVFS :: VFS -> NormalizedUri -> Maybe VirtualFile
+getVirtualFileFromVFS (VFS vfs) uri =
+  case Map.lookup uri vfs of
+    Just (Open x)   -> Just x
+    Just (Closed _) -> Nothing
+    Nothing         -> Nothing
+
+getVirtualFileFromVFSIncludingClosed :: VFS -> NormalizedUri -> Maybe VirtualFileEntry
+getVirtualFileFromVFSIncludingClosed (VFS vfs) uri =
+  case Map.lookup uri vfs of
+    Just x  -> Just x
+    Nothing -> Nothing
+
+
 getProcessID :: IO Int
 installSigUsr1Handler :: IO () -> IO ()
 

plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs

@@ -22,6 +22,7 @@ import           Ide.Plugin.SemanticTokens.Types
 import           Ide.Types
 import qualified Language.LSP.Protocol.Lens         as L
 import           Language.LSP.Protocol.Types
+import qualified Language.LSP.Protocol.Types        as J
 import qualified Language.LSP.Test                  as Test
 import           Language.LSP.VFS                   (VirtualFile (..))
 import           System.FilePath
@@ -90,7 +91,7 @@ docLspSemanticTokensString :: (HasCallStack) => TextDocumentIdentifier -> Sessio
 docLspSemanticTokensString doc = do
   res <- Test.getSemanticTokens doc
   textContent <- documentContents doc
-  let vfs = VirtualFile 0 0 (Rope.fromText textContent)
+  let vfs = VirtualFile 0 0 (Rope.fromText textContent) $ Just J.LanguageKind_Haskell
   case res ^? Language.LSP.Protocol.Types._L of
     Just tokens -> do
       either (error . show) pure $ recoverLspSemanticTokens vfs tokens