diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs
index 74747e66d6..2791dcfc2d 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,13 @@ 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
{ --eventer :: LSP.FromServerMessage -> IO ()
@@ -259,6 +267,14 @@ 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 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))
-- ^ 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
@@ -616,12 +632,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 d84c369f2a..f505dc26e1 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
@@ -1581,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
@@ -1601,6 +1603,7 @@ test-suite hls-semantic-tokens-plugin-tests
, ghcide == 2.6.0.0
, hls-plugin-api == 2.6.0.0
, data-default
+ , row-types
-----------------------------
-- HLS
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..28e05f5e8c 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
@@ -12,8 +12,10 @@ 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.pluginRules = Internal.getSemanticTokensRule recorder <> Internal.persistentGetSemanticTokensRule,
+ { Ide.Types.pluginHandlers =
+ mkPluginHandler SMethod_TextDocumentSemanticTokensFull (Internal.semanticTokensFull recorder)
+ <> mkPluginHandler SMethod_TextDocumentSemanticTokensFullDelta (Internal.semanticTokensFullDelta recorder),
+ 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 3b87c0f336..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
@@ -10,14 +10,19 @@
-- |
-- 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, semanticConfigProperties, semanticTokensFullDelta) where
+import Control.Concurrent.STM (stateTVar)
+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),
@@ -31,10 +36,10 @@ 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 (addPersistentRule,
+import Development.IDE.Core.Shake (ShakeExtras (..),
+ getShakeExtras,
getVirtualFile,
useWithStale_)
import Development.IDE.GHC.Compat hiding (Warning)
@@ -51,11 +56,13 @@ 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))
+ type (|?) (InL, InR))
import Prelude hiding (span)
+import qualified StmContainers.Map as STM
$mkSemanticConfigFunctions
@@ -68,14 +75,40 @@ 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
+semanticTokensFull recorder state pid param = runActionE "SemanticTokens.semanticTokensFull" state computeSemanticTokensFull
+ where
+ computeSemanticTokensFull :: ExceptT PluginError Action (MessageResult Method_TextDocumentSemanticTokensFull)
+ computeSemanticTokensFull = do
+ nfp <- getNormalizedFilePathE (param ^. L.textDocument . L.uri)
+ items <- computeSemanticTokens recorder pid state nfp
+ lift $ setSemanticTokens nfp items
+ return $ InL items
+
+
+semanticTokensFullDelta :: Recorder (WithPriority SemanticLog) -> PluginMethodHandler IdeState 'Method_TextDocumentSemanticTokensFullDelta
+semanticTokensFullDelta 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
+ let previousVersionFromParam = param ^. L.previousResultId
+ runActionE "SemanticTokens.semanticTokensFullDelta" state $ computeSemanticTokensFullDelta recorder previousVersionFromParam pid state nfp
+ where
+ 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 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 do
+ logWith recorder Warning (LogSemanticTokensDeltaMisMatch previousVersionFromParam (previousSemanticTokens^.L.resultId))
+ return $ InL semanticTokens
-- | Defines the 'getSemanticTokensRule' function, compute semantic tokens for a Haskell source file.
--
@@ -98,9 +131,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
@@ -113,3 +143,22 @@ handleError recorder action' = do
logWith recorder Warning msg
pure $ toIdeResult (Left [])
Right value -> pure $ toIdeResult (Right value)
+
+-----------------------
+-- 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
+ liftIO $ atomically $ do
+ i <- stateTVar semanticTokensId (\val -> (val, val+1))
+ return $ T.pack $ show i
+
+getPreviousSemanticTokens :: NormalizedFilePath -> Action (Maybe SemanticTokens)
+getPreviousSemanticTokens uri = getShakeExtras >>= liftIO . atomically . STM.lookup uri . semanticTokensCache
+
+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/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/Query.hs b/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Query.hs
index b0d26c5e87..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
@@ -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
@@ -18,13 +15,16 @@ 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),
SemanticTokenAbsolute (SemanticTokenAbsolute),
- SemanticTokens,
+ SemanticTokens (SemanticTokens),
+ SemanticTokensDelta (SemanticTokensDelta),
defaultSemanticTokensLegend,
- makeSemanticTokens)
+ makeSemanticTokens,
+ makeSemanticTokensDelta)
import Prelude hiding (length, span)
---------------------------------------------------------
@@ -47,8 +47,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
@@ -67,10 +66,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 :: SemanticTokenId -> 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 +79,14 @@ rangeSemanticsSemanticTokens stc mapping =
(fromIntegral len)
(toLspTokenType stc tokenType)
[]
+
+makeSemanticTokensWithId :: Maybe SemanticTokenId -> [SemanticTokenAbsolute] -> Either Text SemanticTokens
+makeSemanticTokensWithId sid tokens = do
+ (SemanticTokens _ tokens) <- makeSemanticTokens defaultSemanticTokensLegend tokens
+ return $ SemanticTokens sid tokens
+
+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..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
@@ -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)
@@ -140,6 +141,7 @@ data SemanticLog
| LogConfig SemanticTokensConfig
| LogMsg String
| LogNoVF
+ | LogSemanticTokensDeltaMisMatch Text (Maybe Text)
deriving (Show)
instance Pretty SemanticLog where
@@ -149,4 +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
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/Main.hs b/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs
similarity index 72%
rename from plugins/hls-semantic-tokens-plugin/test/Main.hs
rename to plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs
index a2d7fde20a..0917b19a2d 100644
--- a/plugins/hls-semantic-tokens-plugin/test/Main.hs
+++ b/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs
@@ -1,7 +1,8 @@
{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE OverloadedLabels #-}
{-# 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
@@ -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)
+
+import Data.Row ((.==))
+import Data.Row.Records ((.+))
import Development.IDE.GHC.Compat (GhcVersion (..),
ghcVersion)
import Development.IDE.Plugin.Test (WaitForIdeRuleResult (..))
@@ -22,17 +26,19 @@ import Ide.Plugin.SemanticTokens
import Ide.Plugin.SemanticTokens.Mappings
import Ide.Plugin.SemanticTokens.Types
import Ide.Types
-import Language.LSP.Protocol.Types (SemanticTokenTypes (..),
- _L)
+import qualified Language.LSP.Protocol.Lens as L
+import Language.LSP.Protocol.Types
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_TextDocumentSemanticTokensFullDelta),
TestName, TestTree,
- TextDocumentIdentifier,
+ changeDoc,
defaultTestRunner,
documentContents, fullCaps,
goldenGitDiff,
@@ -91,7 +97,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 +107,18 @@ 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 :: TextDocumentIdentifier -> Text -> Session (SemanticTokens |? (SemanticTokensDelta |? Null))
+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"
+
+
semanticTokensClassTests :: TestTree
semanticTokensClassTests =
testGroup
@@ -156,6 +174,57 @@ 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
+ _ <- Test.getSemanticTokens doc1
+ 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 $ 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 $ delta @?= expectDelta
+ ]
+
semanticTokensTests :: TestTree
semanticTokensTests =
testGroup "other semantic Token test" $
@@ -174,8 +243,6 @@ semanticTokensTests =
Right (WaitForIdeRuleResult _) -> return ()
Left _ -> error "TypeCheck2 failed"
-
-
result <- docSemanticTokensString def doc2
let expect = unlines [
"3:8-18 TModule \"TModula\\66560bA\""
@@ -231,5 +298,6 @@ main =
semanticTokensDataTypeTests,
semanticTokensValuePatternTests,
semanticTokensFunctionTests,
- semanticTokensConfigTest
+ semanticTokensConfigTest,
+ semanticTokensFullDeltaTests
]