Skip to content

Commit 24b40ca

Browse files
soulomoonfendor
soulomoon
and
fendor
authored
Add Method_TextDocumentSemanticTokensFullDelta (#4073)
* add Method_TextDocumentSemanticTokensFullDelta * remove persistentGetSemanticTokensRule * add doc about semanticTokensCache location * add Note [Semantic Tokens Cache Location] --------- Co-authored-by: fendor <fendor@users.noreply.github.com>
1 parent 310b842 commit 24b40ca

File tree

11 files changed

+204
-41
lines changed

11 files changed

+204
-41
lines changed

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

+18
Original file line numberDiff line numberDiff line change
@@ -164,6 +164,7 @@ import Language.LSP.Diagnostics
164164
import qualified Language.LSP.Protocol.Lens as L
165165
import Language.LSP.Protocol.Message
166166
import Language.LSP.Protocol.Types
167+
import Language.LSP.Protocol.Types (SemanticTokens)
167168
import qualified Language.LSP.Protocol.Types as LSP
168169
import qualified Language.LSP.Server as LSP
169170
import Language.LSP.VFS hiding (start)
@@ -243,6 +244,13 @@ data HieDbWriter
243244
-- with (currently) retry functionality
244245
type IndexQueue = TQueue (((HieDb -> IO ()) -> IO ()) -> IO ())
245246

247+
-- Note [Semantic Tokens Cache Location]
248+
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
249+
-- storing semantic tokens cache for each file in shakeExtras might
250+
-- not be ideal, since it most used in LSP request handlers
251+
-- instead of rules. We should consider moving it to a more
252+
-- appropriate place in the future if we find one, store it for now.
253+
246254
-- information we stash inside the shakeExtra field
247255
data ShakeExtras = ShakeExtras
248256
{ --eventer :: LSP.FromServerMessage -> IO ()
@@ -259,6 +267,14 @@ data ShakeExtras = ShakeExtras
259267
,publishedDiagnostics :: STM.Map NormalizedUri [Diagnostic]
260268
-- ^ This represents the set of diagnostics that we have published.
261269
-- Due to debouncing not every change might get published.
270+
271+
,semanticTokensCache:: STM.Map NormalizedFilePath SemanticTokens
272+
-- ^ Cache of last response of semantic tokens for each file,
273+
-- so we can compute deltas for semantic tokens(SMethod_TextDocumentSemanticTokensFullDelta).
274+
-- putting semantic tokens cache and id in shakeExtras might not be ideal
275+
-- see Note [Semantic Tokens Cache Location]
276+
,semanticTokensId :: TVar Int
277+
-- ^ semanticTokensId is used to generate unique ids for each lsp response of semantic tokens.
262278
,positionMapping :: STM.Map NormalizedUri (EnumMap Int32 (PositionDelta, PositionMapping))
263279
-- ^ Map from a text document version to a PositionMapping that describes how to map
264280
-- positions in a version of that document to positions in the latest version
@@ -616,12 +632,14 @@ shakeOpen recorder lspEnv defaultConfig idePlugins logger debouncer
616632
diagnostics <- STM.newIO
617633
hiddenDiagnostics <- STM.newIO
618634
publishedDiagnostics <- STM.newIO
635+
semanticTokensCache <- STM.newIO
619636
positionMapping <- STM.newIO
620637
knownTargetsVar <- newTVarIO $ hashed HMap.empty
621638
let restartShakeSession = shakeRestart recorder ideState
622639
persistentKeys <- newTVarIO mempty
623640
indexPending <- newTVarIO HMap.empty
624641
indexCompleted <- newTVarIO 0
642+
semanticTokensId <- newTVarIO 0
625643
indexProgressToken <- newVar Nothing
626644
let hiedbWriter = HieDbWriter{..}
627645
exportsMap <- newTVarIO mempty

‎haskell-language-server.cabal

+4-1
Original file line numberDiff line numberDiff line change
@@ -1574,14 +1574,16 @@ library hls-semantic-tokens-plugin
15741574
, hls-graph == 2.6.0.0
15751575
, template-haskell
15761576
, data-default
1577+
, stm
1578+
, stm-containers
15771579

15781580
default-extensions: DataKinds
15791581

15801582
test-suite hls-semantic-tokens-plugin-tests
15811583
import: defaults, pedantic, test-defaults, warnings
15821584
type: exitcode-stdio-1.0
15831585
hs-source-dirs: plugins/hls-semantic-tokens-plugin/test
1584-
main-is: Main.hs
1586+
main-is: SemanticTokensTest.hs
15851587

15861588
build-depends:
15871589
, aeson
@@ -1601,6 +1603,7 @@ test-suite hls-semantic-tokens-plugin-tests
16011603
, ghcide == 2.6.0.0
16021604
, hls-plugin-api == 2.6.0.0
16031605
, data-default
1606+
, row-types
16041607

16051608
-----------------------------
16061609
-- HLS

‎hls-plugin-api/src/Ide/Plugin/ConfigUtils.hs

+2
Original file line numberDiff line numberDiff line change
@@ -94,6 +94,7 @@ pluginsToDefaultConfig IdePlugins {..} =
9494
SMethod_TextDocumentCompletion -> ["completionOn" A..= plcCompletionOn]
9595
SMethod_TextDocumentPrepareCallHierarchy -> ["callHierarchyOn" A..= plcCallHierarchyOn]
9696
SMethod_TextDocumentSemanticTokensFull -> ["semanticTokensOn" A..= plcSemanticTokensOn]
97+
SMethod_TextDocumentSemanticTokensFullDelta -> ["semanticTokensOn" A..= plcSemanticTokensOn]
9798
_ -> []
9899

99100
-- | Generates json schema used in haskell vscode extension
@@ -125,6 +126,7 @@ pluginsToVSCodeExtensionSchema IdePlugins {..} = A.object $ mconcat $ singlePlug
125126
SMethod_TextDocumentCompletion -> [toKey' "completionOn" A..= schemaEntry "completions" plcCompletionOn]
126127
SMethod_TextDocumentPrepareCallHierarchy -> [toKey' "callHierarchyOn" A..= schemaEntry "call hierarchy" plcCallHierarchyOn]
127128
SMethod_TextDocumentSemanticTokensFull -> [toKey' "semanticTokensOn" A..= schemaEntry "semantic tokens" plcSemanticTokensOn]
129+
SMethod_TextDocumentSemanticTokensFullDelta -> [toKey' "semanticTokensOn" A..= schemaEntry "semantic tokens" plcSemanticTokensOn]
128130
_ -> []
129131
schemaEntry desc defaultVal =
130132
A.object

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

+6
Original file line numberDiff line numberDiff line change
@@ -511,6 +511,9 @@ instance PluginMethod Request Method_TextDocumentRangeFormatting where
511511
instance PluginMethod Request Method_TextDocumentSemanticTokensFull where
512512
handlesRequest = pluginEnabledWithFeature plcSemanticTokensOn
513513

514+
instance PluginMethod Request Method_TextDocumentSemanticTokensFullDelta where
515+
handlesRequest = pluginEnabledWithFeature plcSemanticTokensOn
516+
514517
instance PluginMethod Request Method_TextDocumentPrepareCallHierarchy where
515518
handlesRequest = pluginEnabledWithFeature plcCallHierarchyOn
516519

@@ -751,6 +754,9 @@ instance PluginRequestMethod (Method_CustomMethod m) where
751754
instance PluginRequestMethod Method_TextDocumentSemanticTokensFull where
752755
combineResponses _ _ _ _ (x :| _) = x
753756

757+
instance PluginRequestMethod Method_TextDocumentSemanticTokensFullDelta where
758+
combineResponses _ _ _ _ (x :| _) = x
759+
754760
takeLefts :: [a |? b] -> [a]
755761
takeLefts = mapMaybe (\x -> [res | (InL res) <- Just x])
756762

‎plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens.hs

+5-3
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,5 @@
11
{-# LANGUAGE OverloadedStrings #-}
2-
{-# LANGUAGE TemplateHaskell #-}
2+
33

44
module Ide.Plugin.SemanticTokens (descriptor) where
55

@@ -12,8 +12,10 @@ import Language.LSP.Protocol.Message
1212
descriptor :: Recorder (WithPriority SemanticLog) -> PluginId -> PluginDescriptor IdeState
1313
descriptor recorder plId =
1414
(defaultPluginDescriptor plId "Provides semantic tokens")
15-
{ Ide.Types.pluginHandlers = mkPluginHandler SMethod_TextDocumentSemanticTokensFull (Internal.semanticTokensFull recorder),
16-
Ide.Types.pluginRules = Internal.getSemanticTokensRule recorder <> Internal.persistentGetSemanticTokensRule,
15+
{ Ide.Types.pluginHandlers =
16+
mkPluginHandler SMethod_TextDocumentSemanticTokensFull (Internal.semanticTokensFull recorder)
17+
<> mkPluginHandler SMethod_TextDocumentSemanticTokensFullDelta (Internal.semanticTokensFullDelta recorder),
18+
Ide.Types.pluginRules = Internal.getSemanticTokensRule recorder,
1719
pluginConfigDescriptor =
1820
defaultConfigDescriptor
1921
{ configInitialGenericConfig = (configInitialGenericConfig defaultConfigDescriptor) {plcGlobalOn = False}

‎plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Internal.hs

+61-12
Original file line numberDiff line numberDiff line change
@@ -10,14 +10,19 @@
1010

1111
-- |
1212
-- This module provides the core functionality of the plugin.
13-
module Ide.Plugin.SemanticTokens.Internal (semanticTokensFull, getSemanticTokensRule, persistentGetSemanticTokensRule, semanticConfigProperties) where
13+
module Ide.Plugin.SemanticTokens.Internal (semanticTokensFull, getSemanticTokensRule, semanticConfigProperties, semanticTokensFullDelta) where
1414

15+
import Control.Concurrent.STM (stateTVar)
16+
import Control.Concurrent.STM.Stats (atomically)
1517
import Control.Lens ((^.))
1618
import Control.Monad.Except (ExceptT, liftEither,
1719
withExceptT)
20+
import Control.Monad.IO.Class (MonadIO (..))
1821
import Control.Monad.Trans (lift)
1922
import Control.Monad.Trans.Except (runExceptT)
2023
import qualified Data.Map.Strict as M
24+
import Data.Text (Text)
25+
import qualified Data.Text as T
2126
import Development.IDE (Action,
2227
GetDocMap (GetDocMap),
2328
GetHieAst (GetHieAst),
@@ -31,10 +36,10 @@ import Development.IDE (Action,
3136
hieKind, use_)
3237
import Development.IDE.Core.PluginUtils (runActionE,
3338
useWithStaleE)
34-
import Development.IDE.Core.PositionMapping (idDelta)
3539
import Development.IDE.Core.Rules (toIdeResult)
3640
import Development.IDE.Core.RuleTypes (DocAndTyThingMap (..))
37-
import Development.IDE.Core.Shake (addPersistentRule,
41+
import Development.IDE.Core.Shake (ShakeExtras (..),
42+
getShakeExtras,
3843
getVirtualFile,
3944
useWithStale_)
4045
import Development.IDE.GHC.Compat hiding (Warning)
@@ -51,11 +56,13 @@ import Ide.Plugin.SemanticTokens.Tokenize (computeRangeHsSemanti
5156
import Ide.Plugin.SemanticTokens.Types
5257
import Ide.Types
5358
import qualified Language.LSP.Protocol.Lens as L
54-
import Language.LSP.Protocol.Message (Method (Method_TextDocumentSemanticTokensFull))
59+
import Language.LSP.Protocol.Message (MessageResult,
60+
Method (Method_TextDocumentSemanticTokensFull, Method_TextDocumentSemanticTokensFullDelta))
5561
import Language.LSP.Protocol.Types (NormalizedFilePath,
5662
SemanticTokens,
57-
type (|?) (InL))
63+
type (|?) (InL, InR))
5864
import Prelude hiding (span)
65+
import qualified StmContainers.Map as STM
5966

6067

6168
$mkSemanticConfigFunctions
@@ -68,14 +75,40 @@ computeSemanticTokens :: Recorder (WithPriority SemanticLog) -> PluginId -> IdeS
6875
computeSemanticTokens recorder pid _ nfp = do
6976
config <- lift $ useSemanticConfigAction pid
7077
logWith recorder Debug (LogConfig config)
78+
semanticId <- lift getAndIncreaseSemanticTokensId
7179
(RangeHsSemanticTokenTypes {rangeSemanticList}, mapping) <- useWithStaleE GetSemanticTokens nfp
72-
withExceptT PluginInternalError $ liftEither $ rangeSemanticsSemanticTokens config mapping rangeSemanticList
80+
withExceptT PluginInternalError $ liftEither $ rangeSemanticsSemanticTokens semanticId config mapping rangeSemanticList
7381

7482
semanticTokensFull :: Recorder (WithPriority SemanticLog) -> PluginMethodHandler IdeState 'Method_TextDocumentSemanticTokensFull
75-
semanticTokensFull recorder state pid param = do
83+
semanticTokensFull recorder state pid param = runActionE "SemanticTokens.semanticTokensFull" state computeSemanticTokensFull
84+
where
85+
computeSemanticTokensFull :: ExceptT PluginError Action (MessageResult Method_TextDocumentSemanticTokensFull)
86+
computeSemanticTokensFull = do
87+
nfp <- getNormalizedFilePathE (param ^. L.textDocument . L.uri)
88+
items <- computeSemanticTokens recorder pid state nfp
89+
lift $ setSemanticTokens nfp items
90+
return $ InL items
91+
92+
93+
semanticTokensFullDelta :: Recorder (WithPriority SemanticLog) -> PluginMethodHandler IdeState 'Method_TextDocumentSemanticTokensFullDelta
94+
semanticTokensFullDelta recorder state pid param = do
7695
nfp <- getNormalizedFilePathE (param ^. L.textDocument . L.uri)
77-
items <- runActionE "SemanticTokens.semanticTokensFull" state $ computeSemanticTokens recorder pid state nfp
78-
return $ InL items
96+
let previousVersionFromParam = param ^. L.previousResultId
97+
runActionE "SemanticTokens.semanticTokensFullDelta" state $ computeSemanticTokensFullDelta recorder previousVersionFromParam pid state nfp
98+
where
99+
computeSemanticTokensFullDelta :: Recorder (WithPriority SemanticLog) -> Text -> PluginId -> IdeState -> NormalizedFilePath -> ExceptT PluginError Action (MessageResult Method_TextDocumentSemanticTokensFullDelta)
100+
computeSemanticTokensFullDelta recorder previousVersionFromParam pid state nfp = do
101+
semanticTokens <- computeSemanticTokens recorder pid state nfp
102+
previousSemanticTokensMaybe <- lift $ getPreviousSemanticTokens nfp
103+
lift $ setSemanticTokens nfp semanticTokens
104+
case previousSemanticTokensMaybe of
105+
Nothing -> return $ InL semanticTokens
106+
Just previousSemanticTokens ->
107+
if Just previousVersionFromParam == previousSemanticTokens^.L.resultId
108+
then return $ InR $ InL $ makeSemanticTokensDeltaWithId (semanticTokens^.L.resultId) previousSemanticTokens semanticTokens
109+
else do
110+
logWith recorder Warning (LogSemanticTokensDeltaMisMatch previousVersionFromParam (previousSemanticTokens^.L.resultId))
111+
return $ InL semanticTokens
79112

80113
-- | Defines the 'getSemanticTokensRule' function, compute semantic tokens for a Haskell source file.
81114
--
@@ -98,9 +131,6 @@ getSemanticTokensRule recorder =
98131
let hsFinder = idSemantic getTyThingMap (hieKindFunMasksKind hieKind) refMap
99132
return $ computeRangeHsSemanticTokenTypeList hsFinder virtualFile ast
100133

101-
-- | Persistent rule to ensure that semantic tokens doesn't block on startup
102-
persistentGetSemanticTokensRule :: Rules ()
103-
persistentGetSemanticTokensRule = addPersistentRule GetSemanticTokens $ \_ -> pure $ Just (RangeHsSemanticTokenTypes mempty, idDelta, Nothing)
104134

105135
-- taken from /haskell-language-server/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/Rules.hs
106136

@@ -113,3 +143,22 @@ handleError recorder action' = do
113143
logWith recorder Warning msg
114144
pure $ toIdeResult (Left [])
115145
Right value -> pure $ toIdeResult (Right value)
146+
147+
-----------------------
148+
-- helper functions
149+
-----------------------
150+
151+
-- keep track of the semantic tokens response id
152+
-- so that we can compute the delta between two versions
153+
getAndIncreaseSemanticTokensId :: Action SemanticTokenId
154+
getAndIncreaseSemanticTokensId = do
155+
ShakeExtras{semanticTokensId} <- getShakeExtras
156+
liftIO $ atomically $ do
157+
i <- stateTVar semanticTokensId (\val -> (val, val+1))
158+
return $ T.pack $ show i
159+
160+
getPreviousSemanticTokens :: NormalizedFilePath -> Action (Maybe SemanticTokens)
161+
getPreviousSemanticTokens uri = getShakeExtras >>= liftIO . atomically . STM.lookup uri . semanticTokensCache
162+
163+
setSemanticTokens :: NormalizedFilePath -> SemanticTokens -> Action ()
164+
setSemanticTokens uri tokens = getShakeExtras >>= liftIO . atomically . STM.insert tokens uri . semanticTokensCache

‎plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Mappings.hs

+1-1
Original file line numberDiff line numberDiff line change
@@ -1,7 +1,7 @@
11
{-# LANGUAGE GADTs #-}
22
{-# LANGUAGE OverloadedStrings #-}
33
{-# LANGUAGE TypeFamilies #-}
4-
{-# LANGUAGE TypeOperators #-}
4+
55

66
-- |
77
-- This module provides mappings to convert token type information in the Haskell IDE plugin. It includes functions for:

‎plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Query.hs

+20-11
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,3 @@
1-
{-# LANGUAGE OverloadedRecordDot #-}
2-
{-# LANGUAGE OverloadedStrings #-}
3-
41
-- |
52
-- The query module is used to query the semantic tokens from the AST
63
module Ide.Plugin.SemanticTokens.Query where
@@ -18,13 +15,16 @@ import Ide.Plugin.SemanticTokens.Mappings
1815
import Ide.Plugin.SemanticTokens.Types (HieFunMaskKind,
1916
HsSemanticTokenType (TModule),
2017
RangeSemanticTokenTypeList,
18+
SemanticTokenId,
2119
SemanticTokensConfig)
2220
import Language.LSP.Protocol.Types (Position (Position),
2321
Range (Range),
2422
SemanticTokenAbsolute (SemanticTokenAbsolute),
25-
SemanticTokens,
23+
SemanticTokens (SemanticTokens),
24+
SemanticTokensDelta (SemanticTokensDelta),
2625
defaultSemanticTokensLegend,
27-
makeSemanticTokens)
26+
makeSemanticTokens,
27+
makeSemanticTokensDelta)
2828
import Prelude hiding (length, span)
2929

3030
---------------------------------------------------------
@@ -47,8 +47,7 @@ idSemantic tyThingMap hieKind rm (Right n) =
4747
---------------------------------------------------------
4848

4949
nameSemanticFromHie :: forall a. HieFunMaskKind a -> RefMap a -> Name -> Maybe HsSemanticTokenType
50-
nameSemanticFromHie hieKind rm n = do
51-
idSemanticFromRefMap rm (Right n)
50+
nameSemanticFromHie hieKind rm n = idSemanticFromRefMap rm (Right n)
5251
where
5352
idSemanticFromRefMap :: RefMap a -> Identifier -> Maybe HsSemanticTokenType
5453
idSemanticFromRefMap rm' name' = do
@@ -67,10 +66,9 @@ nameSemanticFromHie hieKind rm n = do
6766

6867
-------------------------------------------------
6968

70-
rangeSemanticsSemanticTokens :: SemanticTokensConfig -> PositionMapping -> RangeSemanticTokenTypeList -> Either Text SemanticTokens
71-
rangeSemanticsSemanticTokens stc mapping =
72-
makeSemanticTokens defaultSemanticTokensLegend
73-
. mapMaybe (\(ran, tk) -> toAbsSemanticToken <$> toCurrentRange mapping ran <*> return tk)
69+
rangeSemanticsSemanticTokens :: SemanticTokenId -> SemanticTokensConfig -> PositionMapping -> RangeSemanticTokenTypeList -> Either Text SemanticTokens
70+
rangeSemanticsSemanticTokens sid stc mapping =
71+
makeSemanticTokensWithId (Just sid) . mapMaybe (\(ran, tk) -> toAbsSemanticToken <$> toCurrentRange mapping ran <*> return tk)
7472
where
7573
toAbsSemanticToken :: Range -> HsSemanticTokenType -> SemanticTokenAbsolute
7674
toAbsSemanticToken (Range (Position startLine startColumn) (Position _endLine endColumn)) tokenType =
@@ -81,3 +79,14 @@ rangeSemanticsSemanticTokens stc mapping =
8179
(fromIntegral len)
8280
(toLspTokenType stc tokenType)
8381
[]
82+
83+
makeSemanticTokensWithId :: Maybe SemanticTokenId -> [SemanticTokenAbsolute] -> Either Text SemanticTokens
84+
makeSemanticTokensWithId sid tokens = do
85+
(SemanticTokens _ tokens) <- makeSemanticTokens defaultSemanticTokensLegend tokens
86+
return $ SemanticTokens sid tokens
87+
88+
makeSemanticTokensDeltaWithId :: Maybe SemanticTokenId -> SemanticTokens -> SemanticTokens -> SemanticTokensDelta
89+
makeSemanticTokensDeltaWithId sid previousTokens currentTokens =
90+
let (SemanticTokensDelta _ stEdits) = makeSemanticTokensDelta previousTokens currentTokens
91+
in SemanticTokensDelta sid stEdits
92+

‎plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Types.hs

+7
Original file line numberDiff line numberDiff line change
@@ -18,6 +18,7 @@ import Development.IDE.Graph.Classes (Hashable)
1818
import GHC.Generics (Generic)
1919
import Language.LSP.Protocol.Types
2020
-- import template haskell
21+
import Data.Text (Text)
2122
import Language.Haskell.TH.Syntax (Lift)
2223

2324

@@ -140,6 +141,7 @@ data SemanticLog
140141
| LogConfig SemanticTokensConfig
141142
| LogMsg String
142143
| LogNoVF
144+
| LogSemanticTokensDeltaMisMatch Text (Maybe Text)
143145
deriving (Show)
144146

145147
instance Pretty SemanticLog where
@@ -149,4 +151,9 @@ instance Pretty SemanticLog where
149151
LogNoVF -> "no VirtualSourceFile exist for file"
150152
LogConfig config -> "SemanticTokensConfig_: " <> pretty (show config)
151153
LogMsg msg -> "SemanticLog Debug Message: " <> pretty msg
154+
LogSemanticTokensDeltaMisMatch previousIdFromRequest previousIdFromCache
155+
-> "SemanticTokensDeltaMisMatch: previousIdFromRequest: " <> pretty previousIdFromRequest
156+
<> " previousIdFromCache: " <> pretty previousIdFromCache
152157

158+
159+
type SemanticTokenId = Text

0 commit comments

Comments
 (0)