From 43796d0e6f8348b36b0da239503f4675bb06e597 Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 13 Feb 2024 20:13:07 +0800 Subject: [PATCH 01/25] add Method_TextDocumentSemanticTokensFullDelta --- ghcide/src/Development/IDE/Core/Shake.hs | 6 ++ haskell-language-server.cabal | 2 + hls-plugin-api/src/Ide/Plugin/ConfigUtils.hs | 2 + hls-plugin-api/src/Ide/Types.hs | 6 ++ .../src/Ide/Plugin/SemanticTokens.hs | 4 +- .../src/Ide/Plugin/SemanticTokens/Internal.hs | 61 +++++++++++++++++-- .../src/Ide/Plugin/SemanticTokens/Query.hs | 25 ++++++-- 7 files changed, 94 insertions(+), 12 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 74747e66d6..12516b42a6 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -164,6 +164,7 @@ import Language.LSP.Diagnostics import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types +import Language.LSP.Protocol.Types (SemanticTokens) import qualified Language.LSP.Protocol.Types as LSP import qualified Language.LSP.Server as LSP import Language.LSP.VFS hiding (start) @@ -243,6 +244,7 @@ data HieDbWriter -- with (currently) retry functionality type IndexQueue = TQueue (((HieDb -> IO ()) -> IO ()) -> IO ()) + -- information we stash inside the shakeExtra field data ShakeExtras = ShakeExtras { --eventer :: LSP.FromServerMessage -> IO () @@ -257,6 +259,8 @@ data ShakeExtras = ShakeExtras ,diagnostics :: STMDiagnosticStore ,hiddenDiagnostics :: STMDiagnosticStore ,publishedDiagnostics :: STM.Map NormalizedUri [Diagnostic] + ,semanticTokensCache:: STM.Map NormalizedUri SemanticTokens + ,semanticTokensId :: TVar Int -- ^ This represents the set of diagnostics that we have published. -- Due to debouncing not every change might get published. ,positionMapping :: STM.Map NormalizedUri (EnumMap Int32 (PositionDelta, PositionMapping)) @@ -616,12 +620,14 @@ shakeOpen recorder lspEnv defaultConfig idePlugins logger debouncer diagnostics <- STM.newIO hiddenDiagnostics <- STM.newIO publishedDiagnostics <- STM.newIO + semanticTokensCache <- STM.newIO positionMapping <- STM.newIO knownTargetsVar <- newTVarIO $ hashed HMap.empty let restartShakeSession = shakeRestart recorder ideState persistentKeys <- newTVarIO mempty indexPending <- newTVarIO HMap.empty indexCompleted <- newTVarIO 0 + semanticTokensId <- newTVarIO 0 indexProgressToken <- newVar Nothing let hiedbWriter = HieDbWriter{..} exportsMap <- newTVarIO mempty diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 1284ec438b..1e2e42f66c 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -1574,6 +1574,8 @@ library hls-semantic-tokens-plugin , hls-graph == 2.6.0.0 , template-haskell , data-default + , stm + , stm-containers default-extensions: DataKinds diff --git a/hls-plugin-api/src/Ide/Plugin/ConfigUtils.hs b/hls-plugin-api/src/Ide/Plugin/ConfigUtils.hs index 9c1c592fd2..1dbc97a202 100644 --- a/hls-plugin-api/src/Ide/Plugin/ConfigUtils.hs +++ b/hls-plugin-api/src/Ide/Plugin/ConfigUtils.hs @@ -94,6 +94,7 @@ pluginsToDefaultConfig IdePlugins {..} = SMethod_TextDocumentCompletion -> ["completionOn" A..= plcCompletionOn] SMethod_TextDocumentPrepareCallHierarchy -> ["callHierarchyOn" A..= plcCallHierarchyOn] SMethod_TextDocumentSemanticTokensFull -> ["semanticTokensOn" A..= plcSemanticTokensOn] + SMethod_TextDocumentSemanticTokensFullDelta -> ["semanticTokensOn" A..= plcSemanticTokensOn] _ -> [] -- | Generates json schema used in haskell vscode extension @@ -125,6 +126,7 @@ pluginsToVSCodeExtensionSchema IdePlugins {..} = A.object $ mconcat $ singlePlug SMethod_TextDocumentCompletion -> [toKey' "completionOn" A..= schemaEntry "completions" plcCompletionOn] SMethod_TextDocumentPrepareCallHierarchy -> [toKey' "callHierarchyOn" A..= schemaEntry "call hierarchy" plcCallHierarchyOn] SMethod_TextDocumentSemanticTokensFull -> [toKey' "semanticTokensOn" A..= schemaEntry "semantic tokens" plcSemanticTokensOn] + SMethod_TextDocumentSemanticTokensFullDelta -> [toKey' "semanticTokensOn" A..= schemaEntry "semantic tokens" plcSemanticTokensOn] _ -> [] schemaEntry desc defaultVal = A.object diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index 62552e7e05..c6fd8741a3 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -511,6 +511,9 @@ instance PluginMethod Request Method_TextDocumentRangeFormatting where instance PluginMethod Request Method_TextDocumentSemanticTokensFull where handlesRequest = pluginEnabledWithFeature plcSemanticTokensOn +instance PluginMethod Request Method_TextDocumentSemanticTokensFullDelta where + handlesRequest = pluginEnabledWithFeature plcSemanticTokensOn + instance PluginMethod Request Method_TextDocumentPrepareCallHierarchy where handlesRequest = pluginEnabledWithFeature plcCallHierarchyOn @@ -751,6 +754,9 @@ instance PluginRequestMethod (Method_CustomMethod m) where instance PluginRequestMethod Method_TextDocumentSemanticTokensFull where combineResponses _ _ _ _ (x :| _) = x +instance PluginRequestMethod Method_TextDocumentSemanticTokensFullDelta where + combineResponses _ _ _ _ (x :| _) = x + takeLefts :: [a |? b] -> [a] takeLefts = mapMaybe (\x -> [res | (InL res) <- Just x]) diff --git a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens.hs b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens.hs index 41708d30c2..622acb0c3a 100644 --- a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens.hs +++ b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens.hs @@ -12,7 +12,9 @@ import Language.LSP.Protocol.Message descriptor :: Recorder (WithPriority SemanticLog) -> PluginId -> PluginDescriptor IdeState descriptor recorder plId = (defaultPluginDescriptor plId "Provides semantic tokens") - { Ide.Types.pluginHandlers = mkPluginHandler SMethod_TextDocumentSemanticTokensFull (Internal.semanticTokensFull recorder), + { Ide.Types.pluginHandlers = + mkPluginHandler SMethod_TextDocumentSemanticTokensFull (Internal.semanticTokensFull recorder) + <> mkPluginHandler SMethod_TextDocumentSemanticTokensFullDelta (Internal.semanticTokensFullDelta recorder), Ide.Types.pluginRules = Internal.getSemanticTokensRule recorder <> Internal.persistentGetSemanticTokensRule, pluginConfigDescriptor = defaultConfigDescriptor diff --git a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs index 3b87c0f336..88c9b9ff90 100644 --- a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs +++ b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs @@ -10,19 +10,27 @@ -- | -- This module provides the core functionality of the plugin. -module Ide.Plugin.SemanticTokens.Internal (semanticTokensFull, getSemanticTokensRule, persistentGetSemanticTokensRule, semanticConfigProperties) where +module Ide.Plugin.SemanticTokens.Internal (semanticTokensFull, getSemanticTokensRule, persistentGetSemanticTokensRule, semanticConfigProperties, semanticTokensFullDelta) where +import Control.Concurrent.STM (modifyTVar', + readTVar) +import Control.Concurrent.STM.Stats (atomically) import Control.Lens ((^.)) import Control.Monad.Except (ExceptT, liftEither, withExceptT) +import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Trans (lift) import Control.Monad.Trans.Except (runExceptT) import qualified Data.Map.Strict as M +import Data.Text (Text) +import qualified Data.Text as T import Development.IDE (Action, GetDocMap (GetDocMap), GetHieAst (GetHieAst), HieAstResult (HAR, hieAst, hieModule, refMap), IdeResult, IdeState, + NormalizedUri, + Pretty (pretty), Priority (..), Recorder, Rules, WithPriority, @@ -34,7 +42,9 @@ import Development.IDE.Core.PluginUtils (runActionE, import Development.IDE.Core.PositionMapping (idDelta) import Development.IDE.Core.Rules (toIdeResult) import Development.IDE.Core.RuleTypes (DocAndTyThingMap (..)) -import Development.IDE.Core.Shake (addPersistentRule, +import Development.IDE.Core.Shake (ShakeExtras (..), + addPersistentRule, + getShakeExtras, getVirtualFile, useWithStale_) import Development.IDE.GHC.Compat hiding (Warning) @@ -51,11 +61,14 @@ import Ide.Plugin.SemanticTokens.Tokenize (computeRangeHsSemanti import Ide.Plugin.SemanticTokens.Types import Ide.Types import qualified Language.LSP.Protocol.Lens as L -import Language.LSP.Protocol.Message (Method (Method_TextDocumentSemanticTokensFull)) +import Language.LSP.Protocol.Message (MessageResult, + Method (Method_TextDocumentSemanticTokensFull, Method_TextDocumentSemanticTokensFullDelta)) import Language.LSP.Protocol.Types (NormalizedFilePath, SemanticTokens, - type (|?) (InL)) + normalizedFilePathToUri, + type (|?) (InL, InR)) import Prelude hiding (span) +import qualified StmContainers.Map as STM $mkSemanticConfigFunctions @@ -68,8 +81,9 @@ computeSemanticTokens :: Recorder (WithPriority SemanticLog) -> PluginId -> IdeS computeSemanticTokens recorder pid _ nfp = do config <- lift $ useSemanticConfigAction pid logWith recorder Debug (LogConfig config) + semanticId <- lift getAndIncreaseSemanticTokensId (RangeHsSemanticTokenTypes {rangeSemanticList}, mapping) <- useWithStaleE GetSemanticTokens nfp - withExceptT PluginInternalError $ liftEither $ rangeSemanticsSemanticTokens config mapping rangeSemanticList + withExceptT PluginInternalError $ liftEither $ rangeSemanticsSemanticTokens semanticId config mapping rangeSemanticList semanticTokensFull :: Recorder (WithPriority SemanticLog) -> PluginMethodHandler IdeState 'Method_TextDocumentSemanticTokensFull semanticTokensFull recorder state pid param = do @@ -77,6 +91,43 @@ semanticTokensFull recorder state pid param = do items <- runActionE "SemanticTokens.semanticTokensFull" state $ computeSemanticTokens recorder pid state nfp return $ InL items +getAndIncreaseSemanticTokensId :: Action Text +getAndIncreaseSemanticTokensId = do + ShakeExtras{semanticTokensId} <- getShakeExtras + liftIO $ atomically $ do + i <- readTVar semanticTokensId + modifyTVar' semanticTokensId (+1) + return $ T.pack $ show i + +getPreviousSemanticTokens :: NormalizedUri -> Action (Maybe SemanticTokens) +getPreviousSemanticTokens uri = getShakeExtras >>= liftIO . atomically . STM.lookup uri . semanticTokensCache + +setSemanticTokens :: NormalizedUri -> SemanticTokens -> Action () +setSemanticTokens uri tokens = getShakeExtras >>= liftIO . atomically . STM.insert tokens uri . semanticTokensCache + +computeSemanticTokensFullDelta :: Text -> Recorder (WithPriority SemanticLog) -> PluginId -> IdeState -> NormalizedFilePath -> ExceptT PluginError Action (MessageResult Method_TextDocumentSemanticTokensFullDelta) +computeSemanticTokensFullDelta previousVersionFromParam recorder pid state nfp = do + semanticTokens <- computeSemanticTokens recorder pid state nfp + previousSemanticTokensMaybe <- lift $ getPreviousSemanticTokens (normalizedFilePathToUri nfp) + lift $ setSemanticTokens (normalizedFilePathToUri nfp) semanticTokens + case previousSemanticTokensMaybe of + Nothing -> return $ InL semanticTokens + Just previousSemanticTokens -> + if Just previousVersionFromParam == previousSemanticTokens^.L.resultId + then + do + let delta = makeSemanticTokensDeltaWithId (semanticTokens^.L.resultId) previousSemanticTokens semanticTokens + logWith recorder Info (LogMsg "SemanticTokensDelta:") + logWith recorder Info (LogMsg $ show $ pretty delta) + return $ InR $ InL delta + else return $ InL semanticTokens + +semanticTokensFullDelta :: Recorder (WithPriority SemanticLog) -> PluginMethodHandler IdeState 'Method_TextDocumentSemanticTokensFullDelta +semanticTokensFullDelta recorder state pid param = do + nfp <- getNormalizedFilePathE (param ^. L.textDocument . L.uri) + let previousVersionFromParam = param ^. L.previousResultId + runActionE "SemanticTokens.semanticTokensFullDelta" state $ computeSemanticTokensFullDelta previousVersionFromParam recorder pid state nfp + -- | Defines the 'getSemanticTokensRule' function, compute semantic tokens for a Haskell source file. -- -- This Rule collects information from various sources, including: diff --git a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Query.hs b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Query.hs index b0d26c5e87..7d810dc4e4 100644 --- a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Query.hs +++ b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Query.hs @@ -11,6 +11,7 @@ import qualified Data.Map.Strict as M import Data.Maybe (listToMaybe, mapMaybe) import qualified Data.Set as Set import Data.Text (Text) +import qualified Data.Text as T import Development.IDE.Core.PositionMapping (PositionMapping, toCurrentRange) import Development.IDE.GHC.Compat @@ -22,9 +23,11 @@ import Ide.Plugin.SemanticTokens.Types (HieFunMaskKind, import Language.LSP.Protocol.Types (Position (Position), Range (Range), SemanticTokenAbsolute (SemanticTokenAbsolute), - SemanticTokens, + SemanticTokens (SemanticTokens), + SemanticTokensDelta (SemanticTokensDelta), defaultSemanticTokensLegend, - makeSemanticTokens) + makeSemanticTokens, + makeSemanticTokensDelta) import Prelude hiding (length, span) --------------------------------------------------------- @@ -67,10 +70,9 @@ nameSemanticFromHie hieKind rm n = do ------------------------------------------------- -rangeSemanticsSemanticTokens :: SemanticTokensConfig -> PositionMapping -> RangeSemanticTokenTypeList -> Either Text SemanticTokens -rangeSemanticsSemanticTokens stc mapping = - makeSemanticTokens defaultSemanticTokensLegend - . mapMaybe (\(ran, tk) -> toAbsSemanticToken <$> toCurrentRange mapping ran <*> return tk) +rangeSemanticsSemanticTokens :: Text -> SemanticTokensConfig -> PositionMapping -> RangeSemanticTokenTypeList -> Either Text SemanticTokens +rangeSemanticsSemanticTokens sid stc mapping = + makeSemanticTokensWithId (Just sid) . mapMaybe (\(ran, tk) -> toAbsSemanticToken <$> toCurrentRange mapping ran <*> return tk) where toAbsSemanticToken :: Range -> HsSemanticTokenType -> SemanticTokenAbsolute toAbsSemanticToken (Range (Position startLine startColumn) (Position _endLine endColumn)) tokenType = @@ -81,3 +83,14 @@ rangeSemanticsSemanticTokens stc mapping = (fromIntegral len) (toLspTokenType stc tokenType) [] + +makeSemanticTokensWithId :: Maybe Text -> [SemanticTokenAbsolute] -> Either Text SemanticTokens +makeSemanticTokensWithId sid tokens = do + (SemanticTokens _ tokens) <- makeSemanticTokens defaultSemanticTokensLegend tokens + return $ SemanticTokens sid tokens + +makeSemanticTokensDeltaWithId :: Maybe Text -> SemanticTokens -> SemanticTokens -> SemanticTokensDelta +makeSemanticTokensDeltaWithId sid previousTokens currentTokens = do + let (SemanticTokensDelta _ stEdits) = makeSemanticTokensDelta previousTokens currentTokens + in SemanticTokensDelta sid stEdits + From 3f290073362cbc2b196ceee6eb6fdb631845c014 Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 13 Feb 2024 20:49:31 +0800 Subject: [PATCH 02/25] fix cache and add test --- .../src/Ide/Plugin/SemanticTokens/Internal.hs | 80 +++++++++++-------- .../hls-semantic-tokens-plugin/test/Main.hs | 52 +++++++++--- 2 files changed, 88 insertions(+), 44 deletions(-) diff --git a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs index 88c9b9ff90..7a01e28fc6 100644 --- a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs +++ b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs @@ -86,47 +86,39 @@ computeSemanticTokens recorder pid _ nfp = do withExceptT PluginInternalError $ liftEither $ rangeSemanticsSemanticTokens semanticId config mapping rangeSemanticList semanticTokensFull :: Recorder (WithPriority SemanticLog) -> PluginMethodHandler IdeState 'Method_TextDocumentSemanticTokensFull -semanticTokensFull recorder state pid param = do - nfp <- getNormalizedFilePathE (param ^. L.textDocument . L.uri) - items <- runActionE "SemanticTokens.semanticTokensFull" state $ computeSemanticTokens recorder pid state nfp - return $ InL items - -getAndIncreaseSemanticTokensId :: Action Text -getAndIncreaseSemanticTokensId = do - ShakeExtras{semanticTokensId} <- getShakeExtras - liftIO $ atomically $ do - i <- readTVar semanticTokensId - modifyTVar' semanticTokensId (+1) - return $ T.pack $ show i - -getPreviousSemanticTokens :: NormalizedUri -> Action (Maybe SemanticTokens) -getPreviousSemanticTokens uri = getShakeExtras >>= liftIO . atomically . STM.lookup uri . semanticTokensCache +semanticTokensFull recorder state pid param = runActionE "SemanticTokens.semanticTokensFull" state computeSemanticTokensFullDelta + where + computeSemanticTokensFullDelta :: ExceptT PluginError Action (MessageResult Method_TextDocumentSemanticTokensFull) + computeSemanticTokensFullDelta = do + nfp <- getNormalizedFilePathE (param ^. L.textDocument . L.uri) + items <- computeSemanticTokens recorder pid state nfp + lift $ setSemanticTokens (normalizedFilePathToUri nfp) items + return $ InL items -setSemanticTokens :: NormalizedUri -> SemanticTokens -> Action () -setSemanticTokens uri tokens = getShakeExtras >>= liftIO . atomically . STM.insert tokens uri . semanticTokensCache - -computeSemanticTokensFullDelta :: Text -> Recorder (WithPriority SemanticLog) -> PluginId -> IdeState -> NormalizedFilePath -> ExceptT PluginError Action (MessageResult Method_TextDocumentSemanticTokensFullDelta) -computeSemanticTokensFullDelta previousVersionFromParam recorder pid state nfp = do - semanticTokens <- computeSemanticTokens recorder pid state nfp - previousSemanticTokensMaybe <- lift $ getPreviousSemanticTokens (normalizedFilePathToUri nfp) - lift $ setSemanticTokens (normalizedFilePathToUri nfp) semanticTokens - case previousSemanticTokensMaybe of - Nothing -> return $ InL semanticTokens - Just previousSemanticTokens -> - if Just previousVersionFromParam == previousSemanticTokens^.L.resultId - then - do - let delta = makeSemanticTokensDeltaWithId (semanticTokens^.L.resultId) previousSemanticTokens semanticTokens - logWith recorder Info (LogMsg "SemanticTokensDelta:") - logWith recorder Info (LogMsg $ show $ pretty delta) - return $ InR $ InL delta - else return $ InL semanticTokens semanticTokensFullDelta :: Recorder (WithPriority SemanticLog) -> PluginMethodHandler IdeState 'Method_TextDocumentSemanticTokensFullDelta semanticTokensFullDelta recorder state pid param = do nfp <- getNormalizedFilePathE (param ^. L.textDocument . L.uri) let previousVersionFromParam = param ^. L.previousResultId - runActionE "SemanticTokens.semanticTokensFullDelta" state $ computeSemanticTokensFullDelta previousVersionFromParam recorder pid state nfp + let semanticTokens = computeSemanticTokensFullDelta previousVersionFromParam recorder pid state nfp + runActionE "SemanticTokens.semanticTokensFullDelta" state semanticTokens + where + computeSemanticTokensFullDelta :: Text -> Recorder (WithPriority SemanticLog) -> PluginId -> IdeState -> NormalizedFilePath -> ExceptT PluginError Action (MessageResult Method_TextDocumentSemanticTokensFullDelta) + computeSemanticTokensFullDelta previousVersionFromParam recorder pid state nfp = do + semanticTokens <- computeSemanticTokens recorder pid state nfp + previousSemanticTokensMaybe <- lift $ getPreviousSemanticTokens (normalizedFilePathToUri nfp) + lift $ setSemanticTokens (normalizedFilePathToUri nfp) semanticTokens + case previousSemanticTokensMaybe of + Nothing -> return $ InL semanticTokens + Just previousSemanticTokens -> + if Just previousVersionFromParam == previousSemanticTokens^.L.resultId + then + do + let delta = makeSemanticTokensDeltaWithId (semanticTokens^.L.resultId) previousSemanticTokens semanticTokens + logWith recorder Info (LogMsg "SemanticTokensDelta:") + logWith recorder Info (LogMsg $ show $ pretty delta) + return $ InR $ InL delta + else return $ InL semanticTokens -- | Defines the 'getSemanticTokensRule' function, compute semantic tokens for a Haskell source file. -- @@ -164,3 +156,21 @@ handleError recorder action' = do logWith recorder Warning msg pure $ toIdeResult (Left []) Right value -> pure $ toIdeResult (Right value) + +----------------------- +-- helper functions +----------------------- + +getAndIncreaseSemanticTokensId :: Action Text +getAndIncreaseSemanticTokensId = do + ShakeExtras{semanticTokensId} <- getShakeExtras + liftIO $ atomically $ do + i <- readTVar semanticTokensId + modifyTVar' semanticTokensId (+1) + return $ T.pack $ show i + +getPreviousSemanticTokens :: NormalizedUri -> Action (Maybe SemanticTokens) +getPreviousSemanticTokens uri = getShakeExtras >>= liftIO . atomically . STM.lookup uri . semanticTokensCache + +setSemanticTokens :: NormalizedUri -> SemanticTokens -> Action () +setSemanticTokens uri tokens = getShakeExtras >>= liftIO . atomically . STM.insert tokens uri . semanticTokensCache diff --git a/plugins/hls-semantic-tokens-plugin/test/Main.hs b/plugins/hls-semantic-tokens-plugin/test/Main.hs index a2d7fde20a..4d7a0e0340 100644 --- a/plugins/hls-semantic-tokens-plugin/test/Main.hs +++ b/plugins/hls-semantic-tokens-plugin/test/Main.hs @@ -1,7 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} -import Control.Lens ((^?)) +import Control.Lens ((^.), (^?)) import Control.Monad.IO.Class (liftIO) import Data.Aeson (KeyValue (..), Object) import qualified Data.Aeson.KeyMap as KV @@ -13,7 +13,7 @@ import Data.Text hiding (length, map, unlines) import qualified Data.Text as Text import qualified Data.Text.Utf16.Rope.Mixed as Rope -import Development.IDE (Pretty) +import Development.IDE (Pretty (pretty)) import Development.IDE.GHC.Compat (GhcVersion (..), ghcVersion) import Development.IDE.Plugin.Test (WaitForIdeRuleResult (..)) @@ -22,15 +22,20 @@ import Ide.Plugin.SemanticTokens import Ide.Plugin.SemanticTokens.Mappings import Ide.Plugin.SemanticTokens.Types import Ide.Types +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Types import Language.LSP.Protocol.Types (SemanticTokenTypes (..), - _L) + SemanticTokensDeltaParams (SemanticTokensDeltaParams), + _L, type (|?) (InR)) import Language.LSP.Test (Session, SessionConfig (ignoreConfigurationRequests), - openDoc) + openDoc, request) import qualified Language.LSP.Test as Test import Language.LSP.VFS (VirtualFile (..)) import System.FilePath -import Test.Hls (PluginTestDescriptor, +import Test.Hls (HasCallStack, + PluginTestDescriptor, + SMethod (SMethod_TextDocumentSemanticTokensFull, SMethod_TextDocumentSemanticTokensFullDelta), TestName, TestTree, TextDocumentIdentifier, defaultTestRunner, @@ -91,7 +96,7 @@ docSemanticTokensString cf doc = do xs <- map (lspTokenHsToken cf) <$> docLspSemanticTokensString doc return $ unlines . map show $ xs -docLspSemanticTokensString :: TextDocumentIdentifier -> Session [SemanticTokenOriginal Language.LSP.Protocol.Types.SemanticTokenTypes] +docLspSemanticTokensString :: (HasCallStack) => TextDocumentIdentifier -> Session [SemanticTokenOriginal Language.LSP.Protocol.Types.SemanticTokenTypes] docLspSemanticTokensString doc = do res <- Test.getSemanticTokens doc textContent <- documentContents doc @@ -101,6 +106,20 @@ docLspSemanticTokensString doc = do either (error . show) pure $ recoverLspSemanticTokens vfs tokens _noTokens -> error "No tokens found" + +-- | Pass a param and return the response from `semanticTokensFull` +-- getSemanticTokensFullDelta :: TextDocumentIdentifier -> Session _ +getSemanticTokensFullDelta doc lastResultId = do + let params = SemanticTokensDeltaParams Nothing Nothing doc lastResultId + rsp <- request SMethod_TextDocumentSemanticTokensFullDelta params + case rsp ^. L.result of + Right x -> return x + _ -> error "No tokens found" + +-- docLspSemanticTokensFullDeltaString :: TextDocumentIdentifier -> Session [SemanticTokenOriginal Language.LSP.Protocol.Types.SemanticTokenTypes] +-- docLspSemanticTokensFullDeltaString doc = do +-- res <- Test.getSemanticTokens doc + semanticTokensClassTests :: TestTree semanticTokensClassTests = testGroup @@ -156,6 +175,22 @@ semanticTokensConfigTest = testGroup "semantic token config test" [ liftIO $ unlines (map show result1) @?= "2:1-3 SemanticTokenTypes_Variable \"go\"\n" ] +semanticTokensFullDeltaTests :: TestTree +semanticTokensFullDeltaTests = + testGroup "semanticTokensFullDeltaTests" $ + [ testCase "null delta since unchanged" $ do + let file1 = "TModulaš€bA.hs" + let expectDelta = InR (InL (SemanticTokensDelta (Just "1") [])) + Test.Hls.runSessionWithServerInTmpDir def semanticTokensPlugin (mkFs $ FS.directProjectMulti [file1]) $ do + doc1 <- openDoc file1 "haskell" + _ <- waitForAction "TypeCheck" doc1 + fullResult <- Test.getSemanticTokens doc1 + liftIO $ print fullResult + delta <- getSemanticTokensFullDelta doc1 "0" + liftIO $ delta @?= expectDelta + liftIO $ print delta + ] + semanticTokensTests :: TestTree semanticTokensTests = testGroup "other semantic Token test" $ @@ -174,8 +209,6 @@ semanticTokensTests = Right (WaitForIdeRuleResult _) -> return () Left _ -> error "TypeCheck2 failed" - - result <- docSemanticTokensString def doc2 let expect = unlines [ "3:8-18 TModule \"TModula\\66560bA\"" @@ -231,5 +264,6 @@ main = semanticTokensDataTypeTests, semanticTokensValuePatternTests, semanticTokensFunctionTests, - semanticTokensConfigTest + semanticTokensConfigTest, + semanticTokensFullDeltaTests ] From ff93475d56b646911056f2173bc33f00dec96a8d Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 13 Feb 2024 20:50:52 +0800 Subject: [PATCH 03/25] cleanpu --- .../src/Ide/Plugin/SemanticTokens/Internal.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs index 7a01e28fc6..ef7b84a9ed 100644 --- a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs +++ b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs @@ -100,8 +100,7 @@ semanticTokensFullDelta :: Recorder (WithPriority SemanticLog) -> PluginMethodHa semanticTokensFullDelta recorder state pid param = do nfp <- getNormalizedFilePathE (param ^. L.textDocument . L.uri) let previousVersionFromParam = param ^. L.previousResultId - let semanticTokens = computeSemanticTokensFullDelta previousVersionFromParam recorder pid state nfp - runActionE "SemanticTokens.semanticTokensFullDelta" state semanticTokens + runActionE "SemanticTokens.semanticTokensFullDelta" state $ computeSemanticTokensFullDelta previousVersionFromParam recorder pid state nfp where computeSemanticTokensFullDelta :: Text -> Recorder (WithPriority SemanticLog) -> PluginId -> IdeState -> NormalizedFilePath -> ExceptT PluginError Action (MessageResult Method_TextDocumentSemanticTokensFullDelta) computeSemanticTokensFullDelta previousVersionFromParam recorder pid state nfp = do From decd9e153eb65d70e00f8d0f0673bee8b6a7b030 Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 13 Feb 2024 21:50:40 +0800 Subject: [PATCH 04/25] add tset --- haskell-language-server.cabal | 4 ++- .../test/{Main.hs => SemanticTokensTest.hs} | 30 +++++++++++++++---- 2 files changed, 28 insertions(+), 6 deletions(-) rename plugins/hls-semantic-tokens-plugin/test/{Main.hs => SemanticTokensTest.hs} (90%) diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 1e2e42f66c..cdd57844df 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -1583,7 +1583,7 @@ test-suite hls-semantic-tokens-plugin-tests import: defaults, pedantic, test-defaults, warnings type: exitcode-stdio-1.0 hs-source-dirs: plugins/hls-semantic-tokens-plugin/test - main-is: Main.hs + main-is: SemanticTokensTest.hs build-depends: , aeson @@ -1603,6 +1603,8 @@ test-suite hls-semantic-tokens-plugin-tests , ghcide == 2.6.0.0 , hls-plugin-api == 2.6.0.0 , data-default + , directory + , row-types ----------------------------- -- HLS diff --git a/plugins/hls-semantic-tokens-plugin/test/Main.hs b/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs similarity index 90% rename from plugins/hls-semantic-tokens-plugin/test/Main.hs rename to plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs index 4d7a0e0340..8d6f7aaaac 100644 --- a/plugins/hls-semantic-tokens-plugin/test/Main.hs +++ b/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} import Control.Lens ((^.), (^?)) @@ -14,6 +15,9 @@ import Data.Text hiding (length, map, import qualified Data.Text as Text import qualified Data.Text.Utf16.Rope.Mixed as Rope import Development.IDE (Pretty (pretty)) + +import Data.Row ((.==)) +import Data.Row.Records ((.+)) import Development.IDE.GHC.Compat (GhcVersion (..), ghcVersion) import Development.IDE.Plugin.Test (WaitForIdeRuleResult (..)) @@ -24,9 +28,6 @@ import Ide.Plugin.SemanticTokens.Types import Ide.Types import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Types -import Language.LSP.Protocol.Types (SemanticTokenTypes (..), - SemanticTokensDeltaParams (SemanticTokensDeltaParams), - _L, type (|?) (InR)) import Language.LSP.Test (Session, SessionConfig (ignoreConfigurationRequests), openDoc, request) @@ -35,9 +36,9 @@ import Language.LSP.VFS (VirtualFile (..)) import System.FilePath import Test.Hls (HasCallStack, PluginTestDescriptor, - SMethod (SMethod_TextDocumentSemanticTokensFull, SMethod_TextDocumentSemanticTokensFullDelta), + SMethod (SMethod_TextDocumentSemanticTokensFullDelta), TestName, TestTree, - TextDocumentIdentifier, + changeDoc, defaultTestRunner, documentContents, fullCaps, goldenGitDiff, @@ -188,7 +189,26 @@ semanticTokensFullDeltaTests = liftIO $ print fullResult delta <- getSemanticTokensFullDelta doc1 "0" liftIO $ delta @?= expectDelta + + , testCase "add tokens" $ do + let file1 = "TModulaš€bA.hs" + let expectDelta = InR (InL (SemanticTokensDelta (Just "1") [SemanticTokensEdit 20 0 (Just [2,0,3,8,0])])) + -- r c l t m + -- where r = row, c = column, l = length, t = token, m = modifier + Test.Hls.runSessionWithServerInTmpDir def semanticTokensPlugin (mkFs $ FS.directProjectMulti [file1]) $ do + doc1 <- openDoc file1 "haskell" + _ <- waitForAction "TypeCheck" doc1 + _ <- Test.getSemanticTokens doc1 + -- open the file and append a line to it + let change = TextDocumentContentChangeEvent + $ InL $ #range .== Range (Position 4 0) (Position 4 6) + .+ #rangeLength .== Nothing + .+ #text .== "foo = 1" + changeDoc doc1 [change] + _ <- waitForAction "TypeCheck" doc1 + delta <- getSemanticTokensFullDelta doc1 "0" liftIO $ print delta + liftIO $ delta @?= expectDelta ] semanticTokensTests :: TestTree From e1fd84ec01911a4b8aaf4489442f9a34b73ba504 Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 13 Feb 2024 21:55:12 +0800 Subject: [PATCH 05/25] add delete tokens test --- .../test/SemanticTokensTest.hs | 19 +++++++++++++++++++ 1 file changed, 19 insertions(+) diff --git a/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs b/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs index 8d6f7aaaac..95f21c9fe9 100644 --- a/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs +++ b/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs @@ -209,6 +209,25 @@ semanticTokensFullDeltaTests = delta <- getSemanticTokensFullDelta doc1 "0" liftIO $ print delta liftIO $ delta @?= expectDelta + + , testCase "remove tokens" $ do + let file1 = "TModulaš€bA.hs" + let expectDelta = InR (InL (SemanticTokensDelta (Just "1") [SemanticTokensEdit 0 20 (Just [])])) + -- delete all tokens + Test.Hls.runSessionWithServerInTmpDir def semanticTokensPlugin (mkFs $ FS.directProjectMulti [file1]) $ do + doc1 <- openDoc file1 "haskell" + _ <- waitForAction "TypeCheck" doc1 + _ <- Test.getSemanticTokens doc1 + -- open the file and append a line to it + let change = TextDocumentContentChangeEvent + $ InL $ #range .== Range (Position 2 0) (Position 2 28) + .+ #rangeLength .== Nothing + .+ #text .== Text.replicate 28 " " + changeDoc doc1 [change] + _ <- waitForAction "TypeCheck" doc1 + delta <- getSemanticTokensFullDelta doc1 "0" + liftIO $ print delta + liftIO $ delta @?= expectDelta ] semanticTokensTests :: TestTree From 41499b41eac961f80e40144b7cb0df19c2669279 Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 13 Feb 2024 22:20:34 +0800 Subject: [PATCH 06/25] clean up --- .../src/Ide/Plugin/SemanticTokens/Query.hs | 11 +++-------- 1 file changed, 3 insertions(+), 8 deletions(-) diff --git a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Query.hs b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Query.hs index 7d810dc4e4..188a34e119 100644 --- a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Query.hs +++ b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Query.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE OverloadedRecordDot #-} -{-# LANGUAGE OverloadedStrings #-} - -- | -- The query module is used to query the semantic tokens from the AST module Ide.Plugin.SemanticTokens.Query where @@ -11,7 +8,6 @@ import qualified Data.Map.Strict as M import Data.Maybe (listToMaybe, mapMaybe) import qualified Data.Set as Set import Data.Text (Text) -import qualified Data.Text as T import Development.IDE.Core.PositionMapping (PositionMapping, toCurrentRange) import Development.IDE.GHC.Compat @@ -50,8 +46,7 @@ idSemantic tyThingMap hieKind rm (Right n) = --------------------------------------------------------- nameSemanticFromHie :: forall a. HieFunMaskKind a -> RefMap a -> Name -> Maybe HsSemanticTokenType -nameSemanticFromHie hieKind rm n = do - idSemanticFromRefMap rm (Right n) +nameSemanticFromHie hieKind rm n = idSemanticFromRefMap rm (Right n) where idSemanticFromRefMap :: RefMap a -> Identifier -> Maybe HsSemanticTokenType idSemanticFromRefMap rm' name' = do @@ -90,7 +85,7 @@ makeSemanticTokensWithId sid tokens = do return $ SemanticTokens sid tokens makeSemanticTokensDeltaWithId :: Maybe Text -> SemanticTokens -> SemanticTokens -> SemanticTokensDelta -makeSemanticTokensDeltaWithId sid previousTokens currentTokens = do +makeSemanticTokensDeltaWithId sid previousTokens currentTokens = let (SemanticTokensDelta _ stEdits) = makeSemanticTokensDelta previousTokens currentTokens - in SemanticTokensDelta sid stEdits + in SemanticTokensDelta sid stEdits From 9b373f3f6ec7b01305228809a21fa2f5e3e4e045 Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 13 Feb 2024 22:26:38 +0800 Subject: [PATCH 07/25] clean up --- .../src/Ide/Plugin/SemanticTokens/Internal.hs | 7 +------ .../src/Ide/Plugin/SemanticTokens/Query.hs | 2 +- 2 files changed, 2 insertions(+), 7 deletions(-) diff --git a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs index ef7b84a9ed..e156dd89ae 100644 --- a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs +++ b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs @@ -111,12 +111,7 @@ semanticTokensFullDelta recorder state pid param = do Nothing -> return $ InL semanticTokens Just previousSemanticTokens -> if Just previousVersionFromParam == previousSemanticTokens^.L.resultId - then - do - let delta = makeSemanticTokensDeltaWithId (semanticTokens^.L.resultId) previousSemanticTokens semanticTokens - logWith recorder Info (LogMsg "SemanticTokensDelta:") - logWith recorder Info (LogMsg $ show $ pretty delta) - return $ InR $ InL delta + then return $ InR $ InL $ makeSemanticTokensDeltaWithId (semanticTokens^.L.resultId) previousSemanticTokens semanticTokens else return $ InL semanticTokens -- | Defines the 'getSemanticTokensRule' function, compute semantic tokens for a Haskell source file. diff --git a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Query.hs b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Query.hs index 188a34e119..cbe2907a19 100644 --- a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Query.hs +++ b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Query.hs @@ -79,7 +79,7 @@ rangeSemanticsSemanticTokens sid stc mapping = (toLspTokenType stc tokenType) [] -makeSemanticTokensWithId :: Maybe Text -> [SemanticTokenAbsolute] -> Either Text SemanticTokens +makeSemanticTokensWithId :: Maybe Text -> [SemanticTokenAbsolute] -> Either Text SemanticTokens makeSemanticTokensWithId sid tokens = do (SemanticTokens _ tokens) <- makeSemanticTokens defaultSemanticTokensLegend tokens return $ SemanticTokens sid tokens From 4f7546af17054900102401cd6a999c0e132cdef4 Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 13 Feb 2024 22:28:16 +0800 Subject: [PATCH 08/25] add delete tokens test --- .../src/Ide/Plugin/SemanticTokens/Internal.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs index e156dd89ae..c833957b61 100644 --- a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs +++ b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs @@ -30,7 +30,6 @@ import Development.IDE (Action, HieAstResult (HAR, hieAst, hieModule, refMap), IdeResult, IdeState, NormalizedUri, - Pretty (pretty), Priority (..), Recorder, Rules, WithPriority, From 8af3b993ddfe4bce9b47488369fec007d1a9ced5 Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 13 Feb 2024 22:28:37 +0800 Subject: [PATCH 09/25] cleanup --- .../src/Ide/Plugin/SemanticTokens.hs | 2 +- .../src/Ide/Plugin/SemanticTokens/Mappings.hs | 2 +- .../src/Ide/Plugin/SemanticTokens/Utils.hs | 5 ++--- .../hls-semantic-tokens-plugin/test/SemanticTokensTest.hs | 2 +- 4 files changed, 5 insertions(+), 6 deletions(-) diff --git a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens.hs b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens.hs index 622acb0c3a..0d8dca9636 100644 --- a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens.hs +++ b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens.hs @@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} + module Ide.Plugin.SemanticTokens (descriptor) where diff --git a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Mappings.hs b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Mappings.hs index 1d7c51fd47..d9bfc4449d 100644 --- a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Mappings.hs +++ b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Mappings.hs @@ -1,7 +1,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} + -- | -- This module provides mappings to convert token type information in the Haskell IDE plugin. It includes functions for: diff --git a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Utils.hs b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Utils.hs index d88f5054cc..52cd56a21f 100644 --- a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Utils.hs +++ b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Utils.hs @@ -1,6 +1,5 @@ -{-# LANGUAGE OverloadedRecordDot #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wno-orphans #-} diff --git a/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs b/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs index 95f21c9fe9..8687a15593 100644 --- a/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs +++ b/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs @@ -14,7 +14,7 @@ import Data.Text hiding (length, map, unlines) import qualified Data.Text as Text import qualified Data.Text.Utf16.Rope.Mixed as Rope -import Development.IDE (Pretty (pretty)) +import Development.IDE (Pretty) import Data.Row ((.==)) import Data.Row.Records ((.+)) From 181b10ac9b2a128ccb81ff9fb13f9e593c21de26 Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 13 Feb 2024 22:45:32 +0800 Subject: [PATCH 10/25] fix test --- plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs b/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs index 8687a15593..6575184527 100644 --- a/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs +++ b/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs @@ -110,6 +110,7 @@ docLspSemanticTokensString doc = do -- | Pass a param and return the response from `semanticTokensFull` -- getSemanticTokensFullDelta :: TextDocumentIdentifier -> Session _ +getSemanticTokensFullDelta :: TextDocumentIdentifier -> Text -> Session (SemanticTokens |? (SemanticTokensDelta |? Null)) getSemanticTokensFullDelta doc lastResultId = do let params = SemanticTokensDeltaParams Nothing Nothing doc lastResultId rsp <- request SMethod_TextDocumentSemanticTokensFullDelta params From 9e7af72ab12a5e753bab4e1467bb48cf53345f70 Mon Sep 17 00:00:00 2001 From: Patrick Date: Wed, 14 Feb 2024 02:27:51 +0800 Subject: [PATCH 11/25] cleanup --- ghcide/src/Development/IDE/Core/Shake.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 12516b42a6..d6dc8cc622 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -259,10 +259,10 @@ data ShakeExtras = ShakeExtras ,diagnostics :: STMDiagnosticStore ,hiddenDiagnostics :: STMDiagnosticStore ,publishedDiagnostics :: STM.Map NormalizedUri [Diagnostic] - ,semanticTokensCache:: STM.Map NormalizedUri SemanticTokens - ,semanticTokensId :: TVar Int -- ^ This represents the set of diagnostics that we have published. -- Due to debouncing not every change might get published. + ,semanticTokensCache:: STM.Map NormalizedUri SemanticTokens + ,semanticTokensId :: TVar Int ,positionMapping :: STM.Map NormalizedUri (EnumMap Int32 (PositionDelta, PositionMapping)) -- ^ Map from a text document version to a PositionMapping that describes how to map -- positions in a version of that document to positions in the latest version From cef51ed37e7959bb10b6ed772c3855532291b10b Mon Sep 17 00:00:00 2001 From: Patrick Date: Wed, 14 Feb 2024 20:57:03 +0800 Subject: [PATCH 12/25] remove persistentGetSemanticTokensRule --- .../src/Ide/Plugin/SemanticTokens.hs | 2 +- .../src/Ide/Plugin/SemanticTokens/Internal.hs | 3 --- 2 files changed, 1 insertion(+), 4 deletions(-) diff --git a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens.hs b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens.hs index 0d8dca9636..28e05f5e8c 100644 --- a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens.hs +++ b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens.hs @@ -15,7 +15,7 @@ descriptor recorder plId = { Ide.Types.pluginHandlers = mkPluginHandler SMethod_TextDocumentSemanticTokensFull (Internal.semanticTokensFull recorder) <> mkPluginHandler SMethod_TextDocumentSemanticTokensFullDelta (Internal.semanticTokensFullDelta recorder), - Ide.Types.pluginRules = Internal.getSemanticTokensRule recorder <> Internal.persistentGetSemanticTokensRule, + Ide.Types.pluginRules = Internal.getSemanticTokensRule recorder, pluginConfigDescriptor = defaultConfigDescriptor { configInitialGenericConfig = (configInitialGenericConfig defaultConfigDescriptor) {plcGlobalOn = False} diff --git a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs index c833957b61..5dca46e447 100644 --- a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs +++ b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs @@ -134,9 +134,6 @@ getSemanticTokensRule recorder = let hsFinder = idSemantic getTyThingMap (hieKindFunMasksKind hieKind) refMap return $ computeRangeHsSemanticTokenTypeList hsFinder virtualFile ast --- | Persistent rule to ensure that semantic tokens doesn't block on startup -persistentGetSemanticTokensRule :: Rules () -persistentGetSemanticTokensRule = addPersistentRule GetSemanticTokens $ \_ -> pure $ Just (RangeHsSemanticTokenTypes mempty, idDelta, Nothing) -- taken from /haskell-language-server/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/Rules.hs From fa908a0ec279a34078a507f4ecd93190b0900321 Mon Sep 17 00:00:00 2001 From: Patrick Date: Wed, 14 Feb 2024 21:06:13 +0800 Subject: [PATCH 13/25] fix export --- .../src/Ide/Plugin/SemanticTokens/Internal.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs index 5dca46e447..76a2eef7b9 100644 --- a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs +++ b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs @@ -10,7 +10,7 @@ -- | -- This module provides the core functionality of the plugin. -module Ide.Plugin.SemanticTokens.Internal (semanticTokensFull, getSemanticTokensRule, persistentGetSemanticTokensRule, semanticConfigProperties, semanticTokensFullDelta) where +module Ide.Plugin.SemanticTokens.Internal (semanticTokensFull, getSemanticTokensRule, semanticConfigProperties, semanticTokensFullDelta) where import Control.Concurrent.STM (modifyTVar', readTVar) From e3ed49bd2aab1a809744eb90fb5b04ae5a407201 Mon Sep 17 00:00:00 2001 From: Patrick Date: Wed, 14 Feb 2024 21:38:54 +0800 Subject: [PATCH 14/25] cleanup --- .../src/Ide/Plugin/SemanticTokens/Internal.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs index 76a2eef7b9..a2645ca810 100644 --- a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs +++ b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs @@ -38,11 +38,9 @@ import Development.IDE (Action, hieKind, use_) import Development.IDE.Core.PluginUtils (runActionE, useWithStaleE) -import Development.IDE.Core.PositionMapping (idDelta) import Development.IDE.Core.Rules (toIdeResult) import Development.IDE.Core.RuleTypes (DocAndTyThingMap (..)) import Development.IDE.Core.Shake (ShakeExtras (..), - addPersistentRule, getShakeExtras, getVirtualFile, useWithStale_) From 82b1eafa23c011c547872e8eb75c374254109673 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Thu, 15 Feb 2024 03:08:16 +0800 Subject: [PATCH 15/25] Update plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs Co-authored-by: fendor --- plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs | 3 --- 1 file changed, 3 deletions(-) diff --git a/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs b/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs index 6575184527..ce3bfd1964 100644 --- a/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs +++ b/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs @@ -118,9 +118,6 @@ getSemanticTokensFullDelta doc lastResultId = do Right x -> return x _ -> error "No tokens found" --- docLspSemanticTokensFullDeltaString :: TextDocumentIdentifier -> Session [SemanticTokenOriginal Language.LSP.Protocol.Types.SemanticTokenTypes] --- docLspSemanticTokensFullDeltaString doc = do --- res <- Test.getSemanticTokens doc semanticTokensClassTests :: TestTree semanticTokensClassTests = From e7a17e7a866136c9054ca0967a26d733ce798f5f Mon Sep 17 00:00:00 2001 From: Patrick Date: Thu, 15 Feb 2024 03:10:57 +0800 Subject: [PATCH 16/25] cleanup --- plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs | 3 --- 1 file changed, 3 deletions(-) diff --git a/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs b/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs index ce3bfd1964..4dc27bf27c 100644 --- a/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs +++ b/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs @@ -184,7 +184,6 @@ semanticTokensFullDeltaTests = doc1 <- openDoc file1 "haskell" _ <- waitForAction "TypeCheck" doc1 fullResult <- Test.getSemanticTokens doc1 - liftIO $ print fullResult delta <- getSemanticTokensFullDelta doc1 "0" liftIO $ delta @?= expectDelta @@ -205,7 +204,6 @@ semanticTokensFullDeltaTests = changeDoc doc1 [change] _ <- waitForAction "TypeCheck" doc1 delta <- getSemanticTokensFullDelta doc1 "0" - liftIO $ print delta liftIO $ delta @?= expectDelta , testCase "remove tokens" $ do @@ -224,7 +222,6 @@ semanticTokensFullDeltaTests = changeDoc doc1 [change] _ <- waitForAction "TypeCheck" doc1 delta <- getSemanticTokensFullDelta doc1 "0" - liftIO $ print delta liftIO $ delta @?= expectDelta ] From cc6977598a8926b55b29587c2a6a1962f3b832f6 Mon Sep 17 00:00:00 2001 From: Patrick Date: Thu, 15 Feb 2024 03:20:42 +0800 Subject: [PATCH 17/25] add doc --- ghcide/src/Development/IDE/Core/Shake.hs | 3 +++ .../src/Ide/Plugin/SemanticTokens/Internal.hs | 2 +- .../src/Ide/Plugin/SemanticTokens/Query.hs | 7 ++++--- .../src/Ide/Plugin/SemanticTokens/Types.hs | 3 +++ 4 files changed, 11 insertions(+), 4 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index d6dc8cc622..fce7cbbeac 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -262,7 +262,10 @@ data ShakeExtras = ShakeExtras -- ^ This represents the set of diagnostics that we have published. -- Due to debouncing not every change might get published. ,semanticTokensCache:: STM.Map NormalizedUri SemanticTokens + -- ^ Cache of last response of semantic tokens for each file, + -- so we can compute deltas for semantic tokens(SMethod_TextDocumentSemanticTokensFullDelta). ,semanticTokensId :: TVar Int + -- ^ semanticTokensId is used to generate unique ids for each lsp response of semantic tokens. ,positionMapping :: STM.Map NormalizedUri (EnumMap Int32 (PositionDelta, PositionMapping)) -- ^ Map from a text document version to a PositionMapping that describes how to map -- positions in a version of that document to positions in the latest version diff --git a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs index a2645ca810..3ecf6b07f9 100644 --- a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs +++ b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs @@ -149,7 +149,7 @@ handleError recorder action' = do -- helper functions ----------------------- -getAndIncreaseSemanticTokensId :: Action Text +getAndIncreaseSemanticTokensId :: Action SemanticTokenId getAndIncreaseSemanticTokensId = do ShakeExtras{semanticTokensId} <- getShakeExtras liftIO $ atomically $ do diff --git a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Query.hs b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Query.hs index cbe2907a19..fb7fdd9e71 100644 --- a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Query.hs +++ b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Query.hs @@ -15,6 +15,7 @@ import Ide.Plugin.SemanticTokens.Mappings import Ide.Plugin.SemanticTokens.Types (HieFunMaskKind, HsSemanticTokenType (TModule), RangeSemanticTokenTypeList, + SemanticTokenId, SemanticTokensConfig) import Language.LSP.Protocol.Types (Position (Position), Range (Range), @@ -65,7 +66,7 @@ nameSemanticFromHie hieKind rm n = idSemanticFromRefMap rm (Right n) ------------------------------------------------- -rangeSemanticsSemanticTokens :: Text -> SemanticTokensConfig -> PositionMapping -> RangeSemanticTokenTypeList -> Either Text SemanticTokens +rangeSemanticsSemanticTokens :: SemanticTokenId -> SemanticTokensConfig -> PositionMapping -> RangeSemanticTokenTypeList -> Either Text SemanticTokens rangeSemanticsSemanticTokens sid stc mapping = makeSemanticTokensWithId (Just sid) . mapMaybe (\(ran, tk) -> toAbsSemanticToken <$> toCurrentRange mapping ran <*> return tk) where @@ -79,12 +80,12 @@ rangeSemanticsSemanticTokens sid stc mapping = (toLspTokenType stc tokenType) [] -makeSemanticTokensWithId :: Maybe Text -> [SemanticTokenAbsolute] -> Either Text SemanticTokens +makeSemanticTokensWithId :: Maybe SemanticTokenId -> [SemanticTokenAbsolute] -> Either Text SemanticTokens makeSemanticTokensWithId sid tokens = do (SemanticTokens _ tokens) <- makeSemanticTokens defaultSemanticTokensLegend tokens return $ SemanticTokens sid tokens -makeSemanticTokensDeltaWithId :: Maybe Text -> SemanticTokens -> SemanticTokens -> SemanticTokensDelta +makeSemanticTokensDeltaWithId :: Maybe SemanticTokenId -> SemanticTokens -> SemanticTokens -> SemanticTokensDelta makeSemanticTokensDeltaWithId sid previousTokens currentTokens = let (SemanticTokensDelta _ stEdits) = makeSemanticTokensDelta previousTokens currentTokens in SemanticTokensDelta sid stEdits diff --git a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Types.hs b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Types.hs index 601956bee9..b8442a1e16 100644 --- a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Types.hs +++ b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Types.hs @@ -18,6 +18,7 @@ import Development.IDE.Graph.Classes (Hashable) import GHC.Generics (Generic) import Language.LSP.Protocol.Types -- import template haskell +import Data.Text (Text) import Language.Haskell.TH.Syntax (Lift) @@ -150,3 +151,5 @@ instance Pretty SemanticLog where LogConfig config -> "SemanticTokensConfig_: " <> pretty (show config) LogMsg msg -> "SemanticLog Debug Message: " <> pretty msg + +type SemanticTokenId = Text From 49fd150725c660ad43264b49d106924f478f6f02 Mon Sep 17 00:00:00 2001 From: Patrick Date: Thu, 15 Feb 2024 03:22:31 +0800 Subject: [PATCH 18/25] cleanup --- .../src/Ide/Plugin/SemanticTokens/Internal.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs index 3ecf6b07f9..d582e8974e 100644 --- a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs +++ b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs @@ -97,10 +97,10 @@ semanticTokensFullDelta :: Recorder (WithPriority SemanticLog) -> PluginMethodHa semanticTokensFullDelta recorder state pid param = do nfp <- getNormalizedFilePathE (param ^. L.textDocument . L.uri) let previousVersionFromParam = param ^. L.previousResultId - runActionE "SemanticTokens.semanticTokensFullDelta" state $ computeSemanticTokensFullDelta previousVersionFromParam recorder pid state nfp + runActionE "SemanticTokens.semanticTokensFullDelta" state $ computeSemanticTokensFullDelta recorder previousVersionFromParam pid state nfp where - computeSemanticTokensFullDelta :: Text -> Recorder (WithPriority SemanticLog) -> PluginId -> IdeState -> NormalizedFilePath -> ExceptT PluginError Action (MessageResult Method_TextDocumentSemanticTokensFullDelta) - computeSemanticTokensFullDelta previousVersionFromParam recorder pid state nfp = do + computeSemanticTokensFullDelta :: Recorder (WithPriority SemanticLog) -> Text -> PluginId -> IdeState -> NormalizedFilePath -> ExceptT PluginError Action (MessageResult Method_TextDocumentSemanticTokensFullDelta) + computeSemanticTokensFullDelta recorder previousVersionFromParam pid state nfp = do semanticTokens <- computeSemanticTokens recorder pid state nfp previousSemanticTokensMaybe <- lift $ getPreviousSemanticTokens (normalizedFilePathToUri nfp) lift $ setSemanticTokens (normalizedFilePathToUri nfp) semanticTokens From dcdbb27567a3df5e09f295287b70f1855f65d179 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Thu, 15 Feb 2024 03:50:15 +0800 Subject: [PATCH 19/25] Update plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs Co-authored-by: fendor --- .../src/Ide/Plugin/SemanticTokens/Internal.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs index d582e8974e..06a044532f 100644 --- a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs +++ b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs @@ -153,8 +153,7 @@ getAndIncreaseSemanticTokensId :: Action SemanticTokenId getAndIncreaseSemanticTokensId = do ShakeExtras{semanticTokensId} <- getShakeExtras liftIO $ atomically $ do - i <- readTVar semanticTokensId - modifyTVar' semanticTokensId (+1) + i <- stateTVar semanticTokensId (\val -> (val, val+1)) return $ T.pack $ show i getPreviousSemanticTokens :: NormalizedUri -> Action (Maybe SemanticTokens) From 7e7398af80e587ea653accf15fd02de695134376 Mon Sep 17 00:00:00 2001 From: Patrick Date: Thu, 15 Feb 2024 04:02:23 +0800 Subject: [PATCH 20/25] fix --- haskell-language-server.cabal | 1 - .../src/Ide/Plugin/SemanticTokens/Internal.hs | 3 +-- plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs | 2 +- 3 files changed, 2 insertions(+), 4 deletions(-) diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index cdd57844df..a345577229 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -1603,7 +1603,6 @@ test-suite hls-semantic-tokens-plugin-tests , ghcide == 2.6.0.0 , hls-plugin-api == 2.6.0.0 , data-default - , directory , row-types ----------------------------- diff --git a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs index 06a044532f..a6c712f0a9 100644 --- a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs +++ b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs @@ -12,8 +12,7 @@ -- This module provides the core functionality of the plugin. module Ide.Plugin.SemanticTokens.Internal (semanticTokensFull, getSemanticTokensRule, semanticConfigProperties, semanticTokensFullDelta) where -import Control.Concurrent.STM (modifyTVar', - readTVar) +import Control.Concurrent.STM (stateTVar) import Control.Concurrent.STM.Stats (atomically) import Control.Lens ((^.)) import Control.Monad.Except (ExceptT, liftEither, diff --git a/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs b/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs index 4dc27bf27c..0917b19a2d 100644 --- a/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs +++ b/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs @@ -183,7 +183,7 @@ semanticTokensFullDeltaTests = Test.Hls.runSessionWithServerInTmpDir def semanticTokensPlugin (mkFs $ FS.directProjectMulti [file1]) $ do doc1 <- openDoc file1 "haskell" _ <- waitForAction "TypeCheck" doc1 - fullResult <- Test.getSemanticTokens doc1 + _ <- Test.getSemanticTokens doc1 delta <- getSemanticTokensFullDelta doc1 "0" liftIO $ delta @?= expectDelta From b287639a898caa4b60e21b8dca4b1195a21ee5a7 Mon Sep 17 00:00:00 2001 From: Patrick Date: Mon, 19 Feb 2024 14:14:07 +0800 Subject: [PATCH 21/25] neat --- ghcide/src/Development/IDE/Core/Shake.hs | 2 +- .../src/Ide/Plugin/SemanticTokens/Internal.hs | 22 +++++++++---------- .../src/Ide/Plugin/SemanticTokens/Types.hs | 4 ++++ 3 files changed, 16 insertions(+), 12 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index fce7cbbeac..dbc020e183 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -261,7 +261,7 @@ data ShakeExtras = ShakeExtras ,publishedDiagnostics :: STM.Map NormalizedUri [Diagnostic] -- ^ This represents the set of diagnostics that we have published. -- Due to debouncing not every change might get published. - ,semanticTokensCache:: STM.Map NormalizedUri SemanticTokens + ,semanticTokensCache:: STM.Map NormalizedFilePath SemanticTokens -- ^ Cache of last response of semantic tokens for each file, -- so we can compute deltas for semantic tokens(SMethod_TextDocumentSemanticTokensFullDelta). ,semanticTokensId :: TVar Int diff --git a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs index a6c712f0a9..70d4c25a19 100644 --- a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs +++ b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs @@ -28,7 +28,6 @@ import Development.IDE (Action, GetHieAst (GetHieAst), HieAstResult (HAR, hieAst, hieModule, refMap), IdeResult, IdeState, - NormalizedUri, Priority (..), Recorder, Rules, WithPriority, @@ -61,7 +60,6 @@ import Language.LSP.Protocol.Message (MessageResult, Method (Method_TextDocumentSemanticTokensFull, Method_TextDocumentSemanticTokensFullDelta)) import Language.LSP.Protocol.Types (NormalizedFilePath, SemanticTokens, - normalizedFilePathToUri, type (|?) (InL, InR)) import Prelude hiding (span) import qualified StmContainers.Map as STM @@ -82,13 +80,13 @@ computeSemanticTokens recorder pid _ nfp = do withExceptT PluginInternalError $ liftEither $ rangeSemanticsSemanticTokens semanticId config mapping rangeSemanticList semanticTokensFull :: Recorder (WithPriority SemanticLog) -> PluginMethodHandler IdeState 'Method_TextDocumentSemanticTokensFull -semanticTokensFull recorder state pid param = runActionE "SemanticTokens.semanticTokensFull" state computeSemanticTokensFullDelta +semanticTokensFull recorder state pid param = runActionE "SemanticTokens.semanticTokensFull" state computeSemanticTokensFull where - computeSemanticTokensFullDelta :: ExceptT PluginError Action (MessageResult Method_TextDocumentSemanticTokensFull) - computeSemanticTokensFullDelta = do + computeSemanticTokensFull :: ExceptT PluginError Action (MessageResult Method_TextDocumentSemanticTokensFull) + computeSemanticTokensFull = do nfp <- getNormalizedFilePathE (param ^. L.textDocument . L.uri) items <- computeSemanticTokens recorder pid state nfp - lift $ setSemanticTokens (normalizedFilePathToUri nfp) items + lift $ setSemanticTokens nfp items return $ InL items @@ -101,14 +99,16 @@ semanticTokensFullDelta recorder state pid param = do computeSemanticTokensFullDelta :: Recorder (WithPriority SemanticLog) -> Text -> PluginId -> IdeState -> NormalizedFilePath -> ExceptT PluginError Action (MessageResult Method_TextDocumentSemanticTokensFullDelta) computeSemanticTokensFullDelta recorder previousVersionFromParam pid state nfp = do semanticTokens <- computeSemanticTokens recorder pid state nfp - previousSemanticTokensMaybe <- lift $ getPreviousSemanticTokens (normalizedFilePathToUri nfp) - lift $ setSemanticTokens (normalizedFilePathToUri nfp) semanticTokens + previousSemanticTokensMaybe <- lift $ getPreviousSemanticTokens nfp + lift $ setSemanticTokens nfp semanticTokens case previousSemanticTokensMaybe of Nothing -> return $ InL semanticTokens Just previousSemanticTokens -> if Just previousVersionFromParam == previousSemanticTokens^.L.resultId then return $ InR $ InL $ makeSemanticTokensDeltaWithId (semanticTokens^.L.resultId) previousSemanticTokens semanticTokens - else return $ InL semanticTokens + else do + logWith recorder Warning (LogSemanticTokensDeltaMisMatch previousVersionFromParam (previousSemanticTokens^.L.resultId)) + return $ InL semanticTokens -- | Defines the 'getSemanticTokensRule' function, compute semantic tokens for a Haskell source file. -- @@ -155,8 +155,8 @@ getAndIncreaseSemanticTokensId = do i <- stateTVar semanticTokensId (\val -> (val, val+1)) return $ T.pack $ show i -getPreviousSemanticTokens :: NormalizedUri -> Action (Maybe SemanticTokens) +getPreviousSemanticTokens :: NormalizedFilePath -> Action (Maybe SemanticTokens) getPreviousSemanticTokens uri = getShakeExtras >>= liftIO . atomically . STM.lookup uri . semanticTokensCache -setSemanticTokens :: NormalizedUri -> SemanticTokens -> Action () +setSemanticTokens :: NormalizedFilePath -> SemanticTokens -> Action () setSemanticTokens uri tokens = getShakeExtras >>= liftIO . atomically . STM.insert tokens uri . semanticTokensCache diff --git a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Types.hs b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Types.hs index b8442a1e16..d7cf2a2b50 100644 --- a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Types.hs +++ b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Types.hs @@ -141,6 +141,7 @@ data SemanticLog | LogConfig SemanticTokensConfig | LogMsg String | LogNoVF + | LogSemanticTokensDeltaMisMatch Text (Maybe Text) deriving (Show) instance Pretty SemanticLog where @@ -150,6 +151,9 @@ instance Pretty SemanticLog where LogNoVF -> "no VirtualSourceFile exist for file" LogConfig config -> "SemanticTokensConfig_: " <> pretty (show config) LogMsg msg -> "SemanticLog Debug Message: " <> pretty msg + LogSemanticTokensDeltaMisMatch previousIdFromRequest previousIdFromCache + -> "SemanticTokensDeltaMisMatch: previousIdFromRequest: " <> pretty previousIdFromRequest + <> " previousIdFromCache: " <> pretty previousIdFromCache type SemanticTokenId = Text From 154013beeeb6101806d4af77ca58396bc5abee15 Mon Sep 17 00:00:00 2001 From: Patrick Date: Mon, 19 Feb 2024 19:31:51 +0800 Subject: [PATCH 22/25] add doc --- .../src/Ide/Plugin/SemanticTokens/Internal.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs index 70d4c25a19..1be1b523b6 100644 --- a/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs +++ b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs @@ -148,6 +148,8 @@ handleError recorder action' = do -- helper functions ----------------------- +-- keep track of the semantic tokens response id +-- so that we can compute the delta between two versions getAndIncreaseSemanticTokensId :: Action SemanticTokenId getAndIncreaseSemanticTokensId = do ShakeExtras{semanticTokensId} <- getShakeExtras From 699dab7c96ef8cdbcac8eb50630684554c3e0e07 Mon Sep 17 00:00:00 2001 From: Patrick Date: Wed, 21 Feb 2024 22:59:14 +0800 Subject: [PATCH 23/25] add doc about semanticTokensCache location --- ghcide/src/Development/IDE/Core/Shake.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index dbc020e183..f8e0db54ee 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -259,6 +259,11 @@ data ShakeExtras = ShakeExtras ,diagnostics :: STMDiagnosticStore ,hiddenDiagnostics :: STMDiagnosticStore ,publishedDiagnostics :: STM.Map NormalizedUri [Diagnostic] + + -- storing semantic tokens for each file in shakeExtras might + -- not be ideal, since it most used in LSP request handlers + -- but we don't have a better place to store it for now. + -- ^ This represents the set of diagnostics that we have published. -- Due to debouncing not every change might get published. ,semanticTokensCache:: STM.Map NormalizedFilePath SemanticTokens From a0b6ac74c9b12368372aa489975cfbfc6f0384a3 Mon Sep 17 00:00:00 2001 From: Patrick Date: Thu, 22 Feb 2024 01:38:15 +0800 Subject: [PATCH 24/25] add Note [Semantic Tokens Cache Location] --- ghcide/src/Development/IDE/Core/Shake.hs | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index f8e0db54ee..00a595e731 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -244,6 +244,12 @@ data HieDbWriter -- with (currently) retry functionality type IndexQueue = TQueue (((HieDb -> IO ()) -> IO ()) -> IO ()) +-- Note [Semantic Tokens Cache Location] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- storing semantic tokens cache for each file in shakeExtras might +-- not be ideal, since it most used in LSP request handlers +-- instead of rules. We should consider moving it to a more +-- appropriate place in the future if we find one, store it for now. -- information we stash inside the shakeExtra field data ShakeExtras = ShakeExtras @@ -260,12 +266,10 @@ data ShakeExtras = ShakeExtras ,hiddenDiagnostics :: STMDiagnosticStore ,publishedDiagnostics :: STM.Map NormalizedUri [Diagnostic] - -- storing semantic tokens for each file in shakeExtras might - -- not be ideal, since it most used in LSP request handlers - -- but we don't have a better place to store it for now. - -- ^ This represents the set of diagnostics that we have published. -- Due to debouncing not every change might get published. + -- putting semantic tokens cache and id in shakeExtras might not be ideal + -- see Note [Semantic Tokens Cache Location] ,semanticTokensCache:: STM.Map NormalizedFilePath SemanticTokens -- ^ Cache of last response of semantic tokens for each file, -- so we can compute deltas for semantic tokens(SMethod_TextDocumentSemanticTokensFullDelta). From 4180c435e7672594179529098e2144cb734096d5 Mon Sep 17 00:00:00 2001 From: Patrick Date: Thu, 22 Feb 2024 01:39:43 +0800 Subject: [PATCH 25/25] fix doc --- ghcide/src/Development/IDE/Core/Shake.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 00a595e731..2791dcfc2d 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -265,14 +265,14 @@ data ShakeExtras = ShakeExtras ,diagnostics :: STMDiagnosticStore ,hiddenDiagnostics :: STMDiagnosticStore ,publishedDiagnostics :: STM.Map NormalizedUri [Diagnostic] - -- ^ This represents the set of diagnostics that we have published. -- Due to debouncing not every change might get published. - -- putting semantic tokens cache and id in shakeExtras might not be ideal - -- see Note [Semantic Tokens Cache Location] + ,semanticTokensCache:: STM.Map NormalizedFilePath SemanticTokens -- ^ Cache of last response of semantic tokens for each file, -- so we can compute deltas for semantic tokens(SMethod_TextDocumentSemanticTokensFullDelta). + -- putting semantic tokens cache and id in shakeExtras might not be ideal + -- see Note [Semantic Tokens Cache Location] ,semanticTokensId :: TVar Int -- ^ semanticTokensId is used to generate unique ids for each lsp response of semantic tokens. ,positionMapping :: STM.Map NormalizedUri (EnumMap Int32 (PositionDelta, PositionMapping))