diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,23 @@ # Revision history for haskell-lsp +## 0.7.0.0 -- 2018-08-14 + +* Update CompletionItem + * Add `commitCharacters` field + * Add `MarkupContent` option for `documentation` + * Add `preselect` field +* Add CompletionContext +* Add new server capabilities +* Add workspace folder support +* Add document color and color presentation +* Add folding range support +* Add goto type support +* s/TH/Types/g + * Move all types into haskell-lsp-types + * Hide Language.Haskell.LSP.TH.DataTypesJSON - Use Language.Haskell.LSP.Types instead +* Add lenses for Language.Haskell.LSP.Types.Capabilities + + ## 0.6.0.0 -- 2018-08-06 * Add new DocumentSymbol type and heirarchal support diff --git a/haskell-lsp.cabal b/haskell-lsp.cabal --- a/haskell-lsp.cabal +++ b/haskell-lsp.cabal @@ -1,5 +1,5 @@ name: haskell-lsp -version: 0.6.0.0 +version: 0.7.0.0 synopsis: Haskell library for the Microsoft Language Server Protocol description: An implementation of the types, and basic message server to @@ -18,23 +18,22 @@ category: Development build-type: Simple extra-source-files: ChangeLog.md, README.md -cabal-version: >=1.10 +cabal-version: >=1.22 library + reexported-modules: Language.Haskell.LSP.Types + , Language.Haskell.LSP.Types.Capabilities exposed-modules: Language.Haskell.LSP.Capture , Language.Haskell.LSP.Constant , Language.Haskell.LSP.Core , Language.Haskell.LSP.Control , Language.Haskell.LSP.Diagnostics , Language.Haskell.LSP.Messages - , Language.Haskell.LSP.Types - , Language.Haskell.LSP.Types.Capabilities , Language.Haskell.LSP.Utility , Language.Haskell.LSP.VFS -- other-modules: -- other-extensions: ghc-options: -Wall - -- ghc-options: -Werror build-depends: base >=4.9 && <4.12 , aeson >=1.0.0.0 , bytestring @@ -44,7 +43,7 @@ , filepath , hslogger , hashable - , haskell-lsp-types >= 0.6 + , haskell-lsp-types >= 0.7 , lens >= 4.15.2 , mtl , network-uri @@ -93,13 +92,18 @@ hs-source-dirs: test main-is: Main.hs other-modules: Spec + CapabilitiesSpec DiagnosticsSpec MethodSpec + ServerCapabilitiesSpec URIFilePathSpec VspSpec + WorkspaceFoldersSpec build-depends: base , aeson + , bytestring , containers + , data-default , directory , filepath , hspec @@ -111,6 +115,7 @@ , yi-rope , haskell-lsp , text + , stm ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall default-language: Haskell2010 diff --git a/src/Language/Haskell/LSP/Core.hs b/src/Language/Haskell/LSP/Core.hs --- a/src/Language/Haskell/LSP/Core.hs +++ b/src/Language/Haskell/LSP/Core.hs @@ -35,14 +35,15 @@ import qualified Data.HashMap.Strict as HM import qualified Data.List as L import qualified Data.Map as Map +import Data.Maybe import Data.Monoid import qualified Data.Text as T import Data.Text ( Text ) import Language.Haskell.LSP.Capture import Language.Haskell.LSP.Constant import Language.Haskell.LSP.Messages -import qualified Language.Haskell.LSP.TH.ClientCapabilities as C -import qualified Language.Haskell.LSP.TH.DataTypesJSON as J +import qualified Language.Haskell.LSP.Types.Capabilities as C +import qualified Language.Haskell.LSP.Types as J import Language.Haskell.LSP.Utility import Language.Haskell.LSP.VFS import Language.Haskell.LSP.Diagnostics @@ -77,6 +78,7 @@ , resLspId :: !(TVar Int) , resLspFuncs :: LspFuncs a -- NOTE: Cannot be strict, lazy initialization , resCaptureFile :: !(Maybe FilePath) + , resWorkspaceFolders :: ![J.WorkspaceFolder] } -- --------------------------------------------------------------------- @@ -89,14 +91,20 @@ { textDocumentSync :: Maybe J.TextDocumentSyncOptions , completionProvider :: Maybe J.CompletionOptions , signatureHelpProvider :: Maybe J.SignatureHelpOptions + , typeDefinitionProvider :: Maybe J.GotoOptions + , implementationProvider :: Maybe J.GotoOptions , codeLensProvider :: Maybe J.CodeLensOptions , documentOnTypeFormattingProvider :: Maybe J.DocumentOnTypeFormattingOptions , documentLinkProvider :: Maybe J.DocumentLinkOptions + , colorProvider :: Maybe J.ColorOptions + , foldingRangeProvider :: Maybe J.FoldingRangeOptions , executeCommandProvider :: Maybe J.ExecuteCommandOptions } instance Default Options where - def = Options Nothing Nothing Nothing Nothing Nothing Nothing Nothing + def = Options Nothing Nothing Nothing Nothing Nothing + Nothing Nothing Nothing Nothing Nothing + Nothing -- | A function to publish diagnostics. It aggregates all diagnostics pertaining -- to a particular version of a document, by source, and sends a @@ -122,6 +130,7 @@ , flushDiagnosticsBySourceFunc :: !FlushDiagnosticsBySourceFunc , getNextReqId :: !(IO J.LspId) , rootPath :: !(Maybe FilePath) + , getWorkspaceFolders :: !(IO (Maybe [J.WorkspaceFolder])) } -- | The function in the LSP process that is called once the 'initialize' @@ -144,7 +153,8 @@ , completionHandler :: !(Maybe (Handler J.CompletionRequest)) , completionResolveHandler :: !(Maybe (Handler J.CompletionItemResolveRequest)) , signatureHelpHandler :: !(Maybe (Handler J.SignatureHelpRequest)) - , definitionHandler :: !(Maybe (Handler J.ImplementationRequest)) + , definitionHandler :: !(Maybe (Handler J.DefinitionRequest)) + , typeDefinitionHandler :: !(Maybe (Handler J.TypeDefinitionRequest)) , implementationHandler :: !(Maybe (Handler J.ImplementationRequest)) , referencesHandler :: !(Maybe (Handler J.ReferencesRequest)) , documentHighlightHandler :: !(Maybe (Handler J.DocumentHighlightRequest)) @@ -153,10 +163,13 @@ , codeActionHandler :: !(Maybe (Handler J.CodeActionRequest)) , codeLensHandler :: !(Maybe (Handler J.CodeLensRequest)) , codeLensResolveHandler :: !(Maybe (Handler J.CodeLensResolveRequest)) + , documentColorHandler :: !(Maybe (Handler J.DocumentColorRequest)) + , colorPresentationHandler :: !(Maybe (Handler J.ColorPresentationRequest)) , documentFormattingHandler :: !(Maybe (Handler J.DocumentFormattingRequest)) , documentRangeFormattingHandler :: !(Maybe (Handler J.DocumentRangeFormattingRequest)) , documentTypeFormattingHandler :: !(Maybe (Handler J.DocumentOnTypeFormattingRequest)) , renameHandler :: !(Maybe (Handler J.RenameRequest)) + , foldingRangeHandler :: !(Maybe (Handler J.FoldingRangeRequest)) -- new in 3.0 , documentLinkHandler :: !(Maybe (Handler J.DocumentLinkRequest)) , documentLinkResolveHandler :: !(Maybe (Handler J.DocumentLinkResolveRequest)) @@ -173,6 +186,7 @@ , didCloseTextDocumentNotificationHandler :: !(Maybe (Handler J.DidCloseTextDocumentNotification)) , didSaveTextDocumentNotificationHandler :: !(Maybe (Handler J.DidSaveTextDocumentNotification)) , didChangeWatchedFilesNotificationHandler :: !(Maybe (Handler J.DidChangeWatchedFilesNotification)) + , didChangeWorkspaceFoldersNotificationHandler :: !(Maybe (Handler J.DidChangeWorkspaceFoldersNotification)) -- new in 3.0 , initializedHandler :: !(Maybe (Handler J.InitializedNotification)) , willSaveTextDocumentNotificationHandler :: !(Maybe (Handler J.WillSaveTextDocumentNotification)) @@ -195,7 +209,8 @@ def = Handlers Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing - Nothing Nothing Nothing Nothing Nothing Nothing + Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing + Nothing Nothing -- --------------------------------------------------------------------- nop :: a -> b -> IO a @@ -236,6 +251,7 @@ exitSuccess handlerMap _ h J.CancelRequest = hh nop NotCancelRequestFromClient $ cancelNotificationHandler h -- Workspace +handlerMap _ h J.WorkspaceDidChangeWorkspaceFolders = hwf $ didChangeWorkspaceFoldersNotificationHandler h handlerMap i h J.WorkspaceDidChangeConfiguration = hc i $ didChangeConfigurationParamsHandler h handlerMap _ h J.WorkspaceDidChangeWatchedFiles = hh nop NotDidChangeWatchedFiles $ didChangeWatchedFilesNotificationHandler h handlerMap _ h J.WorkspaceSymbol = hh nop ReqWorkspaceSymbols $ workspaceSymbolHandler h @@ -251,20 +267,24 @@ handlerMap _ h J.CompletionItemResolve = hh nop ReqCompletionItemResolve $ completionResolveHandler h handlerMap _ h J.TextDocumentHover = hh nop ReqHover $ hoverHandler h handlerMap _ h J.TextDocumentSignatureHelp = hh nop ReqSignatureHelp $ signatureHelpHandler h +handlerMap _ h J.TextDocumentDefinition = hh nop ReqDefinition $ definitionHandler h +handlerMap _ h J.TextDocumentTypeDefinition = hh nop ReqTypeDefinition $ definitionHandler h +handlerMap _ h J.TextDocumentImplementation = hh nop ReqImplementation $ implementationHandler h handlerMap _ h J.TextDocumentReferences = hh nop ReqFindReferences $ referencesHandler h handlerMap _ h J.TextDocumentDocumentHighlight = hh nop ReqDocumentHighlights $ documentHighlightHandler h handlerMap _ h J.TextDocumentDocumentSymbol = hh nop ReqDocumentSymbols $ documentSymbolHandler h handlerMap _ h J.TextDocumentFormatting = hh nop ReqDocumentFormatting $ documentFormattingHandler h handlerMap _ h J.TextDocumentRangeFormatting = hh nop ReqDocumentRangeFormatting $ documentRangeFormattingHandler h handlerMap _ h J.TextDocumentOnTypeFormatting = hh nop ReqDocumentOnTypeFormatting $ documentTypeFormattingHandler h -handlerMap _ h J.TextDocumentDefinition = hh nop ReqDefinition $ definitionHandler h -handlerMap _ h J.TextDocumentImplementation = hh nop ReqDefinition $ implementationHandler h handlerMap _ h J.TextDocumentCodeAction = hh nop ReqCodeAction $ codeActionHandler h handlerMap _ h J.TextDocumentCodeLens = hh nop ReqCodeLens $ codeLensHandler h handlerMap _ h J.CodeLensResolve = hh nop ReqCodeLensResolve $ codeLensResolveHandler h +handlerMap _ h J.TextDocumentDocumentColor = hh nop ReqDocumentColor $ documentColorHandler h +handlerMap _ h J.TextDocumentColorPresentation = hh nop ReqColorPresentation $ colorPresentationHandler h handlerMap _ h J.TextDocumentDocumentLink = hh nop ReqDocumentLink $ documentLinkHandler h handlerMap _ h J.DocumentLinkResolve = hh nop ReqDocumentLinkResolve $ documentLinkResolveHandler h handlerMap _ h J.TextDocumentRename = hh nop ReqRename $ renameHandler h +handlerMap _ h J.TextDocumentFoldingRanges = hh nop ReqFoldingRange $ foldingRangeHandler h handlerMap _ _ (J.Misc x) = helper f where f :: TVar (LanguageContextData c) -> J.Value -> IO () f tvarDat n = do @@ -326,7 +346,22 @@ let msg = T.pack $ unwords $ ["haskell-lsp:parse error.", show json, show err] ++ _ERR_MSG_URL sendErrorLog tvarDat msg +-- | Updates the list of workspace folders and then delegates back to 'hh' +hwf :: Maybe (Handler J.DidChangeWorkspaceFoldersNotification) -> TVar (LanguageContextData c) -> J.Value -> IO () +hwf h tvarDat json = do + case J.fromJSON json :: J.Result J.DidChangeWorkspaceFoldersNotification of + J.Success (J.NotificationMessage _ _ params) -> atomically $ do + oldWfs <- resWorkspaceFolders <$> readTVar tvarDat + let J.List toRemove = params ^. J.event . J.removed + wfs0 = foldr L.delete oldWfs toRemove + J.List toAdd = params ^. J.event . J.added + wfs1 = wfs0 <> toAdd + + modifyTVar' tvarDat (\c -> c {resWorkspaceFolders = wfs1}) + _ -> return () + hh nop NotDidChangeWorkspaceFolders h tvarDat json + -- --------------------------------------------------------------------- getVirtualFile :: TVar (LanguageContextData c) -> J.Uri -> IO (Maybe VirtualFile) @@ -371,7 +406,7 @@ -- defaultLanguageContextData :: Handlers -> Options -> LspFuncs c -> TVar Int -> SendFunc -> Maybe FilePath -> LanguageContextData c defaultLanguageContextData h o lf tv sf cf = - LanguageContextData _INITIAL_RESPONSE_SEQUENCE h o sf mempty mempty Nothing tv lf cf + LanguageContextData _INITIAL_RESPONSE_SEQUENCE h o sf mempty mempty Nothing tv lf cf mempty -- --------------------------------------------------------------------- @@ -500,6 +535,12 @@ Just handler -> handler req Nothing -> return () + let wfs = case params ^. J.workspaceFolders of + Just (J.List xs) -> xs + Nothing -> [] + + atomically $ modifyTVar' tvarCtx (\c -> c { resWorkspaceFolders = wfs }) + ctx0 <- readTVarIO tvarCtx -- capture initialize request @@ -516,12 +557,20 @@ let getCapabilities :: J.InitializeParams -> C.ClientCapabilities - getCapabilities (J.InitializeParams _ _ _ _ c _) = c + getCapabilities (J.InitializeParams _ _ _ _ c _ _) = c getLspId tvId = atomically $ do cid <- readTVar tvId modifyTVar' tvId (+1) return $ J.IdInt cid + clientSupportsWfs = fromMaybe False $ do + let (C.ClientCapabilities mw _ _) = params ^. J.capabilities + (C.WorkspaceClientCapabilities _ _ _ _ _ _ mwf _) <- mw + mwf + getWfs tvc + | clientSupportsWfs = atomically $ Just . resWorkspaceFolders <$> readTVar tvc + | otherwise = return Nothing + -- Launch the given process once the project root directory has been set let lspFuncs = LspFuncs (getCapabilities params) (getConfig tvarCtx) @@ -531,6 +580,7 @@ (flushDiagnosticsBySource tvarCtx) (getLspId $ resLspId ctx0) rootDir + (getWfs tvarCtx) let ctx = ctx0 { resLspFuncs = lspFuncs } atomically $ writeTVar tvarCtx ctx @@ -553,6 +603,13 @@ Just x -> Just (J.TDSOptions x) Nothing -> Nothing + workspace = J.WorkspaceOptions workspaceFolder + workspaceFolder = case didChangeWorkspaceFoldersNotificationHandler h of + Just _ -> Just $ + -- sign up to receive notifications + J.WorkspaceFolderOptions (Just True) (Just (J.WorkspaceFolderChangeNotificationsBool True)) + Nothing -> Nothing + capa = J.InitializeResponseCapabilitiesInner { J._textDocumentSync = sync @@ -560,9 +617,10 @@ , J._completionProvider = completionProvider o , J._signatureHelpProvider = signatureHelpProvider o , J._definitionProvider = supported (definitionHandler h) + , J._typeDefinitionProvider = typeDefinitionProvider o + , J._implementationProvider = implementationProvider o , J._referencesProvider = supported (referencesHandler h) , J._documentHighlightProvider = supported (documentHighlightHandler h) - , J._documentSymbolProvider = supported (documentSymbolHandler h) , J._workspaceSymbolProvider = supported (workspaceSymbolHandler h) , J._codeActionProvider = supported (codeActionHandler h) @@ -572,7 +630,10 @@ , J._documentOnTypeFormattingProvider = documentOnTypeFormattingProvider o , J._renameProvider = supported (renameHandler h) , J._documentLinkProvider = documentLinkProvider o + , J._colorProvider = colorProvider o + , J._foldingRangeProvider = foldingRangeProvider o , J._executeCommandProvider = executeCommandProvider o + , J._workspace = Just workspace -- TODO: Add something for experimental , J._experimental = Nothing :: Maybe J.Value } diff --git a/src/Language/Haskell/LSP/Diagnostics.hs b/src/Language/Haskell/LSP/Diagnostics.hs --- a/src/Language/Haskell/LSP/Diagnostics.hs +++ b/src/Language/Haskell/LSP/Diagnostics.hs @@ -22,7 +22,7 @@ import qualified Data.SortedList as SL import qualified Data.Map as Map -import qualified Language.Haskell.LSP.TH.DataTypesJSON as J +import qualified Language.Haskell.LSP.Types as J -- --------------------------------------------------------------------- {-# ANN module ("hlint: ignore Eta reduce" :: String) #-} diff --git a/src/Language/Haskell/LSP/Messages.hs b/src/Language/Haskell/LSP/Messages.hs --- a/src/Language/Haskell/LSP/Messages.hs +++ b/src/Language/Haskell/LSP/Messages.hs @@ -2,14 +2,14 @@ {-# LANGUAGE DeriveGeneric #-} module Language.Haskell.LSP.Messages - ( module Language.Haskell.LSP.TH.MessageFuncs + ( module Language.Haskell.LSP.Types.MessageFuncs , FromClientMessage(..) , FromServerMessage(..) ) where -import Language.Haskell.LSP.TH.MessageFuncs -import Language.Haskell.LSP.TH.DataTypesJSON +import Language.Haskell.LSP.Types.MessageFuncs +import Language.Haskell.LSP.Types import GHC.Generics import Data.Aeson @@ -22,6 +22,8 @@ | ReqCompletionItemResolve CompletionItemResolveRequest | ReqSignatureHelp SignatureHelpRequest | ReqDefinition DefinitionRequest + | ReqTypeDefinition TypeDefinitionRequest + | ReqImplementation ImplementationRequest | ReqFindReferences ReferencesRequest | ReqDocumentHighlights DocumentHighlightRequest | ReqDocumentSymbols DocumentSymbolRequest @@ -29,13 +31,16 @@ | ReqCodeAction CodeActionRequest | ReqCodeLens CodeLensRequest | ReqCodeLensResolve CodeLensResolveRequest + | ReqDocumentLink DocumentLinkRequest + | ReqDocumentLinkResolve DocumentLinkResolveRequest + | ReqDocumentColor DocumentColorRequest + | ReqColorPresentation ColorPresentationRequest | ReqDocumentFormatting DocumentFormattingRequest | ReqDocumentRangeFormatting DocumentRangeFormattingRequest | ReqDocumentOnTypeFormatting DocumentOnTypeFormattingRequest | ReqRename RenameRequest + | ReqFoldingRange FoldingRangeRequest | ReqExecuteCommand ExecuteCommandRequest - | ReqDocumentLink DocumentLinkRequest - | ReqDocumentLinkResolve DocumentLinkResolveRequest | ReqWillSaveWaitUntil WillSaveWaitUntilTextDocumentRequest -- Responses | RspApplyWorkspaceEdit ApplyWorkspaceEditResponse @@ -54,6 +59,7 @@ | NotWillSaveTextDocument WillSaveTextDocumentNotification | NotDidSaveTextDocument DidSaveTextDocumentNotification | NotDidChangeWatchedFiles DidChangeWatchedFilesNotification + | NotDidChangeWorkspaceFolders DidChangeWorkspaceFoldersNotification -- Unknown (The client sends something we don't understand) | UnknownFromClientMessage Value deriving (Eq,Read,Show,Generic,ToJSON,FromJSON) @@ -72,6 +78,8 @@ | RspCompletionItemResolve CompletionItemResolveResponse | RspSignatureHelp SignatureHelpResponse | RspDefinition DefinitionResponse + | RspTypeDefinition TypeDefinitionResponse + | RspImplementation ImplementationResponse | RspFindReferences ReferencesResponse | RspDocumentHighlights DocumentHighlightsResponse | RspDocumentSymbols DocumentSymbolsResponse @@ -79,14 +87,17 @@ | RspCodeAction CodeActionResponse | RspCodeLens CodeLensResponse | RspCodeLensResolve CodeLensResolveResponse + | RspDocumentLink DocumentLinkResponse + | RspDocumentLinkResolve DocumentLinkResolveResponse + | RspDocumentColor DocumentColorResponse + | RspColorPresentation ColorPresentationResponse | RspDocumentFormatting DocumentFormattingResponse | RspDocumentRangeFormatting DocumentRangeFormattingResponse | RspDocumentOnTypeFormatting DocumentOnTypeFormattingResponse | RspRename RenameResponse + | RspFoldingRange FoldingRangeResponse | RspExecuteCommand ExecuteCommandResponse | RspError ErrorResponse - | RspDocumentLink DocumentLinkResponse - | RspDocumentLinkResolve DocumentLinkResolveResponse | RspWillSaveWaitUntil WillSaveWaitUntilTextDocumentResponse -- Notifications | NotPublishDiagnostics PublishDiagnosticsNotification diff --git a/src/Language/Haskell/LSP/Types.hs b/src/Language/Haskell/LSP/Types.hs deleted file mode 100644 --- a/src/Language/Haskell/LSP/Types.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Language.Haskell.LSP.Types - ( - module Language.Haskell.LSP.TH.DataTypesJSON - ) where - -import Language.Haskell.LSP.TH.DataTypesJSON diff --git a/src/Language/Haskell/LSP/Types/Capabilities.hs b/src/Language/Haskell/LSP/Types/Capabilities.hs deleted file mode 100644 --- a/src/Language/Haskell/LSP/Types/Capabilities.hs +++ /dev/null @@ -1,202 +0,0 @@ -module Language.Haskell.LSP.Types.Capabilities - ( - module Language.Haskell.LSP.TH.ClientCapabilities - , fullCaps - , LSPVersion - , capsForVersion - ) where - -import Prelude hiding (min) -import Language.Haskell.LSP.TH.ClientCapabilities -import Language.Haskell.LSP.TH.DataTypesJSON - --- | The whole shebang. The real deal. --- Capabilities for full conformance to the current (v3.10) LSP specification. -fullCaps :: ClientCapabilities -fullCaps = capsForVersion (LSPVersion maxBound maxBound) - --- | A specific version of the LSP specification. -data LSPVersion = LSPVersion Int Int -- ^ Construct a major.minor version - --- | Capabilities for full conformance to the LSP specification up until a version. --- Some important milestones: --- --- * 3.9 completion item preselect --- * 3.8 codeAction literals --- * 3.7 related information in diagnostics --- * 3.6 workspace folders, colors, goto type/implementation --- * 3.4 extended completion item and symbol item kinds --- * 3.0 dynamic registration -capsForVersion :: LSPVersion -> ClientCapabilities -capsForVersion (LSPVersion maj min) = ClientCapabilities (Just w) (Just td) Nothing - where - w = WorkspaceClientCapabilities - (Just True) - (Just (WorkspaceEditClientCapabilities (Just True))) - (Just (DidChangeConfigurationClientCapabilities dynamicReg)) - (Just (DidChangeWatchedFilesClientCapabilities dynamicReg)) - (Just symbol) - (Just (ExecuteClientCapabilities dynamicReg)) - (since 3 6 True) - (since 3 6 True) - - symbol = SymbolClientCapabilities - dynamicReg - (since 3 4 symbolKind) - - symbolKind = - SymbolKindClientCapabilities (Just sKs) - - sKs - | maj >= 3 && min >= 4 = List (oldSKs ++ newSKs) - | otherwise = List oldSKs - - oldSKs = [ SkFile - , SkModule - , SkNamespace - , SkPackage - , SkClass - , SkMethod - , SkProperty - , SkField - , SkConstructor - , SkEnum - , SkInterface - , SkFunction - , SkVariable - , SkConstant - , SkString - , SkNumber - , SkBoolean - , SkArray - ] - - newSKs = [ SkObject - , SkKey - , SkNull - , SkEnumMember - , SkStruct - , SkEvent - , SkOperator - , SkTypeParameter - ] - - td = TextDocumentClientCapabilities - (Just sync) - (Just completion) - (Just hover) - (Just signatureHelp) - (Just (ReferencesClientCapabilities dynamicReg)) - (Just (DocumentHighlightClientCapabilities dynamicReg)) - (Just documentSymbol) - (Just (FormattingClientCapabilities (Just True))) - (Just (RangeFormattingClientCapabilities dynamicReg)) - (Just (OnTypeFormattingClientCapabilities dynamicReg)) - (Just (DefinitionClientCapabilities dynamicReg)) - (since 3 6 (TypeDefinitionClientCapabilities dynamicReg)) - (since 3 6 (ImplementationClientCapabilities dynamicReg)) - (Just codeAction) - (Just (CodeLensClientCapabilities dynamicReg)) - (Just (DocumentLinkClientCapabilities dynamicReg)) - (since 3 6 (ColorProviderClientCapabilities dynamicReg)) - (Just (RenameClientCapabilities dynamicReg)) - (Just (PublishDiagnosticsClientCapabilities (since 3 7 True))) - sync = - SynchronizationTextDocumentClientCapabilities - dynamicReg - (Just True) - (Just True) - (Just True) - - completion = - CompletionClientCapabilities - dynamicReg - (Just completionItem) - (since 3 4 completionItemKind) - (since 3 3 True) - - completionItem = CompletionItemClientCapabilities - (Just True) - (Just True) - (since 3 3 (List [MkPlainText, MkMarkdown])) - (Just True) - (since 3 9 True) - - completionItemKind = - CompletionItemKindClientCapabilities (Just ciKs) - - ciKs - | maj >= 3 && min >= 4 = List (oldCiKs ++ newCiKs) - | otherwise = List oldCiKs - - oldCiKs = [ CiText - , CiMethod - , CiFunction - , CiConstructor - , CiField - , CiVariable - , CiClass - , CiInterface - , CiModule - , CiProperty - , CiUnit - , CiValue - , CiEnum - , CiKeyword - , CiSnippet - , CiColor - , CiFile - , CiReference - ] - - newCiKs = [ CiFolder - , CiEnumMember - , CiConstant - , CiStruct - , CiEvent - , CiOperator - , CiTypeParameter - ] - - hover = - HoverClientCapabilities - dynamicReg - (since 3 3 (List [MkPlainText, MkMarkdown])) - - codeAction = CodeActionClientCapabilities - dynamicReg - (since 3 8 (CodeActionLiteralSupport caKs)) - caKs = CodeActionKindClientCapabilities - (List [ CodeActionQuickFix - , CodeActionRefactor - , CodeActionRefactorExtract - , CodeActionRefactorInline - , CodeActionRefactorRewrite - , CodeActionSource - , CodeActionSourceOrganizeImports - ]) - - signatureHelp = - SignatureHelpClientCapabilities - dynamicReg - (Just signatureInformation) - - signatureInformation = - SignatureInformationClientCapabilities - (Just (List [MkPlainText, MkMarkdown])) - - documentSymbol = DocumentSymbolClientCapabilities - dynamicReg - (since 3 4 documentSymbolKind) - (since 3 10 True) - - documentSymbolKind = - DocumentSymbolKindClientCapabilities - (Just sKs) -- same as workspace symbol kinds - - dynamicReg - | maj >= 3 = Just True - | otherwise = Nothing - since x y a - | maj >= x && min >= y = Just a - | otherwise = Nothing diff --git a/src/Language/Haskell/LSP/VFS.hs b/src/Language/Haskell/LSP/VFS.hs --- a/src/Language/Haskell/LSP/VFS.hs +++ b/src/Language/Haskell/LSP/VFS.hs @@ -37,7 +37,7 @@ import qualified Data.HashMap.Strict as HashMap import qualified Data.Map as Map import Data.Maybe -import qualified Language.Haskell.LSP.TH.DataTypesJSON as J +import qualified Language.Haskell.LSP.Types as J import Language.Haskell.LSP.Utility import qualified Yi.Rope as Yi diff --git a/test/CapabilitiesSpec.hs b/test/CapabilitiesSpec.hs new file mode 100644 --- /dev/null +++ b/test/CapabilitiesSpec.hs @@ -0,0 +1,15 @@ +module CapabilitiesSpec where + +import Language.Haskell.LSP.Types.Capabilities +import Test.Hspec + +spec :: Spec +spec = describe "capabilities" $ do + it "gives 3.10 capabilities" $ + let ClientCapabilities _ (Just tdcs) _ = capsForVersion (LSPVersion 3 10) + Just (DocumentSymbolClientCapabilities _ _ mHierarchical) = _documentSymbol tdcs + in mHierarchical `shouldBe` Just True + it "gives pre 3.10 capabilities" $ + let ClientCapabilities _ (Just tdcs) _ = capsForVersion (LSPVersion 3 9) + Just (DocumentSymbolClientCapabilities _ _ mHierarchical) = _documentSymbol tdcs + in mHierarchical `shouldBe` Nothing diff --git a/test/ServerCapabilitiesSpec.hs b/test/ServerCapabilitiesSpec.hs new file mode 100644 --- /dev/null +++ b/test/ServerCapabilitiesSpec.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE OverloadedStrings #-} +module ServerCapabilitiesSpec where + +import Control.Lens.Operators +import Data.Aeson +import Data.Monoid ((<>)) +import Language.Haskell.LSP.Types +import Test.Hspec + +spec :: Spec +spec = describe "server capabilities" $ do + describe "folding range options" $ do + describe "decodes" $ do + it "just id" $ + let input = "{\"id\": \"abc123\"}" + in decode input `shouldBe` Just (FoldingRangeOptionsDynamicDocument Nothing (Just "abc123")) + it "id and document selector" $ + let input = "{\"id\": \"foo\", \"documentSelector\": " <> documentFiltersJson <> "}" + in decode input `shouldBe` Just (FoldingRangeOptionsDynamicDocument (Just documentFilters) (Just "foo")) + it "static boolean" $ + let input = "true" + in decode input `shouldBe` Just (FoldingRangeOptionsStatic True) + describe "encodes" $ + it "just id" $ + encode (FoldingRangeOptionsDynamicDocument Nothing (Just "foo")) `shouldBe` "{\"id\":\"foo\"}" + it "decodes" $ + let input = "{\"hoverProvider\": true, \"colorProvider\": {\"id\": \"abc123\", \"documentSelector\": " <> documentFiltersJson <> "}}" + Just caps = decode input :: Maybe InitializeResponseCapabilitiesInner + in caps ^. colorProvider `shouldBe` Just (ColorOptionsDynamicDocument (Just documentFilters) (Just "abc123")) + where + documentFilters = List [DocumentFilter (Just "haskell") Nothing Nothing] + documentFiltersJson = "[{\"language\": \"haskell\"}]" diff --git a/test/WorkspaceFoldersSpec.hs b/test/WorkspaceFoldersSpec.hs new file mode 100644 --- /dev/null +++ b/test/WorkspaceFoldersSpec.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE OverloadedStrings #-} + +module WorkspaceFoldersSpec where + +import Control.Concurrent.MVar +import Control.Concurrent.STM +import Data.Aeson +import qualified Data.ByteString.Lazy.Char8 as BSL +import Data.Default +import Language.Haskell.LSP.Core +import Language.Haskell.LSP.Types hiding (error, trace) +import Language.Haskell.LSP.Types.Capabilities +import Test.Hspec + +spec :: Spec +spec = describe "workspace folders" $ + it "keeps track of open workspace folders" $ do + + lfVar <- newEmptyMVar + + let initCb :: InitializeCallback () + initCb = (const $ Left "", \lf -> putMVar lfVar lf >> return Nothing) + handlers = def + + tvarLspId <- newTVarIO 0 + tvarCtx <- newTVarIO $ + defaultLanguageContextData handlers def undefined tvarLspId (const $ return ()) Nothing + + let putMsg msg = + let jsonStr = encode msg + clStr = BSL.pack $ "Content-Length: " ++ show (BSL.length jsonStr) + in handleMessage initCb tvarCtx clStr jsonStr + + let starterWorkspaces = List [wf0] + initParams = InitializeParams + Nothing Nothing (Just (Uri "/foo")) Nothing fullCaps Nothing (Just starterWorkspaces) + initMsg :: InitializeRequest + initMsg = RequestMessage "2.0" (IdInt 0) Initialize initParams + + putMsg initMsg + + firstWorkspaces <- readMVar lfVar >>= getWorkspaceFolders + firstWorkspaces `shouldBe` Just [wf0] + + + putMsg (makeNotif [wf1] []) + readMVar lfVar >>= \lf -> do + Just wfs <- getWorkspaceFolders lf + wfs `shouldContain` [wf1] + wfs `shouldContain` [wf0] + + putMsg (makeNotif [wf2] [wf1]) + readMVar lfVar >>= \lf -> do + Just wfs <- getWorkspaceFolders lf + wfs `shouldNotContain` [wf1] + wfs `shouldContain` [wf0] + wfs `shouldContain` [wf2] + + where + wf0 = WorkspaceFolder "one" "Starter workspace" + wf1 = WorkspaceFolder "/foo/bar" "My workspace" + wf2 = WorkspaceFolder "/foo/baz" "My other workspace" + + makeNotif add rmv = + let addedFolders = List add + removedFolders = List rmv + ev = WorkspaceFoldersChangeEvent addedFolders removedFolders + ps = DidChangeWorkspaceFoldersParams ev + in NotificationMessage "2.0" WorkspaceDidChangeWorkspaceFolders ps