forked from haskell/haskell-language-server
-
Notifications
You must be signed in to change notification settings - Fork 0
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
- Loading branch information
Showing
61 changed files
with
839 additions
and
8 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,66 @@ | ||
| # Semantic tokens (LSP) plugin for Haskell language server | ||
|
|
||
| ## Purpose | ||
|
|
||
| The purpose of this plugin is to provide semantic tokens for the Haskell language server, | ||
| according to the [LSP specification](https://microsoft.github.io/language-server-protocol/specifications/specification-current/#textDocument_semanticTokens) | ||
| It can be used to provide semantic highlighting for Haskell code in editors by given semantic type and modifiers for some tokens. | ||
| A lot of editors support semantic highlighting through LSP, for example vscode, vim, emacs, etc. | ||
|
|
||
| ## Features | ||
|
|
||
| ### Semantic types and modifiers | ||
|
|
||
| The handles request for semantic tokens for the whole file. | ||
| It supports semantic types and but not yet modifiers from the LSP specification. | ||
|
|
||
| Default semantic types defined in lsp diverge greatly from the ones used in ghc. | ||
| But default semantic types allows user with less configuration to get semantic highlighting. | ||
| That is why we use default semantic types for now. By mapping ghc semantic types to lsp semantic types. | ||
| The mapping is defined in `Mapping.hs` file. | ||
|
|
||
| ### delta semantic tokens, range semantic tokens and refresh | ||
|
|
||
| It is not yet support capabilities for delta semantic tokens, which might be | ||
| crucial for performance. | ||
| It should be implemented in the future. | ||
|
|
||
| ## checkList | ||
|
|
||
| * Supported PluginMethodHandler | ||
| * [x] [textDocument/semanticTokens/full](https://microsoft.github.io/language-server-protocol/specifications/lsp/3.17/specification/#semanticTokens_fullRequest). | ||
| * [ ] [textDocument/semanticTokens/full/delta](https://microsoft.github.io/language-server-protocol/specifications/lsp/3.17/specification/#semanticTokens_deltaRequest) | ||
| * [ ] [workspace/semanticTokens/refresh](https://microsoft.github.io/language-server-protocol/specifications/lsp/3.17/specification/#semanticTokens_refreshRequest) | ||
|
|
||
| * Supported semantic tokens type: | ||
| * [x] class and class method | ||
| * [x] type family name (data family) | ||
| * [x] data constructor name (not distinguishing record and normal data, and GADT) | ||
| * [x] type constructor name (GADT) | ||
| * [x] record field name | ||
| * [x] type synonym | ||
| * [x] pattern synonym | ||
| * [x] ~~pattern bindings~~ In favor of differing functions and none-functions from its type | ||
| * [x] ~~value bindings~~ In favor of differing functions and none-functions from its type | ||
| * [x] functions | ||
| * [x] none-function variables | ||
| * [x] imported name | ||
|
|
||
| * Supported modifiers(planning): | ||
| * [future] declaration (as in class declearations, type definition and type family) | ||
| * [future] definition (as in class instance declaration, left hand side value binding, and type family instance) | ||
| * [future] modification (as in rec field update) | ||
|
|
||
| ## Implementation details | ||
|
|
||
| * [x] Compute visible names from renamedsource | ||
| * [x] Compute `NameSemanticMap` for imported and top level name tokens using `HscEnv`(with deps) and type checked result | ||
| * [x] Compute current module `NameSemanticMap` using `RefMap a` from the result of `GetHieAst` | ||
| * [x] Compute all visible `(Name, Span)` in current module, in turn compute their semantic token using the combination map of the above two `NameSemanticMap` | ||
| * [x] use default legends, Candidates map of token type with default token type: [Maps to default token types](https://github.com/soulomoon/haskell-language-server/blob/master/plugins/hls-semantic-tokens-plugin/src/Ide/Plugin/SemanticTokens/Mappings.hs) | ||
| * [x] add args support to turn the plugin on and off | ||
| * [x] enhence test <https://github.com/haskell/haskell-language-server/pull/3892#discussion_r1427844520> | ||
| * [x] enhence error reporting. <https://github.com/haskell/haskell-language-server/pull/3892#discussion_r1427955335> | ||
| * [x] computation of semantic tokens is pushed into rule `getSemanticTokensRule` | ||
| * [future] make use of modifiers | ||
| * [future] hadling customize legends using server capabilities (how?) |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,40 @@ | ||
| {-# LANGUAGE OverloadedStrings #-} | ||
|
|
||
|
|
||
| module Ide.Plugin.Core(descriptor, CoreLog) where | ||
|
|
||
| import Control.Monad.IO.Class (liftIO) | ||
| import Data.Maybe (fromMaybe) | ||
| import Data.Text (Text) | ||
| import Development.IDE | ||
| import Development.IDE.Core.Actions (workspaceSymbols) | ||
| import qualified Development.IDE.Core.Shake as Shake | ||
| import Ide.Types | ||
| import Language.LSP.Protocol.Message | ||
| import Language.LSP.Protocol.Types (WorkspaceSymbolParams (..), | ||
| type (|?) (InL)) | ||
|
|
||
| data CoreLog | ||
| = LogShake Shake.Log | ||
| | CoreLogMsg Text | ||
|
|
||
| instance Pretty CoreLog where | ||
| pretty theLog = case theLog of | ||
| LogShake shakeLog -> pretty shakeLog | ||
| CoreLogMsg msg -> "Core Message: " <> pretty msg | ||
|
|
||
|
|
||
|
|
||
| descriptor :: Recorder (WithPriority CoreLog) -> PluginId -> PluginDescriptor IdeState | ||
| descriptor recorder plId = | ||
| (defaultPluginDescriptor plId "Provides core IDE features for Haskell") | ||
| { | ||
| Ide.Types.pluginHandlers = mkPluginHandler SMethod_WorkspaceSymbol (wsSymbols recorder) | ||
| } | ||
|
|
||
|
|
||
|
|
||
| wsSymbols :: Recorder (WithPriority CoreLog) -> PluginMethodHandler IdeState Method_WorkspaceSymbol | ||
| wsSymbols logger ide _ (WorkspaceSymbolParams _ _ query) = liftIO $ do | ||
| logWith logger Debug $ CoreLogMsg $ "Workspace symbols request: " <> query | ||
| runIdeAction "WorkspaceSymbols" (shakeExtras ide) $ InL . fromMaybe [] <$> workspaceSymbols query |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,14 @@ | ||
| {-# LANGUAGE DataKinds #-} | ||
| {-# LANGUAGE OverloadedLabels #-} | ||
| {-# LANGUAGE OverloadedStrings #-} | ||
|
|
||
| import qualified InitializeResponseTests | ||
| import Test.Hls (defaultTestRunner, testGroup) | ||
|
|
||
|
|
||
| main :: IO () | ||
| main = | ||
| defaultTestRunner $ | ||
| testGroup | ||
| "core" | ||
| [ InitializeResponseTests.tests ] |
144 changes: 144 additions & 0 deletions
144
plugins/hls-core-plugin/test/exe/InitializeResponseTests.hs
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,144 @@ | ||
|
|
||
| {-# LANGUAGE DataKinds #-} | ||
| {-# LANGUAGE OverloadedLabels #-} | ||
| {-# LANGUAGE OverloadedStrings #-} | ||
|
|
||
| module InitializeResponseTests (tests) where | ||
|
|
||
| import Control.Monad | ||
| import Data.List.Extra | ||
| import Data.Row | ||
| import qualified Data.Text as T | ||
| import Development.IDE.Plugin.TypeLenses (typeLensCommandId) | ||
| import qualified Language.LSP.Protocol.Lens as L | ||
| import Language.LSP.Protocol.Message | ||
| -- import qualified Language.LSP.Protocol.Types hiding | ||
| -- (SemanticTokenAbsolute (..), | ||
| -- SemanticTokenRelative (..), | ||
| -- SemanticTokensEdit (..), | ||
| -- mkRange) | ||
| import Language.LSP.Test | ||
|
|
||
| import Control.Lens ((^.)) | ||
| import Data.Default (def) | ||
| import Data.Text (Text) | ||
| import qualified Data.Text as Text | ||
| import Development.IDE.Plugin.Test (blockCommandId) | ||
| import qualified Ide.Plugin.Core as Core | ||
| import Language.LSP.Protocol.Types (CodeLensOptions (..), | ||
| CompletionOptions (..), | ||
| DefinitionOptions (DefinitionOptions), | ||
| DocumentHighlightOptions (..), | ||
| DocumentSymbolOptions (..), | ||
| ExecuteCommandOptions (..), | ||
| HoverOptions (..), | ||
| InitializeResult (..), | ||
| ReferenceOptions (..), | ||
| SaveOptions (..), | ||
| ServerCapabilities (..), | ||
| TextDocumentSyncKind (..), | ||
| TextDocumentSyncOptions (..), | ||
| TypeDefinitionOptions (..), | ||
| WorkspaceFoldersServerCapabilities (..), | ||
| WorkspaceSymbolOptions (..), | ||
| type (|?) (..)) | ||
| import System.FilePath ((</>)) | ||
| import Test.Hls (PluginTestDescriptor, | ||
| mkPluginTestDescriptor, | ||
| runSessionWithServerInTmpDir) | ||
| import qualified Test.Hls.FileSystem as FS | ||
| import Test.Hls.FileSystem (file, text) | ||
| import Test.Tasty | ||
| import Test.Tasty.HUnit | ||
|
|
||
| corePlugin :: PluginTestDescriptor Core.CoreLog | ||
| corePlugin = mkPluginTestDescriptor Core.descriptor "core" | ||
|
|
||
| tests :: TestTree | ||
| tests = withResource acquire release tests where | ||
|
|
||
| -- these tests document and monitor the evolution of the | ||
| -- capabilities announced by the server in the initialize | ||
| -- response. Currently the server advertises almost no capabilities | ||
| -- at all, in some cases failing to announce capabilities that it | ||
| -- actually does provide! Hopefully this will change ... | ||
| tests :: IO (TResponseMessage Method_Initialize) -> TestTree | ||
| tests getInitializeResponse = | ||
| testGroup "initialize response capabilities" | ||
| [ | ||
| chk " text doc sync" _textDocumentSync tds | ||
| , chk " hover" _hoverProvider (Just $ InR (HoverOptions (Just False))) | ||
| , chk " completion" _completionProvider (Just $ CompletionOptions (Just False) (Just ["."]) Nothing (Just True) Nothing) | ||
| , chk "NO signature help" _signatureHelpProvider Nothing | ||
| , chk " goto definition" _definitionProvider (Just $ InR (DefinitionOptions (Just False))) | ||
| , chk " goto type definition" _typeDefinitionProvider (Just $ InR (InL (TypeDefinitionOptions (Just False)))) | ||
| -- BUG in lsp-test, this test fails, just change the accepted response | ||
| -- for now | ||
| , chk "NO goto implementation" _implementationProvider Nothing | ||
| , chk " find references" _referencesProvider (Just $ InR (ReferenceOptions (Just False))) | ||
| , chk " doc highlight" _documentHighlightProvider (Just $ InR (DocumentHighlightOptions (Just False))) | ||
| , chk " doc symbol" _documentSymbolProvider (Just $ InR (DocumentSymbolOptions (Just False) Nothing)) | ||
| , chk " workspace symbol" _workspaceSymbolProvider (Just $ InR (WorkspaceSymbolOptions (Just False) (Just False))) | ||
| , chk "NO code action" _codeActionProvider Nothing | ||
| , chk " code lens" _codeLensProvider (Just $ CodeLensOptions (Just False) (Just True)) | ||
| , chk "NO doc formatting" _documentFormattingProvider Nothing | ||
| , chk "NO doc range formatting" | ||
| _documentRangeFormattingProvider Nothing | ||
| , chk "NO doc formatting on typing" | ||
| _documentOnTypeFormattingProvider Nothing | ||
| , chk "NO renaming" _renameProvider Nothing | ||
| , chk "NO doc link" _documentLinkProvider Nothing | ||
| , chk "NO color" (^. L.colorProvider) Nothing | ||
| , chk "NO folding range" _foldingRangeProvider Nothing | ||
| , che " execute command" _executeCommandProvider [typeLensCommandId, blockCommandId] | ||
| , chk " workspace" (^. L.workspace) (Just $ #workspaceFolders .== Just WorkspaceFoldersServerCapabilities{_supported = Just True, _changeNotifications = Just ( InR True )} | ||
| .+ #fileOperations .== Nothing) | ||
| , chk "NO experimental" (^. L.experimental) Nothing | ||
| ] where | ||
|
|
||
| tds = Just (InL (TextDocumentSyncOptions | ||
| { _openClose = Just True | ||
| , _change = Just TextDocumentSyncKind_Incremental | ||
| , _willSave = Nothing | ||
| , _willSaveWaitUntil = Nothing | ||
| , _save = Just (InR $ SaveOptions {_includeText = Nothing})})) | ||
|
|
||
| chk :: (Eq a, Show a) => TestName -> (ServerCapabilities -> a) -> a -> TestTree | ||
| chk title getActual expected = | ||
| testCase title $ getInitializeResponse >>= \ir -> expected @=? (getActual . innerCaps) ir | ||
|
|
||
| che :: TestName -> (ServerCapabilities -> Maybe ExecuteCommandOptions) -> [T.Text] -> TestTree | ||
| che title getActual expected = testCase title $ do | ||
| ir <- getInitializeResponse | ||
| ExecuteCommandOptions {_commands = commands} <- case getActual $ innerCaps ir of | ||
| Just eco -> pure eco | ||
| Nothing -> assertFailure "Was expecting Just ExecuteCommandOptions, got Nothing" | ||
| let commandNames = (!! 2) . T.splitOn ":" <$> commands | ||
| zipWithM_ (\e o -> T.isSuffixOf e o @? show (e,o)) (sort expected) (sort commandNames) | ||
|
|
||
| innerCaps :: TResponseMessage Method_Initialize -> ServerCapabilities | ||
| innerCaps (TResponseMessage _ _ (Right (InitializeResult c _))) = c | ||
| innerCaps (TResponseMessage _ _ (Left _)) = error "Initialization error" | ||
|
|
||
| acquire :: IO (TResponseMessage Method_Initialize) | ||
| acquire = do | ||
| let content = Text.unlines ["module Hello where", "go _ = 1"] | ||
| let fs = mkFs $ directFile "Hello.hs" content | ||
| runSessionWithServerInTmpDir def corePlugin fs initializeResponse | ||
|
|
||
|
|
||
| release :: TResponseMessage Method_Initialize -> IO () | ||
| release = mempty | ||
|
|
||
| directFile :: FilePath -> Text -> [FS.FileTree] | ||
| directFile fp content = | ||
| [ FS.directCradle [Text.pack fp] | ||
| , file fp (text content) | ||
| ] | ||
|
|
||
| mkFs :: [FS.FileTree] -> FS.VirtualFileTree | ||
| mkFs = FS.mkVirtualFileTree testDataDir | ||
|
|
||
| testDataDir :: FilePath | ||
| testDataDir = "plugins" </> "core-plugin" </> "test" </> "testdata" | ||
|
|
Oops, something went wrong.