Skip to content
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.

Commit 24b40ca

Browse files
soulomoonfendor
andauthoredFeb 21, 2024
Add Method_TextDocumentSemanticTokensFullDelta (#4073)
* add Method_TextDocumentSemanticTokensFullDelta * remove persistentGetSemanticTokensRule * add doc about semanticTokensCache location * add Note [Semantic Tokens Cache Location] --------- Co-authored-by: fendor <[email protected]>
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

Lines changed: 18 additions & 0 deletions
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

Lines changed: 4 additions & 1 deletion
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

Lines changed: 2 additions & 0 deletions
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

Lines changed: 6 additions & 0 deletions
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

Lines changed: 5 additions & 3 deletions
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

Lines changed: 61 additions & 12 deletions
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

Lines changed: 1 addition & 1 deletion
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

Lines changed: 20 additions & 11 deletions
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

Lines changed: 7 additions & 0 deletions
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

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

Lines changed: 2 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,5 @@
1-
{-# LANGUAGE OverloadedRecordDot #-}
2-
{-# LANGUAGE OverloadedStrings #-}
3-
{-# LANGUAGE TypeFamilies #-}
1+
{-# LANGUAGE OverloadedStrings #-}
2+
{-# LANGUAGE TypeFamilies #-}
43
{-# OPTIONS_GHC -Wno-orphans #-}
54

65

‎plugins/hls-semantic-tokens-plugin/test/Main.hs renamed to ‎plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs

Lines changed: 78 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -1,7 +1,8 @@
11
{-# LANGUAGE DataKinds #-}
2+
{-# LANGUAGE OverloadedLabels #-}
23
{-# LANGUAGE OverloadedStrings #-}
34

4-
import Control.Lens ((^?))
5+
import Control.Lens ((^.), (^?))
56
import Control.Monad.IO.Class (liftIO)
67
import Data.Aeson (KeyValue (..), Object)
78
import qualified Data.Aeson.KeyMap as KV
@@ -14,6 +15,9 @@ import Data.Text hiding (length, map,
1415
import qualified Data.Text as Text
1516
import qualified Data.Text.Utf16.Rope.Mixed as Rope
1617
import Development.IDE (Pretty)
18+
19+
import Data.Row ((.==))
20+
import Data.Row.Records ((.+))
1721
import Development.IDE.GHC.Compat (GhcVersion (..),
1822
ghcVersion)
1923
import Development.IDE.Plugin.Test (WaitForIdeRuleResult (..))
@@ -22,17 +26,19 @@ import Ide.Plugin.SemanticTokens
2226
import Ide.Plugin.SemanticTokens.Mappings
2327
import Ide.Plugin.SemanticTokens.Types
2428
import Ide.Types
25-
import Language.LSP.Protocol.Types (SemanticTokenTypes (..),
26-
_L)
29+
import qualified Language.LSP.Protocol.Lens as L
30+
import Language.LSP.Protocol.Types
2731
import Language.LSP.Test (Session,
2832
SessionConfig (ignoreConfigurationRequests),
29-
openDoc)
33+
openDoc, request)
3034
import qualified Language.LSP.Test as Test
3135
import Language.LSP.VFS (VirtualFile (..))
3236
import System.FilePath
33-
import Test.Hls (PluginTestDescriptor,
37+
import Test.Hls (HasCallStack,
38+
PluginTestDescriptor,
39+
SMethod (SMethod_TextDocumentSemanticTokensFullDelta),
3440
TestName, TestTree,
35-
TextDocumentIdentifier,
41+
changeDoc,
3642
defaultTestRunner,
3743
documentContents, fullCaps,
3844
goldenGitDiff,
@@ -91,7 +97,7 @@ docSemanticTokensString cf doc = do
9197
xs <- map (lspTokenHsToken cf) <$> docLspSemanticTokensString doc
9298
return $ unlines . map show $ xs
9399

94-
docLspSemanticTokensString :: TextDocumentIdentifier -> Session [SemanticTokenOriginal Language.LSP.Protocol.Types.SemanticTokenTypes]
100+
docLspSemanticTokensString :: (HasCallStack) => TextDocumentIdentifier -> Session [SemanticTokenOriginal Language.LSP.Protocol.Types.SemanticTokenTypes]
95101
docLspSemanticTokensString doc = do
96102
res <- Test.getSemanticTokens doc
97103
textContent <- documentContents doc
@@ -101,6 +107,18 @@ docLspSemanticTokensString doc = do
101107
either (error . show) pure $ recoverLspSemanticTokens vfs tokens
102108
_noTokens -> error "No tokens found"
103109

110+
111+
-- | Pass a param and return the response from `semanticTokensFull`
112+
-- getSemanticTokensFullDelta :: TextDocumentIdentifier -> Session _
113+
getSemanticTokensFullDelta :: TextDocumentIdentifier -> Text -> Session (SemanticTokens |? (SemanticTokensDelta |? Null))
114+
getSemanticTokensFullDelta doc lastResultId = do
115+
let params = SemanticTokensDeltaParams Nothing Nothing doc lastResultId
116+
rsp <- request SMethod_TextDocumentSemanticTokensFullDelta params
117+
case rsp ^. L.result of
118+
Right x -> return x
119+
_ -> error "No tokens found"
120+
121+
104122
semanticTokensClassTests :: TestTree
105123
semanticTokensClassTests =
106124
testGroup
@@ -156,6 +174,57 @@ semanticTokensConfigTest = testGroup "semantic token config test" [
156174
liftIO $ unlines (map show result1) @?= "2:1-3 SemanticTokenTypes_Variable \"go\"\n"
157175
]
158176

177+
semanticTokensFullDeltaTests :: TestTree
178+
semanticTokensFullDeltaTests =
179+
testGroup "semanticTokensFullDeltaTests" $
180+
[ testCase "null delta since unchanged" $ do
181+
let file1 = "TModula𐐀bA.hs"
182+
let expectDelta = InR (InL (SemanticTokensDelta (Just "1") []))
183+
Test.Hls.runSessionWithServerInTmpDir def semanticTokensPlugin (mkFs $ FS.directProjectMulti [file1]) $ do
184+
doc1 <- openDoc file1 "haskell"
185+
_ <- waitForAction "TypeCheck" doc1
186+
_ <- Test.getSemanticTokens doc1
187+
delta <- getSemanticTokensFullDelta doc1 "0"
188+
liftIO $ delta @?= expectDelta
189+
190+
, testCase "add tokens" $ do
191+
let file1 = "TModula𐐀bA.hs"
192+
let expectDelta = InR (InL (SemanticTokensDelta (Just "1") [SemanticTokensEdit 20 0 (Just [2,0,3,8,0])]))
193+
-- r c l t m
194+
-- where r = row, c = column, l = length, t = token, m = modifier
195+
Test.Hls.runSessionWithServerInTmpDir def semanticTokensPlugin (mkFs $ FS.directProjectMulti [file1]) $ do
196+
doc1 <- openDoc file1 "haskell"
197+
_ <- waitForAction "TypeCheck" doc1
198+
_ <- Test.getSemanticTokens doc1
199+
-- open the file and append a line to it
200+
let change = TextDocumentContentChangeEvent
201+
$ InL $ #range .== Range (Position 4 0) (Position 4 6)
202+
.+ #rangeLength .== Nothing
203+
.+ #text .== "foo = 1"
204+
changeDoc doc1 [change]
205+
_ <- waitForAction "TypeCheck" doc1
206+
delta <- getSemanticTokensFullDelta doc1 "0"
207+
liftIO $ delta @?= expectDelta
208+
209+
, testCase "remove tokens" $ do
210+
let file1 = "TModula𐐀bA.hs"
211+
let expectDelta = InR (InL (SemanticTokensDelta (Just "1") [SemanticTokensEdit 0 20 (Just [])]))
212+
-- delete all tokens
213+
Test.Hls.runSessionWithServerInTmpDir def semanticTokensPlugin (mkFs $ FS.directProjectMulti [file1]) $ do
214+
doc1 <- openDoc file1 "haskell"
215+
_ <- waitForAction "TypeCheck" doc1
216+
_ <- Test.getSemanticTokens doc1
217+
-- open the file and append a line to it
218+
let change = TextDocumentContentChangeEvent
219+
$ InL $ #range .== Range (Position 2 0) (Position 2 28)
220+
.+ #rangeLength .== Nothing
221+
.+ #text .== Text.replicate 28 " "
222+
changeDoc doc1 [change]
223+
_ <- waitForAction "TypeCheck" doc1
224+
delta <- getSemanticTokensFullDelta doc1 "0"
225+
liftIO $ delta @?= expectDelta
226+
]
227+
159228
semanticTokensTests :: TestTree
160229
semanticTokensTests =
161230
testGroup "other semantic Token test" $
@@ -174,8 +243,6 @@ semanticTokensTests =
174243
Right (WaitForIdeRuleResult _) -> return ()
175244
Left _ -> error "TypeCheck2 failed"
176245

177-
178-
179246
result <- docSemanticTokensString def doc2
180247
let expect = unlines [
181248
"3:8-18 TModule \"TModula\\66560bA\""
@@ -231,5 +298,6 @@ main =
231298
semanticTokensDataTypeTests,
232299
semanticTokensValuePatternTests,
233300
semanticTokensFunctionTests,
234-
semanticTokensConfigTest
301+
semanticTokensConfigTest,
302+
semanticTokensFullDeltaTests
235303
]

0 commit comments

Comments
 (0)
Please sign in to comment.